dph-plugin: use our own pipeline
[packages/dph.git] / dph-plugin / DPH / Core / Pretty.hs
1
2 module DPH.Core.Pretty
3 ( module DPH.Base.Pretty
4 , pprTopBinds)
5 where
6 import DPH.Base.Pretty
7 import CoreSyn
8 import Type
9 import Coercion
10 import Var
11 import Name
12 import OccName
13 import DataCon
14 import Literal
15
16
17 -- Top Binds ------------------------------------------------------------------
18 pprTopBinds :: Pretty a => [Bind a] -> Doc
19 pprTopBinds binds
20 = vcat $ map pprTopBind binds
21
22 pprTopBind :: Pretty a => Bind a -> Doc
23 pprTopBind (NonRec binder expr)
24 = pprBinding (binder, expr)
25 <$$> empty
26
27 pprTopBind (Rec [])
28 = text "Rec { }"
29
30 pprTopBind (Rec bb@(b:bs))
31 = vcat
32 [ text "Rec {"
33 , vcat [empty <$$> pprBinding b | b <- bb]
34 , text "end Rec }"
35 , empty ]
36
37
38 -- Binding --------------------------------------------------------------------
39 pprBinding :: Pretty a => (a, Expr a) -> Doc
40 pprBinding (binder, x)
41 = ppr binder
42 <+> breakWhen (not $ isSimpleX x)
43 <+> equals <+> align (ppr x)
44
45
46
47
48 -- Expr -----------------------------------------------------------------------
49 instance Pretty a => Pretty (Expr a) where
50 pprPrec d xx
51 = case xx of
52 Var name -> ppr name
53 Type _ -> empty -- Discard Types
54 Coercion _ -> empty -- Discard Coercions
55 Lit ll -> ppr ll
56
57 Cast x _co
58 -> pprPrec d x
59 -- pprParen' (d > 10)
60 -- $ pprPrec 11 x <+> text "`cast`" <+> text "..."
61
62 Lam{}
63 -> pprParen' (d > 2)
64 $ let (bndrs, body) = collectBinders xx
65 in text "\\" <> sep (map ppr bndrs)
66 <> text "."
67 <> (nest 2
68 $ (breakWhen $ not $ isSimpleX body)
69 <> ppr body)
70
71 App x1 x2
72 | isTypeArg x2
73 -> pprPrec d x1
74
75 | otherwise
76 -> pprParen' (d > 10)
77 $ ppr x1
78 <> nest 4 (breakWhen (not $ isSimpleX x2)
79 <> pprPrec 11 x2)
80
81 Case x1 var ty [(con, binds, x2)]
82 -> pprParen' (d > 2)
83 $ text "let"
84 <+> (fill 12 (ppr con <+> hsep (map ppr binds)))
85 -- <> breakWhen (not $ isSimpleX x1)
86 <> text "<-"
87 <+> ppr x1
88 <+> text "in"
89 <$$> ppr x2
90
91 Case x1 var ty alts
92 -> pprParen' (d > 2)
93 $ (nest 2
94 $ text "case" <+> ppr x1 <+> text "of"
95 <+> ppr var
96 <+> lbrace <> line
97 <> vcat (punctuate semi $ map pprAlt alts))
98 <> line <> rbrace
99
100
101 Let (NonRec b x1) x2
102 -> pprParen' (d > 2)
103 $ text "let"
104 <+> fill 12 (ppr b)
105 <+> equals
106 <+> ppr x1
107 <+> text "in"
108 <$$> ppr x2
109
110 Let (Rec bxs) x2
111 -> text "LETREC"
112
113 _ -> text "DUNNO"
114
115
116 -- Alt ------------------------------------------------------------------------
117 pprAlt :: Pretty a => (AltCon, [a], Expr a) -> Doc
118 pprAlt (con, binds, x)
119 = ppr con <+> (hsep $ map ppr binds)
120 <+> nest 1 (line <> nest 3 (text "->" <+> ppr x))
121
122 instance Pretty AltCon where
123 ppr con
124 = case con of
125 DataAlt con -> ppr con
126 LitAlt lit -> ppr lit
127 DEFAULT -> text "_"
128
129
130 -- Literal --------------------------------------------------------------------
131 instance Pretty Literal where
132 ppr _ = text "<LITERAL>"
133
134
135 -- Type -----------------------------------------------------------------------
136 instance Pretty Type where
137 ppr _ = empty
138
139
140 -- Coercion -------------------------------------------------------------------
141 instance Pretty Coercion where
142 ppr _ = empty
143
144
145 -- Names ----------------------------------------------------------------------
146 instance Pretty DataCon where
147 ppr con
148 = ppr (dataConName con)
149
150
151 instance Pretty CoreBndr where
152 ppr bndr
153 = ppr (Var.varName bndr)
154
155
156 instance Pretty Name where
157 ppr name
158 = ppr (nameOccName name)
159
160 instance Pretty OccName where
161 ppr occName
162 = text (occNameString occName)
163
164
165
166 -- Utils ----------------------------------------------------------------------
167 breakWhen :: Bool -> Doc
168 breakWhen True = line
169 breakWhen False = space
170
171
172 isSimpleX :: Expr a -> Bool
173 isSimpleX xx
174 = case xx of
175 Var{} -> True
176 Lit{} -> True
177 App x1 x2 -> isSimpleX x1 && isAtomX x2
178 Cast x1 _ -> isSimpleX x1
179 _ -> False
180
181 isAtomX :: Expr a -> Bool
182 isAtomX xx
183 = case xx of
184 Var{} -> True
185 Lit{} -> True
186 _ -> False
187
188
189 parens' :: Doc -> Doc
190 parens' d = lparen <> nest 1 d <> rparen
191
192
193 -- | Wrap a `Doc` in parens if the predicate is true.
194 pprParen' :: Bool -> Doc -> Doc
195 pprParen' b c
196 = if b then parens' c
197 else c
198