# Lecture 20 — 2015-11-16

``````module Lec20 where

import Control.Applicative

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

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

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)``

``````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

return = pure

Nope    >>= f = Nope
(Yep x) >>= f = f x

name :: Maybe String -> Maybe String -> Maybe String
name given family =
given >>= \first ->
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``````