{-|
Module      : DeepControl.MonadTrans
Description : Enable deep level Monad-Transform programming.
Copyright   : (c) Andy Gill 2001,
              (c) Oregon Graduate Institute of Science and Technology, 2001,
              (C) 2015 KONISHI Yohsuke 
License     : BSD-style (see the file LICENSE)
Maintainer  : ocean0yohsuke@gmail.com
Stability   : experimental
Portability : ---

This module enables you to program in Monad-Transformer style for more __deeper__ level than the usual @Control.Monad.Trans@ module expresses.
You would realize exactly what __/more deeper level/__ means by reading the example codes, which are attached on the page bottom.
Note: all the MonadTransx instances for Level-4 and Level-5 haven't been written yet.
-}
module DeepControl.MonadTrans (
    -- * MonadIO
    MonadIO(..),

    -- * MonadTrans
    MonadTrans(..), 
    MonadTrans2(..),
    MonadTrans3(..),
    MonadTrans4(..),
    MonadTrans5(..),

    -- * Level-1 example
    -- $Example_Level1

    -- * Level-2 example
    -- $Example_Level2

) where

import DeepControl.Monad

import Control.Monad.IO.Class

----------------------------------------------------------------------
-- Level-1

class  MonadTrans t  where
    -- | Alias for @'Control.Monad.Trans.Class.lift'@.
    trans :: (Monad m) => m a -> t m a

----------------------------------------------------------------------
-- Level-2

class  MonadTrans2 t  where
    trans2 :: (Monad m1, Monad2 m2) => m1 (m2 a) -> t m1 m2 a

----------------------------------------------------------------------
-- Level-3

class  MonadTrans3 t  where
    trans3 :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 a)) -> t m1 m2 m3 a

----------------------------------------------------------------------
-- Level-4

class  MonadTrans4 t  where
    trans4 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => m1 (m2 (m3 (m4 a))) -> t m1 m2 m3 m4 a

----------------------------------------------------------------------
-- Level-5

class  MonadTrans5 t  where
    trans5 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => m1 (m2 (m3 (m4 (m5 a)))) -> t m1 m2 m3 m4 m5 a

----------------------------------------------------------------------
-- Examples

