Deep tuple pattern generation
[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 defFor v (e1 `Equal` e2) | (Var v) == e1 = Just e2
41                          | (Var v) == e2 = Just e1
42 defFor _ _                               = Nothing
43
44 app Map (Conc []) = Conc []
45 app (Conc []) v   = v
46 app f v           = App f v
47
48 unCond v b t (Equal l r) | (Just l') <- isApplOn v l 
49                          , (Just r') <- isApplOn v r = 
50         if hasVar v l' || hasVar v r'
51         then UnCond v b t (Equal l' r')
52         else (Equal l' r')
53 unCond v b t e = UnCond v b t e
54
55 lambda v e | (Just e') <- isApplOn v e, not (hasVar v e') = e'
56            | Var v == e                                   = Conc []
57            | otherwise                                    = Lambda v e
58
59
60 conc f (Conc fs) = Conc (f:fs)
61
62 -- Helpers
63
64 isApplOn v (Var _)                                         = Nothing
65 isApplOn v (App f (Var v')) | v == v'                      = Just (Conc [f])
66 isApplOn v (App f e)        | (Just inner) <- isApplOn v e = Just (conc f inner)
67 isApplOn _ _                                               = Nothing
68
69 hasVar v (Var v')     = v == v'
70 hasVar v (App e1 e2)  = hasVar v e1 && hasVar v e2
71 hasVar v (Conc es)    = any (hasVar v) es
72 hasVar v (Lambda _ e) = hasVar v e
73 hasVar v Map          = False
74
75 isTuple (TPair _ _) = True
76 isTuple _           = False
77
78
79 -- showing
80
81 -- Precedences:
82 -- 10 fun app
83 --  9 (.)
84 --  8 ==
85 --  7 ==>
86 --  6 forall
87
88 instance Show Expr where
89         showsPrec d (Var s)     = showString s
90         showsPrec d (App e1 e2) = showParen (d>10) $
91                 showsPrec 10 e1 . showChar ' ' . showsPrec 11 e2
92         showsPrec d (Conc [])   = showString "id"
93         showsPrec d (Conc [e])  = showsPrec d e
94         showsPrec d (Conc es)   = showParen (d>9) $
95                 showIntercalate (showString " . ") (map (showsPrec 10) es)
96         showsPrec d (Lambda v e) = showParen True $ 
97                                    showString "\\" .
98                                    showString v .
99                                    showString " -> ".
100                                    showsPrec 0 e 
101         showsPrec _ (Pair e1 e2) = showParen True $ 
102                                    showsPrec 0 e1 .
103                                    showString "," .
104                                    showsPrec 0 e2
105         showsPrec _ Map           = showString "map"
106
107 showIntercalate i []  = id
108 showIntercalate i [x] = x
109 showIntercalate i (x:xs) = x . i . showIntercalate i xs
110
111 instance Show BoolExpr where
112         show (Equal e1 e2) = showsPrec 9 e1 $
113                              showString " == " $
114                              showsPrec 9 e2 ""
115         show (And be1 be2) = show be1 ++
116                              " && " ++
117                              show be2 
118         show (AllZipWith v1 v2 be e1 e2) =
119                         "allZipWith " ++
120                         "( " ++
121                         "\\" ++
122                         v1 ++
123                         " " ++
124                         v2 ++
125                         " -> " ++
126                         show be ++
127                         ")" ++
128                         " " ++
129                         showsPrec 11 e1 "" ++
130                         " " ++
131                         showsPrec 11 e2 ""
132         show (Condition v1 v2 t be1 be2) = 
133                         "forall " ++
134                         showsPrec 11 v1 "" ++
135                         " :: " ++
136                         arrowInstType False t ++
137                         ", " ++
138                         showsPrec 11 v2 "" ++
139                         " :: " ++
140                         arrowInstType True t ++
141                         ".\n" ++
142                         (if be1 /= BETrue then indent 2 (show be1) ++ "==>\n" else "") ++
143                         indent 2 (show be2)
144         show (UnpackPair v1 v2 e b t be) = 
145                         "let (" ++
146                         v1 ++
147                         "," ++
148                         v2 ++
149                         ") = " ++
150                         showsPrec 0 e "" ++
151                         " :: " ++
152                         arrowInstType b t ++
153                         " in\n" ++
154                         indent 2 (show be)
155         show (UnCond v1 b t be1) = 
156                         "forall " ++
157                         v1 ++
158                         " :: " ++
159                         arrowInstType b t ++
160                         ".\n" ++
161                         indent 2 (show be1)
162         show (TypeVarInst i be) = 
163                         "forall types t" ++
164                         show (2*i-1) ++
165                         ", t" ++
166                         show (2*i) ++
167                         ", function g" ++
168                         show i ++
169                         " :: t" ++
170                         show (2*i-1) ++
171                         " -> t" ++
172                         show (2*i) ++ 
173                         ".\n" ++
174                         indent 2 (show be)
175
176 indent n = unlines . map (replicate n ' ' ++) . lines
177
178 arrowInstType :: Bool -> Typ -> String
179 arrowInstType b = ait 0
180   where 
181         ait _ Int                       = "Int" 
182         ait _ (TVar (TypVar i)) | not b = "t" ++  show (2*i-1)
183                                 |     b = "t" ++  show (2*i)
184         ait d (Arrow t1 t2)             = paren (d>9) $ 
185                                                   ait 10 t1 ++ " -> " ++ ait 9 t2 
186         ait d (List t)                  = "[" ++ ait 0 t ++ "]"
187         ait d (TEither t1 t2)           = "Either " ++ ait 11 t1 ++ 
188                                                 " " ++ ait 11 t2
189         ait d (TPair t1 t2)             = "(" ++ ait 0 t1 ++ "," ++ ait 0 t2 ++ ")"
190
191 paren b p   =  if b then "(" ++ p ++ ")" else p