NestedVL.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module NestedVL where

import Control.Monad.Free.VanLaarhovenE


data Logging m = Logging
    { logMsgF :: String -> m () }

logMsg :: HasEffect effects Logging
    => String
    -> Free effects ()
logMsg s = liftF (`logMsgF` s)



data Nested m = Nested
    { nodeF :: m ()
    , branchF
        :: forall effects. HasEffect effects Nested
        => Free effects () -> m ()
    }

node :: HasEffect effects Nested
     => Free effects ()
node = liftF (\eff -> nodeF eff)


branch :: HasEffect effects Nested
         => Free effects ()
         -> Free effects ()
branch f = liftF (`branchF` f)


program :: ( HasEffect effects Nested
              , HasEffect effects Logging )
              => Free effects ()
program =
    branch $ do
        logMsg "Inner branch"
        node
        branch $ node



interpretIO :: Effects effects IO -> Nested IO
interpretIO fx = Nested
    { nodeF = putStrLn "node"
    , branchF = \f -> do
        putStrLn "branch"
        -- Need to evaluate sub expression
        -- It should be something of the form

        {-_ `iterM` f -}

        -- My best guess was

        {-nestEffect (interpretIO fx) fx `iterM` f-}

    }

nestEffect :: Nested m -> Effects effects m -> Effects (Nested ': effects) m
nestEffect m fx = m .:. fx