Yet Another Haskell Tutorial/Monads/Solutions

Common Monads

The first law is: return a >>= f ≡ f a. In the case of Maybe, we get:

     return a >>= f
==>  Just a   >>= \x -> f x
==>  (\x -> f x) a
==>  f a

The second law is: f >>= return ≡ f. Here, we get:

     f >>= return
==>  f >>= \x -> return x
==>  f >>= \x -> Just x

At this point, there are two cases depending on whether f is Nothing or not. In the first case, we get:

==>  Nothing >>= \x -> Just x
==>  Nothing
==>  f

In the second case, f is Just a. Then, we get:

==>  Just a >>= \x -> Just x
==>  (\x -> Just x) a
==>  Just a
==>  f

And the second law is shown. The third law states: f >>= (\x -> g x >>= h) ≡ (f >>= g) >>= h.

If f is Nothing, then the left-hand-side clearly reduces to Nothing. The right-hand-side reduces to Nothing >>= h which in turn reduces to Nothing, so they are the same.

Suppose f is Just a. Then the LHS reduces to g a >>= h and the RHS reduces to (Just a >>= \x -> g x) >>= h which in turn reduces to g a >>= h, so these two are the same.

The idea is that we wish to use the Left constructor to represent errors on the Right constructor to represent successes. This leads to an instance declaration like:

instance Monad (Either String) where
    return x      = Right x
    Left  s >>= _ = Left s
    Right x >>= f = f x
    fail  s       = Left s

If we try to use this monad to do search, we get:

Example:

Monads> searchAll gr 0 3 :: Either String [Int]
Right [0,1,3]
Monads> searchAll gr 3 0 :: Either String [Int]
Left "no path"

which is exactly what we want.

MonadPlus

The order to mplus essentially determins the search order. When the recursive call to searchAll2 comes first, we are doing depth-first search. When the recursive call to search' comes first, we are doing breadth-first search. Thus, using the list monad, we expect the solutions to come in the other order:

Example:

MPlus> searchAll3 gr 0 3 :: [[Int]]
[[0,2,3],[0,1,3]]

Just as we expected.

Monad Transformers

This is a very difficult problem; if you found that you were stuck immediately, please just read as much of this solution as you need to try it yourself.

First, we need to define a list transformer monad. This looks like:

newtype ListT m e = ListT { unListT :: m [e] }

The ListT constructor simply wraps a monadic action (in monad m) which returns a list.

We now need to make this a monad:

instance Monad m => Monad (ListT m) where
    return x = ListT (return [x])
    fail   s = ListT (return [] )
    ListT m >>= k = ListT $ do
      l  <- m
      l' <- mapM (unListT . k) l
      return (concat l')

Here, success is designated by a monadic action which returns a singleton list. Failure (like in the standard list monad) is represented by an empty list: of course, it's actually an empty list returned from the enclosed monad. Binding happens essentially by running the action which will result in a list l. This has type [e]. We now need to apply k to each of these elements (which will result in something of type ListT m [e2]. We need to get rid of the ListTs around this (by using unListT) and then concatenate them to make a single list.

Now, we need to make it an instance of MonadPlus

instance Monad m => MonadPlus (ListT m) where
    mzero = ListT (return [])
    ListT m1 `mplus` ListT m2 = ListT $ do
      l1 <- m1
      l2 <- m2
      return (l1 ++ l2)

Here, the zero element is a monadic action which returns an empty list. Addition is done by executing both actions and then concatenating the results.

Finally, we need to make it an instance of MonadTrans:

instance MonadTrans ListT where
    lift x = ListT (do a <- x; return [a])

Lifting an action into ListT simply involves running it and getting the value (in this case, a) out and then returning the singleton list.

Once we have all this together, writing searchAll6 is fairly straightforward:

searchAll6 g@(Graph vl el) src dst
    | src == dst = do
      lift $ putStrLn $
        "Exploring " ++ show src ++ " -> " ++ show dst
      return [src]
    | otherwise  = do
      lift $ putStrLn $
        "Exploring " ++ show src ++ " -> " ++ show dst
      search' el
  where
    search' [] = mzero
    search' ((u,v,_):es)
        | src == u  =
          (do path <- searchAll6 g v dst
              return (u:path)) `mplus`
          search' es
        | otherwise = search' es

The only change (besides changing the recursive call to call searchAll6 instead of searchAll2) here is that we call putStrLn with appropriate arguments, lifted into the monad.

If we look at the type of searchAll6, we see that the result (i.e., after applying a graph and two ints) has type MonadTrans t, MonadPlus (t IO) => t IO [Int]). In theory, we could use this with any appropriate monad transformer; in our case, we want to use ListT. Thus, we can run this by:

Example:

