{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Mnd where
import Prelude hiding (Monad, return, (>>=), (>>))
-- Monads as functors with multiplication
class Functor t => Mnd t where
unit :: x -> t x
mult :: t (t x) -> t x
-- Monads in extension form
class Monad t where
return :: x -> t x
(>>=) :: t x -> (x -> t y) -> t y
(>>) :: t x -> t y -> t y
c >> d = c >>= \ _ -> d
instance Mnd t => Monad t where
return x = unit x
c >>= k = mult (fmap k c)
-- Maybe monad
instance Mnd Maybe where
unit x = Just x
mult Nothing = Nothing
mult (Just c) = c
-- Exception monads
instance Mnd (Either e) where
unit x = Right x
mult (Left e) = Left e
mult (Right c) = c
-- Reader monads
instance Mnd ((->) s) where
unit x = \ _ -> x
mult c = \ s -> c s s
-- Writer monads
{-
-- this is from Prelude
class Monoid p where
mempty :: p
mappend :: p -> p -> p
-}
instance Monoid p => Mnd ((,) p) where
unit x = (mempty, x)
mult (p, (p', x)) = (p `mappend` p', x)
-- State monads (for "extensional" stateful computation)
newtype State s x = St { unSt :: s -> (s, x) }
instance Functor (State s) where
fmap g (St f) = St (\ s -> let (s', x) = f s in (s', g x))
instance Mnd (State s) where
unit x = St (\ s -> (s, x))
-- mult :: (s -> (s, s -> (s, x))) -> s -> (s, x)
mult (St f) = St (\ s -> let (s', St g) = f s in g s')
-- free algebra of State s on x is (State s x, mult)
-- free mnemoid for s on x is (State s x, get, put) like below
-- get, put for the carrier State s x are a "decomposition" of mult_x
get :: (s -> State s x) -> State s x
get f = St (\ s -> unSt (f s) s)
put :: (s, State s x) -> State s x
put (s, St c) = St (\ _ -> c s)
-- Prestate monads (for "intensional stateful computation")
data Prestate s x = Ret x | Get (s -> Prestate s x) | Put (s, Prestate s x)
instance Functor (Prestate s) where
fmap g (Ret x) = Ret (g x)
fmap g (Get f) = Get (\ s -> fmap g (f s))
fmap g (Put (s, c)) = Put (s, fmap g c)
instance Mnd (Prestate s) where
unit x = Ret x
mult (Ret c) = c
mult (Get f) = Get (\ s -> mult (f s))
mult (Put (s, cc)) = Put (s, mult cc)
state2prest :: State s x -> Prestate s x
state2prest (St f) = Get ( \ s -> let (s', x) = f s in Put (s', Ret x))
prest2state :: Prestate s x -> State s x
prest2state (Ret x) = unit x -- = St (\ s -> (s, x))
prest2state (Get f) = get (\ s -> prest2state (f s))
-- = St (\ s -> unSt (prest2state (f s)) s)
prest2state (Put (s, c)) = put (s, prest2state c)
-- = St (\ _ -> unSt (prest2state c) s)
normalize :: Prestate s x -> Prestate s x
{-
Here is an immediate definition that goes via State s x.
normalize = state2prest . prest2state
One can also normalize "on-the fly", see below.
-}
normalize c = Get (\ s -> Put (helper (s, c))) -- using getput equation
where
helper :: (s, Prestate s x) -> (s, Prestate s x)
helper (s, Ret x) = (s, Ret x)
helper (s, Get f) = helper (s, f s) -- using putget equation
helper (_, Put (s', c)) = helper (s', c) -- using putput equation
-- no need for f -> get f equation:
-- (proof skeleton)
-- f -> get put get f -> get f
-- no need for get get f -> get f equation:
-- (proof skeleton)
-- get get f -> get put get get f -> get put get f -> get put f <- get f !!
-- Update monads
class Monoid p => RAct s p where
(<+) :: s -> p -> s
newtype Upd s p x = Up (s -> (p, x))
instance Functor (Upd s p) where
fmap g (Up f) = Up (\ s -> let (s', x) = f s in (s', g x))
instance RAct s p => Mnd (Upd s p) where
unit x = Up (\ s -> (mempty, x))
mult (Up f) = Up (\ s -> let (p, Up g) = f s
(p', x) = g (s <+ p)
in (p `mappend` p', x))
-- Ordinary list monad (free monoids monad)
instance Mnd [] where
unit x = [x]
mult xss = concat xss
-- Alternative list monad (free semigroups-with-zero monad)
{-
instance Mnd [] where
unit x = [x]
mult xss | any null xss = []
mult xss | otherwise = concat xss
-}
-- Ordinary nonempty list monad (free semigroups monad)
data NEList x = Sgt x | x :< NEList x
nemap :: (x -> y) -> NEList x -> NEList y
nemap f (Sgt x) = Sgt (f x)
nemap f (x :< xs) = f x :< nemap f xs
neapp :: NEList x -> NEList x -> NEList x
(Sgt x) `neapp` ys = x :< ys
(x :< xs) `neapp` ys = x :< (xs `neapp` ys)
neconcat :: NEList (NEList x) -> NEList x
neconcat (Sgt xs) = xs
neconcat (xs :< xss) = xs `neapp` neconcat xss
instance Functor NEList where
fmap f xs = nemap f xs
instance Mnd NEList where
unit x = Sgt x
mult xss = neconcat xss
-- Intensional nondeterminism
data NDi x = Rt x | NDi x :$ NDi x
instance Functor NDi where
fmap g (Rt x) = Rt (g x)
fmap g (c :$ c') = fmap g c :$ fmap g c'
instance Mnd NDi where
unit x = Rt x
mult (Rt c) = c
mult (cc :$ cc') = mult cc :$ mult cc'
nelist2ndi :: NEList x -> NDi x
nelist2ndi (Sgt x) = unit x -- Rt x
nelist2ndi (x :< xs) = Rt x :$ nelist2ndi xs
ndi2nelist :: NDi x -> NEList x
ndi2nelist (Rt x) = unit x -- Sgt x
ndi2nelist (c :$ c') = ndi2nelist c `neapp` ndi2nelist c'
normalizeNDi :: NDi x -> NDi x
--normalizeNDi = nelist2ndi . ndi2nelist
normalizeNDi (Rt x) = Rt x
normalizeNDi (Rt x :$ c'') = Rt x :$ normalizeNDi c''
normalizeNDi ((c :$ c') :$ c'') = normalizeNDi (c :$ (c' :$ c''))
-- Free functor-algebras monads (free monads)
data Tree f x = Lf x | Nd (f (Tree f x))
instance Functor f => Functor (Tree f) where
fmap f (Lf x) = Lf (f x)
fmap f (Nd ts) = Nd (fmap (fmap f) ts)
instance Functor f => Mnd (Tree f) where
unit x = Lf x
mult (Lf t) = t
mult (Nd tts) = Nd (fmap mult tts)
-- Prestate monads as free monads
data GP s x = Get' (s -> x) | Put' (s, x)
type Prestate' s = Tree (GP s)
-- Continuations monad
newtype Cont r x = Cn ((x -> r) -> r)
instance Functor (Cont r) where
fmap g (Cn f) = Cn (\ k -> f (k . g))
instance Mnd (Cont r) where
unit x = Cn (\ k -> k x)
mult (Cn f) = Cn (\ k -> f (\ (Cn g) -> g k))
-- =====================================================================
-- Identity monad
newtype Id x = I x deriving Show
instance Functor Id where
fmap f (I x) = I (f x)
instance Mnd Id where
unit x = I x
mult (I c) = c
-- Distributive laws
class (Mnd t0, Mnd t1) => Dist t1 t0 where
dist :: t1 (t0 x) -> t0 (t1 x)
-- Compatible compositions of monads
-- (described by distributive laws)
newtype Comp t0 t1 x = C { unC :: (t0 (t1 x)) } deriving Show
instance (Functor t0, Functor t1) => Functor (Comp t0 t1) where
fmap f (C c) = C (fmap (fmap f) c)
instance Dist t1 t0 => Mnd (Comp t0 t1) where
unit x = C (unit (unit x))
mult (C c) = C (mult (fmap (fmap mult . dist . fmap unC) c))
-- Exception monads distribute over any monads
instance Mnd t => Dist (Either e) t where
dist (Left e) = return (Left e)
dist (Right c) = fmap Right c
-- Writer monads distribute over any strong monads
-- (in Hask every functor/monad is strong)
instance (Mnd t, Monoid p) => Dist ((,) p) t where
-- dist :: (p, t x) -> t (p, x)
dist (p, c) = fmap (\ x -> (p, x)) c
-- Writer monads distribute over reader monads in more ways
instance RAct s p => Dist ((,) p) ((->) s) where
-- dist :: (p, s -> x) -> s -> (p, x)
dist (p, f) = \ s -> (p, f (s <+ p))
-- Update monads reconstructed
type Upd' s p = Comp ((->) s) ((,) p)
-- Ordinary nonempty list monad distributes over maybe monad
instance Dist NEList Maybe where
dist (Sgt Nothing) = Nothing
dist (Sgt (Just x)) = Just (Sgt x)
dist (Nothing :< mxs) = Nothing
dist (Just x :< mxs) = case dist mxs of
Nothing -> Nothing
Just xs -> Just (x :< xs)
-- Alternative list monad reconstructed
type List' = Comp Maybe NEList
-- =====================================================================
-- Product of monads
newtype Prod t0 t1 x = P { unP :: (t0 x, t1 x) } deriving Show
instance (Functor t0, Functor t1) => Functor (Prod t0 t1) where
fmap f (P (c0, c1)) = P (fmap f c0, fmap f c1)
instance (Mnd t0, Mnd t1) => Mnd (Prod t0 t1) where
unit x = P (unit x, unit x)
mult (P (c0, c1)) = P (mult (fmap (fst . unP) c0), mult (fmap (snd . unP) c1))
-- The alternative nonempty list monad (with unit not singleton)
-- reconstructed
type NEList' = Prod Id []
-- =====================================================================