odeMotion :: forall dom m a
    .  ( ConstrainedBy dom Typeable
       , AlphaEq dom dom dom [(VarId,VarId)]
       , Project Let dom
       , MonadState VarId m
       )
    => (forall c. ASTF dom c -> Bool)
         -- ^ Control wether a sub-expression can be hoisted over the given expression
    -> PrjDict dom
    -> MkInjDict dom
    -> MkSubEnv dom
    -> ASTF dom a
    -> m (ASTF dom a)
codeMotion hoistOver pd mkId mkSub a
    | Just (Chosen id b) <- choose hoistOver pd mkId mkSub a = share id b
    | otherwise = descend a
  where
    share :: InjDict dom b a -> ASTF dom b -> m (ASTF dom a)
    share id b = do
        b' <- codeMotion hoistOver pd mkId mkSub b
        v  <- get; put (v+1)
        let x = Sym (injVariable id v)
        body <- codeMotion hoistOver pd mkId mkSub $ substitute b x a
        return
            $  Sym (injLet id)
            :$ b'
            :$ (Sym (injLambda id v) :$ body)

    descend :: AST dom b -> m (AST dom b)
    descend (lt :$ a :$ (Sym lam :$ b))
        | Just Let <- prj lt
        , Just _ <- prjLambda pd lam = do
            a' <- descend a
            b' <- codeMotion hoistOver pd mkId mkSub b
            return $ lt :$ a' :$ (Sym lam :$ b')
    descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion hoistOver pd mkId mkSub a)
    descend a        = return a

codeMotion :: forall dom m a
    .  ( ConstrainedBy dom Typeable
       , AlphaEq dom dom dom [(VarId,VarId)]
       , Project Let dom
       , MonadState VarId m
       )
    => (forall c. ASTF dom c -> Bool)
         -- ^ Control wether a sub-expression can be hoisted over the given expression
    -> PrjDict dom
    -> MkInjDict dom
    -> MkSubEnv dom
    -> ASTF dom a
    -> m (ASTF dom a)
codeMotion hoistOver pd mkId mkSub a
    | Just (Chosen id b) <- choose hoistOver pd mkId mkSub a = share id b
    | otherwise = descend a
  where
    share :: InjDict dom b a -> ASTF dom b -> m (ASTF dom a)
    share id b = do
        b' <- codeMotion hoistOver pd mkId mkSub b
        v  <- get; put (v+1)
        let x = Sym (injVariable id v)
        body <- codeMotion hoistOver pd mkId mkSub $ substitute b x a
        return
            $  Sym (injLet id)
            :$ b'
            :$ (Sym (injLambda id v) :$ body)

    descend :: AST dom b -> m (AST dom b)
    descend (lt :$ a :$ (Sym lam :$ b))
        | Just Let <- prj lt
        , Just _ <- prjLambda pd lam = do
            a' <- descend a
            b' <- codeMotion hoistOver pd mkId mkSub b
            return $ lt :$ a' :$ (Sym lam :$ b')
    descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion hoistOver pd mkId mkSub a)
    descend a        = return a
codeMotion hoistOver pd mkId mkSub a
    | Just (Chosen id b) <- choose hoistOver pd mkId mkSub a = share id b
    | otherwise = descend a
  where
    share :: InjDict dom b a -> ASTF dom b -> m (ASTF dom a)
    share id b = do
        b' <- codeMotion hoistOver pd mkId mkSub b
        v  <- get; put (v+1)
        let x = Sym (injVariable id v)
        body <- codeMotion hoistOver pd mkId mkSub $ substitute b x a
        return
            $  Sym (injLet id)
            :$ b'
            :$ (Sym (injLambda id v) :$ body)

    descend :: AST dom b -> m (AST dom b)
    descend (lt :$ a :$ (Sym lam :$ b))
        | Just Let <- prj lt
        , Just _ <- prjLambda pd lam = do
            a' <- descend a
            b' <- codeMotion hoistOver pd mkId mkSub b
            return $ lt :$ a' :$ (Sym lam :$ b')
    descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion hoistOver pd mkId mkSub a)
    descend a        = return a