Lecture 20 — 2015-11-16

Monads

This lecture is written in literate Haskell; you can download the raw source.

module Lec20 where

import Control.Applicative

import Control.Monad

import Data.Char
import Data.List hiding (group)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe

import Numeric

newtype Parser a = Parser { parse :: String -> Maybe (a,String) }

instance Functor Parser where
  fmap f p = Parser $ \s -> 
    case parse p s of
      Nothing -> Nothing 
      Just (v,s') -> Just (f v,s')

instance Applicative Parser where
  pure a = Parser $ \s -> Just (a,s)
  f <*> a = Parser $ \s -> 
    case parse f s of
      Nothing -> Nothing
      Just (g,s') -> parse (fmap g a) s'
instance Alternative Maybe where
  -- empty :: f a
  empty = Nothing

  -- (<|>) :: f a -> f a -> f a
  Just x <|> _ = Just x
  Nothing <|> r = r
  
  -- empty <|> f == f
  -- f <|> empty == f
instance Alternative Parser where
  empty = Parser $ \s -> empty
  l <|> r = Parser $ \s -> parse l s <|> parse r s
  
  some p = (:) <$> p <*> many p
  many p = some p <|> pure []

satisfy :: (Char -> Bool) -> Parser Char
satisfy p = Parser f
  where f [] = Nothing
        f (c:s) = if p c then Just (c,s) else Nothing

ensure :: (a -> Bool) -> Parser a -> Parser a
ensure pred p = Parser f 
  where f s = case parse p s of
          Just (a,s') | pred a -> Just (a,s')
          _ -> Nothing

lookahead :: Parser (Maybe Char)
lookahead = Parser f
  where f [] = Just (Nothing,[])
        f (c:s) = Just (Just c,c:s)

-- those three are the basis

spaces :: Parser ()
spaces = pure () <* many (satisfy isSpace)

char :: Char -> Parser Char
char c = spaces *> satisfy (==c)

str :: String -> Parser String
str s = spaces *> (sequenceA $ map (satisfy . (==)) s)

int :: Parser Int
int = read <$> some (satisfy isDigit)

opt :: Alternative f => f a -> f (Maybe a)
opt f = (Just <$> f) <|> (pure Nothing)

eof :: Parser ()
eof = pure () <* ensure isNothing lookahead

We were able to quickly and easily add negation/minus to our language…

data Arith = 
  Num Int | 
  Plus Arith Arith | 
  Times Arith Arith |
  Neg Arith deriving Show

term :: Parser Arith
term = liftA2 Plus (factor <* char '+') term 
       <|> liftA2 (\a b -> Plus a (Neg b)) (factor <* char '-') term
       <|> factor

factor :: Parser Arith
factor = liftA2 Times (neg <* char '*') factor <|> neg

neg :: Parser Arith
neg = Neg <$> (char '-' *> atom) <|> atom

atom :: Parser Arith
atom = num <|> char '(' *> term <* char ')'

num :: Parser Arith
num = spaces *> (Num <$> int)

We can come up with a Read instance using our parsers.

readS :: Parser a -> ReadS a
readS (Parser p) s = maybeToList $ p s

instance Read Arith where
  readsPrec _ = readS term

We didn’t see it in class, but here’s an equivalent definition for Applicative.

class Functor f => Monoidal f where
  unit :: f ()
  (***) :: f a -> f b -> f (a,b)

u :: Applicative f => f ()
u = pure ()

prod :: Applicative f => f a -> f b -> f (a,b)
prod a b = (,) <$> a <*> b

p :: Monoidal f => a -> f a
p x = const x <$> unit

appl :: Monoidal f => f (a -> b) -> f a -> f b
appl f a = uncurry ($) <$> f *** a

Why is it called Monoidal? It’s because it behaves like a monoid:

class Monoid a where
  mempty :: a
  mappend :: a -> a -> a
  mconcat :: [a] -> a

Finally, note that we can define fmap from (<*>).

fmapFromAp :: Applicative f => (a -> b) -> f a -> f b
fmapFromAp f fa = pure f <*> fa
-- try to write a parser for the language
--
-- (int |list of ints of length of first int|)+

groupEg = "4 15 16 17 18 1 19 0 0 5 20 21 22 23 24"

group' :: Parser (Parser [Int])
group' = (\n -> sequenceA $ replicate n int) <$> int

Drat, it has the wrong type! We need something like:

joinUp :: Monad f => f (f a) -> f a

We looked at a related type: (>>=), pronounced “bind”, has type f a -> (a -> f b) -> f b.

joinUp = (>>= id)

Monads 

class Applicative m => Monad m where
  return :: a -> m a -- same as pure!
  (>>=) :: m a -> (a -> m b) -> m b

Note that we can define ap a/k/a (<*>) in terms of >>=:

fakeAp :: Monad f => f (a -> b) -> f a -> f b
fakeAp fab fa = 
  fab >>= \f -> 
  fa >>= \a ->
  return $ f a

Ditto fmap a/k/a (<$>):

fakeFmap :: Monad f => (a -> b) -> f a -> f b
fakeFmap f fa = 
  fa >>= \a ->
  return $ f a

What’s it look like for Maybe? Here’s its cousin, CouldBe:

data CouldBe a = Nope | Yep a deriving Show

instance Functor CouldBe where
  fmap f Nope = Nope
  fmap f (Yep a) = Yep $ f a
  
instance Applicative CouldBe where
  pure = Yep
  
  Nope <*> _ = Nope
  _ <*> Nope = Nope
  (Yep f) <*> (Yep x) = Yep $ f x

instance Monad CouldBe where
  return = pure
  
  Nope    >>= f = Nope
  (Yep x) >>= f = f x

name :: Maybe String -> Maybe String -> Maybe String
name given family = 
  given >>= \first ->
  if first `elem` ["Prince","Madonna"]
  then return $ first
  else 
    family >>= \last ->
    return $ first ++ " " ++ last

drdave = name (Just "Dave") (Just "Kauchak")

prince = name (Just "Prince") Nothing

We used the Maybe monad to write a simple typechecker. It saved us tons of boilerplat.

type Id = String

data Expr =
    EVar Id
  | ETrue
  | EFalse
  | EIf Expr Expr Expr
  | ENum Int
  | EIncr Expr
  | EDecr Expr
  | EIsZero Expr
  | EApp Expr Expr
  | ELam Id Type Expr
  deriving (Show, Eq)

data Type =
    TyBool
  | TyNum
  | TyArrow Type Type
  deriving (Show, Eq)

type Context = Map Id Type

sameType :: Type -> Type -> Maybe a -> Maybe a
sameType t1 t2 a | t1 == t2 = a
sameType _ _ _ = Nothing

typeCheck :: Context -> Expr -> Maybe Type
typeCheck ctx (EVar id) = Map.lookup id ctx
typeCheck ctx ETrue = return TyBool
typeCheck ctx EFalse = return TyBool
typeCheck ctx (EIf e1 e2 e3) =
  typeCheck ctx e1 >>= \t1 ->
  sameType t1 TyBool $
    typeCheck ctx e2 >>= \t2 ->
    typeCheck ctx e3 >>= \t3 ->
    sameType t2 t3 $ return t2
typeCheck ctx (ENum n) = return TyNum
typeCheck ctx (EIncr e) =
  typeCheck ctx e >>= \t ->
  sameType t TyNum $ return TyNum
typeCheck ctx (EDecr e) =
  typeCheck ctx e >>= \t ->
  sameType t TyNum $ return TyNum
typeCheck ctx (EIsZero e) =
  typeCheck ctx e >>= \t ->
  sameType t TyNum $ return TyBool
typeCheck ctx (EApp e1 e2) =
  typeCheck ctx e1 >>= \t ->
  typeCheck ctx e2 >>= \t1' ->
  case t of
    TyArrow t1 t2 -> sameType t1 t1' $ return t2
    _ -> Nothing
typeCheck ctx (ELam x t1 e) =
  typeCheck (Map.insert x t1 ctx) e >>= \t2 ->
  return $ TyArrow t1 t2

I also pointed out that we could have written:

    typeCheck ... >>= return . TyArrow t1

To be sure, we can now write the grouped language example from above.

instance Monad Parser where
  return = pure
  
  p >>= f = Parser $ \s ->
    case parse p s of
      Nothing -> Nothing
      Just (v,s') -> parse (f v) s'
group :: Parser [Int]
group =  
  (spaces *> int) >>= \n ->
  sequenceA $ replicate n (spaces *> int)

groups = some group