"Combining" in parenthesis
[darcs-mirror-sem_syn.git] / Shapify.hs
1 module Shapify where
2
3 import Util 
4 import AST
5
6 import Data.Map (Map)
7 import qualified Data.Map as Map
8
9 import Data.Function (fix)
10 import Data.Maybe
11 import Data.List ((\\), intersect)
12
13 -- replaces  "Nil :: Unit"            -> "Z"
14 --           "Cons(_,y) :: List Unit" ->  S(y)
15 introNat :: AST -> AST 
16 introNat (AST decls) =
17     AST $ map introNatD decls 
18     where
19       natT = TCon (Name "Nat") []
20       zP i   = PCon i natT (Name "Z") []
21       sP i x = PCon i natT (Name "S") [x]
22       zE i   = ECon i natT (Name "Z") []
23       sE i x = ECon i natT (Name "S") [x]
24       introNatD (Decl f (TFun is ts t) ps e) =
25           let ts' = map replT ts 
26               t'  = replT t
27               ps' = map replP ps
28               e'  = replE e
29           in Decl f (TFun is ts' t') ps' e'
30       replT (TCon (Name "List") [TCon (Name "Unit") []]) 
31           = TCon (Name "Nat") []
32       replT (TVar i)    = TVar i
33       replT (TCon c ts) = TCon c (map replT ts)
34
35       replP (PVar i (TCon (Name "List") [TCon (Name "Unit") []]) x)
36           = PVar i (TCon (Name "Nat") []) x
37       replP (PVar i t x) 
38           = PVar i (replT t) x 
39       replP (PCon i (TCon (Name "List") [TCon (Name "Unit") []]) 
40                       (Name "Nil") [])
41           = zP i
42       replP (PCon i (TCon (Name "List") [TCon (Name "Unit") []])
43                       (Name "Cons") [x,y])
44           = sP i (replP y)
45       replP (PCon i t c ps)
46           = PCon i (replT t) c (map replP ps)
47  
48       replE (EVar i (TCon (Name "List") [TCon (Name "Unit") []]) x)
49           = EVar i (TCon (Name "Nat") []) x
50       replE (EVar i t x) 
51           = EVar i (replT t) x 
52       replE (ECon i (TCon (Name "List") [TCon (Name "Unit") []]) 
53                       (Name "Nil") [])
54           = zE i 
55       replE (ECon i (TCon (Name "List") [TCon (Name "Unit") []])
56                       (Name "Cons") [x,y])
57           = sE i (replE y)
58       replE (ECon i t c es) = ECon i (replT t) c (map replE es)
59       replE (EFun i t f es) = EFun i (replT t) f (map replE es)
60       
61
62 -- removes parameters/arguments of which type is Unit
63 -- FIXME: This function only checks "Unit" but no singleton types.
64 specializeUnit :: AST -> AST
65 specializeUnit (AST decls) =
66     assignIDsAST $ AST $ map spUnitD decls 
67     where
68       spUnitD (Decl f (TFun is ts t) ps e) =
69           let isUnits = map isUnit ts 
70               ts'     = map fst $ filter (\(_,b) -> not b) $ zip ts isUnits 
71               ps'     = map fst $ filter (\(_,b) -> not b) $ zip ps isUnits 
72           in Decl f (TFun is ts' t) ps' (spUnitE e)
73       spUnitE (EVar i t x)    = EVar i t x
74       spUnitE (ECon i t c es) = ECon i t c (map spUnitE es)
75       spUnitE (EFun i t f es) = 
76           let isUnits = map isUnit (map typeofE es) 
77               es'     = map fst $ filter (\(_,b) -> not b) $ 
78                           zip (map spUnitE es) isUnits 
79           in EFun i t f es' 
80       isUnit (TCon (Name "Unit") []) = True
81       isUnit _                       = False
82               
83
84 -- replaces all "e::t" -> "Unit::Unit"
85 --          and "p::t" -> "Unit::Unit" 
86 -- in functions with type 
87 --              "forall ... t ... . ..."
88 shapify :: AST -> AST
89 shapify (AST decls) = --AST $ map shapifyD decls 
90     specializeUnit $ 
91      AST $ fix (\f proced pend rdecls -> 
92                  let rest = pend \\ proced 
93                  in if null rest then 
94                         rdecls 
95                     else
96                         let decls' = shapifySig rest
97                             pend'  = collectPending decls'
98                         in f (rest++proced) pend' (decls'++rdecls))
99             [] initPend []
100     where
101 --       initPend = Map.toList $ Map.fromList $ map 
102 --                    (\(Decl f (TFun is ts t) _ _) -> 
103 --                         (f,TFun [] (map (replT is) ts) (replT is t))) decls
104       initPend = Map.toList $ Map.fromList $ map
105                   (\(Decl f (TFun is _ _) _ _) -> (f,is)) decls
106
107       unitT = TCon (Name "Unit") []
108       unitP i = PCon i unitT (Name "Unit") []
109       unitE i = ECon i unitT (Name "Unit") []
110               
111       signituresMap 
112           = Map.fromList $ map 
113             (\(Decl f (TFun is ts t) _ _) -> (f,TFun is ts t)) decls
114
115       collectPending decls =
116           snub $ concatMap (\(Decl _ _ _ e) -> funCallsWithT e) decls
117       funCallsWithT (EVar _ _ _)    = []
118       funCallsWithT (ECon _ _ _ es) = concatMap funCallsWithT es
119       funCallsWithT (EFun _ _ (IName f is) es) 
120           = (Name f,is):concatMap funCallsWithT es 
121       funCallsWithT (EFun _ _ _ es) = concatMap funCallsWithT es 
122 --       funCallsWithT (EFun t f es) = (f,TFun [] (map typeofE es) t):
123 --                                        concatMap funCallsWithT es
124       shapifySig [] = []
125       shapifySig ((f,is'):rs)
126           = concatMap (\(d@(Decl g (TFun _ _ _) _ _))  ->
127                            if f == g then 
128                                [shapifyD is' d]
129                            else
130                                []
131                            ) decls ++shapifySig rs 
132       unifyU []                                   = []
133       unifyU ((TCon (Name "Unit") [], TVar i):rs)    = i:unifyU rs
134       unifyU ((TVar i, TCon (Name "Unit") []):rs)    = i:unifyU rs
135       unifyU ((TCon c ts, TCon c' ts'):rs) | c == c' = unifyU (zip ts ts') ++ unifyU rs
136       unifyU (_:rs)                                  = unifyU rs 
137       shapifyD is' (Decl (Name s) (TFun is ts t) ps e)
138           = let ftype = (TFun (is\\is') (map (replT is') ts) (replT is' t))
139             in Decl (IName s is') ftype
140                    (map (replP is') ps) (replE is' e)
141       replT is (TVar i) | i `elem` is = unitT
142                         | otherwise   = TVar i 
143       replT is (TCon c ts) = TCon c (map (replT is) ts)
144
145       replP is p = 
146           case typeofP p of 
147             TVar i | i `elem` is -> unitP (idofP p) 
148             _ -> 
149                 case p of 
150                   PVar i t x    -> PVar i (replT is t) x
151                   PCon i t c ps -> PCon i (replT is t) c (map (replP is) ps)
152
153       replE is e = 
154           case typeofE e of 
155             TVar i | i `elem` is -> unitE (idofE e)
156             _ -> 
157                 case e of 
158                   EVar i t x    -> EVar i (replT is t) x
159                   ECon i t c es -> ECon i (replT is t) c (map (replE is) es)
160                   EFun i t (IName f _) es ->
161                       funCallE i is t f es                       
162                   EFun i t (Name f) es ->
163                       funCallE i is t f es
164           where funCallE i is t f es = 
165                     let es' = map (replE is) es 
166                         TFun is' ts' t' 
167                             = fromJust $ Map.lookup (Name f) signituresMap 
168                         ts  = map typeofE es' 
169                         is'' = intersect 
170                                  is' 
171                                  (snub $ unifyU $ zip (t:ts) (t':ts'))
172                     in  
173                       EFun i (replT is t) (IName f is'') es'