module Language.Pointfree.Pretty
( pf2hs
, type2hs
) where
import Language.Pointfree.Syntax as Pointfree
import Language.Haskell.Exts.Syntax as Exts
instance Show Term where
showsPrec d (ID) = showString "id"
showsPrec d (BANG) = showString "bang"
showsPrec d (AP) = showString "app"
showsPrec d (Curry aa) =
(showString "curry" . showChar ' ' . showsPrec 10 aa)
showsPrec d (aa :.: ab@(_ :.: _)) = showParen (d >= 10)
(showsPrec 10 aa . showChar '.' . showsPrec 0 ab)
showsPrec d (aa :.: ab) = showParen (d >= 10)
(showsPrec 10 aa . showChar '.' . showsPrec 10 ab)
showsPrec d (aa@(_ :\/: _) :\/: ab) = showParen (d >= 10)
(showsPrec 0 aa . showString " \\/ " . showsPrec 10 ab)
showsPrec d (aa :\/: ab) = showParen (d >= 10)
(showsPrec 10 aa . showString " \\/ " . showsPrec 10 ab)
showsPrec d (aa@(_ :/\: _) :/\: ab) = showParen (d >= 10)
(showsPrec 0 aa . showString " /\\ " . showsPrec 10 ab)
showsPrec d (aa :/\: ab) = showParen (d >= 10)
(showsPrec 10 aa . showString " /\\ " . showsPrec 10 ab)
showsPrec d (FST) = showString "fst"
showsPrec d (SND) = showString "snd"
showsPrec d (INL) = showString "inl"
showsPrec d (INR) = showString "inr"
showsPrec d (Point aa) = showParen (d >= 10)
(showString "pnt" . showChar ' ' . showsPrec 10 aa)
showsPrec d (IN) = showString "inn"
showsPrec d (OUT) = showString "out"
showsPrec d (Hylo typ aa ab) = showParen (d >= 10)
(showString "hylo_{" . showsPrec 0 typ . showString "} " .
showsPrec 10 aa . showChar ' ' . showsPrec 10 ab)
showsPrec d (HyloO typ aa ab) = showParen (d >= 10)
(showString "hyloO_{" . showsPrec 0 typ . showString "} " .
showsPrec 10 aa . showChar ' ' . showsPrec 10 ab)
showsPrec d (Macro ('(':sym) [aa,ab]) = showParen (d >= 10)
(showsPrec 10 aa . showString (" "++(init sym)++" ") . showsPrec 10 ab)
showsPrec d (Macro aa []) =
showChar '\'' . showString aa . showChar '\''
showsPrec d (Macro aa lst) = showParen (d >= 10)
(showChar '\'' . showString aa . showString "' " .
showsPrec 10 lst)
instance Show Pointfree.Type
where
show One = "One"
show (Base s) = s
show (Fix (Const One :++: Const One)) = "Bool"
show (Fix (Const One :++: Id)) = "Int"
show (Fix (Const One :++: (Const a :**: Id))) = "["++(show a)++"]"
show (Fix t) = "Fix ("++(show t)++")"
show (t :*: u) = "("++(show t)++","++(show u)++")"
show (t :+: u) = "Either ("++(show t)++") ("++(show u)++")"
show (t :-> u) = "("++(show t)++" -> "++(show u)++")"
instance Show Funct
where
show Id = "Id"
show (Const t) = "Const ("++(show t)++")"
show (f :**: g) = "("++(show f)++" :*: "++(show g)++")"
show (f :++: g) = "("++(show f)++" :+: "++(show g)++")"
pf2hs :: Term -> Exp
pf2hs ID = mkVar "id"
pf2hs (t1 :.: t2) = InfixApp (mbParen$ pf2hs t1)
(mkOp ".") (mbParen$ pf2hs t2)
pf2hs FST = mkVar "fst"
pf2hs SND = mkVar "snd"
pf2hs (t1 :/\: t2) = InfixApp (mbParen$ pf2hs t1) (mkOp "/\\")
(mbParen$ pf2hs t2)
pf2hs INL = mkCon "inl"
pf2hs INR = mkCon "inr"
pf2hs (t1 :\/: t2) = InfixApp (mbParen$ pf2hs t1) (mkOp "\\/")
(mbParen$ pf2hs t2)
pf2hs AP = mkVar "app"
pf2hs (Curry t1) = App (mkVar "curry") (mbParen$ pf2hs t1)
pf2hs BANG = mkVar "bang"
pf2hs (Macro ('(':sym) [t1,t2]) = InfixApp (mbParen $ pf2hs t1)
(QVarOp (UnQual (Symbol (init sym))))
(mbParen $ pf2hs t2)
pf2hs (Macro str []) = mkVar str
pf2hs (Macro str lst) = App (pf2hs $ Macro str (init lst))
(mbParen $ pf2hs $ last lst)
pf2hs (Point str) = App (mkVar "pnt") (mkVar str)
pf2hs IN = mkVar "inn"
pf2hs OUT = mkVar "out"
pf2hs (Hylo typ t1 t2) =
App (App (App
(mkVar "hylo") (Paren $ ExpTypeSig mkLoc
(mkVar "_L") (type2hs typ)))
(mbParen $ pf2hs t1))
(mbParen $ pf2hs t2)
pf2hs (HyloO typ t1 t2) =
App (App (App
(mkVar "hyloO") (Paren $ ExpTypeSig mkLoc
(mkVar "_L") (type2hs typ)))
(mbParen $ pf2hs t1))
(mbParen $ pf2hs t2)
type2hs :: Pointfree.Type -> Exts.Type
type2hs One = mkTCon "One"
type2hs (Base s) = TyVar (Ident s)
type2hs (t1 :*: t2) = TyTuple Boxed [type2hs t1, type2hs t2]
type2hs (t1 :+: t2) = TyApp (TyApp (mkTCon "Either")
(type2hs t1)) (type2hs t2)
type2hs (t1 :-> t2) = TyFun (type2hs t1) (type2hs t2)
type2hs (Fix t) = TyApp (mkTCon "Fix") (func2hs t)
where
func2hs Id = mkTCon "Id"
func2hs (Const t) = TyApp (mkTCon "Const") (type2hs t)
func2hs (f :**: g) = TyApp (TyApp (mkTCon "(:*:)")
(func2hs f)) (func2hs g)
func2hs (f :++: g) = TyApp (TyApp (mkTCon "(:+:)")
(func2hs f)) (func2hs g)
mkLoc = SrcLoc "" 0 0
mkOp = QVarOp . UnQual . Symbol
mkCon = Con . UnQual . Ident
mkVar = Var . UnQual . Ident
mkTCon = TyCon . UnQual . Ident
mbParen :: Exp -> Exp
mbParen e@(App _ _) = Paren e
mbParen e@(InfixApp _ _ _) = Paren e
mbParen e@(Case _ _) = Paren e
mbParen e@(Lambda _ _ _) = Paren e
mbParen x = x