content: 
  module DDC.Core.Transform.Lambdas.Lift
          (liftLambda)
  where
  import DDC.Core.Transform.Lambdas.Base
  import DDC.Core.Fragment
  import DDC.Core.Exp.Annot.Context
  import DDC.Core.Exp.Annot.Ctx
  import DDC.Core.Exp.Annot
  import DDC.Core.Collect
  import DDC.Data.Pretty
  import DDC.Data.Name
  import Data.Function
  import Data.List
  import Data.Set                                 (Set)
  import qualified DDC.Core.Check                 as Check
  import qualified DDC.Type.Env                   as Env
  import qualified DDC.Core.Env.EnvX              as EnvX
  import qualified Data.Set                       as Set
  import qualified Data.Map                       as Map
  
  ---------------------------------------------------------------------------------------------------
  -- | Construct the call site, and new lifted binding for a lambda lifted
  --   abstraction.
  liftLambda
          :: (Show a, Show n, Pretty n, Ord n, CompoundName n, Pretty a)
          => Profile n            -- ^ Language profile.
          -> Context a n          -- ^ Context of the original abstraction.
          -> Set (Bool, Bound n)  -- ^ Free variables in the body of the abstraction.
          -> a
          -> [(Bool, Bind n)]     -- ^ Parameters of the current lambda abstraction.
          -> Exp a n              -- ^ Body of the current lambda abstraction.
          -> S ( Exp a n
               , Bind n, Exp a n)
  
  liftLambda profile c fusFree a bfsParam xBody
   = do
          -- Name of the enclosing top-level binding.
          let Just nTop       = takeTopNameOfCtx        (contextCtx c)
  
          -- Names of other supers bound at top-level.
          let nsSuper         = takeTopLetEnvNamesOfCtx (contextCtx c)
  
          -- The complete abstraction that we're lifting out.
          let xLambda         = makeXLamFlags a bfsParam xBody
  
          -- Get the list of new parameters we need to add to our super.
          -- These bind all the variables that were free in the abstraction
          -- group that we're lifting out.
          let fusFree_filtered
                  = filter (needParamForFreeBound profile nsSuper bfsParam)
                  $ Set.toList fusFree
  
          -- Lookup the types of those variables from the context,
          -- so we can add the correct types for the parameters of the new super.
          let joinType (f@True, u)
               | Just t <- EnvX.lookupT u (contextEnv c)
               = ((f, u), t)
  
              joinType (f@False, u)
               | Just t <- EnvX.lookupX u (contextEnv c)
               = ((f, u), t)
  
              joinType (f, u)
               = error $ unlines
                       [ "ddc-core-simpl.liftLambda: cannot find type of free variable."
                       , show (f, u)
                       , show (Map.keys $ EnvX.envxLocalMap (contextEnv c)) ]
  
          let futsFree_types
                  = map joinType fusFree_filtered
  
  
          -- Add in type variables that are free in the types of free
          -- value variables. We need to bind these as well in the new super.
          let expandFree ((f@True,  u), _)
                  = [(f, u)]
  
              expandFree ((f@False, u), t)
                  =  [(f, u)]
                  ++ [(True, ut) | ut  <- Set.toList
                                       $  freeVarsT Env.empty t]
  
          let fusFree_body
                  =  [(True, ut) | ut  <- Set.toList
                                       $  freeVarsT Env.empty $ typeOfExp profile c xLambda]
  
          let futsFree_expandFree
                  =  map joinType
                  $  Set.toList $ Set.fromList
                  $  (concatMap expandFree $ futsFree_types)
                  ++ fusFree_body
  
  
          -- Sort free vars so the type variables come out the front.
          let futsFree
                  = sortBy (compare `on` (not . fst . fst))
                  $ futsFree_expandFree
  
  
          -- Make the new super.
          --   For the lifted abstraction, wrap it in new lambdas to bind all of
          --   its free variables.
          --   ISSUE #330: Lambda lifter doesn't work with anonymous binders.
          let makeBind ((True,  (UName n)), t) = (True,  BName n t)
              makeBind ((False, (UName n)), t) = (False, BName n t)
              makeBind fut
                      = error $ "ddc-core-simpl.liftLamba: unhandled binder " ++ show fut
  
          let bsParam = map makeBind futsFree
          let xLifted = makeXLamFlags a bsParam xLambda
  
          -- Make a binder for the new super.
          (bLifted, uLifted)
                    <- newVarExtend nTop "L"
                    $  typeOfExp profile c xLifted
  
          -- At the point where the original abstraction group was,
          -- call our new lifted super instead.
          let makeArg  (True,  u) = RType (TVar u)
              makeArg  (False, u) = RTerm (XVar a u)
  
          let xCall = xApps a (XVar a uLifted)
                    $ map makeArg $ map fst futsFree
  
          -- All done.
          return  ( xCall
                  , bLifted, xLifted)
  
  
  ---------------------------------------------------------------------------------------------------
  -- | Decide whether we need to bind the given variable as a new parameter
  --   on the lifted super.
  needParamForFreeBound
          :: (Ord n, Show n)
          => Profile n
          -> Set n                -- ^ Names of supers at top level.
          -> [(Bool, Bind n)]     -- ^ Parameters of the current lambda abstraction.
          -> (Bool,  Bound n)     -- ^ Bound variable, and whether it is a type (True) or not.
          -> Bool
  
  needParamForFreeBound profile nsSuper bfsParam (bType, u)
          -- We don't need new parameters for primitives,
          -- as we can reference those directly.
          | UName n  <- u
          , Just _   <- Env.lookupName n (profilePrimTypes profile)
          = False
  
          -- We don't need new parameters for supers that are already
          -- at top level, as we can reference those directly.
          | not bType
          , UName n  <- u
          , Set.member n nsSuper
          = False
  
          -- We don't need new paramters for variables that
          -- are already bound by the abstractions that we're lifting.
          | any (boundMatchesBind u . snd) bfsParam
          = False
  
          -- We need a new parameter for this free variable.
          | otherwise
          = True
  
  
  -- Function to get the type of an expression in the given context.
  typeOfExp
          :: (Pretty a, Show a, Show n, Pretty n, Eq n, Ord n)
          => Profile n    -- ^ Language profile.
          -> Context a n  -- ^ Current context.
          -> Exp a n      -- ^ Expression we want the type for.
          -> Type n
  
  typeOfExp p c x
   = case Check.typeOfExp
                  (Check.configOfProfile p)
                  (contextEnv c) x
      of  Left err
           -> error $ renderIndent $ vcat
              [ text "ddc-core-simpl.liftLambda: type error in lifted expression"
              , ppr err
              , ppr x]
  
          Right t
           -> t
  
  