module Language.Pointwise.Pretty where

import Language.Pointwise.Syntax as Pointwise
import Language.Haskell.Exts.Syntax as Exts

pw2hs :: Term -> Exp
pw2hs (Pointwise.Var str)     = mkVar str
pw2hs Unit          = mkVar "_L"
pw2hs (Const str)   = mkVar str
pw2hs (t1 :&: t2)   = Tuple [pw2hs t1,pw2hs t2]
pw2hs (Fst t)       = App (mkVar "fst") (mbParen$ pw2hs t)
pw2hs (Snd t)       = App (mkVar "snd") (mbParen$ pw2hs t)
pw2hs (Pointwise.Case t1 (Lam str2 t2) (Lam str3 t3)) =
      Exts.Case (pw2hs t1)
          [Alt mkLoc (PApp (UnQual$ Ident "Left") [mkPVar str2])
           (UnGuardedAlt$ mbParen$ pw2hs t2) (BDecls []),
           Alt mkLoc (PApp (UnQual$ Ident "Right") [mkPVar str3])
           (UnGuardedAlt$ mbParen$ pw2hs t3) (BDecls [])]
pw2hs (Inl t)       = App (mkCon "Left") (mbParen$ pw2hs t)
pw2hs (Inr t)       = App (mkCon "Right") (mbParen$ pw2hs t)
pw2hs (Lam str t)   = Lambda mkLoc [mkPVar str] (mbParen (pw2hs t))
pw2hs (t1 :@: t2)   = App (mbParen$ pw2hs t1) (mbParen$ pw2hs t2)
pw2hs (In term)     = App (mkVar "inn") (mbParen$ pw2hs term)
pw2hs (Out term)    = App (mkVar "out") (mbParen$ pw2hs term)
pw2hs (Fix term)    = App (mkVar "fix")  (mbParen$ pw2hs term)
pw2hs (Pointwise.Match t alts)= Exts.Case (pw2hs t) (map pw2alt alts)
  where
    pw2alt (t1,t2)   = Alt mkLoc (pw2pat t1) (UnGuardedAlt $ pw2hs t2) $ BDecls []
    pw2pat (Pointwise.Var s)   = mkPVar s
    pw2pat Unit      = PWildCard
    pw2pat (Const s) = mkPVar s
    pw2pat (t1 :&: t2) = PTuple [pw2pat t1,pw2pat t2]
    pw2pat (Inl t)   = PApp (UnQual $ Ident "Left") [mbPParen$ pw2pat t]
    pw2pat (Inr t)   = PApp (UnQual $ Ident "Right") [mbPParen$ pw2pat t]
    pw2pat ((Pointwise.Var str) :@: t2) =
                       PApp (UnQual $ Ident str) [mbPParen$ pw2pat t2]
    pw2pat t = error $ "not a valid pattern - " ++ show t


mkLoc = SrcLoc "" 0 0
mkCon  = Con . UnQual . Ident
mkVar  = Exts.Var . UnQual . Ident
mkPVar  = PVar . Ident
-- places parentisis only if it is necessary
mbParen :: Exp -> Exp
mbParen e@(App _ _) = Paren e
mbParen e@(InfixApp _ _ _) = Paren e
mbParen e@(Exts.Case _ _) = Paren e
mbParen e@(Lambda _ _ _) = Paren e
mbParen e@(ExpTypeSig _ _ _) = Paren e
mbParen x = x
mbPParen :: Pat -> Pat
mbPParen p@(PApp _ _) = PParen p
mbPParen p = p