2846c6b576fd2d71a0a6701452f4f81a9cc5becc
[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         | Map
13             deriving (Eq)
14
15 data BoolExpr 
16         = Equal Expr Expr
17         | AllZipWith String String BoolExpr Expr Expr
18         | Condition String String Typ BoolExpr BoolExpr
19         | UnCond String Bool Typ BoolExpr
20         | TypeVarInst Int BoolExpr
21             deriving (Eq)
22
23 -- Smart constructors
24
25 equal = Equal
26
27 allZipWith v1 v2 rel e1 e2 | Just v1' <- defFor v1 rel =
28                                 e1 `equal` app (app Map (lambda v2 v1')) e2
29                          | Just v2' <- defFor v2 rel =
30                                 app (app Map (lambda v1 v2')) e1 `equal` e2
31                          | otherwise =
32                                 AllZipWith v1 v2 rel e1 e2
33
34 defFor v (e1 `Equal` e2) | (Var v) == e1 = Just e2
35                          | (Var v) == e2 = Just e1
36 defFor _ _                               = Nothing
37
38 app Map (Conc []) = Conc []
39 app (Conc []) v   = v
40 app f v           = App f v
41
42 unCond v b t (Equal l r) | (Just l') <- isApplOn v l 
43                          , (Just r') <- isApplOn v r = 
44         if hasVar v l' || hasVar v r'
45         then UnCond v b t (Equal l' r')
46         else (Equal l' r')
47 unCond v b t e = UnCond v b t e
48
49 lambda v e | (Just e') <- isApplOn v e, not (hasVar v e') = e'
50            | Var v == e                                   = Conc []
51            | otherwise                                    = Lambda v e
52
53
54 conc f (Conc fs) = Conc (f:fs)
55
56 -- Helpers
57
58 isApplOn v (Var _)                                         = Nothing
59 isApplOn v (App f (Var v')) | v == v'                      = Just (Conc [f])
60 isApplOn v (App f e)        | (Just inner) <- isApplOn v e = Just (conc f inner)
61 isApplOn _ _                                               = Nothing
62
63 hasVar v (Var v')     = v == v'
64 hasVar v (App e1 e2)  = hasVar v e1 && hasVar v e2
65 hasVar v (Conc es)    = any (hasVar v) es
66 hasVar v (Lambda _ e) = hasVar v e
67 hasVar v Map          = False
68
69
70 -- showing
71
72 -- Precedences:
73 -- 10 fun app
74 --  9 (.)
75 --  8 ==
76 --  7 ==>
77 --  6 forall
78
79 instance Show Expr where
80         showsPrec d (Var s)     = showString s
81         showsPrec d (App e1 e2) = showParen (d>10) $
82                 showsPrec 10 e1 . showChar ' ' . showsPrec 11 e2
83         showsPrec d (Conc [])   = showString "id"
84         showsPrec d (Conc [e])  = showsPrec d e
85         showsPrec d (Conc es)   = showParen (d>9) $
86                 showIntercalate (showString " . ") (map (showsPrec 10) es)
87         showsPrec d (Lambda v e) = showParen True $ 
88                                    showString "\\" .
89                                    showString v .
90                                    showString " -> ".
91                                    showsPrec 0 e 
92         showsPrec _ Map           = showString "map"
93
94 showIntercalate i []  = id
95 showIntercalate i [x] = x
96 showIntercalate i (x:xs) = x . i . showIntercalate i xs
97
98 instance Show BoolExpr where
99         show (Equal e1 e2) = showsPrec 9 e1 $
100                              showString " == " $
101                              showsPrec 9 e2 ""
102         show (AllZipWith v1 v2 be e1 e2) =
103                         "allZipWith " ++
104                         "( " ++
105                         "\\" ++
106                         v1 ++
107                         " " ++
108                         v2 ++
109                         " -> " ++
110                         show be ++
111                         ")" ++
112                         " " ++
113                         showsPrec 11 e1 "" ++
114                         " " ++
115                         showsPrec 11 e2 ""
116         show (Condition v1 v2 t be1 be2) = 
117                         "forall " ++
118                         v1 ++
119                         " :: " ++
120                         arrowInstType False t ++
121                         ", " ++
122                         v2 ++
123                         " :: " ++
124                         arrowInstType True t ++
125                         ".\n" ++
126                         indent 2 (show be1) ++
127                         "==>\n" ++
128                         indent 2 (show be2)
129         show (UnCond v1 b t be1) = 
130                         "forall " ++
131                         v1 ++
132                         " :: " ++
133                         arrowInstType b t ++
134                         ".\n" ++
135                         indent 2 (show be1)
136         show (TypeVarInst i be) = 
137                         "forall types t" ++
138                         show (2*i-1) ++
139                         ", t" ++
140                         show (2*i) ++
141                         ", function g" ++
142                         show i ++
143                         " :: t" ++
144                         show (2*i-1) ++
145                         " -> t" ++
146                         show (2*i) ++ 
147                         ".\n" ++
148                         indent 2 (show be)
149
150 indent n = unlines . map (replicate n ' ' ++) . lines
151
152 arrowInstType :: Bool -> Typ -> String
153 arrowInstType b = ait 0
154   where 
155         ait _ Int                       = "Int" 
156         ait _ (TVar (TypVar i)) | not b = "t" ++  show (2*i-1)
157                                 |     b = "t" ++  show (2*i)
158         ait d (Arrow t1 t2)             = paren (d>9) $ 
159                                                   ait 10 t1 ++ " -> " ++ ait 9 t2 
160         ait d (List t)                  = "[" ++ ait 0 t ++ "]"
161         ait d (TEither t1 t2)           = "Either " ++ ait 11 t1 ++ 
162                                                 " " ++ ait 11 t2
163         ait d (TPair t1 t2)             = "(" ++ ait 0 t1 ++ ", " ++ ait 0 t2 ++ ")"
164
165 paren b p   =  if b then "(" ++ p ++ ")" else p