"Combining" in parenthesis
[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 Control.Monad.State
8
9 data AST = AST [ Decl ]
10
11 instance Ppr AST where
12     ppr (AST ds) = 
13         let dss = groupBy (\(Decl f _ _ _) (Decl g _ _ _) -> f == g) ds
14         in vcat $ map pprDecls dss 
15         where 
16           pprDecls (d:ds) =
17               ppr d $$ pprDeclsSimp ds 
18           pprDeclsSimp ds
19               = vcat $ map (\(Decl f _ ps e) -> ppr (Decl f FTUndet ps e)) ds
20
21 instance Show AST where 
22     show = show . ppr 
23
24 data Name 
25     = Name     String 
26     | IName    String [Int]
27     | NCmpl    Name 
28     | NTuple   Name 
29     | NTupleV  Int      -- Variable Introduced by Tupling 
30     | NTupleVC Int      -- Variable Introduced by Tupling 
31     | NBwd     Name
32     | NInv     Name 
33     | NCConF   Name     -- Constructor Name in Complement (1)
34     | NCConE   Int      -- Constructor Name in Complement (2)
35     | NCConU   Name Int -- After Renaming  
36           deriving (Eq,Ord)
37
38 instance Ppr Name where
39     ppr  (Name s) = text s
40     ppr  (IName s is) = text s <> text "_" <> 
41                         (hcat $ punctuate (text "_") $ map ppr is)
42     ppr  (NCmpl n)  = ppr n <> text "_Cmpl" 
43     ppr  (NTuple n) = ppr n <> text "_T"  
44     ppr  (NTupleV i)  = text "tv" <> ppr i
45     ppr  (NTupleVC i) = text "tc" <> ppr i
46     ppr  (NInv n)     = ppr n <> text "_I" 
47     ppr  (NBwd n)     = ppr n <> text "_B"
48     ppr  (NCConF n)   = text "C" <> ppr n
49     ppr  (NCConE i)   = text "C" <> ppr i 
50     ppr  (NCConU n i) = text "C" <> ppr n <> text "_" <> ppr i
51
52 instance Show Name where
53     show = show . ppr 
54
55 data Decl = Decl Name FType [Pat] Exp
56
57 instance Ppr Decl where
58     ppr (Decl fname ftype ps e) = 
59         addSig (ppr fname <> 
60                      parens (hsep $ punctuate comma (map ppr ps)) $$
61                      nest 4 (text "=") $$
62                      nest 6 (ppr e))
63         where 
64           addSig d = 
65               case ftype of
66                 FTUndet -> empty <> d
67                 _       -> ppr fname <+> text "::" <+> ppr ftype $$ d            
68 instance Show Decl where
69     show = show . ppr 
70
71 data Exp  = EVar ID Type Name 
72           | EFun ID Type Name [Exp] -- Exp must be variable (treeless)
73           | ECon ID Type Name [Exp]
74        deriving (Ord,Eq)
75
76 type ID = Maybe Int
77
78 addPprType t d = 
79     case t of 
80       TUndet -> d
81       _      -> d <> text "::" <> ppr t 
82
83 instance Ppr Exp where
84     ppr (EVar _ t vname)     
85         = addPprType t (ppr vname)
86     ppr (EFun _ t fname es) 
87         = addPprType t $
88             ppr fname <>
89             parens (sep $ punctuate comma (map ppr es))          
90     ppr (ECon _ t cname []) 
91         = addPprType t $ ppr cname 
92     ppr (ECon _ t cname es)
93         = addPprType t $ 
94              ppr cname <>
95              parens (sep $ punctuate comma (map ppr es))
96
97 instance Show Exp where
98     show = show . ppr 
99
100 data Pat  = PVar ID Type Name
101           | PCon ID Type Name [Pat] 
102        deriving (Ord,Eq)
103
104 instance Ppr Pat where
105     ppr (PVar _ t vname)     
106         = addPprType t (ppr vname)
107     ppr (PCon _ t cname [])
108         = addPprType t (ppr cname)
109     ppr (PCon _ t cname ps)
110         = addPprType t $ ppr cname 
111           <> parens (sep $ punctuate comma (map ppr ps))
112           
113 instance Show Pat where
114     show = show . ppr 
115
116 data FType 
117     = TFun [Int] [Type] Type -- Quantified Vars, Input Types, Output Type.
118       -- e.g. forall a. [a] -> a 
119       --      ==> TFun [TVar 1] [ TCon "[]" [TVar 1] ] (TVar 1)
120     | FTUndet
121       deriving (Eq,Ord)
122
123 instance Ppr FType where
124     ppr (FTUndet) = text "??"
125     ppr (TFun is ts t) =
126         (case is of 
127           [] -> empty 
128           _  -> text "forall" <+>
129                 hsep (map pprTV is) <>
130                 text ".")
131          <+> argType <+>
132              ppr t 
133         where
134           argType = 
135               case ts of 
136                 []  -> empty 
137                 [t] -> ppr t <+> text "->" 
138                 _   -> 
139                     parens (sep $ punctuate comma (map ppr ts)) 
140                                <+> text "->"
141           pprTV i = text ("t" ++ show i)
142              
143 instance Show FType where
144     show = show . ppr 
145
146 data Type = TUndet           -- PlaceHolder
147           | TVar Int         -- Type Variable
148           | TCon Name [Type] -- e.g. [Int], Map Int [Char]
149             deriving (Eq,Ord)
150             
151 instance Ppr Type where
152     ppr (TUndet)        = text "?"
153     ppr (TVar i)        = text ("t" ++ show i) 
154     ppr (TCon tname ts) =
155         ppr tname <+> 
156              hsep (map (\t -> f t (ppr t)) ts)
157         where
158           f (TUndet) x = x
159           f (TVar i) x = x 
160           f (TCon tname []) x = x
161           f _ x = parens x
162 instance Show Type where 
163     show = show . ppr 
164
165
166
167 typeofP (PVar _ t _)   = t 
168 typeofP (PCon _ t _ _) = t 
169 typeofE (EVar _ t _)   = t 
170 typeofE (ECon _ t _ _) = t
171 typeofE (EFun _ t _ _) = t 
172
173
174 idofP (PVar t _ _)   = t 
175 idofP (PCon t _ _ _) = t 
176 idofE (EVar t _ _)   = t 
177 idofE (ECon t _ _ _) = t
178 idofE (EFun t _ _ _) = t 
179
180 varsP p = snub $ vp p
181     where vp (PVar _ _ x)    = [x]
182           vp (PCon _ _ _ ps) = concatMap vp ps
183 varsE e = snub $ ve e 
184     where ve (EVar _ _ x)    = [x]
185           ve (ECon _ _ _ es) = concatMap ve es
186           ve (EFun _ _ _ es) = concatMap ve es
187
188
189 -- assignIDsAST :: AST -> AST
190 assignIDsAST (AST decls) = 
191     AST $ evalState (mapM assignIDsD decls) 10
192
193 assignIDsD :: Decl -> State Int (Decl) 
194 assignIDsD (Decl f t ps e) = 
195     do { ps' <- mapM assignIDsP ps 
196        ; e   <- assignIDsE e 
197        ; return $ Decl f t ps e }
198     where
199       uniq = do { i <- get; put (i+1) ; return $ Just (i+1) }
200       assignIDsE (EVar _ t x) = 
201           do { i <- uniq
202              ; return $ EVar i t x }
203       assignIDsE (ECon _ t c es) = 
204           do { i <- uniq 
205              ; es' <- mapM assignIDsE es
206              ; return $ ECon i t c es' }
207       assignIDsE (EFun _ t f es) = 
208           do { i <- uniq 
209              ; es' <- mapM assignIDsE es
210              ; return $ EFun i t f es' }
211
212       assignIDsP (PVar _ t x) =
213           do { i <- uniq
214              ; return $ PVar i t x }
215       assignIDsP (PCon _ t c ps) = 
216           do { i <- uniq
217              ; ps' <- mapM assignIDsP ps 
218              ; return $ PCon i t c ps' }
219
220 isSameFunc (Decl f _ _ _) (Decl g _ _ _) = f == g 
221
222
223 -- After Tupling
224
225 data TAST  = TAST [TDecl]
226 data TDecl = TDecl Name [Pat] [Exp] [VDecl] -- f(ps) = es where ... 
227 data VDecl = VDecl [Name] Name [Name]          -- vs = f(us)
228
229 instance Ppr TAST where 
230     ppr (TAST tdecls) = vcat $ map ppr tdecls 
231 instance Ppr TDecl where
232     ppr (TDecl f ps es vdecls) =
233         ppr f <> parens (hsep $ punctuate comma (map ppr ps)) $$
234             nest 4 (text "=" <+> parens (hsep $ punctuate comma (map ppr es))) $$
235             if null vdecls then 
236                 empty 
237             else 
238                 (nest 6 (text "where") $$
239                  nest 8 (vcat $ map ppr vdecls))
240 instance Ppr VDecl where
241     ppr (VDecl vs f us) = parens (hsep $ punctuate comma (map ppr vs))
242                           <+> text "=" <+> ppr f <>
243                           parens (hsep $ punctuate comma (map ppr us))