{- $Example_Level1
Here is a monad transformer example how to implement a tiny interpreter with RWST-ExceptT-IO monad, a level-1 monad-transformation.

Please turn on three pragmas GeneralizedNewtypeDeriving, FlexibleInstances and MultiParamTypeClasses on this example.

>import DeepControl.Applicative
>import DeepControl.Monad
>import DeepControl.MonadTrans
>import DeepControl.Monad.Except
>import DeepControl.Monad.RWS
>
>import qualified Data.Map as M
>
>-- ----------------------------------------------
>-- Data-types
>
>type Name = String          -- variable names
>
>-- Expression
>data Exp = Lit Int          -- Literal
>         | Var Name         -- Variable
>         | Plus Exp Exp     -- (+)
>         | Lam Name Exp     -- λ
>         | App Exp Exp      -- Application
>         deriving (Show)
>
>-- Value
>data Value = IntVal Int          -- Int Value 
>           | FunVal Env Name Exp -- Functional Value
>           deriving (Show)
>
>-- Environment
>type Env = M.Map Name Value    -- mapping from names to values
>
>-- ----------------------------------------------
>-- Monad-Transform
>
>type EvalError = String
>instance Error EvalError where
>    strMsg x = x
> 
>newtype Eval a = Eval (RWST Env [String] Int 
>                      (ExceptT EvalError
>                          IO) a)
>  deriving (Functor, Applicative, Monad, MonadIO)
>
>unEval :: Eval a -> (RWST Env [String] Int 
>                    (ExceptT EvalError
>                        IO) a)
>unEval (Eval a) = a
>
>runEval :: Eval a 
>           -> Env  -- Reader
>           -> Int  -- States
>           -> IO (Either EvalError (a, Int, [String])) 
>runEval (Eval x) env state = x >- \x -> runRWST x env state
>                               >- runExceptT
>
>instance MonadError EvalError Eval where
>    throwError = Eval . trans . throwError
>    catchError x h = 
>        let x' = unEval x
>        in Eval $ (liftCatch catchError x') (\e -> unEval (h e))
>instance MonadReader Env Eval where
>    ask     = Eval $ ask
>    local x = Eval . (local x) . unEval
>instance MonadWriter [String] Eval where
>    writer   = Eval . writer
>    listen m = Eval $ (listen (unEval m)) 
>    pass m   = Eval $ (pass (unEval m)) 
>instance MonadState Int Eval where
>    get   = Eval $ get
>    put   = Eval . put
>    state = Eval . state
>
>-- ----------------------------------------------
>-- Interpreter
>
>tick :: (Num s, MonadState s m) => m ()
>tick = do 
>    st <- get
>    put (st + 1)
>
>eval :: Exp -> Eval Value
>eval (Lit i)   = do 
>    tick
>    liftIO $ print i
>    return $ IntVal i
>eval (Var n)   = do 
>    tick
>    tell [n]
>    env <- ask
>    case M.lookup n env of
>        Nothing  -> throwError $ "unbound variable: " ++ n
>        Just val -> return val
>eval (Plus e1 e2) = do 
>    tick
>    e1' <- eval e1
>    e2' <- eval e2
>    case (e1', e2') of
>        (IntVal i1, IntVal i2) -> return $ IntVal (i1 + i2)
>        _                      -> throwError "type error in addition"
>eval (Lam n e) = do 
>    tick
>    env <- ask
>    return $ FunVal env n e
>eval (App e1 e2) = do 
>    tick
>    val1 <- eval e1
>    val2 <- eval e2
>    case val1 of
>        FunVal env' n body -> local (const (M.insert n val2 env')) $ eval body
>        _                  -> throwError "type error in application"
>
>-- ----------------------------------------------
>-- Examples
>
>-- 12 + ((\x -> x) (4 + 2))
>exp1 :: Exp
>exp1 = Lit 12 `Plus` ((Lam "x" (Var "x")) `App` (Lit 4 `Plus` Lit 2))
>
>-- (\x -> (\y -> x + y)) a b
>exp2 :: Exp
>exp2 = (Lam "x" (Lam "y" ((Var "x") `Plus` (Var "y")))) `App` (Var "a") `App` (Var "b")
>
>-- An environment
>env :: Env
>env = M.fromList [ ("a", IntVal 1)
>                 , ("b", IntVal 2)
>                 , ("c", IntVal 3)  
>                 , ("d", IntVal 4)
>                 ] 
>
>-- ----------------------------------------------
>-- Tests
>--
>-- > runEval (eval exp1) env 0
>-- 12
>-- 4
>-- 2
>-- Right (IntVal 18,8,["x"])
>
>-- > runEval (eval exp2) env 0
>-- Right (IntVal 3,9,["a","b","x","y"])
>
>-- > runEval (eval $ Var "x") env 0
>-- Left "unbound variable: x"
-}

