Complete exercises for Reader and State chapters
It's beautiful how State is just Reader that returns a tuple of (a, r) instead of just a, allowing you to modify the environment (i.e. state). ```haskell newtype Reader r a = Reader { runReader :: r -> a } newtype State s a = State { runState :: s -> (a, s) } ```
This commit is contained in:
parent
c4fe3c92c7
commit
ee1aeee5f8
2 changed files with 242 additions and 0 deletions
149
scratch/haskell-programming-from-first-principles/reader.hs
Normal file
149
scratch/haskell-programming-from-first-principles/reader.hs
Normal file
|
@ -0,0 +1,149 @@
|
||||||
|
module Reader where
|
||||||
|
|
||||||
|
import Data.Char
|
||||||
|
import Data.Function ((&))
|
||||||
|
import Data.Functor ((<&>))
|
||||||
|
import qualified Control.Applicative as A
|
||||||
|
import qualified Data.Maybe as MB
|
||||||
|
|
||||||
|
cap :: String -> String
|
||||||
|
cap xs = xs <&> toUpper
|
||||||
|
|
||||||
|
rev :: String -> String
|
||||||
|
rev = reverse
|
||||||
|
|
||||||
|
compose :: String -> String
|
||||||
|
compose xs = xs & rev . cap
|
||||||
|
|
||||||
|
fmapped :: String -> String
|
||||||
|
fmapped xs = xs & rev <$> cap
|
||||||
|
|
||||||
|
tupled :: String -> (String, String)
|
||||||
|
tupled xs = A.liftA2 (,) cap rev $ xs
|
||||||
|
|
||||||
|
tupled' :: String -> (String, String)
|
||||||
|
tupled' = do
|
||||||
|
capResult <- cap
|
||||||
|
revResult <- rev
|
||||||
|
pure (revResult, capResult)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
newtype Reader r a = Reader { runReader :: r -> a }
|
||||||
|
|
||||||
|
ask :: Reader a a
|
||||||
|
ask = Reader id
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
newtype HumanName = HumanName String
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
newtype DogName = DogName String
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
newtype Address = Address String
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data Person
|
||||||
|
= Person
|
||||||
|
{ humanName :: HumanName
|
||||||
|
, dogName :: DogName
|
||||||
|
, address :: Address
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
data Dog
|
||||||
|
= Dog
|
||||||
|
{ dogsName :: DogName
|
||||||
|
, dogsAddress :: Address
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
pers :: Person
|
||||||
|
pers =
|
||||||
|
Person (HumanName "Big Bird")
|
||||||
|
(DogName "Barkley")
|
||||||
|
(Address "Sesame Street")
|
||||||
|
|
||||||
|
chris :: Person
|
||||||
|
chris =
|
||||||
|
Person (HumanName "Chris Allen")
|
||||||
|
(DogName "Papu")
|
||||||
|
(Address "Austin")
|
||||||
|
|
||||||
|
getDog :: Person -> Dog
|
||||||
|
getDog p =
|
||||||
|
Dog (dogName p) (address p)
|
||||||
|
|
||||||
|
getDogR :: Person -> Dog
|
||||||
|
getDogR =
|
||||||
|
A.liftA2 Dog dogName address
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
myLiftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
|
||||||
|
myLiftA2 f x y =
|
||||||
|
f <$> x <*> y
|
||||||
|
|
||||||
|
asks :: (r -> a) -> Reader r a
|
||||||
|
asks f = Reader f
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
instance Functor (Reader a) where
|
||||||
|
fmap f (Reader ab) = Reader $ f . ab
|
||||||
|
|
||||||
|
instance Applicative (Reader a) where
|
||||||
|
pure x = Reader $ \_ -> x
|
||||||
|
(Reader rab) <*> (Reader ra) = Reader $ do
|
||||||
|
ab <- rab
|
||||||
|
fmap ab ra
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
instance Monad (Reader r) where
|
||||||
|
return = pure
|
||||||
|
-- (>>=) :: Reader r a -> (a -> Reader r b) -> Reader r b
|
||||||
|
(Reader x) >>= f = undefined
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
x = [1..3]
|
||||||
|
y = [4..6]
|
||||||
|
z = [7..9]
|
||||||
|
|
||||||
|
xs :: Maybe Integer
|
||||||
|
xs = zip x y & lookup 3
|
||||||
|
|
||||||
|
ys :: Maybe Integer
|
||||||
|
ys = zip y z & lookup 6
|
||||||
|
|
||||||
|
zs :: Maybe Integer
|
||||||
|
zs = zip x y & lookup 4
|
||||||
|
|
||||||
|
z' :: Integer -> Maybe Integer
|
||||||
|
z' n = zip x y & lookup n
|
||||||
|
|
||||||
|
x1 :: Maybe (Integer, Integer)
|
||||||
|
x1 = A.liftA2 (,) xs ys
|
||||||
|
|
||||||
|
x2 :: Maybe (Integer, Integer)
|
||||||
|
x2 = A.liftA2 (,) ys zs
|
||||||
|
|
||||||
|
x3 :: Integer -> (Maybe Integer, Maybe Integer)
|
||||||
|
x3 n = (z' n, z' n)
|
||||||
|
|
||||||
|
summed :: Num a => (a, a) -> a
|
||||||
|
summed (x, y) = x + y
|
||||||
|
|
||||||
|
bolt :: Integer -> Bool
|
||||||
|
bolt x = x > 3 && x < 8
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
print $ sequenceA [Just 3, Just 2, Just 1]
|
||||||
|
print $ sequenceA [x, y]
|
||||||
|
print $ sequenceA [xs, ys]
|
||||||
|
print $ summed <$> ((,) <$> xs <*> ys)
|
||||||
|
print $ bolt 7
|
||||||
|
print $ bolt <$> z
|
||||||
|
print $ sequenceA [(>3), (<8) ,even] 7
|
93
scratch/haskell-programming-from-first-principles/state.hs
Normal file
93
scratch/haskell-programming-from-first-principles/state.hs
Normal file
|
@ -0,0 +1,93 @@
|
||||||
|
module StateScratch where
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
import System.Random
|
||||||
|
-- import Control.Monad.Trans.State
|
||||||
|
import Data.Function ((&))
|
||||||
|
|
||||||
|
import qualified Control.Applicative as Ap
|
||||||
|
import qualified Control.Monad as M
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
data Die
|
||||||
|
= DieOne
|
||||||
|
| DieTwo
|
||||||
|
| DieThree
|
||||||
|
| DieFour
|
||||||
|
| DieFive
|
||||||
|
| DieSix
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
intToDie :: Integer -> Maybe Die
|
||||||
|
intToDie 1 = Just DieOne
|
||||||
|
intToDie 2 = Just DieTwo
|
||||||
|
intToDie 3 = Just DieThree
|
||||||
|
intToDie 4 = Just DieFour
|
||||||
|
intToDie 5 = Just DieFive
|
||||||
|
intToDie 6 = Just DieSix
|
||||||
|
intToDie _ = Nothing
|
||||||
|
|
||||||
|
rollDie :: Moi StdGen Die
|
||||||
|
rollDie = do
|
||||||
|
(n, s) <- randomR (1, 6)
|
||||||
|
case intToDie n of
|
||||||
|
Just d -> pure (d, s)
|
||||||
|
Nothing -> pure (DieOne, s)
|
||||||
|
|
||||||
|
rollsToGetN :: Integer -> StdGen -> [Die]
|
||||||
|
rollsToGetN n g = go 0 [] g
|
||||||
|
where
|
||||||
|
go sum result gen
|
||||||
|
| sum >= n = result
|
||||||
|
| otherwise =
|
||||||
|
let (dice, nextGen) = randomR (1, 6) gen
|
||||||
|
in case intToDie dice of
|
||||||
|
Nothing -> go (sum + dice) result nextGen
|
||||||
|
Just d -> go (sum + dice) (d : result) nextGen
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
newtype Moi s a = Moi { runMoi :: s -> (a, s) }
|
||||||
|
|
||||||
|
instance Functor (Moi s) where
|
||||||
|
fmap f (Moi run) =
|
||||||
|
Moi $ \s -> let (x, t) = run s
|
||||||
|
in (f x, t)
|
||||||
|
|
||||||
|
instance Applicative (Moi s) where
|
||||||
|
pure x = Moi $ \s -> (x, s)
|
||||||
|
(Moi f) <*> (Moi run) =
|
||||||
|
Moi $ \s -> let (g, t) = f s
|
||||||
|
(x, u) = run t
|
||||||
|
in (g x, u)
|
||||||
|
|
||||||
|
instance Monad (Moi s) where
|
||||||
|
(Moi run1) >>= f =
|
||||||
|
Moi $ \s -> let (x, t) = run1 s
|
||||||
|
(Moi run2) = f x
|
||||||
|
in run2 t
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
fizzBuzz :: Integer -> String
|
||||||
|
fizzBuzz n | n `mod` 15 == 0 = "FizzBuzz"
|
||||||
|
| n `mod` 5 == 0 = "Buzz"
|
||||||
|
| n `mod` 3 == 0 = "Fizz"
|
||||||
|
| otherwise = show n
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
get :: Moi s s
|
||||||
|
get = Moi $ \s -> (s, s)
|
||||||
|
|
||||||
|
put :: s -> Moi s ()
|
||||||
|
put x = Moi $ \s -> ((), x)
|
||||||
|
|
||||||
|
exec :: Moi s a -> s -> s
|
||||||
|
exec (Moi run) x = x & run & snd
|
||||||
|
|
||||||
|
eval :: Moi s a -> s -> a
|
||||||
|
eval (Moi run) x = x & run & fst
|
||||||
|
|
||||||
|
modify :: (s -> s) -> Moi s ()
|
||||||
|
modify f = Moi $ \s -> ((), f s)
|
Loading…
Reference in a new issue