{-# LANGUAGE FlexibleContexts #-}

{- |
Module      :  Examples
Copyright   :  (c) Mark Snyder 2009.
License     :  BSD-style
Maintainer  :  Mark Snyder, marks@ittc.ku.edu
Stability   :  experimental
Portability :  non-portable (multi-param classes, functional dependencies)

-}


{-

This file represents the barest bones of a how-to for indexed monads.
Hopefully there will be more of a manual or a paper that gets accepted
in the future.


-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 

There is really only one monad--we often create constraints on a type
variable m, such as being an instance of MonadState, MonadReader, and
more, and then we use monad transformers to create that single monad
that actually has all the properties we wanted.  But we can't have,
for instance,

foo :: (MonadState Int m, MonadState Env m,...) :: m a -> ...

because the single monad m is trying to store different things in the
same State monad, and Haskell happily reports the type error and quits
on us.  This is the essence of why we would want other `copies' of
particular monads, copies that you may have seen embedded in various
libraries of monadic Haskell code.

One particular reason to use this library would be that you wish to
provide your own library of code to be used elsewhere (such as when
writing a DSL), and for whatever reasons have to expose your own usage
of a monad.  Rather than e.g. 'use up' the state monad, create your
own monad that really just behaves as the State monad, or expect users
to create their own, you can just get the copy of the monad you wanted
in a quick two-liner.  Usage is (nearly) identical to the original
monads from the Monad Transformer Library ported with GHC.

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 

-}

module Examples where

-- the original monads
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.RWS
import Control.Monad.Error
import Control.Monad.List
import Control.Monad.Identity

-- the indexed monads
import Control.Monad.ReaderX
import Control.Monad.StateX
import Control.Monad.WriterX
import Control.Monad.RWSX
import Control.Monad.ErrorX
import Control.Monad.ListX
import Control.Monad.IdentityX

-- for some of the examples
import Char
import System(getArgs)

-- a 'normal' use of indexed monads should import Control.Monad.FooX
-- for whichever monad Foo you want to use as an indexed monad.  You
-- then can create your own index in a trivial two-liner, and have an
-- entire 'copy' at the type level of the desired monad.

-- ----------------------------------------------------------------

-- Eight separate indexes that should all be usable by any indexed monad.
data X1 = X1 deriving (Show, Eq)
data X2 = X2 deriving (Show, Eq)
data X3 = X3 deriving (Show, Eq)
data X4 = X4 deriving (Show, Eq)
data X5 = X5 deriving (Show, Eq)
data X6 = X6 deriving (Show, Eq)
data X7 = X7 deriving (Show, Eq)
data X8 = X8 deriving (Show, Eq)

-- ...and their trivial instances.
instance Index X1 where getVal=X1
instance Index X2 where getVal=X2
instance Index X3 where getVal=X3
instance Index X4 where getVal=X4
instance Index X5 where getVal=X5
instance Index X6 where getVal=X6
instance Index X7 where getVal=X7
instance Index X8 where getVal=X8

-- in general, you would likely want to name the index something more
-- intuitive, such as:
data EnvIndex = EnvIndex deriving (Show, Eq)
instance Index  EnvIndex where getVal=EnvIndex

-- ----------------------------------------------------------------

-- A structure for use in examples.
data Tree a = L a | Tree a (Tree a) (Tree a) deriving (Show, Eq)

tree123 = Tree 1 (L 2) (L 3)
tree17 = Tree 1(Tree 2(L 3) (L 4)) (Tree 5 (L 6) (L 7))

data MyList a = C a (MyList a) | Nil deriving (Show, Eq)
mylist (x:xs) = C x (mylist xs)
mylist [] = Nil

-- ----------------------------------------------------------------

-- a quick and dirty sanity check that all the examples do function.
-- It does not look pretty.

runall = [show runt1a,  show runt1b,
          show runt2a,  show runt2b,
          show runt3a,  show runt3b, 
          show runt4,
          show runt5,
          show runt6a,  show runt6b,
          show runt7a,  show runt7b,
          show runt8a,  show runt8b,
          show runt9a,  show runt9b,
          show runt10a, show runt10b,
          show runt11a, show runt11b,
          show runt12a, show runt12b, show runt12c,
          show runt13a, show runt13b,
--          show runt14a, show runt14b, show runt14c,
--          show runt15a, show runt15b, show runt15c,
--          show runt16a, show runt16b, show runt16c,
          show runt17a, show runt17b, show runt17c

         ]

-- ----------------------------------------------------------------

-- an example of what using the State monad looks like versus using
-- the StateX monad.  Each non-proper morphism, instance constraint,
-- and run function now has an extra (first) parameter that is simply
-- the index being used.

t1 :: (MonadState Int m) => m Bool
t1 = do
   a <- get
   put 15
   return (a > 100)

--maybe flip is a bit obfuscating here, but when we are creating a
--longer stack of monad transformers, it lends to more readable code;
--we warm up to it here.
runt1a = flip runState   5 t1
runt1b = flip runState 500 t1

t2 :: (MonadStateX X1 Int m) => m Bool
t2 = do
  a <- getx X1
  putx X1 15
  return (a > 100)

-- flip23 is just a convenience function; flip lets us reorder the 1-
-- and 2-spot parameters, and flip23 lets us reorder the 2- and 3-spot
-- parameters.  flip f a c b = f a b c
runt2a = flip23 runStateX X1   5 t2
runt2b = flip23 runStateX X1 500 t2

-- ----------------------------------------------------------------

-- differently indexed monads can hold different contents, the same
-- contents, whatever you like, so long as you always use the indexes.

t3 :: (MonadStateX X1 Int m,
       MonadStateX X2 Int m, 
       MonadStateX X3 Char m, 
       MonadStateX X4 [Int] m, 
       MonadStateX X5 Int m, 
       MonadStateX X6 (Tree Int) m
      ) => m String
t3 = do
   a1 <- getx X1
   a2 <- getx X2
   a3 <- getx X3
   a4 <- getx X4
   a5 <- getx X5
   a6 <- getx X6
   putx X1 100
   putx X2 200
   putx X3 '3'
   putx X4 [a1+a2+a5]
   putx X5 500
   putx X6 (Tree 1 (Tree 2 (L 3 ) (L 4 )) (L 5 ))
   b1 <- getx X1
   b2 <- getx X2
   b3 <- getx X3
   b4 <- getx X4
   b5 <- getx X5
   b6 <- getx X6
   return $ (show b1)++(show b2)++(show b3)++(show b4)++(show b5)++(show b6)

-- type ascription is unnecessary here...
--runt3a :: ((((((String,Tree Int),Int),[Int]),Char),Int),Int)
runt3a = flip23 runStateX  X1 1
       . flip23 runStateTX X2 2
       . flip23 runStateTX X3 't'
       . flip23 runStateTX X4 [4]
       . flip23 runStateTX X5 5
       . flip23 runStateTX X6 (L 0)
       $ t3
       
runt3b = flip23 runStateX  X6 (L 0)
       . flip23 runStateTX X1 1
       . flip23 runStateTX X3 't'
       . flip23 runStateTX X2 2
       . flip23 runStateTX X5 5
       . flip23 runStateTX X4 [4]
       $ t3
       
-- ----------------------------------------------------------------

--Reader example
t4 :: (MonadReader [Int] m) => m Int
t4 = do
  a <- ask
  return $ sum a

runt4 = runReader t4 [1..5]

t5 :: (MonadReaderX X3 [Int] m) => m Int
t5 = do
  a <- askx X3
  return $ sum a

-- note that it doesn't matter which index we choose to use, as long
-- as we always use the one index for one copy of the ReaderX monad
-- (i.e., we don't have to use X1 first--there is no ordering amongst
-- them; we've chosen X3 this time).
runt5 = runReaderX X3 t5 [1..5]

-- ----------------------------------------------------------------

-- a laborious way to sum over the Tree structure.

t6 :: (MonadReader [Int] m) => Tree Int -> m Int
t6 (L v) = do
  a <- ask
  return $ sum (v:a)
t6 (Tree a x y) = do
  env <- ask
  x' <- local (const (a:env)) $ t6 x
  y' <- local (const (a:env)) $ t6 y
  return $ sum (a:x':y':env)

runt6 tm = flip runReader [0] $ t6 tm 
runt6a = runt6 $ tree17  -- 48
runt6b = runt6 $ tree123 --  8

t7 :: (MonadReaderX X2 [Int] m) => Tree Int -> m Int
t7 (L v) = do
  a <- askx X2
  return $ sum (v:a)
t7 (Tree a x y) = do
  env <- askx X2
  x' <- localx X2 (const (a:env)) $ t7 x
  y' <- localx X2 (const (a:env)) $ t7 y
  return $ sum (a:x':y':env)

runt7 tm = flip23 runReaderX X2 [0] $ t7 tm 
runt7a = runt7 $ tree17  -- 48
runt7b = runt7 $ tree123 --  8

-- ----------------------------------------------------------------

-- using the writer to `tell' which even values are in the tree.

t8 :: (MonadWriter [Int] m) => Tree Int -> m (Tree Int)
t8 (L x) = do
  tell $ if even x then [x] else []
  return $ L x
t8 (Tree a x y) = do
  x' <- t8 x
  y' <- t8 y
  tell $ if even a then [a] else []
  return $ Tree a x y

runt8 tm = runWriter $ t8 tm
runt8a = runt8 tree17
runt8b = runt8 tree123


t9 :: (MonadWriterX X6 [Int] m) => Tree Int -> m (Tree Int)
t9 (L x) = do
  tellx X6 $ if even x then [x] else []
  return $ L x
t9 (Tree a x y) = do
  x' <- t9 x
  y' <- t9 y
  tellx X6 $ if even a then [a] else []
  return $ Tree a x y

runt9 tm = runWriterX X6 $ t9 tm
runt9a = runt9 tree17
runt9b = runt8 tree123

-- ----------------------------------------------------------------

-- using the writer to `tell' which even values are in the list.

t10:: (MonadWriter [Int] m) => MyList Int -> m (MyList Int)
t10 (C a as) = do
  tell $ if even a then [a] else []
  as' <- t10 as
  return $ C a as
t10 (Nil) = return Nil

runt10 tm = runWriter $ t10 tm
runt10a = runt10 $ mylist [1..10]
runt10b = runt10 $ mylist [-3..3]


t11:: (MonadWriterX X1 [Int] m) => MyList Int -> m (MyList Int)
t11 (C a as) = do
  tellx X1 $ if even a then [a] else []
  as' <- t11 as
  return $ C a as
t11 (Nil) = return Nil

runt11 tm = runWriterX X1 $ t11 tm
runt11a = runt11 $ mylist [1..10]
runt11b = runt11 $ mylist [-3..3]

-- ----------------------------------------------------------------

--using two separate writers
t12:: (MonadWriterX X1 [Int] m,
       MonadWriterX X2 [Int] m) => MyList Int -> m (MyList Int)
t12 (C a as) = do
  tellx X1 $ if even a then [a] else []
  tellx X2 $ if odd  a then [a] else []
  as' <- t12 as
  return $ C a as
t12 (Nil) = return Nil

runt12 tm = runWriterX X1 . runWriterTX X2 $ t12 tm
runt12a = runt12 $ mylist [1..10]
runt12b = runt12 $ mylist [-3..3]
runt12c = runt12 $ mylist [1,3,5,7,9]

-- ----------------------------------------------------------------

-- using a bunch of writers.  Again, they should be able to hold
-- different types; here, we lazily just see the same type stored in
-- each WriterX.
t13:: (MonadWriterX X1 [Int] m,
       MonadWriterX X2 [Int] m,
       MonadWriterX X3 [Int] m,
       MonadWriterX X4 [Int] m,
       MonadWriterX X5 [Int] m,
       MonadWriterX X6 [Int] m
      ) => MyList Int -> m (MyList Int)
t13 (C a as) = do
  case (mod a 6) of
    0 -> tellx X6 [a]
    1 -> tellx X1 [a]
    2 -> tellx X2 [a]
    3 -> tellx X3 [a]
    4 -> tellx X4 [a]
    5 -> tellx X5 [a]
  as' <- t13 as
  return $ C a as
t13 (Nil) = return Nil

runt13 tm = runWriterX  X1 
          . runWriterTX X2
          . runWriterTX X3
          . runWriterTX X4
          . runWriterTX X5
          . runWriterTX X6
          $ t13 tm
runt13a = runt13 $ mylist [1..10]
runt13b = runt13 $ mylist [-6..17]

-- ----------------------------------------------------------------

{-- ErrorX is just not ready yet...

t14 :: (MonadError String m, MonadState Int m) => Int -> m Int
t14 x = do
  y <- get
  if y==0
    then throwError "div by zero"
    else return ()
  if mod x y /= 0 
     then throwError "escaping integers..."
     else return ()
  return $  mod x y

runt14a = flip runState 0 . runErrorT $ t14 5
runt14b = flip runState 4 . runErrorT $ t14 5
runt14c = flip runState 4 . runErrorT $ t14 16

-- I don't think ErrorX is ready for usage, but if you need it and
-- after looking at the current implementation stubs it seems to work,
-- I'd love to either hear positive testing or even some contributions
-- on the ErrorX monad.  Using the Error (and List) monad was never my
-- strongpoint.
t15 :: (MonadErrorX X1 String m, MonadState Int m) => Int -> m Int
t15 x = do
  y <- get
  if y==0
    then throwErrorx X1 "div by zero"
    else return ()
  if mod x y /= 0 
     then throwErrorx X1 "escaping integers..."
     else return ()
  return $  mod x y

runt15a = flip runState 0 . runErrorTX X1 $ t15 5
runt15b = flip runState 4 . runErrorTX X1 $ t15 5
runt15c = flip runState 4 . runErrorTX X1 $ t15 16

-- ----------------------------------------------------------------

-- the ErrorX monad isn't ready...
data MyError = E1 | E2 Int | E3 String deriving (Show, Eq)
instance Error MyError where
  noMsg = E3 "A string error!"
  strMsg s = E3 s
type ThingMonad = Either MyError

t16 :: (MonadErrorX X1 MyError m, MonadState Int m) => Int -> m Int
t16 x = do
  y <- get
  if y==0
    then throwErrorx X1 $ E2 0-- "div by zero"
    else return ()
  if mod x y /= 0 
     then throwErrorx X1 $ E3 "escaping integers..."
     else return ()
  return $  mod x y

unEither a@(Left _) = error $ "Unhandled MyError Exception: "++(show a)
unEither (Right v) = v

runt16a = flip runState 0 . runErrorTX X1 $ t16 5
runt16b = flip runState 4 . runErrorTX X1 $ t16 5
runt16c = flip runState 4 . runErrorTX X1 $ t16 16

-- ----------------------------------------------------------------

--I can't handle multiple Errors at once yet...

t17 :: (MonadErrorX X1 MyError m, MonadErrorX X2 MyError m, MonadState Int m) => Int -> m Int
t17 x = do
  y <- get
  if y==0
    then throwErrorx X1 $ E2 0-- "div by zero"
    else return ()
  if mod x y /= 0 
     then throwErrorx X2 $ E3 "escaping integers..."
     else return ()
  return $  mod x y

runt17a = flip runState 0 . runErrorTX X1 . runErrorTX X2 $ t17 5
runt17b = flip runState 4 . runErrorTX X1 . runErrorTX X2 $ t17 5
runt17c = flip runState 4 . runErrorTX X1 . runErrorTX X2 $ t17 17


---}

-- ----------------------------------------------------------------
-- ----------------------------------------------------------------
-- ----------------------------------------------------------------


-------------------------------------------------------------------------
-------------------------------------------------------------------------

-- The example in this section is taken from:
-- http://www.haskell.org/all_about_monads/html/listmonad.html .
-- Because I really don't know how to use the List monad substantially
-- on my own...

-- we can parse three different types of terms
data Parsed = Digit Integer | Hex Integer | Word String deriving Show

-- attempts to add a character to the parsed representation of a hex digit
parseHexDigit :: (Monad m, MonadListX X1 Parsed m) => Parsed -> Char -> m Parsed
parseHexDigit (Hex n) c = if isHexDigit c then
                            return (Hex ((n*16) + (toInteger (digitToInt c))))
		          else
                            mzero
parseHexDigit _       _ = mzero

-- attempts to add a character to the parsed representation of a decimal digit
parseDigit :: (Monad m, MonadListX X1 Parsed m) => Parsed -> Char -> m Parsed
parseDigit (Digit n) c = if isDigit c then
                           return (Digit ((n*10) + (toInteger (digitToInt c))))
                         else
                           mzero
parseDigit _         _ = mzero
		   
-- attempts to add a character to the parsed representation of a word
parseWord :: (Monad m, MonadListX X1 Parsed m) => Parsed -> Char -> m Parsed
parseWord (Word s) c = if isAlpha c then
                         return (Word (s ++ [c]))
                       else
                         mzero
parseWord _        _ = mzero

-- tries to parse the digit as a hex value, a decimal value and a word
-- the result is a list of possible parses
parse :: (Monad m, MonadListX X1 Parsed m) => Parsed -> Char -> m Parsed
parse p c = (parseHexDigit p c) `mplus` (parseDigit p c) `mplus` (parseWord p c)

-- parse an entire String and return a list of the possible parsed values
parseArg :: (Monad m, MonadListX X1 Parsed m) => String -> m Parsed
parseArg s = do init <- (return (Hex 0)) `mplus` (return (Digit 0)) `mplus` (return (Word ""))
                foldM parse init s

-- show the original string and all possible parses for the string
showResult :: String -> IO ()
showResult s = do putStr s
                  putStr ": "
                  print $ runListX X1 $ parseArg s

-- prints possible parsed values for command-line arguments
listmain :: IO ()
listmain = do args <- getArgs
              mapM_ showResult args


runt17a = runListX X1 $ parseArg "hello"
runt17b = runListX X1 $ parseArg "24680"
runt17c = runListX X1 $ parseArg "ace15"

-------------------------------------------------------------------------
-------------------------------------------------------------------------

-- I don't know that it's worth having multiple Identity monads, but
-- someone may find a purpose.  So it is included.
runt18a = runIdentityX X1 $ IdentityX X1 3
runt18b = runIdentityX X4 $ IdentityX X4 2

-------------------------------------------------------------------------
-------------------------------------------------------------------------

-- state keeps some free strings around; the environment pairs these
-- strings with values so that children know their ancestors.  Writer
-- relays any node whose number already was used for an ancestor--we
-- get the string, and how many ancestors were similarly named.  This
-- is entirely contrived...

-- A structure (defined far above) for use in examples.
--data Tree a = L a | Tree a (Tree a) (Tree a) deriving (Show, Eq)

data Ix19 = Ix19
instance Index Ix19 where getVal= Ix19

ancestorNames :: Int -> [(String,Int)] -> Int
ancestorNames n = sum . map (\(a,b)->if n==b then 1 else 0)

-- TEST the RWSX monad.
t19 :: (MonadRWSX Ix19 [(String,Int)] [(Int,Int)] [String] m) => Tree Int -> m Int
t19 (Tree a x y) = do
  env <- askx Ix19
  let prevs = ancestorNames a env
  when (prevs /= 0) $ tellx Ix19 [(a,prevs)]
  (v:vs) <- getx Ix19
  putx Ix19 vs
  x' <- localx Ix19 (const ((v,a):env)) (t19 x)
  y' <- localx Ix19 (const ((v,a):env)) (t19 y)
  return $ a + x' + y'
t19 (L a) = do
  env <- askx Ix19
  let prevs = ancestorNames a env
  when (prevs /= 0) $ tellx Ix19 [(a,prevs)]
  return a

runt19 = runRWSX Ix19 (t19 treeAnc1) [] $ map (\a->[a]) ['a'..'z']

treeAnc1 = 

 Tree 2 (Tree 2
             (Tree 1 (L 0) (L 1))
             (Tree 3 (L 2) (L 3))  )
        (Tree 4
            (Tree 3 (L 4) (L 5))
            (Tree 2 (L 6) (L 7))   )


-------------------------------------------------------------------------
-------------------------------------------------------------------------

-- in this example, the previous (#19) RWS monad is doing what it
-- does, except that if our current node is odd or even, we utilize
-- the separate RWS monads.

data Ix20 = Ix20
instance Index Ix20 where getVal= Ix20

-- TEST the RWSX monad with multiple ones.
t20 :: (MonadRWSX Ix19 [(String,Int)] [(Int,Int)] [String] m,
        MonadRWSX Ix20 [(String,Int)] [(Int,Int)] [String] m) 
    => Tree Int -> m Int
t20 (Tree a x y) | even a = do
  env <- askx Ix19
  let prevs = ancestorNames a env
  when (prevs /= 0) $ tellx Ix19 [(a,prevs)]
  (v:vs) <- getx Ix19
  putx Ix19 vs
  x' <- localx Ix19 (const ((v,a):env)) (t20 x)
  y' <- localx Ix19 (const ((v,a):env)) (t20 y)
  return $ a + x' + y'
t20 (Tree a x y) | odd a = do
  env <- askx Ix20
  let prevs = ancestorNames a env
  when (prevs /= 0) $ tellx Ix20 [(a,prevs)]
  (v:vs) <- getx Ix20
  putx Ix20 vs
  x' <- localx Ix20 (const ((v,a):env)) (t20 x)
  y' <- localx Ix20 (const ((v,a):env)) (t20 y)
  return $ a + x' + y'
t20 (L a) | even a = do
  env <- askx Ix19
  let prevs = ancestorNames a env
  when (prevs /= 0) $ tellx Ix19 [(a,prevs)]
  return a
t20 (L a) | odd a = do
  env <- askx Ix20
  let prevs = ancestorNames a env
  when (prevs /= 0) $ tellx Ix20 [(a,prevs)]
  return a

mlast24 f ix tm r s = f ix r s tm

-------------------------------------------------------------------------
-------------------------------------------------------------------------

-- TODO: TEST THE ErrorX monads in combination.

-------------------------------------------------------------------------
-------------------------------------------------------------------------

--TODO: Make some huge test involving as many things as possible.

-------------------------------------------------------------------------
-------------------------------------------------------------------------

-- Not TODO: QuickCheck testing.  As the types of things change, it
-- turned out to be pretty convoluted (to me).

-------------------------------------------------------------------------
-------------------------------------------------------------------------

-- EOF