Viewing:
module Chapter18 where
import Control.Applicative ((*>))
import Control.Monad ((>=>), join)
-- class Applicative m =>
-- Monad m
-- where
-- (>>=) :: m a -> (a -> m b) -> m b
-- (>>) :: m a -> m b -> m b
-- return :: a -> m a
-- fmap' f xs = xs >>= return . f
-- join :: Monad m => m (m a) -> m a
bind :: Monad m => (a -> m b) -> m a -> m b
bind a_m_b m_a = join $ fmap a_m_b m_a
sequencing :: IO ()
sequencing = do
putStrLn "blah"
putStrLn "another thing"
sequencing' :: IO ()
sequencing' = putStrLn "blah" >> putStrLn "another thing"
sequencing'' :: IO ()
sequencing'' = putStrLn "blah" *> putStrLn "another thing"
binding :: IO ()
binding = do
name <- getLine
putStrLn name
binding' :: IO ()
binding' = getLine >>= putStrLn
bindingAndSequencing :: IO ()
bindingAndSequencing = do
putStrLn "name pls:"
name <- getLine
putStrLn ("h helo thar: " ++ name)
bindingAndSequencing' :: IO ()
bindingAndSequencing' =
putStrLn "name pls:" >> getLine >>= \name ->
putStrLn ("y helo thar: " ++ name)
twoBinds :: IO ()
twoBinds = do
putStrLn "name pls:"
name <- getLine
putStrLn "age pls:"
age <- getLine
putStrLn ("h helo thar: " ++ name ++ " who is: " ++ age ++ " years old.")
twoBinds' :: IO ()
twoBinds' =
putStrLn "name pls:" >> getLine >>= \name ->
putStrLn "age pls:" >> getLine >>= \age ->
putStrLn ("y helo thar: " ++ name ++ " who is: " ++ age ++ " years old.")
twiceWhenEven :: [Integer] -> [Integer]
twiceWhenEven xs = do
x <- xs
if even x
then [x * x, x * x]
else twiceWhenEven (map (* 2) [1 .. x])
-- else [x * x]
data Cow =
Cow
{ name :: String
, age :: Int
, weight :: Int
}
deriving (Eq, Show)
noEmpty :: String -> Maybe String
noEmpty "" = Nothing
noEmpty str = Just str
noNegative :: Int -> Maybe Int
noNegative n
| n >= 0 = Just n
| otherwise = Nothing
weightCheck :: Cow -> Maybe Cow
weightCheck c =
let w = weight c
n = name c
in if n == "Bess" && w > 499
then Nothing
else Just c
-- This is pretty much how you'd write it in Elm
mkSphericalCow :: String -> Int -> Int -> Maybe Cow
mkSphericalCow name' age' weight' =
case noEmpty name' of
Nothing -> Nothing
Just nammy ->
case noNegative age' of
Nothing -> Nothing
Just agey ->
case noNegative weight' of
Nothing -> Nothing
Just weighty -> weightCheck (Cow nammy agey weighty)
mkSphericalCow' :: String -> Int -> Int -> Maybe Cow
mkSphericalCow' name' age' weight' = do
nammy <- noEmpty name'
agey <- noNegative age'
weighty <- noNegative weight'
weightCheck (Cow nammy agey weighty)
mkSphericalCow'' :: String -> Int -> Int -> Maybe Cow
mkSphericalCow'' name' age' weight' =
noEmpty name' >>= \nammy ->
noNegative age' >>= \agey ->
noNegative weight' >>= \weighty -> weightCheck (Cow nammy agey weighty)
-- instance Monad Maybe where
-- return x = Just x
-- (Just x) >>= k = k x
-- Nothing >>= _ = Nothing
-- mkSphericalCow'' :: String
-- ->
type Founded = Int
type Coders = Int
data SoftwareShop =
Shop
{ founded :: Founded
, programmers :: Coders
}
deriving (Eq, Show)
data FoundedError
= NegativeYears Founded
| TooManyYears Founded
| NegativeCoders Coders
| TooManyCoders Coders
| TooManyCodersForYears Founded Coders
deriving (Eq, Show)
validateFounded :: Int -> Either FoundedError Founded
validateFounded n
| n < 0 = Left $ NegativeYears n
| n > 500 = Left $ TooManyYears n
| otherwise = Right n
validateCoders :: Int -> Either FoundedError Coders
validateCoders n
| n < 0 = Left $ NegativeCoders n
| n > 5000 = Left $ TooManyCoders n
| otherwise = Right n
mkSoftware :: Int -> Int -> Either FoundedError SoftwareShop
mkSoftware years coders = do
founded <- validateFounded years
programmers <- validateCoders coders
if programmers > div founded 10
then Left $ TooManyCodersForYears founded programmers
else Right $ Shop founded programmers
ap :: (Monad m) => m (a -> b) -> m a -> m b
ap m m' = do
x <- m
x' <- m'
return (x x')
-- Exercise: Either Monad
data Sum a b
= First a
| Second b
deriving (Eq, Show)
instance (Semigroup a, Semigroup b) => Semigroup (Sum a b) where
(<>) (First x1) (First x2) = First (x1 <> x2)
(<>) (Second x1) (Second x2) = Second (x1 <> x2)
(<>) (First x) _ = First x
(<>) _ (First x) = First x
instance (Monoid a, Monoid b) => Monoid (Sum a b) where
mempty = First mempty
mappend = (<>)
instance Functor (Sum a) where
fmap f (First x) = First x
fmap f (Second x) = Second (f x)
instance (Semigroup a) => Applicative (Sum a) where
pure = Second
(<*>) (First x1) (First x2) = First (x1 <> x2)
(<*>) (First x1) (Second _) = First x1
(<*>) (Second _) (First x1) = First x1
(<*>) (Second f) (Second x) = Second (f x)
-- join :: Monad m => m (m a) -> m a
-- bind :: Monad m => (a -> m b) -> m a -> m b
-- bind a_m_b m_a = join $ fmap a_m_b m_a
instance (Semigroup a) => Monad (Sum a) where
return = pure
(>>=) (First x) _ = First x
(>>=) m_a f = join $ fmap f m_a
sayHi :: String -> IO String
sayHi greeting = do
putStrLn greeting
getLine
readM :: Read a => String -> IO a
readM = return . read
getAge :: String -> IO Int
getAge = sayHi >=> readM
askForAge :: IO Int
askForAge = getAge "Hello! How old are you? "