Skip to content

Instantly share code, notes, and snippets.

@holoed holoed/JsonParser.hs
Last active Mar 31, 2017

Embed
What would you like to do?
Json Parser Example
{-#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\"}}"))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.