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