{- $Example_Level2
Here is a monad transformer example how to implement Polish Notation with StateT2-IO-Maybe monad, a level-2 monad-transformation.

>import DeepControl.Applicative
>import DeepControl.Commutative (cmap)
>import DeepControl.Monad
>import DeepControl.Monad.State
>import DeepControl.MonadTrans
>
>-----------------------------------------------
>-- State
>
>push :: a -> State [a] a
>push x = do 
>    xs <- get
>    put (x:xs)
>    return x
>
>pop :: State [a] a
>pop = do 
>    xs <- get
>    put (tail xs)
>    return (head xs)
>
>-- > runState (push 1 >> push 2 >> push 3) []
>-- (3,[3,2,1])
>-- > runState (push 1 >> push 2 >> push 3 >> pop >> pop) []
>-- (2,[1])
>
>poland :: String -> State [Double] Double
>poland "+" = do 
>    x <- pop
>    y <- pop
>    push (y + x)
>poland "-" = do 
>    x <- pop
>    y <- pop
>    push (y - x)
>poland "*" = do 
>    x <- pop
>    y <- pop
>    push (y * x)
>poland "/" = do
>    x <- pop
>    y <- pop
>    push (y / x)
>poland x = push (read x :: Double)
>
>poland_calc :: [String] -> Double
>poland_calc xs = evalState (cmap poland xs >> pop) []
>
>-- > poland_calc ["1","2","*"]
>-- 2.0
>-- > poland_calc ["1","2","-"]
>-- -1.0
>-- > poland_calc ["1","2","+","3","*"]
>-- 9.0
>-- > poland_calc ["1","2","+","3","*","3","/"]
>-- 3.0
>-- > poland_calc ["1","2","+","3","*","0","/"]
>-- Infinity
>
>-----------------------------------------------
>-- StateT-Maybe
>
>pushT :: a -> StateT [a] Maybe a
>pushT x = do 
>    xs <- get
>    put (x:xs)
>    return x
>
>popT :: StateT [a] Maybe a
>popT = do 
>    xs <- get
>    put (tail xs)
>    return (head xs)
>
>-- > runStateT (pushT 1 >> pushT 2 >> pushT 3) []
>-- Just (3,[3,2,1])
>-- > runStateT (pushT 1 >> pushT 2 >> pushT 3 >> popT >> popT) []
>-- Just (2,[1])
>
>polandT :: String -> StateT [Double] Maybe Double
>polandT "+" = do 
>    x <- popT
>    y <- popT
>    pushT (y + x)
>polandT "-" = do 
>    x <- popT
>    y <- popT
>    pushT (y - x)
>polandT "*" = do 
>    x <- popT
>    y <- popT
>    pushT (y * x)
>polandT "/" = do
>    x <- popT
>    y <- popT
>    trans $ guard (x /= 0)
>    pushT (y / x)
>polandT x = pushT (read x :: Double)
>
>poland_calcT :: [String] -> Maybe Double
>poland_calcT xs = evalStateT (cmap polandT xs >> popT) []
>
>-- > poland_calcT ["1","2","*"]
>-- Just 2.0
>-- > poland_calcT ["1","2","-"]
>-- Just (-1.0)
>-- > poland_calcT ["1","2","+","3","*"]
>-- Just 9.0
>-- > poland_calcT ["1","2","+","3","*","3","/"]
>-- Just 3.0
>-- > poland_calcT ["1","2","+","3","*","0","/"]
>-- Nothing
>
>-----------------------------------------------
>-- StateT2-IO-Maybe
>
>pushT2 :: a -> StateT2 [a] IO Maybe a
>pushT2 x = do 
>    xs <- get
>    put (x:xs)
>    return x
>popT2 :: StateT2 [a] IO Maybe a
>popT2 = do 
>    xs <- get
>    put (tail xs)
>    return (head xs)
>
>polandT2 :: String -> StateT2 [Double] IO Maybe Double
>polandT2 "+" = do 
>    x <- popT2
>    y <- popT2
>    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))
>    pushT2 (y + x)
>polandT2 "-" = do 
>    x <- popT2
>    y <- popT2
>    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))
>    pushT2 (y - x)
>polandT2 "*" = do
>    x <- popT2
>    y <- popT2
>    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))
>    pushT2 (y * x)
>polandT2 "/" = do
>    x <- popT2
>    y <- popT2
>    liftIO $ putStr (show y ++" / "++ show x ++" = ")
>    trans2.(*:) $ guard (x /= 0)
>    liftIO $ putStr (show (y / x) ++"\n")
>    pushT2 (y / x)
>polandT2 x = pushT2 (read x :: Double)
>
>poland_calcT2 :: [String] -> IO (Maybe Double)
>poland_calcT2 xs = evalStateT2 (cmap polandT2 xs >> popT2) []
>
>-- > poland_calcT2 ["1","2","*"]
>-- 1.0 * 2.0 = 2.0
>-- Just 2.0
>-- > poland_calcT2 ["1","2","+","3","*"]
>-- 1.0 + 2.0 = 3.0
>-- 3.0 * 3.0 = 9.0
>-- Just 9.0
>-- > poland_calcT2 ["1","2","+","3","*","3","/"]
>-- 1.0 + 2.0 = 3.0
>-- 3.0 * 3.0 = 9.0
>-- 9.0 / 3.0 = 3.0
>-- Just 3.0
>-- > poland_calcT2 ["1","2","+","3","*","0","/"]
>-- 1.0 + 2.0 = 3.0
>-- 3.0 * 3.0 = 9.0
>-- 9.0 / 0.0 = Nothing
-}