work-site/content/courses/h4life/h4life-monads.hs

{- monads.hs

This file contains the examples on monads to be shown in the third
class of the course "Haskell for Life", by Sergiu Ivanov
(sivanov@lacl.fr):

  http://lacl.fr/~sivanov/doku.php?id=en:haskell_for_life

This file is meant to be read sequentially.

This file is distributed under the Creative Commons Attribution Alone
licence.-}

-- This line imports the (<>) operator from the module 'Data,Monoid'
-- (we will need faaar below for the MyWriter monad).
import Data.Monoid((<>))

-- | We will cheat and use these meaningless type synonyms.
type Person = String
type Car = String

personByName :: String -> Maybe Person
personByName p = Just p

carByPerson :: Person -> Maybe Car
carByPerson p = Just (p ++ "'s car")

model :: Car -> Maybe String
model c = Just ("model of " ++ c)

modelFromName :: String -> Maybe String
modelFromName name = do
  person <- personByName name
  car <- carByPerson person
  model car



{- In this section we will reconstruct the Maybe monad.-}

data Perhaps a = Only a | Nope
               deriving Show

instance Monad Perhaps where
  -- | return :: a -> Perhaps a
  --
  -- This implementation is quite natural: we just put the value we
  -- get inside an instance of 'Perhaps', and we cannot actually
  -- implement it differently.  Indeed, since we don't know anything
  -- about the type 'a', we cannot construct values of that type, nor
  -- can we transform them.
  --
  -- ATTENTION! 'return' does not abort execution of any block of code
  -- (as in some other languages)!  It's just a function called
  -- "return".
  return x = Only x

  -- | (>>=) :: Perhaps a -> (a -> Perhaps b) -> Perhaps b
  Nope     >>= f = Nope
  (Only x) >>= f = f x

-- | If you try to compile the file now, GHC will complain that there
-- is no instance for 'Applicative Perhaps'; that instance is required
-- by the definition of 'Monad'.  Let's try defining one, just looking
-- at the types of the functions.
instance Applicative Perhaps where
  -- | pure :: a -> Perhaps
  --
  -- Wait a second, that's the type of return!
  pure = return

  -- | (<*>) :: Perhaps (a -> b) -> Perhaps a -> Perhaps b
  --
  -- OK, so we have a function (perhaps), and we need to apply to
  -- (perhaps) a value and then return the result (perhaps).  Let's do
  -- that.
  --
  -- Note that we don't use the fact that we work with Perhaps, since
  -- only the definitions coming from our instance of 'Monad' are
  -- enough.  This means that we will be able to copy this definition
  -- as-is for the other monads we will construct.
  u <*> v = do -- This means we do our stuff within a monad.
    f <- u -- Extract the function.
    x <- v -- Extract the value.
    return (f x) -- Feed the value to the function and pack the
                 -- result.

-- | Oh noes, we still cannot compile this code: no instance for
-- 'Functor Perhaps'.  Well, 'Functor' seems easy enough.
instance Functor Perhaps where
  -- | fmap :: (a -> b) -> Perhaps a -> Perhaps
  --
  -- Hey, that's simple enough!
  --
  --   fmap f Nope = Nope
  --   fmap f (Only x) = Only (f x)
  --
  -- This code is specific to 'Perhaps', however.  We could perhaps
  -- (pun intended) re-use our definition of 'Monad' once again:
  --
  --   fmap f v = do
  --     x <- v  -- Unpack 'v'.
  --     return (f x)  -- Feed 'x' to f and pack back the result.
  --
  -- Yet, we will use the following cool definition based on the
  -- definition from the instance of 'Applicative'.  It's more compact
  -- and is nice and simple exercise in Haskell types.
  fmap f x = pure f <*> x

-- Let's check now that our 'Perhaps' is similar to 'Maybe', as we
-- wanted.
personByName' :: String -> Perhaps Person
personByName' p = Only p

