darcs - DrHylo

1 module Language.Pointfree.Pretty

2 ( pf2hs

3 , type2hs

4 ) where

6 import Language.Pointfree.Syntax as Pointfree

7 import Language.Haskell.Exts.Syntax as Exts

10 instance Show Term where

11 showsPrec d (ID) = showString "id"

12 showsPrec d (BANG) = showString "bang"

13 showsPrec d (AP) = showString "app"

14 showsPrec d (Curry aa) = -- showParen (d >= 10)

15 (showString "curry" . showChar ' ' . showsPrec 10 aa)

16 showsPrec d (aa :.: ab@(_ :.: _)) = showParen (d >= 10)

17 (showsPrec 10 aa . showChar '.' . showsPrec 0 ab)

18 showsPrec d (aa :.: ab) = showParen (d >= 10)

19 (showsPrec 10 aa . showChar '.' . showsPrec 10 ab)

20 showsPrec d (aa@(_ :\/: _) :\/: ab) = showParen (d >= 10)

21 (showsPrec 0 aa . showString " \\/ " . showsPrec 10 ab)

22 showsPrec d (aa :\/: ab) = showParen (d >= 10)

23 (showsPrec 10 aa . showString " \\/ " . showsPrec 10 ab)

24 showsPrec d (aa@(_ :/\: _) :/\: ab) = showParen (d >= 10)

25 (showsPrec 0 aa . showString " /\\ " . showsPrec 10 ab)

26 showsPrec d (aa :/\: ab) = showParen (d >= 10)

27 (showsPrec 10 aa . showString " /\\ " . showsPrec 10 ab)

28 showsPrec d (FST) = showString "fst"

29 showsPrec d (SND) = showString "snd"

30 showsPrec d (INL) = showString "inl"

31 showsPrec d (INR) = showString "inr"

32 showsPrec d (Point aa) = showParen (d >= 10)

33 (showString "pnt" . showChar ' ' . showsPrec 10 aa)

34 showsPrec d (IN) = showString "inn"

35 showsPrec d (OUT) = showString "out"

36 showsPrec d (Hylo typ aa ab) = showParen (d >= 10)

37 (showString "hylo_{" . showsPrec 0 typ . showString "} " .

38 showsPrec 10 aa . showChar ' ' . showsPrec 10 ab)

39 showsPrec d (HyloO typ aa ab) = showParen (d >= 10)

40 (showString "hyloO_{" . showsPrec 0 typ . showString "} " .

41 showsPrec 10 aa . showChar ' ' . showsPrec 10 ab)

42 showsPrec d (Macro ('(':sym) [aa,ab]) = showParen (d >= 10)

43 (showsPrec 10 aa . showString (" " ++ init sym ++ " ") . showsPrec 10 ab)

44 -- showsPrec d (Macro "sum" [aa,ab]) = showParen (d >= 10)

45 -- (showsPrec 10 aa . showString " -|- " . showsPrec 10 ab)

46 showsPrec d (Macro aa []) =

47 showChar '\'' . showString aa . showChar '\''

48 showsPrec d (Macro aa lst) = showParen (d >= 10)

49 (showChar '\'' . showString aa . showString "' " .

50 showsPrec 10 lst)

52 instance Show Pointfree.Type

53 where

54 show One = "One"

55 show (Base s) = s

56 show (Fix (Const One :++: Const One)) = "Bool"

57 show (Fix (Const One :++: Id)) = "Int"

58 show (Fix (Const One :++: (Const a :**: Id))) = "[" ++ show a ++ "]"

59 show (Fix t) = "Fix (" ++ show t ++ ")"

60 show (t :*: u) = "(" ++ show t ++ "," ++ show u ++ ")"

61 show (t :+: u) = "Either (" ++ show t ++ ") (" ++ show u ++ ")"

62 show (t :-> u) = "(" ++ show t ++ " -> " ++ show u ++ ")"

64 instance Show Funct

65 where

66 show Id = "Id"

67 show (Const t) = "Const (" ++ show t ++ ")"

68 show (f :**: g) = "(" ++ show f ++ " :*: " ++ show g ++ ")"

