52c99d2b9b278a3f5128b057635858c8f8211805
[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         | Pairwise 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 pairwise 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                                 Pairwise 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         showsPrec d (Equal e1 e2) = showParen (d>8) $
100                                     showsPrec 9 e1 .
101                                     showString " == " .
102                                     showsPrec 9 e2 
103         showsPrec d (Pairwise v1 v2 be e1 e2) =
104                         showParen (d>10) $
105                         showString "allZipWith " .
106                         showParen True ( 
107                                 showString "\\" .
108                                 showString v1 .
109                                 showChar ' ' .
110                                 showString v2 . 
111                                 showString " -> " .
112                                 showsPrec 0 be
113                         ) .
114                         showChar ' ' .
115                         showsPrec 11 e1 .
116                         showChar ' ' .
117                         showsPrec 11 e2
118         showsPrec d (Condition v1 v2 t be1 be2) = 
119                         showParen (d>6) $
120                         showString "forall " . 
121                         showString v1 . 
122                         showString " :: " .
123                         arrowInstType False t .
124                         showString ", " .
125                         showString v2 . 
126                         showString " :: " .
127                         arrowInstType True t .
128                         showString ".\n" .
129                         showsPrec 9 be1 .
130                         showString " ==> " .
131                         showsPrec 6 be2
132         showsPrec d (UnCond v1 b t be1) = 
133                         showParen (d>6) $
134                         showString "forall " . 
135                         showString v1 . 
136                         showString " :: " .
137                         arrowInstType b t .
138                         showString ".\n" .
139                         showsPrec 6 be1
140         showsPrec d (TypeVarInst i be) = 
141                         showParen (d>6) $
142                         showString "forall types t" .
143                         shows (2*i-1) .
144                         showString ", t" .
145                         shows (2*i) . 
146                         showString ", function g" .
147                         shows i .
148                         showString " :: t" .
149                         shows (2*i-1) .
150                         showString " -> t" .
151                         shows (2*i) . 
152                         showString ".\n" .
153                         showsPrec 6 be
154
155 arrowInstType :: Bool -> Typ -> ShowS
156 arrowInstType b Int                     = showString "Int" 
157 arrowInstType False (TVar (TypVar i))   = showString "t" .  shows (2*i-1)
158 arrowInstType True (TVar (TypVar i))    = showString "t" .  shows (2*i)
159 arrowInstType b (Arrow t1 t2)           = arrowInstType b t1 .
160                                           showString " -> " .
161                                           arrowInstType b t2