module Language.Pointfree.Parser where
import Language.Pointfree.Syntax
import Language.Haskell.Exts.Syntax
hs2pf (Paren e) = hs2pf e
hs2pf (Var (UnQual (Ident "id"))) = return ID
hs2pf (Var (UnQual (Ident "fst"))) = return FST
hs2pf (Var (UnQual (Ident "snd"))) = return SND
hs2pf (Var (UnQual (Ident "inl"))) = return INL
hs2pf (Var (UnQual (Ident "inr"))) = return INR
hs2pf (Con (UnQual (Ident "Left"))) = return INL
hs2pf (Con (UnQual (Ident "Right"))) = return INR
hs2pf (Var (UnQual (Ident "app"))) = return AP
hs2pf (Var (UnQual (Ident "bang"))) = return BANG
hs2pf (Var (UnQual (Ident "inn"))) = return IN
hs2pf (Var (UnQual (Ident "out"))) = return OUT
hs2pf (Var (UnQual (Ident str))) = return $ Macro str []
hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol "."))) e2)
= do t1 <- hs2pf e1
t2 <- hs2pf e2
return $ t1 :.: t2
hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol "/\\"))) e2)
= do t1 <- hs2pf e1
t2 <- hs2pf e2
return $ t1 :/\: t2
hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol "\\/"))) e2)
= do t1 <- hs2pf e1
t2 <- hs2pf e2
return $ t1 :\/: t2
hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol sym))) e2)
= do t1 <- hs2pf e1
t2 <- hs2pf e2
return $ Macro ('(':sym++")") [t1,t2]
hs2pf (App (Var (UnQual (Ident "curry"))) e)
= hs2pf e >>= return . Curry
hs2pf (App (App (App (Var (UnQual (Ident "hylo")))
(Paren (ExpTypeSig _ (Var (UnQual (Ident "_L")))
typ))) e1) e2)
= do typ' <- hs2type typ
t1 <- hs2pf e1
t2 <- hs2pf e2
return $ Hylo typ' t1 t2
hs2pf (App (App (App (Var (UnQual (Ident "hyloO")))
(Paren (ExpTypeSig _ (Var (UnQual (Ident "_L")))
typ))) e1) e2)
= do typ' <- hs2type typ
t1 <- hs2pf e1
t2 <- hs2pf e2
return $ HyloO typ' t1 t2
hs2pf (App x y)
= do term1 <- hs2pf x
term2 <- hs2pf y
case term1 of (Macro v lst) -> return (Macro v (lst++[term2]))
x -> fail "macro expected"
hs2pf x = fail "not a valid pf term"
hs2type (TyCon (UnQual (Ident "One"))) = return One
hs2type (TyTuple _ [e1,e2])
= do t1 <- hs2type e1
t2 <- hs2type e2
return $ t1 :*: t2
hs2type (TyApp (TyApp (TyCon (UnQual (Ident "Either"))) e1) e2)
= do t1 <- hs2type e1
t2 <- hs2type e2
return $ t1 :+: t2
hs2type (TyFun e1 e2)
= do t1 <- hs2type e1
t2 <- hs2type e2
return $ t1 :-> t2
hs2type (TyVar (Ident v)) = return $ Base v
hs2type (TyApp (TyCon (UnQual (Ident "Fix"))) e)
= hs2func e >>= return . Fix
where
hs2func (TyCon (UnQual (Ident "Id"))) = return Id
hs2func (TyApp (TyCon (UnQual (Ident "Const"))) e)
= hs2type e >>= return . Const
hs2func (TyApp (TyApp (TyCon (UnQual (Symbol ":*:"))) e1) e2)
= do t1 <- hs2func e1
t2 <- hs2func e2
return $ t1 :**: t2
hs2func (TyApp (TyApp (TyCon (UnQual (Symbol ":+:"))) e1) e2)
= do t1 <- hs2func e1
t2 <- hs2func e2
return $ t1 :++: t2
hs2func _ = fail "not a valid type"
hs2type _ = fail "not a valid type"