Make MyInterpret more configurable WRT loaded modules
[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 (PCon i (TCon (Name "List") [TCon (Name "Unit") []]) 
38                       (Name "Nil") [])
39           = zP i
40       replP (PCon i (TCon (Name "List") [TCon (Name "Unit") []])
41                       (Name "Cons") [x,y])
42           = sP i (replP y)
43       replP (PCon i t c ps)
44           = PCon i (replT t) c (map replP ps)
45
46       replE (EVar i (TCon (Name "List") [TCon (Name "Unit") []]) x)
47           = EVar i (TCon (Name "Nat") []) x
48       replE (ECon i (TCon (Name "List") [TCon (Name "Unit") []]) 
49                       (Name "Nil") [])
50           = zE i 
51       replE (ECon i (TCon (Name "List") [TCon (Name "Unit") []])
52                       (Name "Cons") [x,y])
53           = sE i (replE y)
54       replE (ECon i t c es) = ECon i (replT t) c (map replE es)
55       replE (EFun i t f es) = EFun i (replT t) f (map replE es)
56       
57
58 -- removes parameters/arguments of which type is Unit
59 -- FIXME: This function only checks "Unit" but no singleton types.
60 specializeUnit :: AST -> AST
61 specializeUnit (AST decls) =
62     assignIDsAST $ AST $ map spUnitD decls 
63     where
64       spUnitD (Decl f (TFun is ts t) ps e) =
65           let isUnits = map isUnit ts 
66               ts'     = map fst $ filter (\(_,b) -> not b) $ zip ts isUnits 
67               ps'     = map fst $ filter (\(_,b) -> not b) $ zip ps isUnits 
68           in Decl f (TFun is ts' t) ps' (spUnitE e)
69       spUnitE (EVar i t x)    = EVar i t x
70       spUnitE (ECon i t c es) = ECon i t c (map spUnitE es)
71       spUnitE (EFun i t f es) = 
72           let isUnits = map isUnit (map typeofE es) 
73               es'     = map fst $ filter (\(_,b) -> not b) $ 
74                           zip (map spUnitE es) isUnits 
75           in EFun i t f es' 
76       isUnit (TCon (Name "Unit") []) = True
77       isUnit _                       = False
78               
79
80 -- replaces all "e::t" -> "Unit::Unit"
81 --          and "p::t" -> "Unit::Unit" 
82 -- in functions with type 
83 --              "forall ... t ... . ..."
84 shapify :: AST -> AST
85 shapify (AST decls) = --AST $ map shapifyD decls 
86     specializeUnit $ 
87      AST $ fix (\f proced pend rdecls -> 
88                  let rest = pend \\ proced 
89                  in if null rest then 
90                         rdecls 
91                     else
92                         let decls' = shapifySig rest
93                             pend'  = collectPending decls'
94                         in f (rest++proced) pend' (decls'++rdecls))
95             [] initPend []
96     where
97 --       initPend = Map.toList $ Map.fromList $ map 
98 --                    (\(Decl f (TFun is ts t) _ _) -> 
99 --                         (f,TFun [] (map (replT is) ts) (replT is t))) decls
100       initPend = Map.toList $ Map.fromList $ map
101                   (\(Decl f (TFun is _ _) _ _) -> (f,is)) decls
102
103       unitT = TCon (Name "Unit") []
104       unitP i = PCon i unitT (Name "Unit") []
105       unitE i = ECon i unitT (Name "Unit") []
106               
107       signituresMap 
108           = Map.fromList $ map 
109             (\(Decl f (TFun is ts t) _ _) -> (f,TFun is ts t)) decls
110
111       collectPending decls =
112           snub $ concatMap (\(Decl _ _ _ e) -> funCallsWithT e) decls
113       funCallsWithT (EVar _ _ _)    = []
114       funCallsWithT (ECon _ _ _ es) = concatMap funCallsWithT es
115       funCallsWithT (EFun _ _ (IName f is) es) 
116           = (Name f,is):concatMap funCallsWithT es 
117       funCallsWithT (EFun _ _ _ es) = concatMap funCallsWithT es 
118 --       funCallsWithT (EFun t f es) = (f,TFun [] (map typeofE es) t):
119 --                                        concatMap funCallsWithT es
120       shapifySig [] = []
121       shapifySig ((f,is'):rs)
122           = concatMap (\(d@(Decl g (TFun _ _ _) _ _))  ->
123                            if f == g then 
124                                [shapifyD is' d]
125                            else
126                                []
127                            ) decls ++shapifySig rs 
128       unifyU []                                   = []
129       unifyU ((TCon (Name "Unit") [], TVar i):rs)    = i:unifyU rs
130       unifyU ((TVar i, TCon (Name "Unit") []):rs)    = i:unifyU rs
131       unifyU ((TCon c ts, TCon c' ts'):rs) | c == c' = unifyU (zip ts ts') ++ unifyU rs
132       unifyU (_:rs)                                  = unifyU rs 
133       shapifyD is' (Decl (Name s) (TFun is ts t) ps e)
134           = let ftype = (TFun (is\\is') (map (replT is') ts) (replT is' t))
135             in Decl (IName s is') ftype
136                    (map (replP is') ps) (replE is' e)
137       replT is (TVar i) | i `elem` is = unitT
138                         | otherwise   = TVar i 
139       replT is (TCon c ts) = TCon c (map (replT is) ts)
140
141       replP is p = 
142           case typeofP p of 
143             TVar i | i `elem` is -> unitP (idofP p) 
144             _ -> 
145                 case p of 
146                   PVar i t x    -> PVar i (replT is t) x
147                   PCon i t c ps -> PCon i (replT is t) c (map (replP is) ps)
148
149       replE is e = 
150           case typeofE e of 
151             TVar i | i `elem` is -> unitE (idofE e)
152             _ -> 
153                 case e of 
154                   EVar i t x    -> EVar i (replT is t) x
155                   ECon i t c es -> ECon i (replT is t) c (map (replE is) es)
156                   EFun i t (IName f _) es ->
157                       funCallE i is t f es                       
158                   EFun i t (Name f) es ->
159                       funCallE i is t f es
160           where funCallE i is t f es = 
161                     let es' = map (replE is) es 
162                         TFun is' ts' t' 
163                             = fromJust $ Map.lookup (Name f) signituresMap 
164                         ts  = map typeofE es' 
165                         is'' = intersect 
166                                  is' 
167                                  (snub $ unifyU $ zip (t:ts) (t':ts'))
168                     in  
169                       EFun i (replT is t) (IName f is'') es'