69 show (f :++: g) = "(" ++ show f ++ " :+: " ++ show g ++ ")"

72 pf2hs :: Term -> Exp

73 pf2hs ID = mkVar "id"

74 pf2hs (t1 :.: t2) = InfixApp (mbParen$ pf2hs t1)

75 (mkOp ".") (mbParen$ pf2hs t2)

76 pf2hs FST = mkVar "fst"

77 pf2hs SND = mkVar "snd"

78 pf2hs (t1 :/\: t2) = InfixApp (mbParen$ pf2hs t1) (mkOp "/\\")

79 (mbParen$ pf2hs t2)

80 pf2hs INL = mkCon "inl"

81 pf2hs INR = mkCon "inr"

82 pf2hs (t1 :\/: t2) = InfixApp (mbParen$ pf2hs t1) (mkOp "\\/")

83 (mbParen$ pf2hs t2)

85 pf2hs AP = mkVar "app"

86 pf2hs (Curry t1) = App (mkVar "curry") (mbParen$ pf2hs t1)

88 pf2hs BANG = mkVar "bang"

89 pf2hs (Macro ('(':sym) [t1,t2]) = InfixApp (mbParen $ pf2hs t1)

90 (QVarOp (UnQual (Symbol (init sym))))

91 (mbParen $ pf2hs t2)

92 pf2hs (Macro str []) = mkVar str

93 pf2hs (Macro str lst) = App (pf2hs $ Macro str (init lst))

94 (mbParen $ pf2hs $ last lst)

95 pf2hs (Point str) = App (mkVar "pnt") (mkVar str)

97 pf2hs IN = mkVar "inn"

98 pf2hs OUT = mkVar "out"

100 pf2hs (Hylo typ t1 t2) = -- hylo (_L::typ) t1 t2

101 App (App (App

102 (mkVar "hylo") (Paren $ ExpTypeSig mkLoc

103 (mkVar "_L") (type2hs typ)))

104 (mbParen $ pf2hs t1))

105 (mbParen $ pf2hs t2)

106

107 pf2hs (HyloO typ t1 t2) = -- hyloO (_L::typ) t1 t2

108 App (App (App

109 (mkVar "hyloO") (Paren $ ExpTypeSig mkLoc

110 (mkVar "_L") (type2hs typ)))

111 (mbParen $ pf2hs t1))

112 (mbParen $ pf2hs t2)

113

114

115 type2hs :: Pointfree.Type -> Exts.Type

116 type2hs One = mkTCon "One"

117 type2hs (Base s) = TyVar (Ident s)

118 type2hs (t1 :*: t2) = TyTuple Boxed [type2hs t1, type2hs t2]

119 type2hs (t1 :+: t2) = TyApp (TyApp (mkTCon "Either")

120 (type2hs t1)) (type2hs t2)

121 type2hs (t1 :-> t2) = TyFun (type2hs t1) (type2hs t2)

122 type2hs (Fix t) = TyApp (mkTCon "Fix") (func2hs t)

123 where

124 func2hs Id = mkTCon "Id"

125 func2hs (Const t) = TyApp (mkTCon "Const") (type2hs t)

126 -- grammar not rich enough to allow infix constructors

127 func2hs (f :**: g) = TyApp (TyApp (mkTCon "(:*:)")

128 (func2hs f)) (func2hs g)

129 func2hs (f :++: g) = TyApp (TyApp (mkTCon "(:+:)")

130 (func2hs f)) (func2hs g)

131

132

133 -- Auxiliary functions --

134 mkLoc = SrcLoc "" 0 0

135 mkOp = QVarOp . UnQual . Symbol

136 mkCon = Con . UnQual . Ident

137 mkVar = Var . UnQual . Ident

138 mkTCon = TyCon . UnQual . Ident

139

140 -- places parentisis in an expression only if it is necessary

141 mbParen :: Exp -> Exp

142 mbParen e@(App _ _) = Paren e

143 mbParen e@(InfixApp _ _ _) = Paren e

144 mbParen e@(Case _ _) = Paren e

145 mbParen e@(Lambda _ _ _) = Paren e

146 mbParen x = x