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