1 
    2 -- ==========================================================--
    3 -- === Add parameters to supercombinators which           ===--
    4 -- === otherwise return functions          EtaAbstract.hs ===--
    5 -- ==========================================================--
    6 
    7 module EtaAbstract where
    8 import BaseDefs
    9 import Utils
   10 import MyUtils
   11 
   12 
   13 -- ==========================================================--
   14 -- Doesn't assume that the tree has been lambda-lifted.
   15 -- It does however assume that all lambda-terms are 
   16 -- directly attached to a let-binding.
   17 --
   18 eaEtaAbstract :: AnnExpr Naam TExpr ->
   19                  AnnExpr Naam TExpr
   20 
   21 eaEtaAbstract ae@(tau, AVar v)     = ae
   22 eaEtaAbstract ae@(tau, ANum n)     = ae
   23 eaEtaAbstract ae@(tau, AConstr c)  = ae
   24 eaEtaAbstract ae@(tau, AAp e1 e2) 
   25    = (tau, AAp (eaEtaAbstract e1) (eaEtaAbstract e2))
   26 eaEtaAbstract ae@(tau, ACase sw alts)
   27    = (tau, ACase (eaEtaAbstract sw) 
   28                  [(n, (ps, eaEtaAbstract rhs)) | (n, (ps, rhs)) <- alts])
   29 eaEtaAbstract ae@(tau, ALam vs e)
   30    = (tau, ALam vs (eaEtaAbstract e))
   31 
   32 eaEtaAbstract ae@(tau, ALet rf defs body)
   33    = let typeInfo = [eaUncurry ty | (n, (ty, rhs)) <- defs]
   34          mergedDefs = map2nd mergeLams defs
   35          fixedDefs = myZipWith2 fixOne mergedDefs typeInfo
   36          fixOne sc@(n, (tau, ALam vs e)) (argTs, resT)
   37             | length vs == length argTs  = sc
   38             | length vs >  length argTs  = panic "eaEtaAbstract"
   39             | length vs <  length argTs  = eaMain sc argTs resT
   40          fixOne sc@(n, (tau, non_lam_b)) (argTs, resT)
   41             | null argTs  = sc
   42             | otherwise   = eaMain (n, (tau, ALam [] (tau, non_lam_b))) argTs resT
   43          mergeLams ae@(tau, ALam vs (tau2, ALam vs2 e))
   44             = mergeLams (tau, ALam (vs++vs2) e)
   45          mergeLams anyThingElse = anyThingElse
   46      in (tau, ALet rf fixedDefs (eaEtaAbstract body))
   47         
   48 
   49 -- ==========================================================--
   50 --
   51 eaMain :: (Naam, AnnExpr Naam TExpr) ->
   52           [TExpr] ->
   53           TExpr ->
   54           (Naam, AnnExpr Naam TExpr)
   55 
   56 eaMain (scname, (tau, ALam vs (tau2, rhs))) argTs resT
   57    = let actualArity  = length vs
   58          reqdArity    = length argTs
   59          newArgsReqd  = reqdArity - actualArity
   60          newArgs      = eaMakeNewArgs newArgsReqd vs
   61          newArgsTypes = myZip2 newArgs (drop actualArity argTs)
   62          appArgTLists = map ((flip drop) argTs) 
   63                             (actualArity `myIntsFromTo` (reqdArity-1))
   64          appTypes     = map (eaCurry resT) appArgTLists
   65          newBody      = eaMakeApChain (myZip2 newArgsTypes appTypes) (tau2, rhs)
   66      in (scname, (tau, ALam (vs++newArgs) newBody))
   67 
   68 
   69 -- ==========================================================--
   70 --
   71 eaMakeApChain :: [((Naam, TExpr), TExpr)] ->
   72                  AnnExpr Naam TExpr ->
   73                  AnnExpr Naam TExpr
   74 
   75 eaMakeApChain [] app = app
   76 eaMakeApChain (((v, vtype), vaptype):rest) app
   77    = eaMakeApChain rest (vaptype, AAp app (vtype, AVar v))
   78 
   79 
   80 -- ==========================================================--
   81 --
   82 eaMakeNewArgs :: Int -> [Naam] -> [Naam]
   83 
   84 eaMakeNewArgs n vs
   85    = let leadingvs = filter (not.null) (map (takeWhile (== 'v')) vs)
   86          root = last (sort ("":leadingvs)) ++ "v"
   87          newNames = map f (1 `myIntsFromTo` n)
   88          f n = root ++ show (n :: Int)
   89      in newNames
   90 
   91 
   92 -- ==========================================================--
   93 --
   94 eaCurry :: TExpr -> [TExpr] -> TExpr
   95 
   96 eaCurry resT []           = resT
   97 eaCurry resT (argT:argTs) = TArr argT (eaCurry resT argTs)
   98 
   99 
  100 -- ==========================================================--
  101 --
  102 eaUncurry :: TExpr -> ([TExpr], TExpr)
  103 
  104 eaUncurry (TVar tv) = ([], TVar tv)
  105 
  106 eaUncurry (TArr t1 t2)
  107    = let (rest, final) = eaUncurry t2
  108      in (t1:rest, final)
  109 
  110 eaUncurry (TCons tcon targs) 
  111    = ([], TCons tcon targs)
  112 
  113 
  114 -- ==========================================================--
  115 -- === end                                 EtaAbstract.hs ===--
  116 -- ==========================================================--
  117 
  118