Json Parser Example

JsonParser.hs

{-#LANGUAGE DeriveFunctor#-}

module Main where

fix :: ((a -> b) -> a -> b) -> a -> b
fix f = f (fix f)

newtype Fix f = In { out :: f (Fix f) }

type Algebra f a = f a -> a
type CoAlgebra f a = a -> f a

ana :: Functor f => CoAlgebra f a -> (a -> Fix f) -> a -> Fix f
ana psi f = In . fmap f . psi

anaRec :: Functor f => CoAlgebra f a -> a -> Fix f
anaRec psi = fix (ana psi)

cata :: Functor f => Algebra f a -> (Fix f -> a) -> Fix f -> a
cata psi f = psi . fmap f . out

cataRec :: Functor f => Algebra f a -> Fix f -> a
cataRec psi = fix (cata psi)

data ListF a b = Empty | Cons a b deriving Functor

type ListR a = Fix (ListF a)

type Parser a = CoAlgebra (ListF a) String

-- unit parser
unit :: a -> Parser a
unit = Cons

-- zero parser
zero :: Parser a
zero _ = Empty

-- item parser
item :: Parser Char
item (x:xs) = Cons x xs
item [] = Empty

bind :: Parser a -> (a -> Parser b) -> Parser b
bind m f s = case m s of
              Empty -> Empty
              Cons x s' -> f x s'

mapP :: Parser a -> (a -> b) -> Parser b
mapP m f = bind m (unit . f)

-- sat parser
sat :: (Char -> Bool) -> Parser Char
sat p = bind item (\ch -> if p ch then unit ch else zero)

-- char parser
char :: Char -> Parser Char
char x = sat (\y -> x == y)

-- letter parser
letter :: Parser Char
letter = sat (\x -> ('a' <= x && x <= 'z') || 'A' <= x && x <= 'Z')

space :: Parser Char
space = sat (== ' ')

mplus :: Parser a -> Parser a -> Parser a
p `mplus` q = \s -> case p s of
                Empty -> q s
                r -> r

-- many parser
many :: Parser a -> Parser [a]
many p = bind p (\x ->
         bind (many p) (\xs -> unit (x:xs))) `mplus` unit []

-- sepBy parser
sepBy :: Parser a -> Parser b -> Parser [a]
p `sepBy` sep = bind p (\x ->
                bind (many (bind sep (\_ ->
                            bind p unit))) (\xs -> unit (x:xs))) `mplus` unit []
-- string parser
string :: String -> Parser String
string "" = unit ""
string (x:xs) = bind (char x) (\ch ->
                bind (string xs) (\rest -> unit(ch : rest)))

-- word parser
word :: Parser String
word "" = Empty
word s = many letter s

data Json = Json [(String, Json)] | Value String deriving Show

quotedString :: Parser String
quotedString = bind (char '"') (\_ ->
               bind (many (sat (/= '"'))) (\s ->
               bind (char '"') (\_ -> unit s)))

jsonValue :: Parser (String, Json)
jsonValue = bind quotedString (\s ->
            bind (char ':')   (\_ ->
            bind (mapP quotedString Value `mplus` jsonParser) (\v -> unit (s, v))))

jsonParser :: Parser Json
jsonParser = bind (string "{")     (\_ ->
             bind (jsonValue `sepBy` string ", ") (\xs ->
             bind (string "}")     (\ _ -> unit (Json xs))))


parseJson :: String -> ListR Json
parseJson = anaRec jsonParser

printResult :: ListR a -> Maybe a
printResult = cataRec psi
  where psi :: Algebra (ListF a) (Maybe a)
        psi Empty = Nothing
        psi (Cons n _) = Just n

main :: IO ()
main = print (printResult (parseJson "{\"firstName\":\"John\", \"lastName\":\"Doe\", \"Child\":{\"firstName\":\"Bart\"}}"))