4 import Text.PrettyPrint
5 import Data.List (groupBy)
8 import Control.Monad.State
10 data AST = AST [ Decl ]
12 instance Ppr AST where
14 let dss = groupBy isSameFunc ds
15 in vcat $ punctuate (text "\n") $ map pprDecls dss
18 ppr d $$ pprDeclsSimp ds
20 = vcat $ map (\(Decl f _ ps e) -> ppr (Decl f FTUndet ps e)) ds
22 instance Show AST where
30 | NTupleV Int -- Variable Introduced by Tupling
31 | NTupleVC Int -- Variable Introduced by Tupling
34 | NCConF Name -- Constructor Name in Complement (1)
35 | NCConE Int -- Constructor Name in Complement (2)
36 | NCConU Name Int -- After Renaming
39 instance Ppr Name where
41 ppr (IName s is) = text s <> text "_" <>
42 (hcat $ punctuate (text "_") $ map ppr is)
43 ppr (NCmpl n) = ppr n <> text "_Cmpl"
44 ppr (NTuple n) = ppr n <> text "_T"
45 ppr (NTupleV i) = text "tv" <> ppr i
46 ppr (NTupleVC i) = text "tc" <> ppr i
47 ppr (NInv n) = ppr n <> text "_I"
48 ppr (NBwd n) = ppr n <> text "_B"
49 ppr (NCConF n) = text "C" <> ppr n
50 ppr (NCConE i) = text "C" <> ppr i
51 ppr (NCConU n i) = text "C" <> ppr n <> text "_" <> ppr i
53 instance Show Name where
56 data Decl = Decl Name FType [Pat] Exp
58 instance Ppr Decl where
59 ppr (Decl fname ftype ps e) =
61 (hsep $ map pprChildP ps) $$
62 -- parens (hsep $ punctuate comma (map ppr ps)) $$
69 _ -> ppr fname <+> text "::" <+> ppr ftype $$ d
70 instance Show Decl where
73 data Exp = EVar ID Type Name
74 | EFun ID Type Name [Exp] -- Exp must be variable (treeless)
75 | ECon ID Type Name [Exp]
83 _ -> parens ( d <> text "::" <> ppr t )
86 pprChildE e | isAtomicE e = ppr e
87 | otherwise = parens (ppr e)
88 isAtomicE (EVar _ _ _) = True
89 isAtomicE (EFun _ _ _ []) = True
90 isAtomicE (ECon _ _ _ []) = True
91 isAtomicE e | isAllListE e = True
94 pprListE (ECon _ _ (Name "Cons") [e1,ECon _ _ (Name "Nil") []])
96 pprListE (ECon _ _ (Name "Cons") [e1,e2])
97 = ppr e1 <> comma <+> pprListE e2
98 pprListE (ECon _ _ (Name "Nil") [])
101 isAllListE (ECon _ _ (Name "Cons") [e1,e2])
103 isAllListE (ECon _ _ (Name "Nil") [])
108 instance Ppr Exp where
110 = addPprType t (ppr vname)
111 ppr (EFun _ t fname es)
114 (hsep $ map pprChildE es)
115 -- parens (sep $ punctuate comma (map ppr es))
117 = brackets (pprListE e )
118 ppr (ECon _ _ (Name "Cons") [e1,e2])
119 = pprChildE e1 <> text ":" <> ppr e2
120 ppr (ECon _ _ (Name "Unit") [])
122 ppr (ECon _ t cname [])
123 = addPprType t $ ppr cname
124 ppr (ECon _ t cname es)
127 (hsep $ map pprChildE es)
128 -- parens (sep $ punctuate comma (map ppr es))
131 instance Show Exp where
134 data Pat = PVar ID Type Name
135 | PCon ID Type Name [Pat]
139 pprChildP p | isAtomicP p = ppr p
140 | otherwise = parens (ppr p)
141 isAtomicP (PVar _ _ _) = True
142 isAtomicP (PCon _ _ _ []) = True
143 isAtomicP p | isAllListP p = True
146 pprListP (PCon _ _ (Name "Cons") [p1, PCon _ _ (Name "Nil") []])
148 pprListP (PCon _ _ (Name "Cons") [p1,p2])
149 = ppr p1 <> comma <+> pprListP p2
150 pprListP (PCon _ _ (Name "Nil") [])
153 isAllListP (PCon _ _ (Name "Cons") [p1,p2])
155 isAllListP (PCon _ _ (Name "Nil") [])
161 instance Ppr Pat where
163 = addPprType t (ppr vname)
165 = brackets (pprListP e )
166 ppr (PCon _ _ (Name "Cons") [p1,p2])
167 = pprChildP p1 <> text ":" <> ppr p2
168 ppr (PCon _ _ (Name "Unit") []) -- never happens
170 ppr (PCon _ t cname [])
171 = addPprType t (ppr cname)
172 ppr (PCon _ t cname ps)
173 = addPprType t $ ppr cname
174 <+> (hsep $ map pprChildP ps)
175 -- <> parens (sep $ punctuate comma (map ppr ps))
177 instance Show Pat where
181 = TFun [Int] [Type] Type -- Quantified Vars, Input Types, Output Type.
182 -- e.g. forall a. [a] -> a
183 -- ==> TFun [TVar 1] [ TCon "[]" [TVar 1] ] (TVar 1)
187 instance Ppr FType where
188 ppr (FTUndet) = text "??"
192 _ -> text "forall" <+>
193 hsep (map pprTV is) <>
201 [t] -> ppr t <+> text "->"
203 parens (sep $ punctuate comma (map ppr ts))
205 pprTV i = text ("t" ++ show i)
207 instance Show FType where
210 data Type = TUndet -- PlaceHolder
211 | TVar Int -- Type Variable
212 | TCon Name [Type] -- e.g. [Int], Map Int [Char]
215 instance Ppr Type where
216 ppr (TUndet) = text "?"
217 ppr (TVar i) = text ("t" ++ show i)
218 ppr (TCon (Name "Unit") []) =
220 ppr (TCon (Name "List") [t]) =
222 ppr (TCon tname ts) =
224 hsep (map (\t -> f t (ppr t)) ts)
228 f (TCon tname []) x = x
230 instance Show Type where
235 typeofP (PVar _ t _) = t
236 typeofP (PCon _ t _ _) = t
237 typeofE (EVar _ t _) = t
238 typeofE (ECon _ t _ _) = t
239 typeofE (EFun _ t _ _) = t
242 idofP (PVar t _ _) = t
243 idofP (PCon t _ _ _) = t
244 idofE (EVar t _ _) = t
245 idofE (ECon t _ _ _) = t
246 idofE (EFun t _ _ _) = t
248 varsP p = snub $ vp p
249 where vp (PVar _ _ x) = [x]
250 vp (PCon _ _ _ ps) = concatMap vp ps
251 varsE e = snub $ ve e
252 where ve (EVar _ _ x) = [x]
253 ve (ECon _ _ _ es) = concatMap ve es
254 ve (EFun _ _ _ es) = concatMap ve es
257 -- assignIDsAST :: AST -> AST
258 assignIDsAST (AST decls) =
259 AST $ evalState (mapM assignIDsD decls) 10
261 assignIDsD :: Decl -> State Int (Decl)
262 assignIDsD (Decl f t ps e) =
263 do { ps' <- mapM assignIDsP ps
265 ; return $ Decl f t ps e }
267 uniq = do { i <- get; put (i+1) ; return $ Just (i+1) }
268 assignIDsE (EVar _ t x) =
270 ; return $ EVar i t x }
271 assignIDsE (ECon _ t c es) =
273 ; es' <- mapM assignIDsE es
274 ; return $ ECon i t c es' }
275 assignIDsE (EFun _ t f es) =
277 ; es' <- mapM assignIDsE es
278 ; return $ EFun i t f es' }
280 assignIDsP (PVar _ t x) =
282 ; return $ PVar i t x }
283 assignIDsP (PCon _ t c ps) =
285 ; ps' <- mapM assignIDsP ps
286 ; return $ PCon i t c ps' }
288 isSameFunc (Decl f _ _ _) (Decl g _ _ _) = f == g
293 data TAST = TAST [TDecl]
294 data TDecl = TDecl Name [Pat] [Exp] [VDecl] -- f(ps) = es where ...
295 data VDecl = VDecl [Name] Name [Name] -- vs = f(us)
297 parensIfMultiple [] = parens empty
298 parensIfMultiple [p] = p
299 parensIfMultiple ps = parens (hsep $ punctuate comma ps)
301 instance Ppr TAST where
303 let tdeclss = groupBy (\(TDecl f _ _ _) (TDecl g _ _ _) -> f == g) tdecls
304 in vcat $ punctuate (text "\n") $ map (\tdecls -> vcat $ map ppr tdecls) tdeclss
307 instance Ppr TDecl where
308 ppr (TDecl f ps es vdecls) =
309 ppr f <+> parensIfMultiple (map ppr ps) $$
310 nest 4 (text "=" <+> parensIfMultiple (map ppr es)) $$
314 (nest 6 (text "where") $$
315 nest 8 (vcat $ map ppr vdecls))
316 instance Ppr VDecl where
317 ppr (VDecl vs f us) = parensIfMultiple (map ppr vs)
318 <+> text "=" <+> ppr f <>
319 parensIfMultiple (map ppr us)