import Debug.Trace
import qualified List
import qualified Data.Monoid as Monoid
+import qualified Control.Arrow as Arrow
import qualified Control.Monad as Monad
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Writer as Writer
let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo
+-- Create a new type variable with the given name and kind. A Unique is
+-- appended to the given name, to ensure uniqueness (not strictly neccesary,
+-- since the Unique is also stored in the name, but this ensures variable
+-- names are unique in the output).
+mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var
+mkTypeVar str kind = do
+ uniq <- mkUnique
+ let occname = OccName.mkVarOcc (str ++ show uniq)
+ let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
+ return $ Var.mkTyVar name kind
+
+-- Creates a binder for the given expression with the given name. This
+-- works for both value and type level expressions, so it can return a Var or
+-- TyVar (which is just an alias for Var).
+mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var
+mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty)
+mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr)
+
+-- Creates a reference to the given variable. This works for both a normal
+-- variable as well as a type variable
+mkReferenceTo :: Var.Var -> CoreExpr
+mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var)
+ | otherwise = (Var var)
+
cloneVar :: Var.Var -> TransformMonad Var.Var
cloneVar v = do
uniq <- mkUnique
-- contains, but vannillaIdInfo is always correct, since it means "no info").
return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
+-- Creates a new function with the same name as the given binder (but with a
+-- new unique) and with the given function body. Returns the new binder for
+-- this function.
+mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr
+mkFunction bndr body = do
+ let ty = CoreUtils.exprType body
+ id <- cloneVar bndr
+ let newid = Var.setVarType id ty
+ Trans.lift $ addGlobalBind newid body
+ return newid
+
-- Apply the given transformation to all expressions in the given expression,
-- including the expression itself.
everywhere :: (String, Transform) -> Transform
-- Replace each of the binders given with the coresponding expressions in the
-- given expression.
substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
-substitute replace expr = CoreSubst.substExpr subs expr
- where subs = foldl (\s (b, e) -> CoreSubst.extendIdSubst s b e) CoreSubst.emptySubst replace
+substitute [] expr = expr
+-- Apply one substitution on the expression, but also on any remaining
+-- substitutions. This seems to be the only way to handle substitutions like
+-- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
+-- according to CoreSubst documentation (but it doesn't seem to be a problem).
+-- TODO: Find out how this works, exactly.
+substitute ((b, e):subss) expr = substitute subss' expr'
+ where
+ -- Create the Subst
+ subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
+ -- Apply this substitution to the main expression
+ expr' = CoreSubst.substExpr subs expr
+ -- Apply this substitution on all the expressions in the remaining
+ -- substitutions
+ subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
-- Run a given TransformSession. Used mostly to setup the right calls and
-- an initial state.