Eip.hs

--  | This module holds the messy code I wrote while walking through:
--
--     The Essence of the Iterator Pattern
--     Jeremy Gibbons, Bruno César dos Santos Oliveira. 2009.
--     http://www.cs.ox.ac.uk/publications/publication1409-abstract.html
--

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}

{-# LANGUAGE UndecidableInstances #-}
-- ^ Some 'Coerce' instances require this.



module Eip where

import Prelude hiding (map, lcm)
import Control.Applicative (Applicative(..))
import Data.Monoid (Monoid(..), (<>), Sum(..))
import Data.Char (isSpace)
import Control.Monad.Trans.Writer



class Bifunctor s where
  bimap :: (a -> b) -> (c -> d) -> s a c -> s b d

prop_bimap_identity_law bf =
  bimap id id bf == id bf
prop_bimap_composition_law f g h k bf =
  bimap (f . h) (g . k) bf == (bimap f g . bimap h k) bf

data Fix s a = In { out :: s a (Fix s a) }

instance Bifunctor s => Functor (Fix s) where
  fmap f = In . bimap f (fmap f) . out

fold :: Bifunctor s => (s a b -> b) -> Fix s a -> b
fold f = f . bimap id (fold f) . out

unfold :: Bifunctor s => (b -> s a b) -> b -> Fix s a
unfold f = In . bimap id (unfold f) . f

instance Bifunctor (,) where
  bimap f g (a,b) = (f a, g b)



newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }

instance Functor m => Functor (WrappedMonad m) where
  fmap f = WrapMonad . fmap f . unwrapMonad

instance (Functor m, Monad m) => Applicative (WrappedMonad m) where
  pure = WrapMonad . return
  mf <*> mx = WrapMonad $ do f <- unwrapMonad mf
                             x <- unwrapMonad mx
                             return (f x)

data Stream a = SCons a (Stream a)
  deriving (Show)

streamHead (SCons a _) = a

instance Functor Stream where
  fmap f (SCons x xs) = SCons (f x) (fmap f xs)

instance Applicative Stream where
  pure x = xs where xs = SCons x xs
  (SCons f fs) <*> (SCons x xs) = SCons (f x) (fs <*> xs)


newtype Const b a = Const { unConst :: b }
  deriving (Show)

instance Functor (Const b) where
  fmap _ (Const x) = Const x

instance Monoid b => Applicative (Const b) where
  pure _ = Const mempty
  (Const x) <*> (Const y) = Const (x `mappend` y)

-- instance Monoid b => Monoid (Const b a) where
--   mempty = Const mempty
--   mappend (Const x) (Const y) = Const (x `mappend` y)


newtype Reader r a = R { runReader :: r -> a }
  deriving (Functor, Monad, Applicative)

ask :: Reader r r
ask = R $ \r -> r



