Reduce Uncurry when possible
[darcs-mirror-polyfix.git] / Term2Expr.hs
1 {-# LANGUAGE PatternGuards #-}
2
3 module Term2Expr (insertTermsInCondition, term2Expr, termCond2Exprs) where
4
5 import ExFindExtended
6 import Expr
7 import qualified ExFindExtended as T
8 import qualified Expr as E
9 import Debug.Trace
10 import qualified Data.Map as M
11 import Data.Generics
12 import Data.List
13
14 insertTermsInCondition :: (T.Term,T.TermCont) -> BoolExpr -> BoolExpr
15 insertTermsInCondition (t,tc) =
16         replaceTermBE (E.Var F) f .
17         replaceBinds binds 
18   where f = term2Expr t
19         binds = termCond2Exprs tc
20
21
22 replaceBinds :: M.Map EVar Expr -> BoolExpr -> BoolExpr
23 replaceBinds binds = gmapT (mkT (replaceBinds binds)) `extT` go
24   where go (Condition vars cond concl)
25                 = let (toReplace, notToReplace) = partition isReplaced vars
26                       subst be = M.foldWithKey replaceBind be binds
27                       binds' = M.filterWithKey (\v _ -> any ((==Just v).getVar) vars) binds
28                   in  condition notToReplace
29                                 (replaceBinds binds' (subst cond))
30                                 (replaceBinds binds' (subst concl))
31         go be = gmapT (mkT (replaceBinds binds)) be
32                                 
33         replaceBind v t = replaceTermBE (E.Var v) t
34
35         isReplaced te | Just v <- getVar te = v `M.member` binds
36         isReplaced _                     = False
37
38         getVar (TypedExpr (E.Var v) _) = Just v
39         getVar _                       = Nothing
40
41
42 term2Expr :: T.Term -> E.Expr
43 term2Expr = absTerm2Expr (const E.EUnit)
44
45 termPlus2Expr :: T.TermPlus -> E.Expr
46 termPlus2Expr = absTerm2Expr (\(PlusElem _ i) -> EUnit)
47
48
49 termCond2Exprs = M.fromList . concatMap
50                  (\(TermVar i,(tp1,tp2)) -> [
51                         (FromParam i False, termPlus2Expr tp1) ,
52                         (FromParam i True,  termPlus2Expr tp2) ] )
53                 . M.assocs
54
55 absTerm2Expr :: (Eq a) => (a -> Expr) -> AbsTerm a -> Expr
56 absTerm2Expr ex (T.Var v)       = E.Var (termVar2EVar v)
57 absTerm2Expr ex (T.Abs v vt at) = lambda' (E.Var (termVar2EVar v)) (absTerm2Expr ex at)
58 absTerm2Expr ex (T.App t1 t2)   = E.App (absTerm2Expr ex t1) (absTerm2Expr ex t2)
59 absTerm2Expr ex (T.TAbs _ at)   = absTerm2Expr ex at
60 absTerm2Expr ex (Nil _)         = trace "Can not convert Nil" undefined
61 absTerm2Expr ex (Cons e (Nil _))= Singleton (absTerm2Expr ex e)
62 absTerm2Expr ex (Cons _ _)      = trace "Can not convert non-singleton Cons" undefined
63 absTerm2Expr ex (Case e _ v b)  = app' (app' HeadMap
64                                              (lambda' (E.Var (termVar2EVar v))
65                                                       (absTerm2Expr ex b)))
66                                              (absTerm2Expr ex e)
67 absTerm2Expr ex (T.Bottom t)    = E.Bottom
68 absTerm2Expr ex (Extra e)       = ex e
69
70 absTerm2Expr ex (Case1 t _ z w) | z == w = E.CaseUnit (absTerm2Expr ex t) (absTerm2Expr ex w)
71 absTerm2Expr ex (Case1 _ _ _ _) = trace "Can not convert Case1" undefined
72 absTerm2Expr ex T.Zero          = E.Zero
73 absTerm2Expr ex (T.Pair t1 t2)  = E.Pair (absTerm2Expr ex t1) (absTerm2Expr ex t2)
74 absTerm2Expr ex (T.ECase e vl el vr er)
75                                 = app' ( app' (app' EitherMap
76                                    (lambda' (E.Var (termVar2EVar vl)) (absTerm2Expr ex el)) )
77                                    (lambda' (E.Var (termVar2EVar vr)) (absTerm2Expr ex el)) )
78                                    (absTerm2Expr ex e)
79 absTerm2Expr ex (T.Right t)     = ERight (absTerm2Expr ex t)
80 absTerm2Expr ex (T.Left  t)     = ELeft (absTerm2Expr ex t)
81 absTerm2Expr ex (T.PCase pt v1 v2 e) = app' (app'
82                                 Uncurry
83                                 (lambda' (E.Var (termVar2EVar v1))
84                                          (lambda' (E.Var (termVar2EVar v2))
85                                                   (absTerm2Expr ex e))))
86                                 (absTerm2Expr ex pt)
87
88 termVar2EVar (T.TermVar i) = E.FromTypVar i
89
90