Initial check in
[darcs-mirror-polyfix.git] / Expr.hs
1 {-# LANGUAGE PatternGuards  #-}
2 module Expr where
3
4 import Data.List
5
6 data Expr
7         = Var String
8         | App Expr Expr
9         | Conc [Expr]
10         | Lambda String Expr
11         | Map
12             deriving (Eq)
13
14 data BoolExpr 
15         = Equal Expr Expr
16         | Pairwise String String BoolExpr Expr Expr
17         | Condition String String BoolExpr BoolExpr
18         | UnCond String BoolExpr
19         | TypeVarInst Int BoolExpr
20             deriving (Eq)
21
22 -- Smart constructors
23
24 unCond v (Equal l r) | (Just l') <- isApplOn v l 
25                      , (Just r') <- isApplOn v r = 
26         if hasVar v l' || hasVar v r'
27         then UnCond v (Equal l' r')
28         else (Equal l' r')
29 unCond v e = UnCond v e
30
31 lambda v e | (Just e') <- isApplOn v e, not (hasVar v e') = e'
32            | otherwise                                    = Lambda v e
33
34
35 conc f (Conc fs) = Conc (f:fs)
36
37 -- Helpers
38
39 isApplOn v (Var _)                                         = Nothing
40 isApplOn v (App f (Var v')) | v == v'                      = Just (Conc [f])
41 isApplOn v (App f e)        | (Just inner) <- isApplOn v e = Just (conc f inner)
42 isApplOn _ _                                               = Nothing
43
44 hasVar v (Var v')     = v == v'
45 hasVar v (App e1 e2)  = hasVar v e1 && hasVar v e2
46 hasVar v (Conc es)    = any (hasVar v) es
47
48
49 -- showing
50
51 -- Precedences:
52 -- 10 fun app
53 --  9 (.)
54 --  8 ==
55 --  7 ==>
56 --  6 forall
57
58 instance Show Expr where
59         showsPrec d (Var s)     = showString s
60         showsPrec d (App e1 e2) = showParen (d>10) $
61                 showsPrec 10 e1 . showChar ' ' . showsPrec 11 e2
62         showsPrec d (Conc es)   = showParen (d>9) $
63                 showIntercalate (showString " . ") (map (showsPrec 10) es)
64         showsPrec d (Lambda v e) = showParen True $ 
65                                    showString "\\" .
66                                    showString v .
67                                    showString " -> ".
68                                    showsPrec 0 e 
69         showsPrec _ Map           = showString "map"
70
71 showIntercalate i []  = id
72 showIntercalate i [x] = x
73 showIntercalate i (x:xs) = x . i . showIntercalate i xs
74
75 instance Show BoolExpr where
76         showsPrec d (Equal e1 e2) = showParen (d>8) $
77                                     showsPrec 9 e1 .
78                                     showString " == " .
79                                     showsPrec 9 e2 
80         showsPrec d (Pairwise v1 v2 be e1 e2) =
81                         showParen (d>10) $
82                         showString "allZipWith " .
83                         showParen True ( 
84                                 showString "(\\" .
85                                 showString v1 .
86                                 showChar ' ' .
87                                 showString v2 . 
88                                 showString " -> " .
89                                 showsPrec 0 e1
90                         ) .
91                         showChar ' ' .
92                         showsPrec 11 e2
93         showsPrec d (Condition v1 v2 be1 be2) = 
94                         showParen (d>6) $
95                         showString "forall " . 
96                         showString v1 . 
97                         showChar ' ' .
98                         showString v2 . 
99                         showString ". " .
100                         showsPrec 9 be1 .
101                         showString " ==> " .
102                         showsPrec 6 be2
103         showsPrec d (UnCond v1 be1) = 
104                         showParen (d>6) $
105                         showString "forall " . 
106                         showString v1 . 
107                         showString ". " .
108                         showsPrec 6 be1
109         showsPrec d (TypeVarInst i be) = 
110                         showParen (d>6) $
111                         showString "forall types t" .
112                         shows (2*i-1) .
113                         showString ", t" .
114                         shows (2*i) . 
115                         showString ", function g" .
116                         shows i .
117                         showString " :: t" .
118                         shows (2*i-1) .
119                         showString " -> t" .
120                         shows (2*i) . 
121                         showString ".\n" .
122                         showsPrec 6 be
123