carByPerson' :: Person -> Perhaps Car
carByPerson' p = Only (p ++ "'s car")

model' :: Car -> Perhaps String
model' c = Only ("model of " ++ c)

modelFromName' :: String -> Perhaps String
modelFromName' name = do
  person <- personByName' name
  car <- carByPerson' person
  model' car



{- In this section we will reconstruct the list monad.-}

data List a = Cons a (List a) | Nil
            deriving Show

-- | Concatenates two 'List's.
concat2 :: List a -> List a  -> List a
concat2 Nil ys = ys
concat2 (Cons x xs) ys = Cons x (concat2 xs ys)

-- | Concatenates a 'List' of 'Lists'.
--
-- Example:
-- concatLists ( Cons (Cons 1 Nil) (Cons (Cons 2 Nil) Nil) ) == Cons 1 (Cons 2 Nil)
concatLists :: List (List a) -> List a
concatLists xs = concatAll xs Nil
  where concatAll (Cons x xs) res = concatAll xs (concat2 res x)
        concatAll Nil res = res

-- | Applies the function to all elements of the list and returns the
-- list of results.
mapList :: (a -> b) -> List a -> List b
mapList _ Nil = Nil
mapList f (Cons x xs) = Cons (f x) (mapList f xs)

instance Monad List where
  -- | return :: a -> List a
  --
  -- Create a singleton list out of 'x', just like in the case of
  -- 'Maybe'.
  return x = Cons x Nil

  -- (>>=) :: List a -> (a -> List b) -> List b
  --
  -- So, we should probably feed the values from 'List a' into the
  -- function 'a -> List b' one by one (we don't really have any other
  -- choice).  Then we are going to get a bunch of 'List b'; we should
  -- probably concatenate them to get one single big 'List b'.
  x >>= f = concatLists (mapList f x)

-- | And for our 'Applicative' and 'Functor' instances we'll just
-- reuse the code we wrote for 'Perhaps'.
instance Applicative List where
  pure = return
  u <*> v = do
    f <- u
    x <- v
    return (f x)

instance Functor List where
  fmap f x = pure f <*> x

