module Language.Pointwise.Parser where
import Language.Pointwise.Syntax as Pointwise
import Language.Haskell.Exts.Syntax as Exts
import Language.Haskell.Exts.Pretty
import Data.Char
mkVar = Exts.Var . UnQual . Ident
hs2pw :: Exp -> Maybe Term
hs2pw (Paren e) = hs2pw e
hs2pw (Exts.Var(UnQual(Ident "undefined"))) = return $ Unit
hs2pw (Exts.Var(UnQual(Ident "_L"))) = return $ Unit
hs2pw (App (Exts.Var (UnQual (Ident "inn"))) exp)
= hs2pw exp >>= return . In
hs2pw (App (Exts.Var (UnQual (Ident "out"))) exp)
= hs2pw exp >>= return . Out
hs2pw (Lit lit) = return $ Const $ prettyPrint lit
hs2pw (Exts.Var(UnQual(Ident str))) = return $ Pointwise.Var str
hs2pw (InfixApp e1 (QConOp (Special Cons)) e2)
= do t1 <- hs2pw e1
t2 <- hs2pw e2
return $ ((Const ":") :@: t1) :@: t2
hs2pw (List []) = return $ Const "[]"
hs2pw (List (x:xs))
= do e <- hs2pw x
es <- hs2pw (List xs)
return $ ((Const ":") :@: e) :@: es
hs2pw (App (Exts.Var (UnQual (Ident "fix"))) exp) =
do term <- hs2pw exp
return $ Fix term
hs2pw (Tuple [e1,e2]) =
do t1 <- hs2pw e1
t2 <- hs2pw e2
return $ t1 :&: t2
hs2pw (App (Exts.Var (UnQual (Ident "fst"))) e) =
do t <- hs2pw e
return $ Fst t
hs2pw (App (Exts.Var (UnQual (Ident "snd"))) e) =
do t <- hs2pw e
return $ Snd t
hs2pw (App (Con (UnQual (Ident "Left"))) e) =
do t <- hs2pw e
return $ Inl t
hs2pw (App (Con (UnQual (Ident "Right"))) e) =
do t <- hs2pw e
return $ Inr t
hs2pw (App e1 e2) =
do t1 <- hs2pw e1
t2 <- hs2pw e2
return $ t1 :@: t2
hs2pw (Lambda _ [PVar(Ident str)] e) =
do t <- hs2pw e
return $ Lam str t
hs2pw (Exts.Case e1
[Alt _ (PApp (UnQual(Ident "Left"))
[PVar(Ident str2)]) (UnGuardedAlt e2) _,
Alt _ (PApp (UnQual(Ident "Right"))
[PVar(Ident str3)]) (UnGuardedAlt e3) _]) =
do t1 <- hs2pw e1
t2 <- hs2pw e2
t3 <- hs2pw e3
return $ Pointwise.Case t1 (Lam str2 t2) (Lam str3 t3)
hs2pw (Exts.Case e1
[Alt _ (PApp (UnQual(Ident "Right"))
[PVar(Ident str3)]) (UnGuardedAlt e3) _,
Alt _ (PApp (UnQual(Ident "Left"))
[PVar(Ident str2)]) (UnGuardedAlt e2) _]) =
do t1 <- hs2pw e1
t2 <- hs2pw e2
t3 <- hs2pw e3
return $ Pointwise.Case t1 (Lam str2 t2) (Lam str3 t3)
hs2pw (Exts.Case e alts) =
do t1 <- hs2pw e
ts <- mapM alt2pws alts
return $ Pointwise.Match t1 ts
where alt2pws (Alt _ pat (UnGuardedAlt e) _) =
do tp <- pat2pw pat
te <- hs2pw e
return (tp,te)
alt2pws _ = fail "No guards allowed."
hs2pw (Con (UnQual (Ident x))) = return $ Const x
hs2pw t = fail $ "'"++prettyPrint t++
"' is not a valid pointwise term."
hsPat2Exp :: Pat -> Exp
hsPat2Exp (Exts.PVar hsName) = Exts.Var $ UnQual hsName
hsPat2Exp (PLit hsLiteral) = Lit hsLiteral
hsPat2Exp (PNeg hsPat) = NegApp . hsPat2Exp $ hsPat
hsPat2Exp (PInfixApp hsPat1 hsQName hsPat2) =
let hsExp1 = hsPat2Exp hsPat1
hsExp2 = hsPat2Exp hsPat2
hsQOp = (if f hsQName then QConOp else QVarOp) hsQName
in InfixApp hsExp1 hsQOp hsExp2
where
f (Qual _ name) = g name
f (UnQual name) = g name
f (Special _ ) = True
g (Ident name) = isUpper $ head name
g (Symbol str) = isUpper $ head str
hsPat2Exp (PApp hsQName []) = Con hsQName
hsPat2Exp (PApp hsQName lPat) =
foldl App (Con hsQName) . map hsPat2Exp $ lPat
hsPat2Exp (PTuple lPat) = Tuple $ map hsPat2Exp lPat
hsPat2Exp (PList lPat) = List $ map hsPat2Exp lPat
hsPat2Exp (PParen hsPat) = Paren $ hsPat2Exp hsPat
hsPat2Exp (PRec hsQName lPatField) =
RecConstr hsQName (map f lPatField)
where
f (PFieldPat hsQName hsPat) = FieldUpdate hsQName $ hsPat2Exp hsPat
hsPat2Exp (PWildCard) = mkVar "_L"
pat2pw = hs2pw . hsPat2Exp