{-#  LANGUAGE FlexibleContexts       #-}
{-#  LANGUAGE FlexibleInstances      #-}
{-#  LANGUAGE MultiParamTypeClasses  #-}


{-#  LANGUAGE NoMonomorphismRestriction  #-}


{- |
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.RWS.Class
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 = [-- StateX    examples
          show runt1a,  show runt1b,
          show runt2a,  show runt2b,
          show runt3a,  show runt3b, 
          -- ReaderX   examples
          show runt4,
          show runt5,
          show runt6a,  show runt6b,
          show runt7a,  show runt7b,
          -- WriterX   examples
          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,
          -- ErrorX    examples
          show runt14a, show runt14b, show runt14c,
          show runt15a, show runt15b, show runt15c,
          show runt16a, show runt16b, show runt16c,
          show runt17a, show runt17b, show runt17c,
          show runt18a, show runt18b,
          -- IdentityX examples
          show runt19a, show runt19b,
          -- RWSX      examples
          show runt20a, show runt20b,
          show runt21a, show runt21b,
          show runt22a, show runt22b, show runt22c,
          show runt23a, show runt23b, show runt23c,
--        list examples
          show runLista, show runListb, show runListc
         ]

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

-- 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)

runt2a = flip (runStateX X1)   5 t2
runt2b = flip (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 = flip (runStateX  X1) 1
       . flip (runStateTX X2) 2
       . flip (runStateTX X3) 't'
       . flip (runStateTX X4) [4]
       . flip (runStateTX X5) 5
       . flip (runStateTX X6) (L 0)
       $ t3
       
runt3b = flip (runStateX  X6) (L 0)
       . flip (runStateTX X1) 1
       . flip (runStateTX X3) 't'
       . flip (runStateTX X2) 2
       . flip (runStateTX X5) 5
       . flip (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 = flip (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]

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

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

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
data MyError = E1 | E2 Int | E3 String deriving (Show, Eq)
instance (Index ix) => ErrorX ix MyError where
  noMsgx  _   = E3 "A string error!"
  strMsgx _ 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

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

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

-- multiple Errors at once

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 16

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

-- Thanks to Tom Shrijvers for this example!

-- because there's otherwise no indication what the non-error value's
-- type should be, I've ascribed the type of t18.  We could execute
-- runt18 without the ascription, but evaluating something like <show
-- runt18> creates an ambiguous (Show a) constraint and fails.
t18 :: (MonadErrorX X1 String m, MonadErrorX X2 String m) => m Int
t18 = catchErrorx X1 
            (throwErrorx X1 "error") 
            (\e -> throwErrorx X2 e)

runt18a = runIdentity  $ runErrorTX X1 $ runErrorTX X2 $ t18
runt18b = runIdentity $ runErrorTX X2 $ runErrorTX X1 $ t18


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

-- I don't know that it's worth having multiple Identity monads, but
-- someone may find a purpose.  So it is included.
runt19a = runIdentityX X1 $ mkIdentityX X1 3
runt19b = runIdentityX X4 $ mkIdentityX 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 Ix20 = Ix20
instance Index Ix20 where getVal= Ix20

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

-- TEST the RWSX monad.
t20 :: (MonadRWSX Ix20 [(String,Int)] [(Int,Int)] [String] m) => Tree Int -> m Int
t20 (Tree a x y) = 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) = do
  env <- askx Ix20
  let prevs = ancestorNames a env
  when (prevs /= 0) $ tellx Ix20 [(a,prevs)]
  return a


sInit = map (\a->[a]) ['a'..'h']
rInit = []

flip31 f b c a = f a b c

runt20a =               flip31 (runRWSX  Ix20) rInit sInit $ t20 treeAnc1
runt20b = runIdentity $ flip31 (runRWSTX Ix20) rInit sInit $ t20 treeAnc1

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))
          )


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

-- 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)

-- TEST the RWS monad.
t21 :: (MonadRWS  [(String,Int)] [(Int,Int)] [String] m) => Tree Int -> m Int
t21 (Tree a x y) = do
  env <- ask
  let prevs = ancestorNames a env
  when (prevs /= 0) $ tell [(a,prevs)]
  (v:vs) <- get
  put vs
  x' <- local (const ((v,a):env)) (t21 x)
  y' <- local (const ((v,a):env)) (t21 y)
  return $ a + x' + y'
t21 (L a) = do
  env <- ask
  let prevs = ancestorNames a env
  when (prevs /= 0) $ tell [(a,prevs)]
  return a

runt21a =               flip31  runRWS  rInit sInit $ t21 treeAnc1
runt21b = runIdentity $ flip31  runRWST rInit sInit $ t21 treeAnc1

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

-- in this example, the previous (#20) RWSX monad is doing what it
-- does, except that our current node's even- or oddness determines
-- which RWS/X monad we use.

data Ix22 = Ix22
instance Index Ix22 where getVal= Ix22


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

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

f  = flip31  runRWS        rInit sInit 
fX = flip31 (runRWSX Ix22) rInit sInit 

fT  = flip31  runRWST        rInit sInit 
fTX = flip31 (runRWSTX Ix22) rInit sInit 

comp     :: (MonadRWS       [(String,Int)] [(Int,Int)] [String] m,
             MonadRWSX Ix22 [(String,Int)] [(Int,Int)] [String] m,
             Monad m) 
    => m Int
comp = t22 treeAnc1

runt22a  =               flip31 (runRWSX Ix22) rInit sInit $ flip31 (runRWST      ) rInit sInit $ t22 treeAnc1
runt22b  =               flip31 (runRWS      ) rInit sInit $ flip31 (runRWSTX Ix22) rInit sInit $ t22 treeAnc1
runt22c  = runIdentity $ flip31 (runRWST     ) rInit sInit $ flip31 (runRWSTX Ix22) rInit sInit $ t22 treeAnc1


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


-- in this example, the previous (#20) RWS monad is doing what it
-- does, except that our current node's even- or oddness determines
-- which RWS monad we use.

data Ix23 = Ix23 deriving (Show, Eq)
instance Index Ix23 where getVal= Ix23


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

f1 = flip31 (runRWSX Ix20) rInit sInit 
f2 = flip31 (runRWSX Ix23) rInit sInit 

f1' = flip31 (runRWSTX Ix20) rInit sInit 
f2' = flip31 (runRWSTX Ix23) rInit sInit 

runt23a =               flip31 (runRWSX  Ix23) rInit sInit $ flip31 (runRWSTX Ix20) rInit sInit $ t23 treeAnc1
runt23b =               flip31 (runRWSX  Ix20) rInit sInit $ flip31 (runRWSTX Ix23) rInit sInit $ t23 treeAnc1
runt23c = runIdentity $ flip31 (runRWSTX Ix20) rInit sInit $ flip31 (runRWSTX Ix23) rInit sInit $ t23 treeAnc1

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

-- 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


runLista = runListX X1 $ parseArg "hello"
runListb = runListX X1 $ parseArg "24680"
runListc = runListX X1 $ parseArg "ace15"

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

--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