Parsing Stuff in Haskell - London Haskell

parsing.hs

-- https://www.youtube.com/watch?v=r_Enynu_TV0
-- Hey, I parsed the largest JSON on my hard drive!
import Text.ParserCombinators.Parsec hiding ((<|>),many)
import Control.Applicative
import Control.Monad

matchTrue :: Parser String
matchTrue = string "true"

alwaysTrue :: Parser Bool
alwaysTrue = pure True

--boolTrue = matchTrue *> alwaysTrue

boolTrue :: Parser Bool
boolFalse :: Parser Bool
boolTrue = (string "true") *> (pure True)
boolFalse = (string "false") *> (pure False)

bool :: Parser Bool
bool = boolTrue <|> boolFalse

stringLiteral :: Parser String
stringLiteral =
  char '"' *> (many (noneOf ['"'])) <* char '"'

-- char :: Parser Char
-- noneOf :: [Char] -> Parser Char

data JSONValue =
      B Bool
    | S String
    | A [JSONValue]
    | O [(String, JSONValue)]
    | Null
           deriving (Show,Read)

comma = lexeme $ char ','

ws :: Parser String
ws = many (oneOf " \t\r\n")

lexeme p = p <* ws

jsonObject = lexeme $
    O <$> ((lexeme $ char '{') *>
           (lexeme $ objectEntry `sepBy` comma)
            <* (lexeme $ char '}'))
         
objectEntry :: Parser (String, JSONValue)
objectEntry = lexeme $ do
  key <- stringLiteral
  lexeme $ char ':'
  value <- jsonValue
  return (key, value)

jsonBool' :: Parser JSONValue
jsonBool' = B <$> bool

jsonStringLiteral :: Parser JSONValue
jsonStringLiteral = lexeme (S <$> stringLiteral)

parseNull :: Parser JSONValue
parseNull = string "null" *> pure Null

jsonNull :: Parser JSONValue
jsonNull = lexeme (parseNull)

jsonValue :: Parser JSONValue
jsonValue = jsonBool 
    <|> jsonStringLiteral 
    <|> jsonArray
    <|> jsonObject
    <|> jsonNull

array :: Parser [JSONValue]
array = (lexeme $ char '[')
    *> ( jsonValue `sepBy` (lexeme $ char ',') )
    <* (lexeme $ char ']')

jsonArray :: Parser JSONValue
jsonArray = lexeme ( A <$> array )

jsonBool = lexeme jsonBool'

-- weekday parser (backtracking example)
day =   (string "Monday"   *> pure 1)
    <|> try (string "Tuesday"  *> pure 2)
    <|> (string "Wednesday"*> pure 3)
    <|> (string "Thursday" *> pure 4) -- can't match Thursday if Tuesday fails
    <|> (string "Friday"   *> pure 5)
    <|> try (string "Saturday" *> pure 6)
    <|> (string "Sunday"   *> pure 0)

(<||>) :: Parser a -> Parser a -> Parser a
p <||> q = (try p) <|> q

day2 =   (string "Monday"   *> pure 1)
    <||> (string "Tuesday"  *> pure 2)
    <||> (string "Wednesday"*> pure 3)
    <||> (string "Thursday" *> pure 4) 
    <||> (string "Friday"   *> pure 5)
    <||> (string "Saturday" *> pure 6)
    <||> (string "Sunday"   *> pure 0)

fn = "C:\\Program Files (x86)\\Microsoft Visual Studio 14.0\\Common7\\IDE\\Extensions\\Xamarin\\Xamarin\\4.1.1.3\\Dictionary\\Types.json"

test :: Int -> IO ()

test 1 = do
    print $ parse bool "test bool" "truefalse"
    print $ parse bool "test bool" "falsetrue"
    print $ parse jsonBool "t" "true"
    print $ parse jsonStringLiteral "test2" "\" hello there \""
    print $ parse jsonValue "t" "true"
    print $ parse jsonValue "testString" "\" hello there \""
    print $ parse jsonValue "testobj" "{\"beer\":true}\""
    print $ parse jsonValue "array with whitespace" "[true, true, true]"

test 2 = do
    x <- parseFromFile jsonValue fn
    case x of
      Right (O x') -> do
	putStrLn $ show x'
      Right (A arr) -> do
	mapM_ (putStrLn.show) arr
      Right anything -> do
        putStrLn $ show anything
      Left badstuff -> do
        putStrLn $ "Error: Parse failure: " ++ show badstuff

test _ = putStrLn ""        

main = test 2