Input and output codes now looks similar to Haskell (or Curry?)
[darcs-mirror-sem_syn.git] / AST.hs
1 module AST where 
2
3 import Util 
4 import Text.PrettyPrint
5 import Data.List (groupBy)
6
7 import Debug.Trace 
8 import Control.Monad.State
9
10 data AST = AST [ Decl ]
11
12 instance Ppr AST where
13     ppr (AST ds) = 
14         let dss = groupBy isSameFunc ds
15         in vcat $ punctuate (text "\n") $ map pprDecls dss 
16         where 
17           pprDecls (d:ds) =
18               ppr d $$ pprDeclsSimp ds 
19           pprDeclsSimp ds
20               = vcat $ map (\(Decl f _ ps e) -> ppr (Decl f FTUndet ps e)) ds
21
22 instance Show AST where 
23     show = show . ppr 
24
25 data Name 
26     = Name     String 
27     | IName    String [Int]
28     | NCmpl    Name 
29     | NTuple   Name 
30     | NTupleV  Int      -- Variable Introduced by Tupling 
31     | NTupleVC Int      -- Variable Introduced by Tupling 
32     | NBwd     Name
33     | NInv     Name 
34     | NCConF   Name     -- Constructor Name in Complement (1)
35     | NCConE   Int      -- Constructor Name in Complement (2)
36     | NCConU   Name Int -- After Renaming  
37           deriving (Eq,Ord)
38
39 instance Ppr Name where
40     ppr  (Name s) = text s
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
52
53 instance Show Name where
54     show = show . ppr 
55
56 data Decl = Decl Name FType [Pat] Exp
57
58 instance Ppr Decl where
59     ppr (Decl fname ftype ps e) = 
60         addSig (ppr fname <+> 
61                     (hsep $ map pprChildP ps) $$
62 --                     parens (hsep $ punctuate comma (map ppr ps)) $$
63                      nest 4 (text "=") $$
64                      nest 6 (ppr e))
65         where 
66           addSig d = 
67               case ftype of
68                 FTUndet -> empty <> d
69                 _       -> ppr fname <+> text "::" <+> ppr ftype $$ d            
70 instance Show Decl where
71     show = show . ppr 
72
73 data Exp  = EVar ID Type Name 
74           | EFun ID Type Name [Exp] -- Exp must be variable (treeless)
75           | ECon ID Type Name [Exp]
76        deriving (Ord,Eq)
77
78 type ID = Maybe Int
79
80 addPprType t d = 
81     case t of 
82       TUndet -> d
83       _      -> parens ( d <> text "::" <> ppr t )
84
85
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 
92 isAtomicE _                = False
93
94 pprListE (ECon _ _ (Name "Cons") [e1,ECon _ _ (Name "Nil") []]) 
95     = ppr e1 
96 pprListE (ECon _ _ (Name "Cons") [e1,e2]) 
97     = ppr e1 <> comma <+> pprListE e2 
98 pprListE (ECon _ _ (Name "Nil") []) 
99     = empty
100
101 isAllListE (ECon _ _ (Name "Cons") [e1,e2])
102     = isAllListE e2 
103 isAllListE (ECon _ _ (Name "Nil") []) 
104     = True
105 isAllListE _ 
106     = False 
107
108 instance Ppr Exp where
109     ppr (EVar _ t vname)     
110         = addPprType t (ppr vname)
111     ppr (EFun _ t fname es) 
112         = addPprType t $
113             ppr fname <+>
114                 (hsep $ map pprChildE es)
115 --            parens (sep $ punctuate comma (map ppr es))          
116     ppr e | isAllListE e
117         = brackets (pprListE e )
118     ppr (ECon _ _ (Name "Cons") [e1,e2]) 
119         = pprChildE e1 <> text ":" <> ppr e2 
120     ppr (ECon _ _ (Name "Unit") []) 
121         = parens empty 
122     ppr (ECon _ t cname []) 
123         = addPprType t $ ppr cname 
124     ppr (ECon _ t cname es)
125         = addPprType t $ 
126              ppr cname <+>
127                  (hsep $ map pprChildE es)
128 --             parens (sep $ punctuate comma (map ppr es))
129
130
131 instance Show Exp where
132     show = show . ppr 
133
134 data Pat  = PVar ID Type Name
135           | PCon ID Type Name [Pat] 
136        deriving (Ord,Eq)
137
138
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
144 isAtomicP _                = False
145
146 pprListP (PCon _ _ (Name "Cons") [p1, PCon _ _ (Name "Nil") []])
147     = ppr p1
148 pprListP (PCon _ _ (Name "Cons") [p1,p2]) 
149     = ppr p1 <> comma <+> pprListP p2 
150 pprListP (PCon _ _ (Name "Nil") []) 
151     = empty
152
153 isAllListP (PCon _ _ (Name "Cons") [p1,p2])
154     = isAllListP p2 
155 isAllListP (PCon _ _ (Name "Nil") []) 
156     = True
157 isAllListP _ 
158     = False 
159
160
161 instance Ppr Pat where
162     ppr (PVar _ t vname)     
163         = addPprType t (ppr vname)
164     ppr e | isAllListP e
165         = brackets (pprListP e )
166     ppr (PCon _ _ (Name "Cons") [p1,p2]) 
167         = pprChildP p1 <> text ":" <> ppr p2 
168     ppr (PCon _ _ (Name "Unit") []) -- never happens 
169         = parens empty 
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))
176           
177 instance Show Pat where
178     show = show . ppr 
179
180 data FType 
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)
184     | FTUndet
185       deriving (Eq,Ord)
186
187 instance Ppr FType where
188     ppr (FTUndet) = text "??"
189     ppr (TFun is ts t) =
190         (case is of 
191           [] -> empty 
192           _  -> text "forall" <+>
193                 hsep (map pprTV is) <>
194                 text ".")
195          <+> argType <+>
196              ppr t 
197         where
198           argType = 
199               case ts of 
200                 []  -> empty 
201                 [t] -> ppr t <+> text "->" 
202                 _   -> 
203                     parens (sep $ punctuate comma (map ppr ts)) 
204                                <+> text "->"
205           pprTV i = text ("t" ++ show i)
206              
207 instance Show FType where
208     show = show . ppr 
209
210 data Type = TUndet           -- PlaceHolder
211           | TVar Int         -- Type Variable
212           | TCon Name [Type] -- e.g. [Int], Map Int [Char]
213             deriving (Eq,Ord)
214             
215 instance Ppr Type where
216     ppr (TUndet)        = text "?"
217     ppr (TVar i)        = text ("t" ++ show i) 
218     ppr (TCon (Name "Unit") []) =
219         parens empty 
220     ppr (TCon (Name "List") [t]) = 
221         brackets $ ppr t
222     ppr (TCon tname ts) =
223         ppr tname <+> 
224              hsep (map (\t -> f t (ppr t)) ts)
225         where
226           f (TUndet) x = x
227           f (TVar i) x = x 
228           f (TCon tname []) x = x
229           f _ x = parens x
230 instance Show Type where 
231     show = show . ppr 
232
233
234
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 
240
241
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 
247
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
255
256
257 -- assignIDsAST :: AST -> AST
258 assignIDsAST (AST decls) = 
259     AST $ evalState (mapM assignIDsD decls) 10
260
261 assignIDsD :: Decl -> State Int (Decl) 
262 assignIDsD (Decl f t ps e) = 
263     do { ps' <- mapM assignIDsP ps 
264        ; e   <- assignIDsE e 
265        ; return $ Decl f t ps e }
266     where
267       uniq = do { i <- get; put (i+1) ; return $ Just (i+1) }
268       assignIDsE (EVar _ t x) = 
269           do { i <- uniq
270              ; return $ EVar i t x }
271       assignIDsE (ECon _ t c es) = 
272           do { i <- uniq 
273              ; es' <- mapM assignIDsE es
274              ; return $ ECon i t c es' }
275       assignIDsE (EFun _ t f es) = 
276           do { i <- uniq 
277              ; es' <- mapM assignIDsE es
278              ; return $ EFun i t f es' }
279
280       assignIDsP (PVar _ t x) =
281           do { i <- uniq
282              ; return $ PVar i t x }
283       assignIDsP (PCon _ t c ps) = 
284           do { i <- uniq
285              ; ps' <- mapM assignIDsP ps 
286              ; return $ PCon i t c ps' }
287
288 isSameFunc (Decl f _ _ _) (Decl g _ _ _) = f == g 
289
290
291 -- After Tupling
292
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)
296
297 parensIfMultiple []  = parens empty 
298 parensIfMultiple [p] = p
299 parensIfMultiple ps  = parens (hsep $ punctuate comma ps)
300
301 instance Ppr TAST where 
302     ppr (TAST tdecls) = 
303         let tdeclss = groupBy (\(TDecl f _ _ _) (TDecl g _ _ _) -> f == g) tdecls 
304         in vcat $ punctuate (text "\n") $ map (\tdecls -> vcat $ map ppr tdecls) tdeclss
305
306
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)) $$
311             if null vdecls then 
312                 empty 
313             else 
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)