MTrans> unListT (searchAll6 gr 0 3)
Exploring 0 -> 3
Exploring 1 -> 3
Exploring 3 -> 3
Exploring 2 -> 3
Exploring 3 -> 3
MTrans> it
[[0,1,3],[0,2,3]]

This is precisely what we were looking for. This exercise is actually simpler than the previous one. All we need to do is incorporate the calls to putT and getT into searchAll6 and add an extra lift to the IO calls. This extra lift is required because now we're stacking two transformers on top of IO instead of just one.

searchAll7 g@(Graph vl el) src dst
    | src == dst = do
      lift $ lift $ putStrLn $
        "Exploring " ++ show src ++ " -> " ++ show dst
      visited <- getT
      putT (src:visited)
      return [src]
    | otherwise  = do
      lift $ lift $ putStrLn $
        "Exploring " ++ show src ++ " -> " ++ show dst
      visited <- getT
      putT (src:visited)
      if src `elem` visited
        then mzero
        else search' el
  where
    search' [] = mzero
    search' ((u,v,_):es)
        | src == u  =
          (do path <- searchAll7 g v dst
              return (u:path)) `mplus`
          search' es
        | otherwise = search' es

The type of this has grown significantly. After applying the graph and two ints, this has type Monad (t IO), MonadTrans t, MonadPlus (StateT [Int] (t IO)) => StateT [Int] (t IO) [Int].

Essentially this means that we've got something that's a state transformer wrapped on top of some other arbitrary transformer (t) which itself sits on top of IO. In our case, t is going to be ListT. Thus, we run this beast by saying:

Example:

MTrans> unListT (evalStateT (searchAll7 gr4 0 3) [])
Exploring 0 -> 3
Exploring 1 -> 3
Exploring 3 -> 3
Exploring 0 -> 3
Exploring 2 -> 3
Exploring 3 -> 3
MTrans> it
[[0,1,3],[0,2,3]]

And it works, even on gr4.

Parsing Monads

A Simple Parsing Monad

First we write a function spaces which will parse out whitespaces:

spaces :: Parser ()
spaces = many (matchChar isSpace) >> return ()

Now, using this, we simply sprinkle calls to spaces through intList to get intListSpace:

intListSpace :: Parser [Int]
intListSpace = do
  char '['
  spaces
  intList' `mplus` (char ']' >> return [])
    where intList' = do
            i <- int
            spaces
            r <- (char ',' >> spaces >> intList')
                 `mplus`
                 (char ']' >> return [])
            return (i:r)

We can test that this works:

Example:

Parsing> runParser intListSpace "[1 ,2 , 4  \n\n ,5\n]"
Right ("",[1,2,4,5])
Parsing> runParser intListSpace "[1 ,2 , 4  \n\n ,a\n]"
Left "expecting char, got 'a'"

=== Parsec ===

We do this by replacing the state functions with push and pop functions as follows:

parseValueLet2 :: CharParser (FiniteMap Char [Int]) Int
parseValueLet2 = choice
  [ int
  , do string "let "
       c <- letter
       char '='
       e <- parseValueLet2
       string " in "
       pushBinding c e
       v <- parseValueLet2
       popBinding c
       return v
  , do c  <- letter
       fm <- getState
       case lookupFM fm c of
         Nothing    -> unexpected ("variable " ++
                                   show c ++
                                   " unbound")
         Just (i:_) -> return i
  , between (char '(') (char ')') $ do
      e1 <- parseValueLet2
      op <- oneOf "+*"
      e2 <- parseValueLet2
      case op of
        '+' -> return (e1 + e2)
        '*' -> return (e1 * e2)
  ]
  where
    pushBinding c v = do
      fm <- getState
      case lookupFM fm c of
        Nothing -> setState (addToFM fm c [v])
        Just  l -> setState (addToFM fm c (v:l))
    popBinding c = do
      fm <- getState
      case lookupFM fm c of
        Just [_]   -> setState (delFromFM fm c)
        Just (_:l) -> setState (addToFM fm c l)

The primary difference here is that instead of calling updateState, we use two local functions, pushBinding and popBinding. The pushBinding function takes a variable name and a value and adds the value onto the head of the list pointed to in the state FiniteMap. The popBinding function looks at the value and if there is only one element on the stack, it completely removes the stack from the FiniteMap; otherwise it just removes the first element. This means that if something is in the FiniteMap, the stack is never empty.

This enables us to modify only slightly the usage case; this time, we simply take the top element off the stack when we need to inspect the value of a variable.

We can test that this works:

Example:

ParsecI> runParser parseValueLet2 emptyFM "stdin"
               "((let x=2 in 3+4)*x)"
Left "stdin" (line 1, column 20):
unexpected variable 'x' unbound