comments
[darcs-mirror-polyfix.git] / Expr.hs
1 {-# LANGUAGE PatternGuards  #-}
2 module Expr where
3
4 import Data.List
5 import ParseType
6
7 data Expr
8         = Var String
9         | App Expr Expr
10         | Conc [Expr] -- Conc [] is Id
11         | Lambda String Expr
12         | Pair Expr Expr
13         | Map
14             deriving (Eq)
15
16 data BoolExpr 
17         = BETrue
18         | Equal Expr Expr
19         | And BoolExpr BoolExpr
20         | AllZipWith String String BoolExpr Expr Expr
21         | Condition Expr Expr Typ BoolExpr BoolExpr
22         | UnpackPair String String Expr Bool Typ BoolExpr
23         | UnCond String Bool Typ BoolExpr
24         | TypeVarInst Int BoolExpr
25             deriving (Eq)
26
27 -- Smart constructors
28
29 equal = Equal
30
31 unpackPair = UnpackPair
32
33 allZipWith v1 v2 rel e1 e2 | Just v1' <- defFor v1 rel =
34                                 e1 `equal` app (app Map (lambda v2 v1')) e2
35                            | Just v2' <- defFor v2 rel =
36                                 app (app Map (lambda v1 v2')) e1 `equal` e2
37                            | otherwise =
38                                 AllZipWith v1 v2 rel e1 e2
39
40 -- | Is inside the term a definition for the variable?
41 defFor v (e1 `Equal` e2) | (Var v) == e1 = Just e2
42                          | (Var v) == e2 = Just e1
43 defFor v (e1 `And` e2)   | Just d  <- defFor v e1
44                          , Nothing <- defFor v e2 = Just d
45 defFor v (e1 `And` e2)   | Just d  <- defFor v e2
46                          , Nothing <- defFor v e1 = Just d
47 defFor _ _                               = Nothing
48
49 app Map (Conc []) = Conc []
50 app (Conc []) v   = v
51 app f v           = App f v
52
53 unCond v b t (Equal l r) | (Just l') <- isApplOn v l 
54                          , (Just r') <- isApplOn v r = 
55         if hasVar v l' || hasVar v r'
56         then UnCond v b t (Equal l' r')
57         else (Equal l' r')
58 unCond v b t e = UnCond v b t e
59
60 lambda v e | (Just e') <- isApplOn v e, not (hasVar v e') = e'
61            | Var v == e                                   = Conc []
62            | otherwise                                    = Lambda v e
63
64
65 conc f (Conc fs) = Conc (f:fs)
66
67 -- Helpers
68
69 isApplOn v (Var _)                                         = Nothing
70 isApplOn v (App f (Var v')) | v == v'                      = Just (Conc [f])
71 isApplOn v (App f e)        | (Just inner) <- isApplOn v e = Just (conc f inner)
72 isApplOn _ _                                               = Nothing
73
74 hasVar v (Var v')     = v == v'
75 hasVar v (App e1 e2)  = hasVar v e1 && hasVar v e2
76 hasVar v (Conc es)    = any (hasVar v) es
77 hasVar v (Lambda _ e) = hasVar v e
78 hasVar v Map          = False
79
80 isTuple (TPair _ _) = True
81 isTuple _           = False
82
83
84 -- showing
85
86 -- Precedences:
87 -- 10 fun app
88 --  9 (.)
89 --  8 ==
90 --  7 ==>
91 --  6 forall
92
93 instance Show Expr where
94         showsPrec d (Var s)     = showString s
95         showsPrec d (App e1 e2) = showParen (d>10) $
96                 showsPrec 10 e1 . showChar ' ' . showsPrec 11 e2
97         showsPrec d (Conc [])   = showString "id"
98         showsPrec d (Conc [e])  = showsPrec d e
99         showsPrec d (Conc es)   = showParen (d>9) $
100                 showIntercalate (showString " . ") (map (showsPrec 10) es)
101         showsPrec d (Lambda v e) = showParen True $ 
102                                    showString "\\" .
103                                    showString v .
104                                    showString " -> ".
105                                    showsPrec 0 e 
106         showsPrec _ (Pair e1 e2) = showParen True $ 
107                                    showsPrec 0 e1 .
108                                    showString "," .
109                                    showsPrec 0 e2
110         showsPrec _ Map           = showString "map"
111
112 showIntercalate i []  = id
113 showIntercalate i [x] = x
114 showIntercalate i (x:xs) = x . i . showIntercalate i xs
115
116 instance Show BoolExpr where
117         show (Equal e1 e2) = showsPrec 9 e1 $
118                              showString " == " $
119                              showsPrec 9 e2 ""
120         show (And be1 be2) = show be1 ++
121                              " && " ++
122                              show be2 
123         show (AllZipWith v1 v2 be e1 e2) =
124                         "allZipWith " ++
125                         "( " ++
126                         "\\" ++
127                         v1 ++
128                         " " ++
129                         v2 ++
130                         " -> " ++
131                         show be ++
132                         ")" ++
133                         " " ++
134                         showsPrec 11 e1 "" ++
135                         " " ++
136                         showsPrec 11 e2 ""
137         show (Condition v1 v2 t be1 be2) = 
138                         "forall " ++
139                         showsPrec 11 v1 "" ++
140                         " :: " ++
141                         arrowInstType False t ++
142                         ", " ++
143                         showsPrec 11 v2 "" ++
144                         " :: " ++
145                         arrowInstType True t ++
146                         ".\n" ++
147                         (if be1 /= BETrue then indent 2 (show be1) ++ "==>\n" else "") ++
148                         indent 2 (show be2)
149         show (UnpackPair v1 v2 e b t be) = 
150                         "let (" ++
151                         v1 ++
152                         "," ++
153                         v2 ++
154                         ") = " ++
155                         showsPrec 0 e "" ++
156                         " :: " ++
157                         arrowInstType b t ++
158                         " in\n" ++
159                         indent 2 (show be)
160         show (UnCond v1 b t be1) = 
161                         "forall " ++
162                         v1 ++
163                         " :: " ++
164                         arrowInstType b t ++
165                         ".\n" ++
166                         indent 2 (show be1)
167         show (TypeVarInst i be) = 
168                         "forall types t" ++
169                         show (2*i-1) ++
170                         ", t" ++
171                         show (2*i) ++
172                         ", function g" ++
173                         show i ++
174                         " :: t" ++
175                         show (2*i-1) ++
176                         " -> t" ++
177                         show (2*i) ++ 
178                         ".\n" ++
179                         indent 2 (show be)
180
181 indent n = unlines . map (replicate n ' ' ++) . lines
182
183 arrowInstType :: Bool -> Typ -> String
184 arrowInstType b = ait 0
185   where 
186         ait _ Int                       = "Int" 
187         ait _ (TVar (TypVar i)) | not b = "t" ++  show (2*i-1)
188                                 |     b = "t" ++  show (2*i)
189         ait d (Arrow t1 t2)             = paren (d>9) $ 
190                                                   ait 10 t1 ++ " -> " ++ ait 9 t2 
191         ait d (List t)                  = "[" ++ ait 0 t ++ "]"
192         ait d (TEither t1 t2)           = "Either " ++ ait 11 t1 ++ 
193                                                 " " ++ ait 11 t2
194         ait d (TPair t1 t2)             = "(" ++ ait 0 t1 ++ "," ++ ait 0 t2 ++ ")"
195
196 paren b p   =  if b then "(" ++ p ++ ")" else p