{- Stuff
 -
instance Functor (Reader r) where
  fmap f (R g) = R (f . g)

class Functor f => Applicative f where
  pure :: a -> f a
  (<*>) :: f (a -> b) -> f a -> f b


instance Applicative (Reader r) where
   pure x = R (const x)

-- (Reader  (      a -> b)) <*> (Reader       a ) = Reader        b
-- (R       (r -> (a -> b)) <*> (R      (r -> a)) = R       (r -> b)
   (R       f             ) <*> (R      x       ) = R      (\r -> f r (x r))


instance Functor ((->) r) where
 -- fmap :: (a -> b) ->         F a  ->         F b
 -- fmap :: (a -> b) -> (->) r    a  -> (->) r    b
 -- fmap :: (a -> b) ->     (r -> a) ->     (r -> b)
    fmap    f               g        =      \r -> (f . g) r

instance Applicative ((->) r) where
 -- pure :: a ->         A a
 -- pure :: a -> (->) r    a
 -- pure :: a ->     (r -> a)
    pure    x  = const x

 -- (<*>) ::          A (a -> b)  ->          A a  ->          A b
 -- (<*>) ::  (->) r    (a -> b)  ->  (->) r    a  ->  (->) r    b
 -- (<*>) ::      (r -> (a -> b)) ->      (r -> a) ->      (r -> b)
    (<*>)         f                       g         =      \r -> f r (g r)


instance Monad ((->) r) where
 -- return :: a ->         M a
 -- return :: a -> (->) r    a
 -- return :: a ->     (r -> a)
    return    x  =     \r -> x

 -- (>>=) ::         M a  -> (a ->         M b)  ->          M b
 -- (>>=) :: (->) r    a  -> (a -> (->) r    b)  -> (->) r    b
 -- (>>=) ::     (r -> a) -> (a ->     (r -> b)) ->     (r -> b)
    (>>=)        f           k                    =     \r -> k (f r) r
-}



data Product m n a = Product { pfst :: m a, psnd :: n a }
  deriving (Show)
prod :: (Functor m, Functor n) => (a -> m b) -> (a -> n b) -> (a -> Product m n b)
prod f g x = Product (f x) (g x)

instance (Functor m, Functor n) => Functor (Product m n) where
  fmap f (Product a b) = Product (fmap f a) (fmap f b)

instance (Applicative m, Applicative n) => Applicative (Product m n) where
  pure x = Product (pure x) (pure x)
  mf <*> mx = Product (pfst mf <*> pfst mx) (psnd mf <*> psnd mx)


data Compose m n a = Compose { unCompose :: m (n a) }
  deriving (Show)

comp :: (Functor m, Functor n) => (b -> n c) -> (a -> m b) -> (a -> Compose m n c)
comp f g x = Compose (fmap f (g x))


instance (Functor m, Functor n) => Functor (Compose m n) where
  fmap f (Compose x) = Compose (fmap (fmap f) x)

instance (Applicative m, Applicative n) => Applicative (Compose m n) where
  pure x = Compose (pure (pure x))
  mf <*> mx = Compose (pure (<*>) <*> unCompose mf <*> unCompose mx)

traverseList :: Applicative m => (a -> m b) -> [a] -> m [b]
traverseList f []     = pure []
traverseList f (x:xs) = pure (:) <*> f x <*> traverseList f xs

distList :: Applicative m => [m a] -> m [a]
distList = traverseList id


class Functor t => Traversable t where
  traverse :: Applicative m => (a -> m b) -> t a -> m (t b)
  traverse f = dist . fmap f
  -- Free theorems:
  --  1. traverse (g . h)      = traverse g . fmap h
  --  2. traverse (fmap k . f) = fmap (fmap k) . traverse f

  dist :: Applicative m => t (m a) -> m (t a)
  dist = traverse id
  -- Free theorem:
  --   1. dist . fmap (fmap k) = fmap (fmap k) . dist


data Tree a = Leaf a | Bin (Tree a) (Tree a)
  deriving (Show, Eq)

sampleTree :: Tree Int
sampleTree = Bin (Bin (Leaf 3) (Bin (Bin (Leaf 5) (Leaf 3)) (Bin (Leaf 9) (Bin (Bin (Leaf 8) (Leaf 1)) (Leaf 2))))) (Leaf 4)


instance Functor Tree where
  fmap f (Leaf a)  = Leaf (f a)
  fmap f (Bin l r) = Bin (fmap f l) (fmap f r)

instance Traversable Tree where
  traverse f (Leaf x)  = pure Leaf <*> f x
  traverse f (Bin l r) = pure Bin <*> traverse f l <*> traverse f r


class Bifunctor s => Bitraversable s where
  bdist :: Applicative m => s (m a) (m b) -> m (s a b)

instance Bitraversable s => Traversable (Fix s) where
  traverse f = fold (fmap In . bdist . bimap f id)

instance (Traversable m, Traversable n) => Traversable (Product m n) where
  traverse f (Product mx nx) = pure Product <*> traverse f mx <*> traverse f nx


newtype Id a = Id { unId :: a }
  deriving (Show)

instance Traversable Id where
  traverse f (Id x) = pure Id <*> f x

instance Functor Id where
  fmap f (Id x) = Id (f x)

instance Applicative Id where
  pure          = Id
  Id f <*> Id x = Id (f x)

instance Traversable [] where
  traverse _ []     = pure []
  traverse f (x:xs) = pure (:) <*> f x <*> traverse f xs

-- Data.Traversable.foldMapDefault
--   :: (Traversable t, Monoid m) => (a -> m) -> t a -> m
reduce :: (Traversable t, Monoid m) => (a -> m) -> t a -> m
reduce f = unConst . traverse (Const . f)

-- Data.Foldable.fold
--   :: (Foldable t, Monoid m) => t m -> m
crush :: (Traversable t, Monoid m) => t m -> m
crush = reduce id

instance Traversable Stream where
  traverse f (SCons x xs) = pure SCons <*> f x <*> traverse f xs

class Coerce a b | a -> b where
  d' :: a -> b
  c' :: b -> a

instance Coerce (Id a) a where
  d' = unId
  c' = Id

instance Coerce (Const a b) a where
  d' = unConst
  c' = Const

-- {- The following 3 instances require enabling UndecidableInstances
instance (Functor m, Functor n, Coerce (m a) b, Coerce (n a) c) => Coerce (Product m n a) (b, c) where
  d' mnx   = (d' (pfst mnx), d' (psnd mnx))
  c' (x,y) = Product (c' x) (c' y)

instance (Functor m, Functor n, Coerce (m b) c, Coerce (n a) b) => Coerce (Compose m n a) c where
  d' = d' . fmap d' . unCompose
  c' = Compose . fmap c' . c'

instance (Monad m, Coerce (m a) c) => Coerce (WrappedMonad m a) c where
  d' = d' . unwrapMonad
  c' = WrapMonad . c'
-- -}

contentsBody :: a -> Const [a] b
contentsBody x = Const [x]

contents :: Traversable t => t a -> Const [a] (t b)
contents = traverse contentsBody

run :: (Coerce b c, Traversable t) => (t a -> b) -> t a -> c
run program = d' . program

runContents :: Traversable t => t a -> [a]
runContents = run contents

shapeBody :: a -> Id ()
shapeBody _ = Id ()

shape :: Traversable t => t a -> Id (t ())
shape = traverse shapeBody

runShape :: Traversable t => t a -> t ()
runShape = run shape

-- Decompose into shape and contents using parallel traversals.
decompose :: Traversable t => t a -> Product Id (Const [a]) (t ())
decompose = prod shape contents
-- decompose x = Product (shape x) (contents x)

-- Decompose into shape and contents fusing traversals.
decompose' :: Traversable t => t a -> Product Id (Const [a]) (t ())
decompose' = traverse $ prod shapeBody contentsBody

instance Coerce (Maybe a) (Maybe a) where
  d' = id
  c' = id

newtype State s a = State { runState :: s -> (a,s) }

instance Functor (State s) where
  fmap f x = State $ \s -> let (a, s') = runState x s
                            in (f a, s')

instance Monad (State s) where
  return a = State $ \s -> (a, s)
  m >>= k  = State $ \s -> let (a, s')  = runState m s
                            in runState (k a) s'

-- get :: State s s
-- get = State $ \s -> (s, s)
--
-- put :: s -> State s ()
-- put s = State $ \s' -> ((), s)

squareInCubeState :: Int -> State Int Int
squareInCubeState z = do
  -- Triple cube state. We do it in two steps to check if 'get' and
  -- 'put' work as expected.
  x  <- get; put (x * x)
  xx <- get; put (x * xx)
  -- Double out
  return (z * z)

prop_squareInCubeState a s
  = (a*a, s*s*s) == runState (squareInCubeState a) s

instance Coerce (State s a) (s -> (a,s)) where
  d' = runState
  c' = State

-- {- mindblowing stuff
reassembleBody :: () -> Compose (WrappedMonad (State [a])) (WrappedMonad Maybe) a
reassembleBody = c' . takeHead
  where takeHead _ []     = (Nothing, [])
        takeHead _ (x:xs) = (Just x , xs)

reassemble :: Traversable t => t () -> Compose (WrappedMonad (State [a])) (WrappedMonad Maybe) (t a)
reassemble = traverse reassembleBody

runReassemble :: Traversable t => (t (), [a]) -> Maybe (t a)
runReassemble = fst . uncurry (run reassemble)

prop_reassemble t =
  let decomposed = d' $ decompose t
   in maybe False (==t) $ runReassemble decomposed
-- try: True == prop_reassemble sampleTree

-- -} end of mindblowing stuff


-- perform the effect @f@ for each @a@ and purely map values using @g@.
collect :: (Traversable t, Applicative m) => (a -> m ()) -> (a -> b) -> t a -> m (t b)
collect f g = traverse (\a -> pure (\() -> g a) <*> f a)

-- traverse the structure using the State monad to capture counting and
-- purely mapping values with @f@
loop :: Traversable t => (a -> b) -> t a -> WrappedMonad (State Int) (t b)
loop f = collect (\a -> WrapMonad (get >>= put . succ)) f

loop' :: Traversable t => (a -> b) -> Int -> t a -> (t b, Int)
loop' f s t = runState (unwrapMonad $ loop f t) s
-- loop' odd 10 [1,2,3,4,5] == ([True,False,True,False,True],15)


-- Super cool. Apply @g@ to each @a@ from @ta@ and @b@ from the effectful @mb@.
disperse :: (Traversable t, Applicative m) => m b -> (a -> b -> c) -> t a -> m (t c)
disperse mb g ta = traverse (\a -> pure (g a) <*> mb) ta

-- Almost the same as above but taking an applicative action.
dispersek :: (Traversable t, Applicative m) => (a -> m b) -> (a -> b -> c) -> t a -> m (t c)
dispersek kb g = traverse (\a -> fmap (g a) (kb a))
-- dispersek (\a -> putStrLn ("??? "++a) >> getLine) (++) ["Hi ", "Bye "]
-- ??? Hi
-- World
-- ??? Bye
-- bdf
-- ["Hi World","Bye bdf"]


-- Label each element with its position in order of traversal
label :: Traversable t => t a -> WrappedMonad (State Int) (t Int)
label = disperse (WrapMonad labelStep) (\_ b -> b)

labelStep :: State Int Int
labelStep = get >>= \n -> put (n+1) >> return n

labelStepA :: a -> WrappedMonad (State Int) Int
labelStepA _ = WrapMonad labelStep

label' :: Traversable t => t a -> Id (t Int)
label' = c' . fst . flip runState 0 . unwrapMonad . label
-- label' [8,6,7] == [0,1,2]

-- d' $ prod label' contents (Just 4) == (Just 0,[4])


instance Traversable Maybe where
  traverse f Nothing  = pure Nothing
  traverse f (Just x) = pure Just <*> f x


newtype Backwards m a = Backwards { runBackwards :: m a }
  deriving (Show)

instance Functor f => Functor (Backwards f) where
  fmap f (Backwards mx) = Backwards $ fmap f mx

instance Applicative m => Applicative (Backwards m) where
  pure = Backwards . pure
  mf <*> mx = Backwards $ pure (flip ($)) <*> runBackwards mx <*> runBackwards mf

data AppAdapter m where
  AppAdapter :: Applicative (g m)
             => (forall a. m a -> g m a)
             -> (forall a. g m a -> m a)
             -> AppAdapter m

backwards :: Applicative m => AppAdapter m
backwards = AppAdapter Backwards runBackwards

ptraverse :: (Applicative m, Traversable t) => AppAdapter m -> (a -> m b) -> t a -> m (t b)
ptraverse (AppAdapter c d) f = d . traverse (c . f)

revContents :: Traversable t => t a -> Const [a] (t b)
revContents = ptraverse backwards contentsBody

newtype Forwards m a = Forwards { runForwards :: m a }

instance Functor m => Functor (Forwards m) where
  fmap f (Forwards mx) = Forwards $ fmap f mx

instance Applicative m => Applicative (Forwards m) where
  pure = Forwards . pure
  mf <*> mx = Forwards $ runForwards mf <*> runForwards mx

forwards :: Applicative m => AppAdapter m
forwards = AppAdapter Forwards runForwards

-- [4,3,2] == d' $ comp (ptraverse backwards contentsBody) (traverse (\a -> Id (a+1))) [1,2,3]


-- Given an applicative functor transformation 'f':
--   f :: (Applicative m, Applicative n) => m a -> n a
--
-- - 'f' is an homomorphism over the structure of applicative, functors respecting:
--     1. f (pure_m a)     = pure_n a
--     2. f (mf <*>_m mx)  = (f mf) <*>_n (f mx)
--
-- - 'dist' satisfies the following naturality property:
--     1. dist_n . fmap f = f . dist_m
--
--    From this, the Purity Law follows:
--      a. traverse pure = pure
--
--    An f a Fusion Law for the parallel composition of traversals:
--      b. (traverse f `prod` traverse g) = traverse (f `prod` g)


{- Preserving Purity Law

| This definition of traverse in which the two children are swapped on
traversal breaks the Purity Law.

instance Traversable Tree where
  traverse f (Leaf x)  = pure Leaf <*> f x
  traverse f (Bin l r) = pure Bin <*> traverse f r <*> traverse f l


| This definition of traverse doesn't break the Purity Law. The two children are
swapped on traversal but the 'Bin' operater is flipped to compensate. The effect
of the reversal is that the elements of the tree are traversed from right to
left.

instance Traversable Tree where
  traverse f (Leaf x)  = pure Leaf <*> f x
  traverse f (Bin l r) = pure (flip Bin) <*> traverse f r <*> traverse f l

-- Btw, we can use 'Backwards' to achieve the same reversed traversal.
-}

(<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
(<=<) fc fb a = fb a >>= fc

(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
(>=>) = flip (<=<)

prop_traverse_kleisli_fuse kc kb ta = tc == tc'
  where tc  = (traverse kc <=< traverse kb) ta
        tc' = traverse (kc <=< kb) ta

-- True == prop_traverse_kleisli_fuse (\b -> Just (b*10)) (\a -> Just (a+1)) [1,2,3]

ap :: Monad m => m (a -> b) -> m a -> m b
ap mf ma = do { f <- mf; a <- ma; return (f a) }

instance Applicative (State s) where
  pure x = State $ \s -> (x, s)
  (<*>) = ap

update1, update2 :: a -> State Int a
update1 x = do { s <- get; put (s*2); return x }
update2 x = do { s <- get; put (s+1); return x }

-- monadic1 /= monadic2.
-- Composing some Kleisli arrows, such as update1 and update2, is not
-- necessarily commutative.
monadic1, monadic2 :: Traversable t => t a -> State Int (t a)
monadic1 = traverse update1 <=< traverse update2
monadic2 = traverse (update1 <=< update2)

-- applicative1 == applicative2
applicative1, applicative2 :: Traversable t => t a -> Compose (State Int) (State Int) (t a)
applicative1 = comp (traverse update1) (traverse update2)
applicative2 = traverse (comp update1 update2)

-- XXX I'm not sure if this is OK.
runA12 is1 is2 ma ta = ((is1, is2, s1), (a1, a1'))
  where
    st1        = unCompose $ ma ta
    (st1', a1) = runState st1  is1
    (a1', s1)  = runState st1' is2

-- XXX and this
prop_applicative12 :: (Eq (t a), Traversable t) => Int -> Int -> t a -> Bool
prop_applicative12 is1 is2 ta = xx1 == xx2
  where xx1 = runA12 is1 is2 applicative1 ta
        xx2 = runA12 is1 is2 applicative2 ta


index :: Traversable t => t a -> (t Int, Int)
index xs = run label xs 0

{- This traversal visits the same element multiple times. It satisfies the
purity law. However, if behaves strangely in cases such as extracting a list of
element indices:

instance Traversable [] where
  traverse f [] = pure []
  traverse f (x:xs) = pure (const (:)) <*> f x <*> f x <*> traverse f xs

indices are not quite expected:
  ([1,3,5],6) == index [1,2,3]
nor contents:
  [1,1,2,2,3,3] == runContents [1,2,3]
even while:
  m [1,2,3] == traverse pure [1,2,3]
-}



{- Word Count -}

-- Accumulate a result in the Int-as-Monoid applicative functor:
type Count = Const (Sum Int)

count :: Int -> Count b
count n = Const (Sum n)

-- The body of the iteration simply yields 1 for every element:
cciBody :: Char -> Count a
cciBody _ = count 1

-- Traversing with 'cciBody' accumulates the character count
cci :: String -> Count [a]
cci = traverse cciBody

test :: Bool -> Int
test b = if b then 1 else 0

-- Yield 1 for every line
lciBody :: Char -> Count a
lciBody c = count $ test (c == '\n')

-- Traversing with 'lciBody' accumulates the line count
lci :: String -> Count [a]
lci = traverse lciBody

-- Word count
wciBody :: Char -> Compose (WrappedMonad (State Bool)) Count a
wciBody c = comp Const (WrapMonad . State) updateState
  where updateState w = let s = not (isSpace c)
                         in (Sum $ test (not w && s), s)

wci :: String -> Compose (WrappedMonad (State Bool)) Count [a]
wci = traverse wciBody

runWci :: String -> Int
runWci s = getSum $ fst (run wci s False)

-- Count characters and lines sequentially.
clci' :: String -> Product Count Count [a]
clci' = prod cci lci

-- Count characters and lines in parallel.
clci :: String -> Product Count Count [a]
clci = traverse (prod cciBody lciBody)

-- Count characers, lines and words in parallel.
cclwi :: String -> Product (Product Count Count) (Compose (WrappedMonad (State Bool)) Count) [a]
cclwi = traverse (cciBody `prod` lciBody `prod` wciBody)
-- clwci = traverse (prod (prod cciBody lciBody) wciBody)

runCclwi :: String -> (Int {- chars -}, Int {- lines -}, Int {- words -})
runCclwi s = uncurry f (run cclwi s) where
 f (Sum cc, Sum lc) wck = let (Sum wc, _) = wck False
                           in (cc, lc, wc)
-- (34,3,7) == runCclwi  "one two\n three four\nfive six\nseven"

quiBody :: Char -> Pair Bool
quiBody c = Pair (c == 'q', c =='u')

qui :: String -> Pair [Bool]
qui = traverse quiBody

newtype Pair a = Pair (a,a)
  deriving (Show, Eq)

instance Functor Pair where
  fmap f (Pair (a,a')) = Pair (f a, f a')

instance Applicative Pair where
  pure a = Pair (a,a)
  Pair (f,f') <*> Pair (a,a') = Pair (f a, f' a')

instance Coerce (Pair a) (a,a) where
  d' (Pair x) = x
  c'          = Pair

-- qui "aqua" == Pair ([False,True,False,False],[False,False,True,False])

ccqui :: String -> Product Count Pair [Bool]
ccqui = traverse $ cciBody `prod` quiBody

-- run ccqui "qui asd"
--     == (Sum {getSum = 7},([True,False,False,False,False,False,False]
--                          ,[False,True,False,False,False,False,False]))

wcqui :: String -> Product Pair (Compose (WrappedMonad (State Bool)) Count) [Bool]
wcqui = traverse $ quiBody `prod` wciBody

-- In general component traversals may not be so amenable to composition as in
-- 'wcqui', and Product may not be the appropiate combinator. Here we use
-- Compose instead.
wcqui' :: String -> Compose (Product Id (Compose (WrappedMonad (State Bool)) Count)) Pair [Bool]
wcqui' = traverse (quiBody `comp` (Id `prod` wciBody))


runWcqui :: String -> (([Bool], [Bool]), Int)
runWcqui = fmap (\wks -> getSum . fst . wks $ False) . run wcqui

runWcqui' :: String -> (([Bool], [Bool]), Int)
runWcqui' = fmap (\wks -> getSum . fst . wks $ False) . run wcqui'


-- Now count characters, lines and words using Writer.

ccmBody :: Char -> Writer (Sum Int) Char
ccmBody c = tell (Sum 1) >> return c

ccm :: String -> Writer (Sum Int) String
ccm = traverse ccmBody

lcmBody :: Char -> Writer (Sum Int) Char
lcmBody c = tell (Sum $ test (c == '\n')) >> return c

lcm :: String -> Writer (Sum Int) String
lcm = traverse lcmBody

wcmBody :: Char -> State (Int, Bool) Char
wcmBody c = do
  let s = not (isSpace c)
  (n,w) <- get
  put (n + (test (not w && s)), s)
  return c

wcm :: String -> State (Int, Bool) String
wcm = traverse wcmBody

runWcm :: String -> Int
runWcm ta = wc where
 (_,(wc,_)) = runState (wcm ta) (0,False)


-- Now fuse the three monadic traversals into one.

clwcm, clwcm'
 :: String
 -> Product (Product (Writer (Sum Int)) (Writer (Sum Int)))
            (State (Int, Bool))
            String

-- sequentially:
clwcm = ccm `prod` lcm `prod` wcm
-- in parallel:
clwcm' = traverse $ ccmBody `prod` lcmBody `prod` wcmBody



runClwcm' :: String -> (Int {- chars -}, Int {- lines -}, Int {- words -})
runClwcm' s = (cc, lc, wc) where
  mwcc `Product` mwlc `Product` mswc = clwcm' s
  (_,Sum cc) = runWriter mwcc
  (_,Sum lc) = runWriter mwlc
  (_,(wc,_)) = runState mswc (0,False)

data Qum = QumU | QumQ deriving (Show, Eq)

qumBody :: Char -> Reader Qum Bool
qumBody c = ask >>= return . f where
  f QumQ = (c == 'q')
  f QumU = (c == 'u')

qum :: String -> Reader Qum [Bool]
qum = traverse qumBody

class MonadTrans t where
  lift :: Monad m => m a -> t m a


newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }

instance Monad m => Monad (StateT s m) where
  return a = StateT $ \s -> return (a,s)
  m >>= k  = StateT $ \s -> do
    (a, s') <- runStateT m s
    runStateT (k a) s'

instance MonadTrans (StateT s) where
  lift ma = StateT $ \s -> ma >>= \a -> return (a,s)

class Monad m => MonadState s m | m -> s where
  get :: m s
  put :: s -> m ()

instance MonadState s (State s) where
  get = State $ \s -> (s, s)
  put s = State $ \s' -> ((), s)

instance Monad m => MonadState s (StateT s m) where
  get = StateT $ \s -> return (s, s)
  put s = StateT $ \s' -> return ((), s)

(<=<^) :: (Monad m, MonadTrans t, Monad (t m))
       => (b -> t m c) -> (a -> m b) -> (a -> t m c)
ktf <=<^ kg = ktf <=< (lift . kg)

(^<=<) :: (Monad m, MonadTrans t, Monad (t m))
       => (b -> m c) -> (a -> t m b) -> (a -> t m c)
kf ^<=< ktg = (lift . kf) <=< ktg


wcmBody' :: MonadState (Int,Bool) m => Char -> m Char
wcmBody' c = do
  let s = not (isSpace c)
  (n,w) <- get
  put (n + (test (not w && s)), s)
  return c

quwcm :: String -> StateT (Int, Bool) (Reader Qum) [Bool]
quwcm = mapM (qumBody ^<=< wcmBody') -- == mapM qumBody ^<=< mapM wcmBody'

runQuwcm :: String -> Qum -> ([Bool], Int)
runQuwcm ta qx = (qu, wc) where
  (qu,(wc,_)) = runReader (runStateT (quwcm ta) (0, False)) qx



{- Abstracting with Applicatives.

  Starting from here, code is related to Edward Kmett's article at
  http://comonad.com/reader/2012/abstracting-with-applicatives/
-}

type WriterA b = Product (Const b) Id

tellA :: b -> WriterA b ()
tellA x = Product (Const x) (pure ())

-- >>> tellA [1,2] *> tellA [2]
-- Product {pfst = Const {unConst = [1,2,2]}, psnd = Id {unId = ()}}


type FailingWriterA b = Compose (WriterA b) Maybe

tellFWA :: Monoid b => b -> FailingWriterA b ()
tellFWA x = Compose (tellA x *> pure (Just ()))

-- >>> tellFWA [1,2] *> tellFWA [3]
-- Compose {unCompose = Product {pfst = Const {unConst = [1,2,3]},
--                               psnd = Id {unId = Just ()}}}


failFWA :: Monoid b => FailingWriterA b a
failFWA = Compose (pure Nothing)

-- >>> tellFWA [1,2] *> failFWA *> tellFWA [3]
-- Compose {unCompose = Product {pfst = Const {unConst = [1,2,3]},
--                               psnd = Id {unId = Nothing}}}

justFWA :: Monoid b => a -> FailingWriterA b a
justFWA x = Compose (pure (Just x))

-- >>>  tellFWA [1,2] *> justFWA (*5) <*> justFWA 4
-- Compose {unCompose = Product {pfst = Const {unConst = [1,2]},
--                                             psnd = Id {unId = Just 20}}}

-- >>>  tellFWA [1,2] *> justFWA (*5) <*> failFWA
-- Compose {unCompose = Product {pfst = Const {unConst = [1,2]},
--                               psnd = Id {unId = Nothing}}}

type HasEnv k m = Product (Const [k]) m

takeEnv :: (k -> m a) -> k -> HasEnv k m a
takeEnv f x = Product (Const [x]) (f x)

-- >>> let he = takeEnv (\e k -> e + k) 5
-- >>> :t he
-- he :: HasEnv Integer ((->) Integer) Integer
-- >>> pfst he
-- Const {unConst = [5]}
-- >>> :t psnd he
-- psnd he :: Integer -> Integer
-- >>> psnd he 10
-- 15

takeEnvNew :: (e -> k -> a) -> k -> HasEnv k (Reader e) a
takeEnvNew f x = Product (Const [x]) (R $ flip f x)

-- >>> let hen = takeEnvNew (\e k -> e + k) 5
-- >>> :t hen
-- hen :: HasEnv Integer (Reader Integer) Integer
-- >>> pfst hen
-- Const {unConst = [5]}
-- >>> :t psnd hen
-- psnd he :: Reader Integer Integer
-- >>> runReader (psnd hen) 10
-- 15


-- | Something that can be executed in one context as a monoid that
-- builds a form, and in another as a parser.
type FormletOne b a
  = Product (Const b) Id a

-- | .. also we can read from and environment and perhaps get an answer.
type FormletTwo b env a
  = Product (Const b) (Compose (Reader env) Maybe) a

-- | .. also we can get monoidal trace of errors wether we succeed or not.
type FormletThree b err env a
  = Product (Const b) (Compose (Reader env) (Product (Const err) Maybe)) a

-- ... but we want to either succeed, or get errors. So we need a sum
-- functor:

data Coproduct f g a = InL (f a) | InR (g a) deriving Show
-- ^ Named 'Coproduct' in comonad-transformers.

instance (Functor f, Functor g) => Functor (Coproduct f g) where
  fmap f (InL x) = InL (fmap f x)
  fmap g (InR y) = InR (fmap g y)

-- To make @'Coproduct' f g@ we need some sort of “bias”, since 'pure'
-- should prefer to inject the value to just one of 'InL' and 'InR'. We
-- pick 'InR' arbitrarily, following 'Either'\'s convention of using
-- 'Right'.
--
-- We need the capacity to “work in” one side of the sum until compelled
-- to switch over to the other, at which point we are stuck there.
--
-- We can make @'Coproduct' f g@ an 'Applicative'as long as there is a
-- natural transformation between @g@ and @f@, that is, there is a
-- function:
--
--   eta :: (Functor f, Functor g) g x -> f x
--
-- such that 'eta' “respects fmap”:
--
--   fmap h . eta == eta . fmap h
--
-- (Actually we want something stronger, called a “monoidal natural
-- transformation” that respects not only 'fmap', but '<*>' too.)

class Natural f g where
  eta :: f a -> g a

instance (Applicative f, Applicative g, Natural g f)
         => Applicative (Coproduct f g) where
  pure x = InR (pure x)
  InR g <*> InR y = InR (g <*> y)
  InL f <*> InL x = InL (f <*> x)
  InL f <*> InR x = InL (f <*> eta x)
  InR g <*> InL x = InL (eta g <*> x)

-- | Terminal homomorphism that sends any functor to 'Const':
instance Monoid b => Natural f (Const b) where
  eta = const (Const mempty)

instance Applicative f => Natural g (Compose f g) where
  eta = Compose . pure

instance (Applicative g, Functor f) => Natural f (Compose f g) where
  eta = Compose . fmap pure

instance (Natural f g) => Natural f (Product f g) where
  eta fa = Product fa (eta fa)

instance (Natural g f) => Natural g (Product f g) where
  eta ga = Product (eta ga) ga

instance Natural (Product f g) f where
  eta (Product fa _) = fa

instance Natural (Product f g) g where
  eta (Product _ ga) = ga

instance Natural g f => Natural (Coproduct f g) f where
  eta (InL fa) = fa
  eta (InR ga) = eta ga

instance Natural Id (Reader r) where
  eta (Id x) = R (pure x)

-- To avoid overlapping issues, we can't both have the terminal
-- homomorphism that sends everything to 'Const' and the initial
-- homomorphism that sends 'Id' to anything like so:
--
--   instance Applicative g => Natural Id g where
--     eta (Id x) = pure x
--

-- A version of 'Coproduct' with the initial tranformation baked in
-- lives in 'transformers' as 'Lift'.


-- | This applicative will yield either a single result 'InR', or an
-- accumulation of monoidal errors 'InL'. It exists on hackage in the
-- 'Validation' package.
type Validation b = Coproduct (Const b) Id

validationError :: Monoid b => b -> Validation b a
validationError x = InL (Const x)

-- Now we can produce a full formlet that does what we want:
--
--   Something that can be executed in one context as a monoid @b@ that
--   builds a form, and in another as a parser that can read from an
--   environment @env@ an either succeed providing a result @a@ or fail providing
--   a trace of errors @err@.
type Formlet b err env a
  = Product (Const b)
            (Compose (Reader env) (Coproduct (Const err) Id))
            a

-- Stripping away all the above noise:
type FormletClean b err env a = (b, env -> Either err a)