amelia
/
ahc-old


include import "./lang.ml"

include import "./lexer.ml"

open import "prelude.ml"


let parse = lex


let laid_out_block p = between obrace cbrace (sep_end_by_1 semi p)


let rec atom : forall 'm. monad 'm => parser_t 'm expr =

 map Ref (try varid)

 <+> map Ref (try conid)

 <+> between (try oparen) cparen expr

and fexp : forall 'm. monad 'm => parser_t 'm expr =

 let! a = atom

 let! ats = many atom

 pure (foldl (curry App) a ats)

and expr : forall 'm. monad 'm => parser_t 'm expr =

 let lam =

 let! _ = back

 let! vs = many (try varid)

 let! _ = arrow

 let! b = expr

 pure (foldr ((Lam #) # curry id) b vs)

 let case =

 let! _ = keyword "case"

 let! e = fexp

 let! _ = keyword "of"

 let! arms =

 laid_out_block (

 let! c = conid

 let! vs = many (try varid)

 let! _ = arrow

 let! e = expr

 pure (c, foldr ((Lam #) # curry id) e vs)

 )

 pure (Case (e, arms))

 try lam <|> try case <+> fexp


let rec ty_atom : forall 'm. monad 'm => parser_t 'm hstype =

 map Tyvar (try varid)

 <|> map Tycon (try conid)

 <+> between (try oparen) cparen ty_exp

and ty_exp : forall 'm. monad 'm => parser_t 'm hstype =

 let! a = ty_atom

 let! ats = many ty_atom

 pure (foldl (curry Tyapp) a ats)


let datadec : forall 'm. monad 'm => parser_t 'm decl =

 let! _ = keyword "data"

 let datacon =

 let! nm = conid

 let! args = many ty_atom

 pure (Constr (nm, args))

 let! nm = conid

 let! args = many (try varid)

 let! _ = equals

 let! c = sep_by_1 pipe (try datacon)

 pure (Data (nm, args, c))


let dec : forall 'm. monad 'm => parser_t 'm decl =

 let func =

 let! nm = varid

 let! args = many (try varid)

 let! _ = equals

 map (fun e -> Decl (nm, args, e)) expr

 try datadec <|> func


let prog : forall 'm. monad 'm => parser_t 'm prog =

 sep_end_by_1 semi dec <* eof