-- | Now let's see what kind of tricks one can do in the list monad.
-- We will use Haskell's built-in '[]' for convenience, but exactly
-- the same things can be done in `List'.

-- | Compute the Cartesian product of two lists.
--
-- We "unpack" first 'xs', then 'ys', and put the obtained 'x' and 'y'
-- together.  Note that the bind operator '(>>=)' in the list monad
-- means that the lambda functions are applied to every element in
-- 'xs' and 'ys'.  In other words, '(>>=)' is a kind of a foreach
-- loop.
cartesian :: [a] -> [b] -> [(a,b)]
cartesian xs ys = xs >>=
                  (\x -> ys >>=
                         (\y -> return (x,y)))

-- | Now, let's rewrite the same function using the do notation.  In
-- this case, every "unpacking" (<-) means a loop over all elements of
-- the list.  Thus, we loop over all elements of 'xs'; then, for each
-- such element, we loop over 'ys' and produce a pair '(x,y)' at each
-- iteration.
cartesian' :: [a] -> [b] -> [(a,b)]
cartesian' xs ys = do
  x <- xs
  y <- ys
  return (x,y)


-- | Return a list of elements for which the given function returns
-- 'True'.
--
-- Note that we do not use return; instead we produce the singleton
-- list '[x]' directly.  We need that to be able to write '[]' when
-- 'x' does satisfy the property.
myFilter :: (a -> Bool) -> [a] -> [a]
myFilter f xs = do
  x <- xs
  if f x then [x] else []



{- In this section we will reconstruct a simplified version of the
State monad.-}

-- | Our simplified state monad.
data MyState s a = MyState (s -> (a, s))

-- | This is just a getter for the only field of 'MyState'.
runState :: MyState s a -> (s -> (a, s))
runState (MyState f) s = f s

{- In the case of the 'Maybe' ('Perhaps') monad, we wanted to deal
with functions returning 'Maybe a'.  In the case of state, we want to
deal with functions which get state as an argument and which return
their result _and also_ the new state.  Thus, the functions we work
with have types of the form

  'arg1 -> ... -> argn -> state -> (result, state)'.

Since the bind operator (>>=) will have to pass the state from one
function to another one, we cannot just define

  data MyState s a = MyState (a, s)

If we did that, the bind operator (>>=) would have no way of passing
the state to the next function.  With our definition of 'MyState' as
containing a field of a function type, we will be able to pass around
the state.

The next issue is that 'Monad' can only work with types having one
parameter, while 'MyState' has two.  This means that we will have to
fix one of them.  If we fix the parameter 'a' (which is the result of
computation), then bind (>>=) should be able to put together two
functions returning the same result, but using states of different
type, which is not what we want.  Therefore, we are going to fix 's',
the type of the state.-}

instance Monad (MyState s) where
  -- | return :: a -> MyState s a
  --   return :: a -> (s -> (a, s))
  --
  -- We don't want 'return' to tinker with the state; it should just
  -- put our value into the monad, nothing more.  So, it will return a
  -- function taking the state and returning a tuple containing 'x'
  -- and _the same_ state.
  return x = MyState (\s -> (x, s))

  -- | (>>=) :: MyState s a -> (a -> MyState s b) -> MyState s b
  --
  -- Now, that's a more difficult type.  Without going too much into
  -- details, let's keep in mind that we want to get the result out of
  -- 'MyState s a' and put it into the function which is the second
  -- argument.  Now, how do we get the result ('a') out of 'MyState s
  -- a'?  'MyState s a' is the same thing as 's -> (a,s)', so we could
  -- get an 'a' if we had an 's', which we don't seem to have...
  --
  -- But wait a little!  We are supposed to return 'MyState s b',
  -- which is actually 's -> (b,s)'; that is, we are supposed to
  -- return a function!  And inside this function, we can haz access
  -- to an instance of 's' which we can use to run the first argument
  -- ('MyState s a') and get our instance of 'a' to feed into the
  -- second argument.
  --
  -- And yes, a let declaration is just a local binding of values,
  -- like:
  --
  --   let x = 2
  --       y = 3
  --   in x + y
  --
  -- We can also use pattern matching in let bindings (just like in
  -- GHCi).
  x >>= f = MyState (\s ->
                      -- Run 'x' and get the tuple (result,state) in runState (f a) s'
                      let (a,s') = runState x s
                      -- Apply 'f' to 'a', and then run the resulting
                      -- state with 's'.
                      in runState (f a) s')

-- | Again, a small copy-and-paste work to get our 'Applicative' and
-- 'Functor' instances in place.
instance Applicative (MyState s) where
  pure = return
  u <*> v = do
    f <- u
    x <- v
    return (f x)

instance Functor (MyState s) where
  fmap f x = pure f <*> x

-- | Oh, before we get to write any functions using our 'MyState'
-- monad, we have to provide a way to access our state.

-- | Returns the current state.
--
-- Remember that unpacking (<-) in a State monad means getting the
-- first element of the tuple returned by any function in this monad.
-- Thus, the only thing 'myGet' needs to do is put the state it gets
-- as an argument into the first component of the tuple.
myGet :: MyState s s
myGet = MyState (\s -> (s, s))

-- | Sets the current state.
--
-- 'myPut' only changes the state and does not return anything
-- meaningful; we therefore make it put the empty tuple '()' (unit)
-- into the first component of the returned tuple, and we put the new
-- state into the second component of the returned tuple.
myPut :: s -> MyState s ()
myPut s' = MyState (\_ -> ((), s'))

{- We can now use MyState to implement a small database of cars and
people.-}
data CarsPeopleDB = CarsPeopleDB [Car] [Person]
                  deriving Show

cars :: CarsPeopleDB -> [Car]
cars (CarsPeopleDB c _) = c

people :: CarsPeopleDB -> [Person]
people (CarsPeopleDB _ p) = p

-- | This function adds a car to the database.
--
-- This function can access the database because it is in the
-- 'MyState' monad (it returns the type 'MyState <bla bla>').  It just
-- adds a car and returns nothing, that's why the '()'.
addCar :: Car -> MyState CarsPeopleDB ()
addCar c = do
  db <- myGet  -- Get the database.

  let cs = cars db  -- Get the list of cars.
      ps = people db  -- Get the list of people.

  let db' = (CarsPeopleDB (c:cs) ps)  -- Build the new database.

  myPut db'  -- Save the new database.

-- | Adds a person to the database.
--
-- Does the same thing as 'addCar', but is written more concisely.
addPerson :: Person -> MyState CarsPeopleDB ()
addPerson p = do
  (CarsPeopleDB cs ps) <- myGet
  myPut (CarsPeopleDB cs (p:ps))

-- | Checks whether a car is in the database.
--
-- Now, besides producing the new state, this function should also
-- tell us whether the car is in the database or not.  That is why the
-- second argument to 'MyState' is 'Bool' — it's the answer of the
-- function.
carKnown :: Car -> MyState CarsPeopleDB Bool
carKnown c = do
  (CarsPeopleDB cs _) <- myGet
  return (elem c cs) -- Pack the result of checking whether 'c' is an
                     -- element of 'cs'.

-- | Checks whether a person is in the database.
personKnown :: Person -> MyState CarsPeopleDB Bool
personKnown p = do
  (CarsPeopleDB _ ps) <- myGet
  return (elem p ps)


-- | And now we can use our functions to build a real (c) (hehe)
-- database of car and people!
testCarsPeopleDB :: CarsPeopleDB
testCarsPeopleDB = let (res, db) = runState buildDB (CarsPeopleDB [] [])
                   in db
  where buildDB = do
          addPerson "John"
          addPerson "Mary"
          addCar "Mercedes"
          addCar "Renault"

          johnKnown <- personKnown "John"
          if not johnKnown
            then addPerson "Bruce"
            else return () -- We have to do something in the else
                           -- branch as well, so let's just pack an
                           -- empty tuple.



{- In this section we will define a simplified version of the Reader
monad.-}

-- | The Reader monad is essentially the read-only State monad.  Since
-- the state never changes, we do not need to deal with functions of
-- the form 's -> (a,s)', but only 's -> a' (there is no new state, it
-- is always the same).
--
-- We will use the so-called "record syntax" to define the accessor
-- for the single field of MyReader.  It is really a syntactic sugar
-- for
--
--   data MyReader s a = MyReader (s -> a)
--   runReader :: MyReader s a -> (s -> a)
--   runReader (MyReader f) = f
data MyReader s a = MyReader { runReader :: s -> a
                             }

-- | The 'Monad' instance for 'MyReader' is defined in _exactly_ the
-- same way as for 'MyState'.
instance Monad (MyReader s) where
  return x = MyReader (\s -> x)

  -- | This time we don't have to deal with the new state, so things
  -- are simpler.  We first run 'x' with the state 's'; it returns an
  -- instance of 'a'.  Then we feed this result to 'f', and then run
  -- the resulting reader with the same state 's'.
  x >>= f = MyReader (\s -> runReader (f (runReader x s)) s )

-- | Again, some copy and paste.
instance Applicative (MyReader s) where
  pure = return
  u <*> v = do
    f <- u
    x <- v
    return (f x)

instance Functor (MyReader s) where
  fmap f x = pure f <*> x

-- | And a small function to tell us our read-only state.  (It's
-- exactly like 'myGet', but is called differently).
myAsk :: MyReader s s
myAsk = MyReader (\s -> s)
-- myAsk = MyReader id

{- And here's a very simple and stupid example.  We will write
functions generating various greetings for a name, which will be
obtained from the reader monad-}

hello :: MyReader Person String
hello = do
  name <- myAsk
  return $ "Hello " ++ name ++ "!" -- The $ is just a shortcut for not
                                   -- writing parentheses.
-- return ("Hello " ++ name ++ "!")

howdy :: MyReader Person String
howdy = do
  name <- myAsk
  return $ "Howdy " ++ name ++ "!"

goodMorning :: MyReader Person String
goodMorning = do
  name <- myAsk
  return $ "Good morning " ++ name ++ "!"

-- This function produces all possible (hehe) greetings for the given
-- name.
--
-- Mind the pointfree style!  The function may actually be written as
--
--   greetings name = runReader mkGreetings name
--
greetings :: String -> [String]
greetings = runReader mkGreetings
  where mkGreetings = do
          hl <- hello
          hw <- howdy
          gm <- goodMorning
          return [hl,hw,gm]



{- In this section we will define a simplified version of the Writer
monad.-}

-- | The Writer monad is essentially a write-only State monad.  Since
-- the functions in this monad do not need to access the state, the
-- type of the Writer monad is really really simple: just a tuple.
--
-- (Mind the record syntax.)
data MyWriter s a = MyWriter { runWriter :: (a,s) }

-- | There's a catch however: we're not really interested in a
-- write-only state: this would mean that we always get the state set
-- by the last function.  That is why in the Writer monad the state is
-- actually an accumulator and, instead of changing it directly, the
-- functions in this monad append stuff to it.  Therefore, the Writer
-- monad is the logger monad.
--
-- What we have just said means that we require some special
-- properties of 's' (some special structure): we should be able to
-- put together (append, concatenate) to values of type 's', like
-- lists or with strings.  This property is described by the typeclass
-- 'Monoid'; types belonging to this typeclass have the function
-- 'mappend' (or '<>', which is the same thing) which can append two
-- values, and also the function 'mempty', returning the "empty"
-- element (like the empty list or the empty string).
instance (Monoid s) => Monad (MyWriter s) where
  -- | This where the 'mempty' function for the type 's' comes in handy:
  -- return "packs" the value "x" together with an empty log.
  return x = MyWriter (x,mempty)

  -- | We have to take the result out of 'x' and feed it into 'f', and
  -- then put together the logs of the two.
  x >>= f = let (r, w ) = runWriter $ x
                (r',w') = runWriter $ f r
            in MyWriter (r', w <> w')

-- | Some more instances...
instance (Monoid s) => Applicative (MyWriter s) where
  pure = return
  u <*> v = do
    f <- u
    x <- v
    return $ f x

instance (Monoid s) => Functor (MyWriter s) where
  fmap f x = pure f <*> x

-- | ... and a small function appending something to the log.
myTell :: Monoid s => s -> MyWriter s ()
myTell x = MyWriter ((), x)

{- And now it's time for an eccentric example!  Let's make a weirdly
verbose calculator.-}

-- | The following functions carry out some operations, but also log
-- what they do to the Writer monad.
myAdd :: Double -> Double -> MyWriter [String] Double
myAdd x y = do
  myTell $ [show x ++ "+" ++ show y]
  return $ x + y

mySub :: Double -> Double -> MyWriter [String] Double
mySub x y = do
  myTell $ [show x ++ "-" ++ show y]
  return $ x - y

myMul :: Double -> Double -> MyWriter [String] Double
myMul x y = do
  myTell $ [show x ++ "*" ++ show y]
  return $ x * y

myDiv :: Double -> Double -> MyWriter [String] Double
myDiv x y = do
  myTell $ [show x ++ "/" ++ show y]
  return $ x / y

-- | Let's test our calculator.
testCalc :: (Double, [String])
testCalc = runWriter $ do
  let x = 2
  y <- myMul x 2
  z <- mySub y 3
  t <- myDiv y 10
  a <- myAdd z t
  return a