1  
    2 -- ==========================================================--
    3 -- === Reduction of abstract expressions                  ===--
    4 -- ===                                   AbstractEval2.hs ===--
    5 -- ==========================================================--
    6 
    7 module AbstractEval2 where
    8 import BaseDefs
    9 import Utils
   10 import MyUtils
   11 import AbstractVals2
   12 import Apply
   13 
   14 -- ==========================================================--
   15 --
   16 aeEval :: HExpr Naam -> HExpr Naam
   17 
   18 aeEval   (HVar _)   = panic "aeEval(1)"
   19 aeEval   (HLam _ _) = panic "aeEval(2)"
   20 aeEval   (HTable _) = panic "aeEval(3)"
   21 
   22 aeEval h@(HPoint _) = h
   23 
   24 aeEval   (HMeet es) = HPoint (foldr1 (\/) (map aeEvalConst es))
   25 
   26 aeEval   (HApp (HTable t) e2)
   27    = aeEval (utSureLookup t "aeEval(5)" (aeEvalConst e2))
   28 
   29 aeEval   (HVAp (HPoint f) es)
   30    = HPoint (apApply f (map aeEvalConst es))
   31 
   32 aeEval   (HApp f@(HApp _ _) someArg)
   33    = aeEval (HApp (aeEval f) someArg)
   34 
   35 aeEval   (HApp f@(HPoint _) e)
   36    = aeEval (HVAp f [e])
   37 
   38 aeEval x = panic "aeEval(4)"
   39 
   40 
   41 -- ==========================================================--
   42 --
   43 aeEvalConst :: HExpr Naam -> Route
   44 
   45 aeEvalConst e 
   46    = case aeEval e of {HPoint p -> p; _ -> panic "aeEvalConst"}
   47 
   48 
   49 -- ==========================================================--
   50 --
   51 aeEvalExact :: HExpr Naam -> [HExpr Naam] -> Route
   52 
   53 aeEvalExact (HLam vs e) args
   54    = case aeEval (aeSubst (myZip2 vs args) e) of
   55        {HPoint p -> p; _ -> panic "aeEvalExact"}
   56 
   57 
   58 -- ==========================================================--
   59 --
   60 aeSubst :: AList Naam (HExpr Naam) -> HExpr Naam -> HExpr Naam
   61 
   62 aeSubst rho (HVar v)      = utSureLookup rho "aeSubst" v
   63 aeSubst rho h@(HPoint p)  = h
   64 aeSubst rho (HLam _ _)    = panic "aeSubst(1)"
   65 aeSubst rho (HMeet es)    = HMeet (map (aeSubst rho) es)
   66 aeSubst rho (HTable t)    = HTable (map2nd (aeSubst rho) t)
   67 aeSubst rho (HApp e1 e2)  = HApp (aeSubst rho e1) (aeSubst rho e2)
   68 aeSubst rho (HVAp f es)   = HVAp (aeSubst rho f) (map (aeSubst rho) es)
   69 
   70 
   71 -- ==========================================================--
   72 --
   73 aeMkMeet :: HExpr Naam -> [HExpr Naam] -> HExpr Naam
   74 
   75 aeMkMeet bottom []    = bottom
   76 aeMkMeet bottom [x]   = x
   77 aeMkMeet bottom xs    = HMeet xs
   78 
   79 
   80 -- ==========================================================--
   81 -- === end                               AbstractEval2.hs ===--
   82 -- ==========================================================--