├── .gitignore ├── LICENSE ├── README.md ├── hsbook.cabal ├── src ├── Ch05Ex-types-2.hs ├── Ch05Ex-types.hs ├── Ch06-typeclasses.hs ├── Ch06Ex-type-kwon-do-rnd2.hs ├── Ch07-Penguin.hs ├── Ch07-codersRuleCEOsDrool.hs ├── Ch07-foldBool.hs ├── Ch08Ex-wordnumber.hs ├── Ch08Ex.hs ├── Ch09Ex-ciphers.hs ├── Ch09Ex-stdFunc.hs ├── Ch10-theDatabase.hs ├── Ch11-BinaryTree.hs ├── Ch11-OS-BinT.hs ├── Ch11-records.hs ├── Ch11-tooManyGoats.hs ├── Ch11Ex-asPatterns.hs ├── Ch12-smart.hs ├── Ch12Ex-unfolds.hs ├── Ch13Ex.hs ├── Ch14Ex-tests.hs ├── Ch15-Monoids.hs ├── Ch15-Semigroups.hs ├── Ch15Ex-Mem.hs ├── Ch15Ex-Monoid.hs ├── Ch16-Functor.hs ├── Ch16-FunctorQuickCheck.hs ├── Ch16Ex-Functor.hs ├── Ch17-Applicative-Ex.hs ├── Ch17-Applicative-QuickTest.hs ├── Ch17-Applicative-Validation.hs ├── Ch17-Applicative-zipList.hs ├── Ch17-Applicative.hs ├── Ch18-BadMonad.hs ├── Ch18-EitherMonad.hs ├── Ch18-Monad.hs ├── Ch18-MonadComposition.hs ├── Ch20-Foldable.hs ├── Ch21-Traversable.hs ├── Ch21-httpStuff.hs ├── Ch22-Reader.hs ├── Ch22-ReaderPractice.hs ├── Ch23-FizzBuzz.hs ├── Ch23-MyState.hs ├── Ch23-RandomExample.hs ├── Ch23-RandomExample2.hs ├── Ch23-State.hs ├── Ch24-AltParsing.hs ├── Ch24-AltParsing2.hs ├── Ch24-Fractions-parsers.hs ├── Ch24-Fractions.hs ├── Ch24-FractionsEx.hs ├── Ch24-LearnParsers.hs ├── Ch24-LogFile.hs ├── Ch24-Marshalling.hs ├── Ch24-ParsePhone.hs ├── Ch24-PositiveInteger.hs ├── Ch24-Semver.hs ├── Ch24-ini.hs ├── Ch24-ipv6.hs ├── Ch25-IdentityT.hs ├── Ch25-Twinplicative.hs ├── Ch26-Ex.hs ├── Ch26-HitCounter.hs ├── Ch26-MaybeT.hs ├── Ch26-MonadTrans.hs ├── Ch26-Morra.hs ├── Ch26-MorraState.hs ├── Ch26-OuterInner.hs ├── Ch26-ReaderT.hs ├── Ch26-Scotty-2.hs ├── Ch26-Scotty-3.hs ├── Ch26-Scotty-4.hs ├── Ch26-Scotty.hs ├── Ch26-StepByStep.hs ├── Ch26-lookMa.hs ├── Ch27-Bang.hs ├── Ch27-CoreDump.hs ├── Ch27-Kaboom.hs ├── Ch27-OutsideIn.hs ├── Ch27-StrictTest.hs ├── Ch27-StrictTest1.hs ├── Ch27-Trace.hs ├── IPv4.hs ├── Lib.hs └── notes.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # haskellbook 2 | Exercise solutions for _Haskell Programming from first principles_, a.k.a. [Haskell Book](http://haskellbook.com) 3 | 4 | This is just my personal work. Happy to receive advice here or on [twitter](https://twitter.com/intent/tweet?text=@dmlvianna%20&related=github&url=https://t.co/PGtie7leCX). 5 | -------------------------------------------------------------------------------- /hsbook.cabal: -------------------------------------------------------------------------------- 1 | name: hsbook 2 | version: 0.1.0.0 3 | synopsis: Exercises from haskellbook.com 4 | description: Please see README.md 5 | homepage: https://github.com/dmvianna/hsbook#readme 6 | license: OtherLicense 7 | license-file: LICENSE 8 | author: Daniel Vianna 9 | maintainer: dmlvianna@gmail.com 10 | copyright: 2016 Daniel Vianna 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Lib 19 | build-depends: QuickCheck 20 | , base 21 | , bifunctors 22 | , bytestring 23 | , checkers 24 | , containers 25 | , hspec 26 | , mtl 27 | , parsers 28 | , random 29 | , raw-strings-qq 30 | , scotty 31 | , text 32 | , transformers 33 | , trifecta 34 | , word8 35 | default-language: Haskell2010 36 | 37 | source-repository head 38 | type: git 39 | location: https://github.com/dmvianna/hsbook 40 | -------------------------------------------------------------------------------- /src/Ch05Ex-types-2.hs: -------------------------------------------------------------------------------- 1 | f :: Int -> String 2 | f = undefined 3 | 4 | g :: String -> Char 5 | g = undefined 6 | 7 | h :: Int -> Char 8 | h a = g (f a) 9 | 10 | 11 | data A 12 | data B 13 | data C 14 | 15 | q :: A -> B 16 | q = undefined 17 | 18 | w :: B -> C 19 | w = undefined 20 | 21 | e :: A -> C 22 | e a = w (q a) 23 | 24 | data X 25 | data Y 26 | data Z 27 | 28 | xz :: X -> Z 29 | xz = undefined 30 | 31 | yz :: Y -> Z 32 | yz = undefined 33 | 34 | xform :: (X, Y) -> (Z, Z) 35 | xform (a, b) = (xz a, yz b) 36 | 37 | -- Mash Until No Good 38 | 39 | data W 40 | 41 | ywz :: Y -> (W, Z) 42 | ywz = undefined 43 | 44 | xy :: X -> Y 45 | xy = undefined 46 | 47 | munge :: (x -> y) -> (y -> (w, z)) -> x -> w 48 | munge xy ywz x = fst (ywz (xy x)) 49 | 50 | 51 | divideThenAdd :: Fractional a => a -> a -> a 52 | divideThenAdd x y = (x / y) + 1 53 | -------------------------------------------------------------------------------- /src/Ch05Ex-types.hs: -------------------------------------------------------------------------------- 1 | 2 | functionH :: [a] -> a 3 | functionH (x:_) = x 4 | 5 | functionC :: Ord a => a -> a -> Bool 6 | functionC x y = if (x > y) then True else False 7 | 8 | functionS :: (a, b) -> b 9 | functionS (x, y) = y 10 | 11 | i :: a -> a 12 | i = \a -> a 13 | 14 | c :: a -> b -> a 15 | c = \a b -> a 16 | 17 | c'' :: b -> a -> b 18 | c'' = \b a -> b 19 | 20 | c' :: a -> b -> b 21 | c' = \a b -> b 22 | 23 | r :: [a] -> [a] 24 | r = \a -> reverse a 25 | 26 | co :: (b -> c) -> (a -> b) -> (a -> c) 27 | co a b c = a (b c) 28 | 29 | a :: (a -> c) -> a -> a 30 | a c a = a 31 | 32 | a' :: (a -> b) -> a -> b 33 | a' a b = a b 34 | -------------------------------------------------------------------------------- /src/Ch06-typeclasses.hs: -------------------------------------------------------------------------------- 1 | data Trivial = 2 | Trivial' 3 | 4 | instance Eq Trivial where 5 | Trivial' == Trivial' = True 6 | 7 | data DayOfWeek = 8 | Mon | Tue | Wed | Thu | Fri | Sat | Sun 9 | deriving (Show) 10 | 11 | -- Day of week and numerical day of month 12 | 13 | data Date = 14 | Date DayOfWeek Int 15 | 16 | instance Eq DayOfWeek where 17 | (==) Mon Mon = True 18 | (==) Tue Tue = True 19 | (==) Wed Wed = True 20 | (==) Thu Thu = True 21 | (==) Fri Fri = True 22 | (==) Sat Sat = True 23 | (==) Sun Sun = True 24 | (==) _ _ = False 25 | 26 | instance Ord DayOfWeek where 27 | compare Fri Fri = EQ 28 | compare Fri _ = GT 29 | compare _ Fri = LT 30 | compare _ _ = EQ 31 | 32 | 33 | instance Eq Date where 34 | (==) (Date weekday monthNum) 35 | (Date weekday' monthNum') = 36 | weekday == weekday' && monthNum == monthNum' 37 | 38 | 39 | f :: Int -> Bool 40 | f 1 = True 41 | f 2 = True 42 | f _ = False 43 | 44 | data Identity a = 45 | Identity a 46 | 47 | instance Eq a => Eq (Identity a) where 48 | (==) (Identity v) (Identity v') = v == v' 49 | 50 | data TisAnInteger = 51 | TisAn Integer 52 | 53 | instance Eq TisAnInteger where 54 | (==) (TisAn a) (TisAn a') = a == a' 55 | 56 | data TwoIntegers = 57 | Two Integer Integer 58 | 59 | instance Eq TwoIntegers where 60 | (==) (Two a b) (Two a' b') = 61 | a == a' && b == b' 62 | 63 | data StringOrInt = 64 | TisAnInt Int 65 | | TisAString String 66 | 67 | instance Eq StringOrInt where 68 | (==) (TisAnInt a) (TisAnInt a') = a == a' 69 | (==) (TisAString a) (TisAString a') = a == a' 70 | (==) _ _ = False 71 | 72 | data Pair a = 73 | Pair a a 74 | 75 | instance Eq a => Eq (Pair a) where 76 | (==) (Pair a a') (Pair b b') = a == b && a' == b' 77 | 78 | data Tuple a b = 79 | Tuple a b 80 | 81 | instance (Eq a, Eq b) => Eq (Tuple a b) where 82 | (==) (Tuple a a') (Tuple b b') = a == b && a' == b' 83 | 84 | data Which a = 85 | ThisOne a 86 | | ThatOne a 87 | 88 | instance Eq a => Eq (Which a) where 89 | (==) (ThisOne a) (ThisOne a') = a == a' 90 | (==) (ThatOne a) (ThatOne a') = a == a' 91 | (==) _ _ = False 92 | 93 | data EitherOr a b = 94 | Hello a 95 | | Goodbye b 96 | 97 | instance (Eq a, Eq b) => Eq (EitherOr a b) where 98 | (==) (Hello a) (Hello a') = a == a' 99 | (==) (Goodbye a) (Goodbye a') = a == a' 100 | (==) _ _ = False 101 | -------------------------------------------------------------------------------- /src/Ch06Ex-type-kwon-do-rnd2.hs: -------------------------------------------------------------------------------- 1 | 2 | chk :: Eq b => (a -> b) -> a -> b -> Bool 3 | chk ab a b = ab a == b 4 | 5 | 6 | arith :: Num b => (a -> b) -> Integer -> a -> b 7 | arith ab i a = (ab a) + (fromInteger i) 8 | -------------------------------------------------------------------------------- /src/Ch07-Penguin.hs: -------------------------------------------------------------------------------- 1 | module RegisteredUser where 2 | 3 | newtype Username = Username String 4 | newtype AccountNumber = AccountNumber Integer 5 | 6 | data User = UnregisteredUser 7 | | RegisteredUser Username AccountNumber 8 | 9 | printUser :: User -> IO () 10 | printUser UnregisteredUser = putStrLn "UnregisteredUser" 11 | printUser (RegisteredUser (Username name) 12 | (AccountNumber acctNum)) 13 | = putStrLn $ name ++ " " ++ show acctNum 14 | 15 | data WherePenguinsLive = 16 | Galapagos 17 | | Antarctica 18 | | Australia 19 | | SouthAfrica 20 | | SouthAmerica 21 | | NewZealand 22 | deriving (Eq, Show) 23 | 24 | data Penguin = 25 | Peng WherePenguinsLive 26 | deriving (Eq, Show) 27 | 28 | isSouthAfrica :: WherePenguinsLive -> Bool 29 | isSouthAfrica SouthAfrica = True 30 | isSouthAfrica _ = False 31 | 32 | gimmeWhereTheyLive :: Penguin -> WherePenguinsLive 33 | gimmeWhereTheyLive (Peng whereitlives) = whereitlives 34 | 35 | humboldt = Peng SouthAmerica 36 | gentoo = Peng Antarctica 37 | macaroni = Peng Antarctica 38 | little = Peng Australia 39 | galapagos = Peng Galapagos 40 | 41 | galapagosPenguin :: Penguin -> Bool 42 | galapagosPenguin (Peng Galapagos) = True 43 | galapagosPenguin _ = False 44 | 45 | antarcticPenguin :: Penguin -> Bool 46 | antarcticPenguin (Peng Antarctica) = True 47 | antarcticPenguin _ = False 48 | 49 | antarcticOrGalapagos :: Penguin -> Bool 50 | antarcticOrGalapagos p = 51 | (galapagosPenguin p) || (antarcticPenguin p) 52 | 53 | -------------------------------------------------------------------------------- /src/Ch07-codersRuleCEOsDrool.hs: -------------------------------------------------------------------------------- 1 | module TupleFunction where 2 | 3 | addEmUp :: Num a => (a, a) -> a 4 | addEmUp (x, y) = x + y 5 | 6 | fst3 :: (a, b, c) -> a 7 | fst3 (x, _, _) = x 8 | 9 | k (x, y) = x 10 | k1 = k ((4-1), 10) 11 | k2 = k ("three", (1 + 2)) 12 | k3 = k (3, True) 13 | 14 | f :: (a, b, c) -> (d, e, f) -> ((a, d), (c, f)) 15 | f (a, b, c) (d, e, f) = ((a, d), (c, f)) 16 | 17 | funcZ :: (Num a, Eq a) => a -> [Char] 18 | funcZ x = 19 | case x + 1 == 1 of 20 | True -> "AWESOME" 21 | False -> "wut" 22 | 23 | pal :: Eq a => [a] -> [Char] 24 | pal xs = 25 | case xs == reverse xs of 26 | True -> "yes" 27 | False -> "no" 28 | 29 | functionC x y = 30 | case x > y of 31 | True -> x 32 | False -> y 33 | 34 | ifEvenAdd2 n = 35 | case even n of 36 | True -> n + 2 37 | False -> n 38 | 39 | num x = 40 | case compare x 0 of 41 | LT -> -1 42 | GT -> 1 43 | EQ -> 0 44 | 45 | data Employee = Coder 46 | | Manager 47 | | Veep 48 | | CEO 49 | deriving (Eq, Ord, Show) 50 | 51 | reportBoss :: Employee -> Employee -> IO () 52 | reportBoss e e' = 53 | putStrLn $ show e ++ " is the boss of " ++ show e' 54 | 55 | employeeRank :: (Employee -> Employee -> Ordering) 56 | -> Employee -> Employee -> IO () 57 | employeeRank f e e' = 58 | case f e e' of 59 | GT -> reportBoss e e' 60 | EQ -> putStrLn "Neither employee is the boss" 61 | LT -> (flip reportBoss) e e' 62 | 63 | codersRuleCEOsDrool :: Employee -> Employee -> Ordering 64 | codersRuleCEOsDrool Coder Coder = EQ 65 | codersRuleCEOsDrool Coder _ = GT 66 | codersRuleCEOsDrool _ Coder = LT 67 | codersRuleCEOsDrool e e' = compare e e' 68 | 69 | dodgy :: Num a => a -> a -> a 70 | dodgy x y = x + y * 10 71 | 72 | oneIsOne :: Num a => a -> a 73 | oneIsOne = dodgy 1 74 | 75 | oneIsTwo :: Num a => a -> a 76 | oneIsTwo = (flip dodgy) 2 77 | -------------------------------------------------------------------------------- /src/Ch07-foldBool.hs: -------------------------------------------------------------------------------- 1 | tensDigit :: Integral a => a -> a 2 | tensDigit x = d 3 | where xLast = x `div` 10 4 | d = xLast `mod` 10 5 | 6 | 7 | potDig :: Integral a => a -> a -> a 8 | potDig x y = d 9 | where (xLast, _) = divMod x $ 10 ^ (y - 1) 10 | (_, d) = divMod xLast $ 10 11 | 12 | foldBool :: a -> a -> Bool -> a 13 | foldBool x y b = 14 | case b of 15 | True -> x 16 | False -> y 17 | 18 | foldBool2 :: a -> a -> Bool -> a 19 | foldBool2 x y b 20 | | b = x 21 | | otherwise = y 22 | 23 | g :: (a -> b) -> (a, c) -> (b, c) 24 | g f (a, c) = (f a, c) 25 | -------------------------------------------------------------------------------- /src/Ch08Ex-wordnumber.hs: -------------------------------------------------------------------------------- 1 | module WordNumber where 2 | 3 | import Data.List (intercalate) 4 | 5 | digitToWord :: Int -> String 6 | digitToWord n = ["zero", 7 | "one", 8 | "two", 9 | "three", 10 | "four", 11 | "five", 12 | "six", 13 | "seven", 14 | "eight", 15 | "nine"] !! n 16 | 17 | 18 | digits :: Int -> [Int] 19 | digits n = go n [] 20 | where go x xs 21 | | div x 10 == 0 = mod x 10 : xs 22 | | otherwise = go (div x 10) (mod x 10 : xs) 23 | 24 | wordNumber :: Int -> String 25 | wordNumber = intercalate "-" . map digitToWord . digits 26 | 27 | myWords :: String -> Char -> [String] 28 | myWords s c = go s [] 29 | where drops = dropWhile (/= c) 30 | takes = takeWhile (/= c) 31 | go x xs 32 | | null x = xs 33 | | head x == c = go (drop 1 x) xs 34 | | otherwise = go (drops x) 35 | (xs ++ [takes x]) 36 | 37 | firstSen = "Tyger Tyger, burning bright\n" 38 | secondSen = "In the forests of the night\n" 39 | thirdSen = "What immortal hand or eye\n" 40 | fourthSen = "could frame thy fearful symmetry?" 41 | sentences = firstSen ++ secondSen ++ thirdSen ++ fourthSen 42 | 43 | inList :: Eq a => a -> [a] -> Bool 44 | inList x xs 45 | | null xs = False 46 | | otherwise = (x == head xs) || (inList x $ tail xs) 47 | 48 | noArt :: String -> [String] 49 | noArt s = go (words s) [] 50 | where go xs acc 51 | | null xs = acc 52 | | not $ (head xs) `inList` ["the","a","an"] = 53 | go (tail xs) (acc ++ [head xs]) 54 | | otherwise = go (tail xs) acc 55 | 56 | myZip :: [a] -> [b] -> [(a, b)] 57 | myZip xs ys = go xs ys [] 58 | where go x y acc 59 | | null x || null y = acc 60 | | otherwise = go (tail x) (tail y) (acc ++ [(head x, head y)]) 61 | 62 | myZipWith :: (a -> b -> c) -> [a] -> [b] -> [c] 63 | myZipWith f xs ys = go xs ys [] 64 | where go x y acc 65 | | null x || null y = acc 66 | | otherwise = go (tail x) (tail y) (acc ++ [f (head x) (head y)]) 67 | -------------------------------------------------------------------------------- /src/Ch08Ex.hs: -------------------------------------------------------------------------------- 1 | module Arith4 where 2 | 3 | roundTrip :: (Show a, Read b) => a -> b 4 | roundTrip = read . show 5 | 6 | main = do 7 | print (roundTrip 4 :: Int) 8 | print (id 4) 9 | 10 | incTimes :: (Eq a, Num a) => a -> a -> a 11 | incTimes 0 n = n 12 | incTimes times n = 1 + (incTimes (times - 1) n) 13 | 14 | applyTimes :: (Eq a, Num a) => a -> (b -> b) -> b -> b 15 | applyTimes 0 f b = b 16 | applyTimes n f b = f . applyTimes (n-1) f $ b 17 | 18 | fibonacci :: Integral a => a -> a 19 | fibonacci 0 = 0 20 | fibonacci 1 = 1 21 | fibonacci x = fibonacci (x - 1) + fibonacci (x - 2) 22 | 23 | cattyConny :: String -> String -> String 24 | cattyConny x y = x ++ " mrow " ++ y 25 | 26 | flippy :: String -> String -> String 27 | flippy = flip cattyConny 28 | 29 | appedCatty :: String -> String 30 | appedCatty = cattyConny "woops" 31 | 32 | frappe :: String -> String 33 | frappe = flippy "haha" 34 | 35 | sums :: (Eq a, Ord a, Num a) => a -> a 36 | sums 1 = 1 37 | sums n = if n > 0 38 | then n + sums (n - 1) 39 | else n + sums (n + 1) 40 | 41 | data DividedResult = 42 | Result (Integer, Integer) 43 | | DividedByZero 44 | deriving Show 45 | 46 | dividedBy :: Integer -> Integer -> DividedResult 47 | dividedBy num 0 = DividedByZero 48 | dividedBy num denom = go num denom 0 49 | where go n d count 50 | | n < d = Result (count, n) 51 | | otherwise = go (n - d) d (count + 1) 52 | 53 | divBy :: Integer -> Integer -> DividedResult 54 | divBy num 0 = DividedByZero 55 | divBy num denom = go (abs num) (abs denom) 0 56 | where go n d count 57 | | n < d && num > 0 && denom > 0 = Result (count, n) 58 | | n < d && num < 0 && denom > 0 = Result (negate count, negate n) 59 | | n < d && num < 0 && denom < 0 = Result (count, negate n) 60 | | n < d && num > 0 && denom < 0 = Result (negate count, n) 61 | | otherwise = go (n - d) d (count + 1) 62 | 63 | mc91 :: Integral a => a -> a 64 | mc91 a 65 | | a > 100 = a - 10 66 | | otherwise = mc91 $ mc91 $ a + 11 67 | -------------------------------------------------------------------------------- /src/Ch09Ex-ciphers.hs: -------------------------------------------------------------------------------- 1 | module Cipher where 2 | 3 | import Data.Char 4 | 5 | 6 | charToRight :: Int -> Char -> Char 7 | charToRight n x 8 | | ord x >= 97 && ord x <= 122 = go n x ['a'..'z'] 97 9 | | ord x >= 65 && ord x <= 90 = go n x ['A'..'Z'] 65 10 | | otherwise = x 11 | where go nn xx xxs off 12 | | ord xx - off + nn < 0 = go nn xx xxs (off - 26) 13 | | ord xx - off + nn > 25 = go nn xx xxs (off + 26) 14 | | otherwise = xxs !! (ord xx - off + nn) 15 | 16 | inCaesar :: Int -> String -> String 17 | inCaesar n = map (charToRight n) 18 | 19 | unCaesar :: Int -> String -> String 20 | unCaesar n = map (charToRight $ negate n) 21 | 22 | vigenere :: (Int -> Int) -> String -> String -> String 23 | vigenere switch baseKeys baseExs = 24 | case (baseKeys, baseExs) of 25 | (_, "") -> "" 26 | ("", xs) -> xs 27 | (bks, bxs) -> 28 | go bks bxs [] 29 | where 30 | go keys exs acc = 31 | case (keys, exs) of 32 | (_, []) -> acc 33 | ([], xs) -> go baseKeys xs acc 34 | (k:ks, x:xs) -> goAgain k ks x xs 35 | where goAgain k ks x xs 36 | | x `elem` ['A'..'Z'] = 37 | go ks xs (acc 38 | ++ [charToRight 39 | (switch (ord k - 65)) x]) 40 | | x `elem` ['a'..'z'] = 41 | go ks xs (acc 42 | ++ [charToRight 43 | (switch (ord k - 97)) x]) 44 | | otherwise = 45 | go keys xs (acc ++ [x]) 46 | 47 | inVig :: String -> String -> String 48 | inVig = vigenere id 49 | 50 | unVig :: String -> String -> String 51 | unVig = vigenere negate 52 | 53 | -- unVig "ally" $ inVig "ally" "meet at dawn" 54 | -------------------------------------------------------------------------------- /src/Ch09Ex-stdFunc.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | fUp :: String -> String 4 | fUp a = filter isUpper a 5 | 6 | title :: String -> String 7 | title [] = [] 8 | title (x:xs) = toUpper x : title xs 9 | 10 | hUp :: String -> Char 11 | hUp (x:xs) = toUpper x 12 | 13 | hUp2 :: String -> Char 14 | hUp2 = toUpper . head 15 | 16 | hUp3 :: String -> String 17 | hUp3 = map toUpper 18 | 19 | myOr :: [Bool] -> Bool 20 | myOr [] = False 21 | myOr (x:xs) = if x then True else myOr xs 22 | 23 | myAny :: (a -> Bool) -> [a] -> Bool 24 | myAny f [] = False 25 | myAny f (x:xs) = if f x then True else myAny f xs 26 | 27 | myElem :: Eq a => a -> [a] -> Bool 28 | myElem x (y:[]) = x == y 29 | myElem x (y:ys) = myElem x [y] || myElem x ys 30 | 31 | myReverse :: [a] -> [a] 32 | myReverse (x:[]) = [x] 33 | myReverse (x:xs) = myReverse xs ++ [x] 34 | 35 | squish :: [[a]] -> [a] 36 | squish (x:[]) = x 37 | squish (x:xs) = x ++ squish xs 38 | 39 | squishMap :: (a -> [b]) -> [a] -> [b] 40 | squishMap f (x:[]) = f x 41 | squishMap f (x:xs) = f x ++ squishMap f xs 42 | 43 | squishAgain :: [[a]] -> [a] 44 | squishAgain = squishMap id 45 | 46 | myMaximumBy :: (a -> a -> Ordering) -> [a] -> a 47 | myMaximumBy f (x:[]) = x 48 | myMaximumBy f' (x:xs) = go f' x xs 49 | where 50 | go f x (y:[]) 51 | | f x y == GT = x 52 | | f x y == EQ = x 53 | | f x y == LT = y 54 | go f x (y:ys) = go f (go f x [y]) ys 55 | 56 | myMinimumBy :: (a -> a -> Ordering) -> [a] -> a 57 | myMinimumBy f (x:[]) = x 58 | myMinimumBy f (x:y:[]) 59 | | f x y == LT = x 60 | | f x y == EQ = x 61 | | f x y == GT = y 62 | myMinimumBy f (x:x':xs) = myMinimumBy f $ (myMinimumBy f (x:x':[])):xs 63 | 64 | myCompare :: Ord a => [a] -> a 65 | myCompare (x:[]) = x 66 | --myCompare (x:x':[]) = max x x' 67 | myCompare (x:x':xs) = myCompare $ max x x':xs 68 | 69 | 70 | myMaximum :: (Ord a) => [a] -> a 71 | myMaximum = myMaximumBy compare 72 | 73 | myMinimum :: (Ord a) => [a] -> a 74 | myMinimum = myMinimumBy compare 75 | 76 | 77 | -------------------------------------------------------------------------------- /src/Ch10-theDatabase.hs: -------------------------------------------------------------------------------- 1 | import Data.Time 2 | 3 | data DatabaseItem = DbString String 4 | | DbNumber Integer 5 | | DbDate UTCTime 6 | deriving (Eq, Ord, Show) 7 | 8 | theDatabase :: [DatabaseItem] 9 | theDatabase = 10 | [ DbDate (UTCTime 11 | (fromGregorian 1911 5 1) 12 | (secondsToDiffTime 34123)) 13 | , DbString "Hello, world!" 14 | , DbDate (UTCTime 15 | (fromGregorian 1921 5 1) 16 | (secondsToDiffTime 34123)) 17 | ] 18 | 19 | filterDbDate :: [DatabaseItem] -> [UTCTime] 20 | filterDbDate = 21 | foldr maybeCons [] 22 | where maybeCons a b = 23 | case a of 24 | (DbDate date) -> date : b 25 | _ -> b 26 | 27 | filterDbNumber :: [DatabaseItem] -> [Integer] 28 | filterDbNumber [] = [] 29 | filterDbNumber (DbNumber x:[]) = [x] 30 | filterDbNumber (_:[]) = [] 31 | filterDbNumber (DbNumber x:xs) = x:filterDbNumber xs 32 | filterDbNumber (_:xs) = filterDbNumber xs 33 | 34 | mostRecent :: [DatabaseItem] -> UTCTime 35 | mostRecent = maximum . filterDbDate 36 | 37 | sumDb :: [DatabaseItem] -> Integer 38 | sumDb = sum . filterDbNumber 39 | 40 | avgDb :: [DatabaseItem] -> Double 41 | avgDb x = fromIntegral 42 | (foldr (\a b -> a + b) 0 $ filterDbNumber x) 43 | / (fromIntegral $ length $ filterDbNumber x) 44 | 45 | avgDb2 :: [DatabaseItem] -> Double 46 | avgDb2 x = (fromIntegral $ sumDb x) / 47 | (fromIntegral $ length $ filterDbNumber x) 48 | 49 | fDbDate :: [DatabaseItem] -> [UTCTime] 50 | fDbDate x = 51 | case x of 52 | [] -> [] 53 | DbDate x:[] -> [x] 54 | _:[] -> [] 55 | DbDate x:xs -> x:fDbDate xs 56 | _:xs -> fDbDate xs 57 | 58 | fibs = 1 : scanl (+) 1 fibs 59 | fibsN x = take x fibs 60 | 61 | fibsLess :: Int -> [Int] 62 | fibsLess x = go x 0 [] 63 | where go n ix xs 64 | | n > fibs !! ix = fibs !! ix : go x (ix + 1) xs 65 | | n <= fibs !! ix = xs 66 | 67 | ---------------- 68 | 69 | myOr :: [Bool] -> Bool 70 | myOr = foldr (||) False 71 | 72 | myAny :: (a -> Bool) -> [a] -> Bool 73 | myAny f = foldr ((||) . f) False 74 | 75 | myElem :: Eq a => a -> [a] -> Bool 76 | myElem x = any ((==) x) 77 | 78 | myReverse :: [a] -> [a] 79 | myReverse = foldl (flip (:)) [] 80 | 81 | myMap :: (a -> b) -> [a] -> [b] 82 | myMap f = foldr ((:) . f) [] 83 | 84 | myFilter :: (a -> Bool) -> [a] -> [a] 85 | myFilter f = foldr (\a b -> if f a then a:b else b) [] 86 | 87 | squish :: [[a]] -> [a] 88 | squish = foldr (++) [] 89 | 90 | squishMap :: (a -> [b]) -> [a] -> [b] 91 | squishMap f = foldr ((++) . f) [] 92 | 93 | squishAgain :: [[a]] -> [a] 94 | squishAgain = squishMap id 95 | 96 | -- myMaximumBy :: (a -> a -> Ordering) -> [a] -> a 97 | -- myMaximumBy f = foldr (\a b -> if f a b == GT then a else b) 98 | -------------------------------------------------------------------------------- /src/Ch11-BinaryTree.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Foldable as F 2 | 3 | data BinaryTree a = Leaf 4 | | Node (BinaryTree a) a (BinaryTree a) 5 | deriving (Eq, Ord, Show) 6 | 7 | insert' :: Ord a => a -> BinaryTree a -> BinaryTree a 8 | insert' b Leaf = Node Leaf b Leaf 9 | insert' b (Node left a right) 10 | | b == a = Node left a right 11 | | b < a = Node (insert' b left) a right 12 | | b > a = Node left a (insert' b right) 13 | 14 | mapTree :: (a -> b) -> BinaryTree a -> BinaryTree b 15 | mapTree _ Leaf = Leaf 16 | mapTree f (Node left a right) = Node (mapTree f left) (f a) (mapTree f right) 17 | 18 | -- 19 | 20 | 21 | preorder :: BinaryTree a -> [a] 22 | preorder x = go x [] 23 | where go tree acc = 24 | case tree of 25 | Node Leaf a Leaf -> a:acc 26 | Node left a right -> 27 | a : (go left acc) ++ (go right acc) 28 | 29 | 30 | inorder :: BinaryTree a -> [a] 31 | inorder x = go x [] 32 | where go tree acc = 33 | case tree of 34 | Node Leaf a Leaf -> a:acc 35 | Node left a right -> 36 | (go left acc) ++ [a] ++ (go right acc) 37 | 38 | 39 | 40 | postorder :: Ord a => BinaryTree a -> [a] 41 | postorder x = go x [] 42 | where go tree acc = 43 | case tree of 44 | Node Leaf a Leaf -> a:acc 45 | Node left a right -> 46 | (go left acc) ++ (go right acc) ++ [a] 47 | 48 | 49 | testTree :: BinaryTree Integer 50 | testTree = Node (Node Leaf 1 Leaf) 2 (Node Leaf 3 Leaf) 51 | 52 | testPreorder :: IO () 53 | testPreorder = 54 | if preorder testTree == [2,1,3] 55 | then putStrLn "Preorder fine!" 56 | else putStrLn "Bad news bears." 57 | 58 | testInorder :: IO () 59 | testInorder = 60 | if inorder testTree == [1,2,3] 61 | then putStrLn "Inorder fine!" 62 | else putStrLn "Bad news bears." 63 | 64 | 65 | testPostorder :: IO () 66 | testPostorder = 67 | if postorder testTree == [1,3,2] 68 | then putStrLn "Postorder fine!" 69 | else putStrLn "Postorder failed check" 70 | 71 | main :: IO () 72 | main = do 73 | testPreorder 74 | testInorder 75 | testPostorder 76 | 77 | 78 | foldTree :: (a -> b -> b -> b) -> b -> BinaryTree a -> b 79 | foldTree f b node = 80 | case node of 81 | Node Leaf a Leaf -> f a b b 82 | Node Leaf a right -> f a b (foldTree f b right) 83 | Node left a Leaf -> f a b (foldTree f b left) 84 | Node left a right -> f a (foldTree f b right) (foldTree f b left) 85 | 86 | mapTree' :: (a -> b) -> BinaryTree a -> BinaryTree b 87 | mapTree' f = foldTree (\a b c -> Node b (f a) c) Leaf 88 | -------------------------------------------------------------------------------- /src/Ch11-OS-BinT.hs: -------------------------------------------------------------------------------- 1 | data Fiction = Fiction deriving Show 2 | data Nonfiction = Nonfiction deriving Show 3 | 4 | data BookType = FictionBook Fiction 5 | | NonfictionBook Nonfiction 6 | deriving Show 7 | 8 | type AuthorName = String 9 | data Author = Author (AuthorName, BookType) 10 | 11 | data GuessWhat = 12 | Chickenbutt deriving (Eq, Show) 13 | 14 | data Id a = 15 | MkId a deriving (Eq, Show) 16 | 17 | data Product a b = 18 | Product a b deriving (Eq, Show) 19 | 20 | data Sum a b = First a 21 | | Second b 22 | deriving (Eq, Show) 23 | 24 | data RecordProduct a b = 25 | RecordProduct { pfirst :: a 26 | , psecond :: b } 27 | deriving (Eq, Show) 28 | 29 | newtype NumCow = 30 | NumCow Int 31 | deriving (Eq, Show) 32 | 33 | newtype NumPig = 34 | NumPig Int 35 | deriving (Eq, Show) 36 | 37 | data Farmhouse = 38 | Farmhouse NumCow NumPig 39 | deriving (Eq, Show) 40 | 41 | type Farmhouse' = Product NumCow NumPig 42 | 43 | newtype NumSheep = 44 | NumSheep Int 45 | deriving (Eq, Show) 46 | 47 | data BigFarmHouse = 48 | BigFarmHouse NumCow NumPig NumSheep 49 | deriving (Eq, Show) 50 | 51 | type BigFarmHouse' = 52 | Product NumCow (Product NumPig NumSheep) 53 | 54 | type Name = String 55 | type Age = Int 56 | type LovesMud = Bool 57 | 58 | type PoundsOfWool = Int 59 | 60 | data CowInfo = 61 | CowInfo Name Age 62 | deriving (Eq, Show) 63 | 64 | data PigInfo = 65 | PigInfo Name Age LovesMud 66 | deriving (Eq, Show) 67 | 68 | data SheepInfo = 69 | SheepInfo Name Age PoundsOfWool 70 | deriving (Eq, Show) 71 | 72 | data Animal = Cow CowInfo 73 | | Pig PigInfo 74 | | Sheep SheepInfo 75 | deriving (Eq, Show) 76 | 77 | type Animal' = Sum CowInfo (Sum PigInfo SheepInfo) 78 | 79 | trivialValue :: GuessWhat 80 | trivialValue = Chickenbutt 81 | 82 | myRecord :: RecordProduct Integer Float 83 | myRecord = RecordProduct 42 0.00001 84 | 85 | data OperatingSystem = GnuPlusLinux 86 | | OpenBSDPlusNevermindJustBSDStill 87 | | Mac 88 | | Windows 89 | deriving (Eq, Show) 90 | 91 | data ProgrammingLanguage = Haskell 92 | | Agda 93 | | Idris 94 | | PureScript 95 | deriving (Eq, Show) 96 | 97 | data Programmer = Programmer { os :: OperatingSystem 98 | , lang :: ProgrammingLanguage } 99 | deriving (Eq, Show) 100 | 101 | nineToFive :: Programmer 102 | nineToFive = Programmer { os = Mac 103 | , lang = Haskell } 104 | 105 | feelingWizardly :: Programmer 106 | feelingWizardly = Programmer { lang = Agda 107 | , os = GnuPlusLinux } 108 | 109 | allOperatingSystems :: [OperatingSystem] 110 | allOperatingSystems = 111 | [ GnuPlusLinux 112 | , OpenBSDPlusNevermindJustBSDStill 113 | , Mac 114 | , Windows 115 | ] 116 | 117 | allLanguages :: [ProgrammingLanguage] 118 | allLanguages = [Haskell, Agda, Idris, PureScript] 119 | 120 | allProgrammers :: [Programmer] 121 | allProgrammers = [Programmer { os = os 122 | , lang = lang } 123 | | lang <- allLanguages, 124 | os <- allOperatingSystems] 125 | 126 | data ThereYet = 127 | There Integer Float String Bool 128 | deriving (Eq, Show) 129 | 130 | nope :: Float -> String -> Bool -> ThereYet 131 | nope = There 10 132 | 133 | notYet :: String -> Bool -> ThereYet 134 | notYet = nope 25.5 135 | 136 | notQuite :: Bool -> ThereYet 137 | notQuite = notYet "whoohoo" 138 | 139 | yusss :: ThereYet 140 | yusss = notQuite False 141 | 142 | -- newtype Name = Name String deriving Show 143 | newtype Acres = Acres Int deriving Show 144 | 145 | data FarmerType = DairyFarmer 146 | | WheatFarmer 147 | | SoybeanFarmer deriving Show 148 | 149 | data Farmer = 150 | Farmer Name Acres FarmerType deriving Show 151 | 152 | isDairyFarmer :: Farmer -> Bool 153 | isDairyFarmer (Farmer _ _ DairyFarmer) = True 154 | isDairyFarmer _ = False 155 | 156 | data FarmerRec = 157 | FarmerRec { name :: Name 158 | , acres :: Acres 159 | , farmerType :: FarmerType } 160 | deriving Show 161 | 162 | isDairyFarmerRec :: FarmerRec -> Bool 163 | isDairyFarmerRec farmer = 164 | case farmerType farmer of 165 | DairyFarmer -> True 166 | _ -> False 167 | 168 | eQuad = 8 -- Either, so no product, just sum 169 | prodQuad = 16 170 | funcQuad = 256 171 | prodTBool = 8 172 | gTwo = 16 173 | fTwo = 65536 174 | 175 | data BinaryTree a = Leaf 176 | | Node (BinaryTree a) a (BinaryTree a) 177 | deriving (Eq, Ord, Show) 178 | 179 | insert' :: Ord a => a -> BinaryTree a -> BinaryTree a 180 | insert' b Leaf = Node Leaf b Leaf 181 | insert' b (Node left a right) 182 | | b == a = Node left a right 183 | | b < a = Node (insert' b left) a right 184 | | b > a = Node left a (insert' b right) 185 | 186 | mapTree :: (a -> b) -> BinaryTree a -> BinaryTree b 187 | mapTree _ Leaf = Leaf 188 | mapTree f (Node left a right) = Node (mapTree f left) (f a) (mapTree f right) 189 | -------------------------------------------------------------------------------- /src/Ch11-records.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} 2 | 3 | import Data.Int 4 | 5 | class TooMany a where 6 | tooMany :: a -> Bool 7 | 8 | instance TooMany Int where 9 | tooMany n = n > 42 10 | 11 | newtype Goats = Goats Int deriving (Eq, Show, TooMany, Num) 12 | 13 | instance TooMany (Int, String) where 14 | tooMany (n,_) = n > 42 15 | 16 | -- instance TooMany (Int, Int) where 17 | -- tooMany (x, y) = (x + y) > 42 18 | 19 | instance (Num a, TooMany a) => TooMany (a, a) where 20 | tooMany (x, y) = tooMany (x + y) 21 | 22 | 23 | 24 | data NumberOrBool = 25 | Numba Int8 26 | | BoolyBool Bool 27 | deriving (Eq, Show) 28 | 29 | -- data Person = MkPerson String Int deriving (Eq, Show) 30 | 31 | jm = Person "julie" 108 32 | ca = Person "chris" 16 33 | 34 | -- namae :: Person -> String 35 | -- namae (MkPerson s _) = s 36 | 37 | data Person = 38 | Person { name :: String 39 | , age :: Int } 40 | deriving (Eq, Show) 41 | 42 | -------------------------------------------------------------------------------- /src/Ch11-tooManyGoats.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | data Price = Price Integer deriving (Eq, Show) 4 | data Size = Size Integer deriving (Eq, Show) 5 | 6 | data Manufacturer = Mini 7 | | Mazda 8 | | Tata 9 | deriving (Eq, Show) 10 | 11 | data Airline = PapuAir 12 | | CatapultsR'Us 13 | | TakeYourChancesUnited 14 | deriving (Eq, Show) 15 | 16 | data Vehicle = Car Manufacturer Price 17 | | Plane Airline Size 18 | deriving (Eq, Show) 19 | 20 | myCar = Car Mini (Price 14000) 21 | urCar = Car Mazda (Price 20000) 22 | clownCar = Car Tata (Price 7000) 23 | doge = Plane PapuAir (Size 34000) 24 | 25 | isCar :: Vehicle -> Bool 26 | isCar x = case x of 27 | Car _ _ -> True 28 | _ -> False 29 | 30 | isPlane :: Vehicle -> Bool 31 | isPlane x = case x of 32 | Plane _ _ -> True 33 | _ -> False 34 | 35 | areCars :: [Vehicle] -> [Bool] 36 | areCars = map isCar 37 | 38 | getManu :: Vehicle -> Maybe Manufacturer 39 | getManu x = case x of 40 | Car x _ -> Just x 41 | _ -> Nothing 42 | 43 | newtype Goats = Goats Int deriving (Eq, Show) 44 | newtype Cows = Cows Int deriving (Eq, Show) 45 | 46 | tooManyGoats :: Goats -> Bool 47 | tooManyGoats (Goats n) = n > 42 48 | 49 | class TooMany a where 50 | tooMany :: a -> Bool 51 | 52 | instance TooMany Int where 53 | tooMany n = n > 42 54 | 55 | instance TooMany Goats where 56 | tooMany (Goats n) = tooMany n 57 | -------------------------------------------------------------------------------- /src/Ch11Ex-asPatterns.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | f :: Show a => (a, b) -> IO (a, b) 4 | f t@(a, _) = do 5 | print a 6 | return t 7 | 8 | isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool 9 | isSubsequenceOf sub par = 10 | case sub of 11 | [] -> True 12 | x:xs -> x `elem` par && isSubsequenceOf xs par 13 | 14 | -- isLetter :: Char -> Bool 15 | -- isLetter = flip elem (['a'..'z'] ++ ['A'..'Z']) 16 | 17 | splitWords :: String -> [String] 18 | splitWords str = 19 | go str [] True 20 | where 21 | go [] acc _ = reverse acc 22 | go (x:xs) [] True 23 | | isLetter x = go xs [[x]] False 24 | | otherwise = go xs [] True 25 | go (x:xs) acc@(w:ws) startWord 26 | | (not $ isLetter x) && startWord = go xs acc startWord 27 | | (isLetter x && startWord) = go xs ([x]:acc) False 28 | | (not $ isLetter x) && not startWord = go xs acc True 29 | | (isLetter x) && not startWord = go xs ((w ++ [x]):ws) startWord 30 | 31 | 32 | capitalizeWords :: String -> [(String, String)] 33 | capitalizeWords str = map (\x -> (x, capitalizeWord x)) $ splitWords str 34 | 35 | capitalizeWord :: String -> String 36 | capitalizeWord [] = [] 37 | capitalizeWord (x:xs) = toUpper x:xs 38 | 39 | capitalizeParagraph :: String -> String 40 | capitalizeParagraph s = 41 | go s [] True 42 | where 43 | go [] acc _ = acc 44 | go (x:xs) acc period 45 | | x == '.' = go xs (acc ++ [x]) True 46 | | x `elem` ['a'..'z'] && period = 47 | go xs (acc ++ [toUpper x]) False 48 | | x `elem` ['A'..'Z'] && period = 49 | go xs (acc ++ [x]) False 50 | | otherwise = go xs (acc ++ [x]) period 51 | 52 | -- Phone excercise 53 | 54 | data DaPhone = Sommat 55 | 56 | convo :: [String] 57 | convo = ["Wanna play 20 questions", 58 | "Ya", 59 | "U 1st haha", 60 | "Lol ok. Have u ever tasted alcohol lol", 61 | "Lol ya", 62 | "Wow ur cool haha. Ur turn", 63 | "Ok. Do u think I am pretty Lol", 64 | "Lol ya", 65 | "Haha thanks just making sure rofl ur turn"] 66 | 67 | -- validButtons = "1234567890*#" 68 | type Digit = Char 69 | 70 | -- valid presses = [1..4] 71 | type Presses = Int 72 | 73 | cellPhonesDead :: DaPhone -> String -> [(Digit, Presses)] 74 | cellPhonesDead = undefined 75 | -------------------------------------------------------------------------------- /src/Ch12-smart.hs: -------------------------------------------------------------------------------- 1 | module EqCaseGuard where 2 | 3 | import Data.Char 4 | 5 | type Name = String 6 | type Age = Integer 7 | 8 | data Person = Person Name Age deriving Show 9 | 10 | data PersonInvalid = NameEmpty 11 | | AgeTooLow 12 | deriving (Eq, Show) 13 | 14 | -- mkPerson :: Name 15 | -- -> Age 16 | -- -> Either PersonInvalid Person 17 | 18 | -- mkPerson name age 19 | -- | name /= "" && age >= 0 = Right $ Person name age 20 | -- | name == "" = Left NameEmpty 21 | -- | otherwise = Left AgeTooLow 22 | 23 | 24 | type ValidatePerson a = Either [PersonInvalid] a 25 | 26 | ageOkay :: Age -> Either [PersonInvalid] Age 27 | ageOkay age = case age >= 0 of 28 | True -> Right age 29 | False -> Left [AgeTooLow] 30 | 31 | nameOkay :: Name -> Either [PersonInvalid] Name 32 | nameOkay name = case name /= "" of 33 | True -> Right name 34 | False -> Left [NameEmpty] 35 | 36 | mkPerson :: Name -> Age -> ValidatePerson Person 37 | mkPerson name age = mkPerson' (nameOkay name) (ageOkay age) 38 | 39 | mkPerson' :: ValidatePerson Name 40 | -> ValidatePerson Age 41 | -> ValidatePerson Person 42 | mkPerson' (Right nameOk) (Right ageOk) = 43 | Right (Person nameOk ageOk) 44 | mkPerson' (Left badName) (Left badAge) = 45 | Left (badName ++ badAge) 46 | mkPerson' (Left badName) _ = Left badName 47 | mkPerson' _ (Left badAge) = Left badAge 48 | 49 | -- Chapter Exercises 50 | 51 | -- Determine the kind 52 | -- k: a = * 53 | -- k: a = * 54 | -- k: f = * -> * 55 | 56 | -- String Processing 57 | 58 | -------------------------------------- 59 | 60 | -- 1. the / a 61 | 62 | splitWords :: String -> [String] 63 | splitWords string = 64 | go string [] 65 | where 66 | go [] acc = reverse acc 67 | go (x:xs) [] = go xs [[x]] 68 | go (x:xs) ht@(str@(y:_):ts) = 69 | if isLetter x == isLetter y 70 | then go xs ((str ++ [x]):ts) 71 | else go xs ([x]:ht) 72 | 73 | -- theRep :: String -> String 74 | -- theRep x = if x == "the" then "a" else x 75 | 76 | -- theA :: String -> String 77 | -- theA string = concatMap theRep $ splitWords string 78 | 79 | notThe :: String -> Maybe String 80 | notThe x = if x == "the" then Nothing else Just x 81 | 82 | nothA :: Maybe String -> String 83 | nothA x = case x of 84 | Nothing -> "a" 85 | Just x -> x 86 | 87 | replaceThe :: String -> String 88 | replaceThe x = concatMap (nothA . notThe) $ splitWords x 89 | 90 | ------------------------------------------------ 91 | 92 | -- 2. count "the" before vowel 93 | 94 | -- Creates Just for words 95 | justWords :: String -> Maybe String 96 | justWords w@(c:_) = if isLetter c then Just w else Nothing 97 | 98 | -- Filters Nothing out 99 | onlyJust :: [Maybe a] -> [a] 100 | onlyJust [] = [] 101 | onlyJust list = 102 | go list [] 103 | where 104 | go [] acc = reverse acc 105 | go (x:xs) acc = 106 | case x of 107 | Just x -> go xs (x:acc) 108 | Nothing -> go xs acc 109 | 110 | 111 | -- Counts "the" before vowels (only words present in list) 112 | countTheBeforeVowel' :: [String] -> Int 113 | countTheBeforeVowel' strings = 114 | go strings 0 115 | where 116 | go (_:[]) acc = acc 117 | go (aWord:bWord@(ch:_):tWords) acc = 118 | if aWord == "the" && ch `elem` "aeiou" 119 | then go (bWord:tWords) (acc + 1) 120 | else go (bWord:tWords) acc 121 | 122 | 123 | 124 | countTheBeforeVowel :: String -> Int 125 | countTheBeforeVowel x = countTheBeforeVowel' . onlyJust $ map justWords $ splitWords x 126 | 127 | ----------------------------------- 128 | 129 | -- 3. Return the number of letters that are vowels in a word 130 | 131 | -- Creates Just for words 132 | 133 | justVowels :: Char -> Maybe Char 134 | justVowels c = if c `elem` "aeiou" then Just c else Nothing 135 | 136 | countVowels :: String -> Integer 137 | countVowels x = toInteger . length . onlyJust $ map justVowels x 138 | 139 | --------------------------------------- 140 | 141 | -- Validate the word 142 | 143 | newtype Word' = 144 | Word' String 145 | deriving (Eq, Show) 146 | 147 | vowels = "aeiou" -- not used, had it in previous exercise 148 | 149 | mkWord :: String -> Maybe Word' 150 | mkWord x = if countVowels x > toInteger (length x) - countVowels x 151 | then Nothing 152 | else Just $ Word' x 153 | 154 | -------------------------------------- 155 | 156 | -- It's only natural 157 | 158 | data Nat = Zero 159 | | Succ Nat 160 | deriving (Eq, Show) 161 | 162 | natToInteger :: Nat -> Integer 163 | natToInteger x = 164 | case x of 165 | Zero -> 0 166 | Succ n -> succ $ natToInteger n 167 | 168 | integerToNat' :: Integer -> Nat 169 | integerToNat' x = if x == 0 170 | then Zero 171 | else Succ $ integerToNat' $ pred x 172 | 173 | integerToNat :: Integer -> Maybe Nat 174 | integerToNat x = if x < 0 175 | then Nothing 176 | else Just $ integerToNat' x 177 | 178 | ----------------------------------------- 179 | 180 | -- Small library for Maybe 181 | 182 | -- 1. Boolean tests 183 | 184 | isJust :: Maybe a -> Bool 185 | isJust Nothing = False 186 | isJust (Just _) = True 187 | 188 | isNothing :: Maybe a -> Bool 189 | isNothing = not . isJust 190 | 191 | -- 2. Maybe catamorphism 192 | 193 | mayybee :: b -> (a -> b) -> Maybe a -> b 194 | mayybee fallback f m = 195 | case m of 196 | Nothing -> fallback 197 | Just x -> f x 198 | 199 | -- 3. Fallback value 200 | 201 | fromMaybe :: a -> Maybe a -> a 202 | fromMaybe = flip mayybee id 203 | 204 | -- 4. Convert between List and Maybe 205 | 206 | listToMaybe :: [a] -> Maybe a 207 | listToMaybe [] = Nothing 208 | listToMaybe (x:_) = Just x 209 | 210 | maybeToList :: Maybe a -> [a] 211 | maybeToList Nothing = [] 212 | maybeToList (Just x) = [x] 213 | 214 | -- 5. Drop Nothings 215 | 216 | catMaybes :: [Maybe a] -> [a] 217 | catMaybes = onlyJust 218 | 219 | -- 6. "sequence" 220 | 221 | flipMaybe :: [Maybe a] -> Maybe [a] 222 | flipMaybe [] = Nothing 223 | flipMaybe list = 224 | go list [] 225 | where 226 | go [] acc = Just $ reverse acc 227 | go (x:xs) acc = 228 | case x of 229 | Just y -> go xs (y:acc) 230 | Nothing -> Nothing 231 | 232 | ----------------------------------- 233 | 234 | -- Small library for Either 235 | 236 | -- 1. Use foldr 237 | 238 | left' :: Either a b -> Maybe a 239 | left' (Left a) = Just a 240 | left' (Right _) = Nothing 241 | 242 | lefts'' :: [Either a b] -> [Maybe a] 243 | lefts'' = foldr (\ab acc -> acc ++ [left' ab]) [] 244 | 245 | lefts' :: [Either a b] -> [a] 246 | lefts' = catMaybes . lefts'' 247 | 248 | -- 2. Use foldr 249 | 250 | right' :: Either a b -> Maybe b 251 | right' (Left _) = Nothing 252 | right' (Right a) = Just a 253 | 254 | rights'' :: [Either a b] -> [Maybe b] 255 | rights'' = foldr (\ab acc -> acc ++ [right' ab]) [] 256 | 257 | rights' :: [Either a b] -> [b] 258 | rights' = catMaybes . rights'' 259 | 260 | -- 3. Partition Eithers 261 | 262 | partitionEithers' :: [Either a b] -> ([a], [b]) 263 | partitionEithers' xs = (lefts' xs, rights' xs) 264 | 265 | -- 4. eitherMaybe 266 | 267 | eitherMaybe' :: (b -> c) -> Either a b -> Maybe c 268 | eitherMaybe' f x = 269 | case x of 270 | Right b -> Just $ f b 271 | Left _ -> Nothing 272 | 273 | -- 5. General Either catamorphism 274 | 275 | either' :: (a -> c) -> (b -> c) -> Either a b -> c 276 | either' f g e = 277 | case e of 278 | Right b -> g b 279 | Left a -> f a 280 | 281 | -- 6. Use either' 282 | 283 | eitherMaybe'' :: (b -> c) -> Either a b -> Maybe c 284 | eitherMaybe'' f = either' (\x -> Nothing) (Just . f) 285 | 286 | -------------------------------------------------------------------------------- /src/Ch12Ex-unfolds.hs: -------------------------------------------------------------------------------- 1 | 2 | import Data.List 3 | import Data.Maybe 4 | 5 | -- Unfolds 6 | 7 | mehSum :: Num a => [a] -> a 8 | mehSum xs = go 0 xs 9 | where go :: Num a => a -> [a] -> a 10 | go n [] = n 11 | go n (x:xs) = go (n + x) xs 12 | 13 | niceSum :: Num a => [a] -> a 14 | niceSum = foldl' (+) 0 15 | 16 | mehProduct :: Num a => [a] -> a 17 | mehProduct xs = go 1 xs 18 | where go :: Num a => a -> [a] -> a 19 | go n [] = n 20 | go n (x:xs) = go (n * x) xs 21 | 22 | niceProduct :: Num a => [a] -> a 23 | niceProduct = foldl' (*) 1 24 | 25 | mehConcat :: [[a]] -> [a] 26 | mehConcat xs = go [] xs 27 | where go :: [a] -> [[a]] -> [a] 28 | go xs' [] = xs' 29 | go xs' (x:xs) = go (xs' ++ x) xs 30 | 31 | niceConcat :: [[a]] -> [a] 32 | niceConcat = foldr (++) [] 33 | 34 | ----------------------------------------- 35 | 36 | -- Write your own iterate and unfoldr 37 | 38 | -- 1. Write myIterate using direct recursion 39 | 40 | myIterate :: (a -> a) -> a -> [a] 41 | myIterate f x = x:(myIterate f (f x)) 42 | 43 | -- OMG I MADE IT WORK -> No need for the [], 44 | -- it will never be evaluated. 45 | 46 | -- 2. Write myUnfoldr using direct recursion 47 | 48 | myUnfoldr :: (b -> Maybe (a, b)) -> b -> [a] 49 | myUnfoldr f x = 50 | case (f x) of 51 | Just (a, b) -> a : myUnfoldr f b 52 | Nothing -> [] 53 | 54 | -- IN YOUR FACE 55 | 56 | -- 3. Stuff that. Rewrite myIterate using unfoldr 57 | 58 | betterIterate :: (a -> a) -> a -> [a] 59 | betterIterate f = unfoldr (\x -> Just (x, f x)) 60 | 61 | ---------------------------------------------- 62 | 63 | -- Binary Tree 64 | 65 | data BinaryTree a = Leaf 66 | | Node (BinaryTree a) a (BinaryTree a) 67 | deriving (Eq, Ord, Show) 68 | 69 | -- 1. Write unfold for BinaryTree 70 | 71 | unfold :: (a -> Maybe (a, b, a)) -> a -> BinaryTree b 72 | unfold f x = 73 | case (f x) of 74 | Nothing -> Leaf 75 | Just (a, b, c) -> Node (unfold f a) b (unfold f c) 76 | 77 | -- 2. Tree builder 78 | 79 | treeBuild :: Integer -> BinaryTree Integer 80 | treeBuild n = 81 | unfold (\x -> if x >= n 82 | then Nothing 83 | else Just (x+1, x, x+1)) 0 84 | -------------------------------------------------------------------------------- /src/Ch13Ex.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Exercises 2 & 3 3 | 4 | import Control.Monad 5 | import System.Exit (exitSuccess) 6 | import Data.Char (toLower, isLetter) 7 | import System.IO 8 | 9 | 10 | palindrome :: IO () -- doesn't like haskell-mode (emacs) 11 | palindrome = forever $ do 12 | line1 <- getLine 13 | case (standardise line1 == reverse (standardise line1)) of 14 | True -> putStrLn "It's a palindrome!" 15 | False -> do 16 | putStrLn "Nope!" 17 | exitSuccess 18 | 19 | 20 | standardise :: String -> String 21 | standardise = (filter isLetter) . (map toLower) 22 | 23 | -- Exercise 4 24 | 25 | type Name = String 26 | type Age = Integer 27 | 28 | data Person = Person Name Age deriving Show 29 | 30 | data PersonInvalid = NameEmpty 31 | | AgeTooLow 32 | | PersonInvalidUnknown String 33 | deriving (Eq, Show) 34 | 35 | mkPerson :: Name 36 | -> Age 37 | -> Either PersonInvalid Person 38 | mkPerson name age 39 | | name /= "" && age > 0 = Right $ Person name age 40 | | name == "" = Left NameEmpty 41 | | not (age > 0) = Left AgeTooLow 42 | | otherwise = Left $ PersonInvalidUnknown $ 43 | "Name was: " ++ show name ++ 44 | " Age was: " ++ show age 45 | 46 | ---- 47 | 48 | gimmePerson :: IO () 49 | gimmePerson = do 50 | hSetBuffering stdout NoBuffering 51 | putStr "Enter NAME: " 52 | name <- getLine 53 | putStr "Enter AGE: " 54 | age <- getLine 55 | case mkPerson name (read age) of 56 | Right (Person name age) -> do 57 | putStr "Yay! Successfully got a person: " 58 | putStrLn $ (show name) ++ " " ++ (show age) 59 | Left error -> do 60 | putStr "Error: " 61 | putStrLn (show error) 62 | -------------------------------------------------------------------------------- /src/Ch14Ex-tests.hs: -------------------------------------------------------------------------------- 1 | 2 | import Test.QuickCheck 3 | import Data.List (sort) 4 | import Data.Char (toUpper) 5 | 6 | -- Exercises: using QuickCheck 7 | 8 | -- 1. Division 9 | 10 | divisor :: Gen Float 11 | divisor = arbitrary `suchThat` (/= 0) 12 | 13 | half x = x / 2 14 | halfIdentity = (*2) . half 15 | 16 | prop_half :: Property 17 | prop_half = 18 | forAll divisor 19 | (\x -> (half x) * 2 == x) 20 | 21 | prop_identity :: Property 22 | prop_identity = 23 | forAll divisor 24 | (\x -> (halfIdentity x) == x) 25 | 26 | -- 2. Sorting 27 | 28 | genList :: (Arbitrary a, Eq a) => Gen [a] 29 | genList = do 30 | a <- arbitrary 31 | b <- arbitrary `suchThat` (/= a) 32 | c <- arbitrary `suchThat` (`notElem` [a, b]) 33 | return [a, b, c] 34 | 35 | listOrdered :: (Ord a) => [a] -> Bool 36 | listOrdered xs = snd $ foldr go (Nothing, True) xs 37 | where go y (Nothing, t) = (Just y, t) 38 | go y (Just x, t) = (Just y, x >= y) 39 | 40 | prop_listOrdered :: Property 41 | prop_listOrdered = 42 | forAll (genList :: Gen String) 43 | (\x -> listOrdered $ sort x) 44 | 45 | -- 3. Addition 46 | 47 | associative :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool 48 | associative f x y z = x `f` (y `f` z) == (x `f` y) `f` z 49 | 50 | commutative :: Eq a => (a -> a -> a) -> a -> a -> Bool 51 | commutative f x y = x `f` y == y `f` x 52 | 53 | genTuple :: (Arbitrary a, Arbitrary b) => Gen (a, b) 54 | genTuple = arbitrary 55 | 56 | genThreeple :: (Arbitrary a, Arbitrary b, Arbitrary c) => 57 | Gen (a, b, c) 58 | genThreeple = arbitrary 59 | 60 | untrurry :: (a -> b -> c -> d) -> ((a, b, c) -> d) 61 | untrurry f (a, b, c) = f a b c 62 | 63 | prop_plusAssoc :: Property 64 | prop_plusAssoc = 65 | forAll (genThreeple :: Gen (Int, Int, Int)) 66 | (untrurry $ associative (+)) 67 | 68 | prop_plusComm :: Property 69 | prop_plusComm = 70 | forAll (genTuple :: Gen (Int, Int)) 71 | (uncurry $ commutative (+)) 72 | 73 | -- 4. Multiplication 74 | 75 | prop_timesAssoc :: Property 76 | prop_timesAssoc = 77 | forAll (genThreeple :: Gen (Int, Int, Int)) 78 | (untrurry $ associative (*)) 79 | 80 | prop_timesComm :: Property 81 | prop_timesComm = 82 | forAll (genTuple :: Gen (Int, Int)) 83 | (uncurry $ commutative (*)) 84 | 85 | -- 5. div vs mod 86 | 87 | quotVsRem :: Integral a => a -> a -> Bool 88 | quotVsRem x y = (quot x y) * y + (rem x y) == x 89 | 90 | divVsMod :: Integral a => a -> a -> Bool 91 | divVsMod x y = (div x y) * y + (mod x y) == x 92 | 93 | genTupleNonZero :: (Arbitrary a, Num a, Eq a) => Gen (a, a) 94 | genTupleNonZero = do 95 | x <- arbitrary `suchThat` (/= 0) 96 | y <- arbitrary `suchThat` (/= 0) 97 | return (x, y) 98 | 99 | prop_quotRem :: Property 100 | prop_quotRem = 101 | forAll (genTupleNonZero :: Gen (Int, Int)) 102 | (uncurry quotVsRem) 103 | 104 | prop_divMod :: Property 105 | prop_divMod = 106 | forAll (genTupleNonZero :: Gen (Int, Int)) 107 | (uncurry divVsMod) 108 | 109 | -- 6. (^) 110 | 111 | genTuplePos :: (Arbitrary a, Num a, Ord a) => Gen (a, a) 112 | genTuplePos = do 113 | x <- arbitrary `suchThat` (> 1) 114 | y <- arbitrary `suchThat` (> 1) 115 | return (x, y) 116 | 117 | genThreeplePos :: (Arbitrary a, Num a, Ord a) => Gen (a, a, a) 118 | genThreeplePos = do 119 | x <- arbitrary `suchThat` (> 1) 120 | y <- arbitrary `suchThat` (> 1) 121 | z <- arbitrary `suchThat` (> 1) 122 | return (x, y, z) 123 | 124 | prop_hatAssoc :: Property 125 | prop_hatAssoc = 126 | forAll (genThreeplePos :: Gen (Int, Int, Int)) 127 | (untrurry $ associative (^)) 128 | 129 | prop_hatComm :: Property 130 | prop_hatComm = 131 | forAll (genTuplePos :: Gen (Int, Int)) 132 | (uncurry $ commutative (^)) 133 | 134 | -- 7. reverse reverse list == list 135 | 136 | prop_reverse :: Property 137 | prop_reverse = 138 | forAll (genList :: Gen [Int]) 139 | (\x -> (reverse . reverse) x == id x) 140 | 141 | -- 8. ($) 142 | 143 | prop_dollar :: Property 144 | prop_dollar = 145 | forAll divisor 146 | (\x -> ((-) x $ x + x) == (-) x (x + x)) 147 | 148 | -- 9. Check functions 149 | 150 | prop_concat :: Property 151 | prop_concat = 152 | forAll (genTuple :: Gen ([Int], [Int])) 153 | (\(x, y) -> foldr (:) y x == (++) x y) 154 | 155 | prop_concat' :: Property 156 | prop_concat' = 157 | forAll (genTuple :: Gen ([Int], [Int])) 158 | (\(x, y) -> foldr (++) [] [x, y] == concat [x, y]) 159 | 160 | -- 10. Check property 161 | 162 | prop_lengthTake :: Property 163 | prop_lengthTake = 164 | forAll (genTuple :: Gen (Int, [Int])) 165 | (\(n, xs) -> length (take n xs) == n) 166 | 167 | -- 11. show . read 168 | 169 | prop_showRead :: Property 170 | prop_showRead = 171 | forAll (genList :: Gen String) 172 | (\x -> (read (show x)) == x) 173 | 174 | -- Failure 175 | 176 | genPos :: (Num a, Arbitrary a, Ord a) => Gen a 177 | genPos = arbitrary `suchThat` (> 0) 178 | 179 | square x = x * x 180 | squareId = square . sqrt 181 | 182 | prop_square :: Property 183 | prop_square = 184 | forAll (genPos :: Gen Float) 185 | (\x -> squareId x == x) 186 | 187 | -- Idempotence 188 | 189 | twice f = f . f 190 | fourTimes = twice . twice 191 | 192 | capitalizeWord :: String -> String 193 | capitalizeWord = map toUpper 194 | 195 | prop_capitalizeWord :: Property 196 | prop_capitalizeWord = 197 | forAll (genList :: Gen String) 198 | (\x -> capitalizeWord x == twice capitalizeWord x 199 | && 200 | capitalizeWord x == fourTimes capitalizeWord x) 201 | 202 | prop_sort :: Property 203 | prop_sort = 204 | forAll (genList :: Gen String) 205 | (\x -> sort x == twice sort x 206 | && 207 | sort x == fourTimes sort x) 208 | 209 | -- Make Gen for Fool 210 | 211 | data Fool = Fulse | Frue deriving (Eq, Show) 212 | 213 | -- 1. Equal probabilities 214 | 215 | genFool :: Gen Fool 216 | genFool = elements [Fulse, Frue] 217 | 218 | -- 2. 2/3 Fulse, 1/3 Frue 219 | 220 | genUnfair :: Gen Fool 221 | genUnfair = elements [Frue, Fulse, Fulse] 222 | 223 | -- Main 224 | 225 | main :: IO () 226 | main = do 227 | putStrLn "\nhalf" 228 | quickCheck prop_half 229 | putStrLn "\nhalfIdentity" 230 | quickCheck prop_identity 231 | putStrLn "\nCheck ordering" 232 | quickCheck prop_listOrdered 233 | putStrLn "\nCheck plusAssociative" 234 | quickCheck prop_plusAssoc 235 | putStrLn "\nCheck plusCommutative" 236 | quickCheck prop_plusComm 237 | putStrLn "\nCheck timesAssociative" 238 | quickCheck prop_timesAssoc 239 | putStrLn "\nCheck timesCommutative" 240 | quickCheck prop_timesComm 241 | putStrLn "\nCheck quotVsRem" 242 | quickCheck prop_quotRem 243 | putStrLn "\nCheck divVsMod" 244 | quickCheck prop_divMod 245 | putStrLn "\nCheck if exponentiation is commutative" 246 | quickCheck prop_hatComm 247 | putStrLn "\nCheck if exponentiation is associative" 248 | quickCheck prop_hatAssoc 249 | putStrLn "\nCheck if reverse . reverse == id" 250 | quickCheck prop_reverse 251 | putStrLn "\nCheck ($)" 252 | quickCheck prop_dollar 253 | putStrLn "\nCompare foldr (:) and (++)" 254 | quickCheck prop_concat 255 | putStrLn "\nCompare foldr (++) [] and concat" 256 | quickCheck prop_concat' 257 | putStrLn "\nCheck length n take == n" 258 | quickCheck prop_lengthTake 259 | putStrLn "\nCheck show . read == id" 260 | quickCheck prop_showRead 261 | putStrLn "\nCheck square . sqrt with Float" 262 | quickCheck prop_square 263 | putStrLn "\nCheck idempotence capitalizeWord" 264 | quickCheck prop_capitalizeWord 265 | putStrLn "\nCheck idempotence sort" 266 | quickCheck prop_sort 267 | -------------------------------------------------------------------------------- /src/Ch15-Monoids.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad 3 | import Data.Monoid 4 | import Test.QuickCheck 5 | 6 | data Booly a = False' 7 | | True' 8 | deriving (Eq, Show) 9 | 10 | instance Monoid (Booly a) where 11 | mempty = False' 12 | mappend False' _ = False' 13 | mappend _ False' = False' 14 | mappend True' True' = True' 15 | 16 | data Optional a = Nada 17 | | Only a 18 | deriving (Eq, Show) 19 | 20 | -- sample (genOnly :: Gen (Optional String)) 21 | genOnly :: Arbitrary a => Gen (Optional a) 22 | genOnly = do 23 | x <- arbitrary 24 | return $ Only x 25 | 26 | instance Arbitrary a => Arbitrary (Optional a) where 27 | arbitrary = 28 | frequency [ (1, genOnly) 29 | , (1, return Nada) ] 30 | 31 | 32 | instance Monoid a => Monoid (Optional a) where 33 | mempty = Nada 34 | mappend Nada (Only a) = Only a 35 | mappend (Only a) Nada = Only a 36 | mappend (Only a) (Only a') = Only (a <> a') 37 | mappend Nada Nada = Nada 38 | 39 | --- 40 | 41 | type Verb = String 42 | type Adjective = String 43 | type Adverb = String 44 | type Noun = String 45 | type Exclamation = String 46 | 47 | madlibbin' :: Exclamation 48 | -> Adverb 49 | -> Noun 50 | -> Adjective 51 | -> String 52 | madlibbin' e adv noun adj = 53 | e <> "! he said " <> 54 | adv <> " as he jumped into his car " <> 55 | noun <> " and drove off with his " <> 56 | adj <> " wife." 57 | 58 | madlibbinBetter' :: Exclamation 59 | -> Adverb 60 | -> Noun 61 | -> Adjective 62 | -> String 63 | madlibbinBetter' e adv noun adj = mconcat [e, 64 | "! he said ", 65 | adv, 66 | " as he jumped into his car ", 67 | noun, 68 | " and drove off with his ", 69 | adj, 70 | " wife."] 71 | 72 | ---- 73 | 74 | monoidAssoc :: (Eq m, Monoid m) => m -> m -> m -> Bool 75 | monoidAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c) 76 | 77 | monoidLeftIdentity :: (Eq m, Monoid m) => m -> Bool 78 | monoidLeftIdentity a = (a <> mempty) == a 79 | 80 | monoidRightIdentity :: (Eq m, Monoid m) => m -> Bool 81 | monoidRightIdentity a = (mempty <> a) == a 82 | 83 | type S = String 84 | type B = Bool 85 | 86 | data Bull = Fools 87 | | Twoo 88 | deriving (Eq, Show) 89 | 90 | instance Arbitrary Bull where 91 | arbitrary = 92 | frequency [ (1, return Fools) 93 | , (1, return Twoo) ] 94 | 95 | instance Monoid Bull where 96 | mempty = Fools 97 | mappend _ _ = Fools 98 | 99 | type BullMappend = Bull -> Bull -> Bull -> Bool 100 | 101 | -- main :: IO () 102 | -- main = do 103 | -- quickCheck (monoidAssoc :: BullMappend) 104 | -- quickCheck (monoidLeftIdentity :: Bull -> Bool) 105 | -- quickCheck (monoidRightIdentity :: Bull -> Bool) 106 | 107 | ---- 108 | 109 | newtype First' a = 110 | First' { getFirst' :: Optional a } 111 | deriving (Eq, Show) 112 | 113 | instance Monoid (First' a) where 114 | mempty = (First' { getFirst' = Nada }) 115 | mappend (First' { getFirst' = Nada }) 116 | (First' { getFirst' = Nada }) = 117 | (First' { getFirst' = Nada }) 118 | mappend (First' { getFirst' = Nada }) 119 | (First' { getFirst' = Only a }) = 120 | (First' { getFirst' = Only a}) 121 | mappend (First' { getFirst' = Only a }) 122 | (First' { getFirst' = Nada }) = 123 | (First' { getFirst' = Only a }) 124 | mappend (First' { getFirst' = Only a }) 125 | (First' { getFirst' = Only _ }) = 126 | (First' { getFirst' = Only a }) 127 | 128 | firstMappend :: First' a -> First' a -> First' a 129 | firstMappend = mappend 130 | 131 | type FirstMappend = First' String 132 | -> First' String 133 | -> First' String 134 | -> Bool 135 | 136 | genFirst :: Arbitrary a => Gen (First' a) 137 | genFirst = do 138 | x <- arbitrary 139 | return First' { getFirst' = x } 140 | 141 | instance Arbitrary a => Arbitrary (First' a) where 142 | arbitrary = genFirst 143 | 144 | 145 | main :: IO () 146 | main = do 147 | quickCheck (monoidAssoc :: FirstMappend) 148 | quickCheck (monoidLeftIdentity :: First' String -> Bool) 149 | quickCheck (monoidRightIdentity :: First' String -> Bool) 150 | -------------------------------------------------------------------------------- /src/Ch15Ex-Mem.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid (mempty, mappend) 2 | 3 | -- 8. Mem 4 | newtype Mem s a = 5 | Mem { 6 | runMem :: s -> (a,s) 7 | } 8 | 9 | instance Monoid a => Monoid (Mem s a) where 10 | mempty = Mem $ \s -> (mempty, s) 11 | mappend (Mem f) (Mem f') = 12 | Mem $ \s -> let (firstA, firstS) = f' s 13 | (secondA, secondS) = f firstS in 14 | (mappend firstA secondA, secondS) 15 | 16 | f' = Mem $ \s -> ("hi", s + 1) 17 | 18 | checkMem = do 19 | let 20 | -- We give runMem the neutral element (mempty) of the monoid Mem, 21 | -- then we fix Mem's first type variable s to Integer using 0. 22 | -- runMem is now (a -> (a, Integer)) meaning Mem's a is still unbound, 23 | -- but according to Mem's monoid instance that a has to have a 24 | -- monoid instance, too. Since we passed Mem's mempty to runMem, 25 | -- the value of a will be a's mempty; that's how mempty is 26 | -- defined in Mem's monoid instance. 27 | -- Later, with rmzero :: (String, Int), we fix a to String. String's 28 | -- mempty is "", yielding ("",0) 29 | rmzero = runMem mempty 0 30 | rmleft = runMem (f' `mappend` mempty) 0 31 | rmright = runMem (mempty `mappend` f') 0 32 | -- ("hi",1) 33 | print $ rmleft 34 | -- ("hi",1) 35 | print $ rmright 36 | -- ("",0) 37 | print (rmzero :: (String, Int)) 38 | -- True 39 | print $ rmleft == runMem f' 0 40 | -- True 41 | print $ rmright == runMem f' 0 42 | -------------------------------------------------------------------------------- /src/Ch15Ex-Monoid.hs: -------------------------------------------------------------------------------- 1 | 2 | import Data.Monoid (Monoid, mempty, mappend, Sum(..), getSum) 3 | import Data.Semigroup (Semigroup, (<>)) 4 | import Test.QuickCheck (Arbitrary, 5 | arbitrary, 6 | elements, 7 | Gen, 8 | quickCheck) 9 | 10 | -- Monoid exercises 11 | 12 | -- Semigroup and Monoid tests 13 | 14 | semigroupAssoc :: (Eq s, Semigroup s) => s -> s -> s -> Bool 15 | semigroupAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c) 16 | 17 | monoidLeftIdentity :: (Eq m, Monoid m, Semigroup m) => m -> Bool 18 | monoidLeftIdentity a = (a <> mempty) == a 19 | 20 | monoidRightIdentity :: (Eq m, Monoid m, Semigroup m) => m -> Bool 21 | monoidRightIdentity a = (mempty <> a) == a 22 | 23 | -- 1. Trivial 24 | 25 | data Trivial = Trivial deriving (Eq, Show) 26 | 27 | instance Semigroup Trivial where 28 | _ <> _ = Trivial 29 | 30 | instance Monoid Trivial where 31 | mempty = Trivial 32 | mappend = (<>) 33 | 34 | instance Arbitrary Trivial where 35 | arbitrary = return Trivial 36 | 37 | type TrivialAssoc = Trivial -> Trivial -> Trivial -> Bool 38 | 39 | -- 2. Identity 40 | 41 | newtype Identity a = Identity a deriving Show 42 | 43 | -- Id Instances 44 | 45 | instance Semigroup a => Semigroup (Identity a) where 46 | Identity a <> Identity a' = Identity (a <> a') 47 | 48 | instance (Monoid a, Semigroup a) => Monoid (Identity a) where 49 | mempty = Identity mempty 50 | mappend = (<>) 51 | 52 | instance Eq a => Eq (Identity a) where 53 | Identity a == Identity a' = a == a' 54 | 55 | instance (Arbitrary a, Monoid a, Semigroup a) => 56 | Arbitrary (Identity a) where 57 | arbitrary = genId 58 | 59 | -- ID generator 60 | 61 | genId :: Arbitrary a => Gen (Identity a) 62 | genId = do 63 | x <- arbitrary 64 | return $ Identity x 65 | 66 | type S = String 67 | type Id = Identity 68 | type IdAssoc = Id S -> Id S -> Id S -> Bool 69 | 70 | -- test ID 71 | 72 | testIdEq :: Eq a => Id a -> Id a -> Bool 73 | testIdEq x x' = (\ (Identity a) (Identity a') -> a == a') x x' == (x == x') 74 | 75 | -- 3. Two 76 | 77 | data Two a b = Two a b deriving Show 78 | 79 | -- Two Instances 80 | 81 | instance (Semigroup a, Semigroup b) => Semigroup (Two a b) where 82 | Two a b <> Two a' b' = Two (a <> a') (b <> b') 83 | 84 | instance (Monoid a, Monoid b, Semigroup a, Semigroup b) => 85 | Monoid (Two a b) where 86 | mempty = Two mempty mempty 87 | mappend = (<>) 88 | 89 | instance (Eq a, Eq b) => Eq (Two a b) where 90 | Two a b == Two a' b' = (a == a') && (b == b') 91 | 92 | instance (Arbitrary a, Monoid a, Semigroup a, 93 | Arbitrary b, Monoid b, Semigroup b) => 94 | Arbitrary (Two a b) where 95 | arbitrary = genTwo 96 | 97 | genTwo :: (Arbitrary a, Arbitrary b) => Gen (Two a b) 98 | genTwo = do 99 | a <- arbitrary 100 | b <- arbitrary 101 | return $ Two a b 102 | 103 | -- test Two 104 | 105 | type TwoAssoc = Two S S -> Two S S -> Two S S -> Bool 106 | 107 | testTwoEq :: (Eq a, Eq b) => Two a b -> Two a b -> Bool 108 | testTwoEq x x' = (\ (Two a b) (Two a' b') -> (a == a') && (b == b')) x x' == 109 | (x == x') 110 | 111 | -- 4. BoolConj 112 | 113 | newtype BoolConj = BoolConj Bool 114 | 115 | instance Semigroup BoolConj where 116 | BoolConj True <> BoolConj True = BoolConj True 117 | BoolConj _ <> BoolConj _ = BoolConj False 118 | 119 | instance Monoid BoolConj where 120 | mempty = BoolConj True 121 | mappend = (<>) 122 | 123 | instance Eq BoolConj where 124 | BoolConj a == BoolConj a' = a == a' 125 | 126 | instance Show BoolConj where 127 | show (BoolConj a) = "BoolConj " ++ show a 128 | 129 | instance Arbitrary BoolConj where 130 | arbitrary = genBConj 131 | 132 | genBConj :: Gen BoolConj 133 | genBConj = elements [BoolConj False, BoolConj True] 134 | 135 | -- test BoolConj 136 | 137 | type BCAssoc = BoolConj -> BoolConj -> BoolConj -> Bool 138 | 139 | testBCEq :: BoolConj -> BoolConj -> Bool 140 | testBCEq x x' = (\ (BoolConj a) (BoolConj b) -> a == b) x x' == (x == x') 141 | 142 | testBCShow :: BoolConj -> Bool 143 | testBCShow x = (\ (BoolConj a) -> "BoolConj " ++ show a) x == show x 144 | 145 | testBC :: BoolConj -> BoolConj -> Bool 146 | testBC x x' = (\ (BoolConj a) (BoolConj b) -> a && b) x x' == 147 | (\ (BoolConj a) -> a) (x <> x') 148 | 149 | -- 5. BoolDisj 150 | 151 | newtype BoolDisj = BoolDisj Bool 152 | 153 | instance Semigroup BoolDisj where 154 | BoolDisj False <> BoolDisj False = BoolDisj False 155 | BoolDisj _ <> BoolDisj _ = BoolDisj True 156 | 157 | instance Monoid BoolDisj where 158 | mempty = BoolDisj False 159 | mappend = (<>) 160 | 161 | instance Eq BoolDisj where 162 | BoolDisj a == BoolDisj a' = a == a' 163 | 164 | instance Show BoolDisj where 165 | show (BoolDisj a) = "BoolDisj " ++ show a 166 | 167 | instance Arbitrary BoolDisj where 168 | arbitrary = genBDisj 169 | 170 | genBDisj :: Gen BoolDisj 171 | genBDisj = elements [BoolDisj False, BoolDisj True] 172 | 173 | -- test BoolDisj 174 | 175 | type BDAssoc = BoolDisj -> BoolDisj -> BoolDisj -> Bool 176 | 177 | testBDEq :: BoolDisj -> BoolDisj -> Bool 178 | testBDEq x x' = (\ (BoolDisj a) (BoolDisj b) -> a == b) x x' == (x == x') 179 | 180 | testBDShow :: BoolDisj -> Bool 181 | testBDShow x = (\ (BoolDisj a) -> "BoolDisj " ++ show a) x == show x 182 | 183 | testBD :: BoolDisj -> BoolDisj -> Bool 184 | testBD x x' = (\ (BoolDisj a) (BoolDisj b) -> a || b) x x' == 185 | (\ (BoolDisj a) -> a) (x <> x') 186 | 187 | -- 6. Or 188 | 189 | data Or a b = Fst a | Snd b deriving (Eq, Show) 190 | 191 | instance Semigroup (Or a b) where 192 | Fst _ <> Snd x = Snd x 193 | Fst _ <> Fst x = Fst x 194 | Snd x <> Fst _ = Snd x 195 | Snd x <> Snd _ = Snd x 196 | 197 | instance Monoid a => Monoid (Or a b) where 198 | mempty = Fst mempty 199 | mappend = (<>) 200 | 201 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Or a b) where 202 | arbitrary = genOr 203 | 204 | genOr :: (Arbitrary a, Arbitrary b) => Gen (Or a b) 205 | genOr = do 206 | a <- arbitrary 207 | b <- arbitrary 208 | elements [Fst a, Snd b] 209 | 210 | --Doesn't quickCheck --NOTE LeftAssociativity not working 211 | testOr :: (Eq a, Eq b) => Or a b -> Or a b -> Bool 212 | testOr x x' = case (x, x') of 213 | (Fst _, Snd a) -> x <> x' == Snd a 214 | (Fst _, Fst a) -> x <> x' == Fst a 215 | (Snd a, Fst _) -> x <> x' == Snd a 216 | (Snd a, Snd _) -> x <> x' == Snd a 217 | 218 | type OrAssoc = Or S S -> Or S S -> Or S S -> Bool 219 | 220 | -- 7. Combine 221 | 222 | newtype Combine a b = Combine { unCombine :: (a -> b) } 223 | 224 | instance Semigroup b => Semigroup (Combine a b) where 225 | Combine f <> Combine g = Combine (f <> g) 226 | 227 | instance (Monoid b, Semigroup b) => Monoid (Combine a b) where 228 | mempty = Combine mempty 229 | mappend = (<>) 230 | 231 | -- 8. Comp 232 | 233 | newtype Comp a = Comp (a -> a) 234 | 235 | instance Semigroup a => Semigroup (Comp a) where 236 | Comp f <> Comp g = Comp (f <> g) 237 | 238 | instance (Monoid a, Semigroup a) => Monoid (Comp a) where 239 | mempty = Comp mempty 240 | mappend = (<>) 241 | 242 | -- 9. Mem Copy and run in new file 243 | --import Data.Monoid 244 | --newtype Mem s a = 245 | -- Mem { 246 | -- runMem :: s -> (a,s) 247 | -- } 248 | 249 | -- instance Monoid a => Monoid (Mem s a) where 250 | -- mempty = Mem $ (\s -> (mempty,s)) 251 | -- mappend (Mem {runMem = f}) (Mem {runMem = g}) = 252 | -- Mem $ (\x -> let 253 | -- (u,q) = f x 254 | -- (v,w) = g q 255 | -- in 256 | -- (u <> v,w)) 257 | 258 | 259 | -- f' = Mem $ (\s -> ("hi",s+1)) 260 | 261 | -- testMem = do 262 | -- print $ runMem (f' <> mempty) 0 263 | -- print $ runMem (mempty <> f') 0 264 | -- print $ (runMem mempty 0 :: (String,Int)) 265 | -- print $ runMem (f' <> mempty) 0 == runMem f' 0 266 | -- print $ runMem (mempty <> f') 0 == runMem f' 0 267 | 268 | -- main 269 | 270 | main :: IO () 271 | main = do 272 | putStrLn "\n Trivial" 273 | quickCheck (semigroupAssoc :: TrivialAssoc) 274 | quickCheck (monoidLeftIdentity :: Trivial -> Bool) 275 | quickCheck (monoidRightIdentity :: Trivial -> Bool) 276 | putStrLn "\n Identity" 277 | quickCheck (semigroupAssoc :: IdAssoc) 278 | quickCheck (monoidLeftIdentity :: Id S -> Bool) 279 | quickCheck (monoidRightIdentity :: Id S -> Bool) 280 | quickCheck (testIdEq :: Id S -> Id S -> Bool) 281 | putStrLn "\n Two" 282 | quickCheck (semigroupAssoc :: TwoAssoc) 283 | quickCheck (monoidLeftIdentity :: Two S S -> Bool) 284 | quickCheck (monoidRightIdentity :: Two S S -> Bool) 285 | quickCheck (testTwoEq :: Two S S -> Two S S -> Bool) 286 | putStrLn "\n BoolConj" 287 | quickCheck (semigroupAssoc :: BCAssoc) 288 | quickCheck (monoidLeftIdentity :: BoolConj -> Bool) 289 | quickCheck (monoidRightIdentity :: BoolConj -> Bool) 290 | quickCheck (testBCEq :: BoolConj -> BoolConj -> Bool) 291 | quickCheck (testBCShow :: BoolConj -> Bool) 292 | quickCheck (testBC :: BoolConj -> BoolConj -> Bool) 293 | putStrLn "\n BoolDisj" 294 | quickCheck (semigroupAssoc :: BDAssoc) 295 | quickCheck (monoidLeftIdentity :: BoolDisj -> Bool) 296 | quickCheck (monoidRightIdentity :: BoolDisj -> Bool) 297 | quickCheck (testBDEq :: BoolDisj -> BoolDisj -> Bool) 298 | quickCheck (testBDShow :: BoolDisj -> Bool) 299 | quickCheck (testBD :: BoolDisj -> BoolDisj -> Bool) 300 | putStrLn "\n Or" 301 | quickCheck (semigroupAssoc :: OrAssoc) 302 | putStrLn "No left identity, as Fst a <> Fst b = Fst b" 303 | quickCheck (monoidLeftIdentity :: Or S S -> Bool) 304 | quickCheck (monoidRightIdentity :: Or S S -> Bool) 305 | quickCheck (testOr :: Or S S -> Or S S -> Bool) 306 | -------------------------------------------------------------------------------- /src/Ch16-Functor.hs: -------------------------------------------------------------------------------- 1 | 2 | module ReplaceExperiment where 3 | 4 | import Data.Functor ((<$>)) 5 | 6 | replaceWithP :: b -> Char 7 | replaceWithP = const 'p' 8 | 9 | lms :: [Maybe [Char]] 10 | lms = [Just "Ave", Nothing, Just "woohoo"] 11 | 12 | replaceWithP' :: [Maybe [Char]] -> Char 13 | replaceWithP' = replaceWithP 14 | 15 | liftedReplace :: Functor f => f a -> f Char 16 | liftedReplace = fmap replaceWithP 17 | 18 | liftedReplace' :: [Maybe [Char]] -> [Char] 19 | liftedReplace' = liftedReplace 20 | 21 | twiceLifted :: (Functor f1, Functor f) => 22 | f (f1 a) -> f (f1 Char) 23 | twiceLifted = (fmap . fmap) replaceWithP 24 | 25 | twiceLifted' :: [Maybe [Char]] -> [Maybe Char] 26 | twiceLifted' = twiceLifted 27 | 28 | thriceLifted :: (Functor f2, Functor f1, Functor f) => 29 | f (f1 (f2 a)) -> f (f1 (f2 Char)) 30 | thriceLifted = (fmap . fmap . fmap) replaceWithP 31 | 32 | thriceLifted' :: [Maybe [Char]] -> [Maybe [Char]] 33 | thriceLifted' = thriceLifted 34 | 35 | main :: IO () 36 | main = do 37 | putStr "replaceWithP' lms: " 38 | print (replaceWithP' lms) 39 | putStr "liftedReplace lms: " 40 | print (liftedReplace lms) 41 | putStr "liftedReplace' lms: " 42 | print (liftedReplace' lms) 43 | putStr "twiceLifted lms: " 44 | print (twiceLifted lms) 45 | putStr "twiceLifted' lms: " 46 | print (twiceLifted' lms) 47 | putStr "thriceLifted lms: " 48 | print (thriceLifted lms) 49 | putStr "thriceLifted' lms: " 50 | print (thriceLifted' lms) 51 | 52 | -- Lifting 53 | 54 | a = (+1) <$> read "[1]" :: [Int] 55 | 56 | b = (fmap . fmap) (++ "lol") (Just ["Hi,", "Hello"]) 57 | 58 | c = fmap (* 2) (\x -> x - 2) 59 | 60 | d = fmap ((return '1' ++) . show) (\x -> [x, 1..3]) 61 | 62 | e :: IO Integer 63 | e = let ioi = readIO "1" :: IO Integer 64 | changed = fmap (read . ("123"++) . show) ioi 65 | in fmap (* 3) changed 66 | 67 | -- 16.8 68 | 69 | data Two a b = Two a b deriving (Eq, Show) 70 | 71 | data Or a b = First a | Second b deriving (Eq, Show) 72 | 73 | instance Functor (Two a) where 74 | fmap f (Two a b) = Two a (f b) 75 | 76 | instance Functor (Or a) where 77 | fmap _ (First a) = First a 78 | fmap f (Second b) = Second (f b) 79 | 80 | -------------------------------------------------------------------------------- /src/Ch16-FunctorQuickCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Function 5 | 6 | -- 16.9 7 | 8 | functorIdentity :: (Functor f, Eq (f a)) => 9 | f a -> Bool 10 | functorIdentity f = fmap id f == f 11 | 12 | functorCompose :: (Eq (f c), Functor f) => 13 | (a -> b) 14 | -> (b -> c) 15 | -> f a 16 | -> Bool 17 | functorCompose f g x = (fmap g (fmap f x)) == (fmap (g . f) x) 18 | 19 | functorCompose' :: (Eq (f c), Functor f) => 20 | f a 21 | -> Fun a b 22 | -> Fun b c 23 | -> Bool 24 | functorCompose' x (Fun _ f) (Fun _ g) = 25 | (fmap (g . f) x) == (fmap g . fmap f $ x) 26 | 27 | -- 1. 28 | 29 | newtype Identity a = Identity a deriving (Eq, Show) 30 | 31 | instance Functor Identity where 32 | fmap f (Identity a) = Identity (f a) 33 | 34 | genId :: Arbitrary a => Gen (Identity a) 35 | genId = do 36 | x <- arbitrary 37 | return $ Identity x 38 | 39 | instance Arbitrary a => Arbitrary (Identity a) where 40 | arbitrary = genId 41 | 42 | -- 2. 43 | 44 | data Pair a = Pair a a deriving (Eq, Show) 45 | 46 | instance Functor Pair where 47 | fmap f (Pair a b) = Pair (f a) (f b) 48 | 49 | genPair :: Arbitrary a => Gen (Pair a) 50 | genPair = do 51 | x <- arbitrary 52 | y <- arbitrary 53 | return $ Pair x y 54 | 55 | instance Arbitrary a => Arbitrary (Pair a) where 56 | arbitrary = genPair 57 | 58 | -- 3. 59 | 60 | data Two a b = Two a b deriving (Eq, Show) 61 | instance Functor (Two a) where 62 | fmap f (Two a b) = Two a (f b) 63 | 64 | genTwo :: (Arbitrary a, Arbitrary b) => Gen (Two a b) 65 | genTwo = do 66 | x <- arbitrary 67 | y <- arbitrary 68 | return $ Two x y 69 | 70 | instance (Arbitrary a, Arbitrary b) => 71 | Arbitrary (Two a b) where 72 | arbitrary = genTwo 73 | 74 | -- 4. 75 | 76 | data Three a b c = Three a b c deriving (Eq, Show) 77 | instance Functor (Three a b) where 78 | fmap f (Three a b c) = Three a b (f c) 79 | 80 | genThree :: (Arbitrary a, Arbitrary b, Arbitrary c) => 81 | Gen (Three a b c) 82 | genThree = do 83 | a <- arbitrary 84 | b <- arbitrary 85 | c <- arbitrary 86 | return $ Three a b c 87 | 88 | instance (Arbitrary a, Arbitrary b, Arbitrary c) => 89 | Arbitrary (Three a b c) where 90 | arbitrary = genThree 91 | 92 | -- 5. 93 | 94 | data Three' a b = Three' a b b deriving (Eq, Show) 95 | instance Functor (Three' a) where 96 | fmap f (Three' a b c) = Three' a (f b) (f c) 97 | 98 | genThree' :: (Arbitrary a, Arbitrary b) => 99 | Gen (Three' a b) 100 | genThree' = do 101 | a <- arbitrary 102 | b <- arbitrary 103 | c <- arbitrary 104 | return $ Three' a b c 105 | 106 | instance (Arbitrary a, Arbitrary b) => 107 | Arbitrary (Three' a b) where 108 | arbitrary = genThree' 109 | 110 | -- 6. 111 | 112 | data Four a b c d = Four a b c d deriving (Eq, Show) 113 | 114 | instance Functor (Four a b c) where 115 | fmap f (Four a b c d) = Four a b c (f d) 116 | 117 | instance (Arbitrary a, Arbitrary b, 118 | Arbitrary c, Arbitrary d) => 119 | Arbitrary (Four a b c d) where 120 | arbitrary = genFour 121 | 122 | genFour :: (Arbitrary a, Arbitrary b, 123 | Arbitrary c, Arbitrary d) => 124 | Gen (Four a b c d) 125 | 126 | genFour = do 127 | a <- arbitrary 128 | b <- arbitrary 129 | c <- arbitrary 130 | d <- arbitrary 131 | return $ Four a b c d 132 | 133 | -- 7. 134 | 135 | data Four' a b = Four' a a a b deriving (Eq, Show) 136 | 137 | instance Functor (Four' a) where 138 | fmap f (Four' a b c d) = Four' a b c (f d) 139 | 140 | instance (Arbitrary a, Arbitrary b) => 141 | Arbitrary (Four' a b) where 142 | arbitrary = genFour' 143 | 144 | genFour' :: (Arbitrary a, Arbitrary b) => 145 | Gen (Four' a b) 146 | 147 | genFour' = do 148 | a <- arbitrary 149 | b <- arbitrary 150 | c <- arbitrary 151 | d <- arbitrary 152 | return $ Four' a b c d 153 | 154 | -- main 155 | 156 | type IntToInt = Fun Int Int 157 | type IntFC = [Int] -> IntToInt -> IntToInt -> Bool 158 | type IdFC = Identity Int -> IntToInt -> IntToInt -> Bool 159 | type PairFC = Pair Int -> IntToInt -> IntToInt -> Bool 160 | type TwoFC = Two Int Int -> IntToInt -> IntToInt -> Bool 161 | type ThreeFC = Three Int Int Int -> IntToInt -> IntToInt -> Bool 162 | type ThreeFC' = Three' Int Int -> IntToInt -> IntToInt -> Bool 163 | type FourFC = Four Char Char Char Int -> IntToInt -> IntToInt -> Bool 164 | type FourFC' = Four' Char Int -> IntToInt -> IntToInt -> Bool 165 | 166 | main :: IO () 167 | main = do 168 | putStrLn "\n [Int]" 169 | quickCheck (functorIdentity :: [Int] -> Bool) 170 | quickCheck (functorCompose' :: IntFC) 171 | putStrLn "\n Identity" 172 | quickCheck (functorIdentity :: Identity Int -> Bool) 173 | quickCheck (functorCompose' :: IdFC) 174 | putStrLn "\n Pair" 175 | quickCheck (functorIdentity :: Pair Int -> Bool) 176 | quickCheck (functorCompose' :: PairFC) 177 | putStrLn "\n Two" 178 | quickCheck (functorIdentity :: Two Int Int -> Bool) 179 | quickCheck (functorCompose' :: TwoFC) 180 | putStrLn "\n Three" 181 | quickCheck (functorIdentity :: Three Int Int Int -> Bool) 182 | quickCheck (functorCompose' :: ThreeFC) 183 | putStrLn "\n Three'" 184 | quickCheck (functorIdentity :: Three' Int Int -> Bool) 185 | quickCheck (functorCompose' :: ThreeFC') 186 | putStrLn "\n Four" 187 | quickCheck (functorIdentity :: Four Char Char Char Char -> Bool) 188 | quickCheck (functorCompose' :: FourFC) 189 | putStrLn "\n Four'" 190 | quickCheck (functorIdentity :: Four' Char Int -> Bool) 191 | quickCheck (functorCompose' :: FourFC') 192 | 193 | -------------------------------------------------------------------------------- /src/Ch16Ex-Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | import GHC.Arr 4 | import Data.Word 5 | 6 | -- Chapter exercises 7 | 8 | -- 1. Bool has kind *, hence no Functor instance 9 | -- 2. Kind * -> *, can have Functor 10 | -- 3. Same 11 | -- 4. 12 | newtype Mu f = InF { outF :: f (Mu f) } 13 | -- Mu :: (* -> *) -> * 14 | -- Yes? 15 | 16 | -- 5. 17 | data D = D (Array Word Word) Int Int 18 | -- D :: * 19 | -- No! 20 | 21 | -- Rearrange 22 | 23 | -- 1. 24 | data Sum a b = First a | Second b deriving (Eq, Show) 25 | instance Functor (Sum e) where 26 | fmap f (First a) = First a 27 | fmap f (Second b) = Second (f b) 28 | 29 | -- 2. 30 | data Company a b c = DeepBlue a c | Something b 31 | instance Functor (Company e e') where 32 | fmap _ (Something b) = Something b 33 | fmap f (DeepBlue a c) = DeepBlue a (f c) 34 | 35 | -- 3. 36 | data More a b = L b a b | R a b a deriving (Eq, Show) 37 | instance Functor (More x) where 38 | fmap f (R a b a') = R a (f b) a' 39 | fmap f (L b a b') = L (f b) a (f b') 40 | 41 | -- Write Functor instances 42 | -- 1. 43 | data Quant a b = Finance | Desk a | Bloor b 44 | instance Functor (Quant e) where 45 | fmap f Finance = Finance 46 | fmap f (Desk a) = Desk a 47 | fmap f (Bloor b) = Bloor (f b) 48 | -- 2. 49 | data K a b = K a 50 | instance Functor (K a) where 51 | fmap f (K b) = K b 52 | -- 3. 53 | newtype Flip f a b = Flip (f b a) deriving (Eq, Show) 54 | instance Functor (Flip K a) where 55 | fmap f (Flip (K b)) = Flip (K (f b)) 56 | -- 4. 57 | data EvilGoateeConst a b = GoatyConst b deriving (Eq, Show) 58 | instance Functor (EvilGoateeConst a) where 59 | fmap f (GoatyConst b) = GoatyConst (f b) 60 | -- 5. 61 | data LiftItOut f a = LiftItOut (f a) deriving (Eq, Show) 62 | instance Functor f => Functor (LiftItOut f) where 63 | fmap f (LiftItOut fa) = LiftItOut (fmap f fa) 64 | -- 6. 65 | data Parappa f g a = DaWrappa (f a) (g a) deriving (Eq, Show) 66 | instance (Functor f, Functor g) => Functor (Parappa f g) where 67 | fmap f (DaWrappa fa ga) = DaWrappa (fmap f fa) (fmap f ga) 68 | -- 7. 69 | data IgnoreOne f g a b = IgnoringSomething (f a) (g b) 70 | instance (Functor f, Functor g) => Functor (IgnoreOne f g a) where 71 | fmap f (IgnoringSomething fa gb) = 72 | IgnoringSomething fa (fmap f gb) 73 | -- 8. 74 | data Notorious g o a t = Notorious (g o) (g a) (g t) 75 | instance Functor g => Functor (Notorious g o a) where 76 | fmap f (Notorious go ga gt) = Notorious go ga (fmap f gt) 77 | -- 9. 78 | data List a = Nil | Cons a (List a) deriving (Eq, Show) 79 | instance Functor List where 80 | fmap f Nil = Nil 81 | fmap f (Cons a list) = Cons (f a) (fmap f list) 82 | -- 10. 83 | data GoatLord a = NoGoat 84 | | OneGoat a 85 | | MoreGoats (GoatLord a) (GoatLord a) (GoatLord a) 86 | instance Functor GoatLord where 87 | fmap f NoGoat = NoGoat 88 | fmap f (OneGoat a) = OneGoat (f a) 89 | fmap f (MoreGoats gl gl' gl'') = 90 | MoreGoats (fmap f gl) (fmap f gl') (fmap f gl'') 91 | -- 11. 92 | data TalkToMe a = Halt 93 | | Print String a 94 | | Read (String -> a) 95 | instance Functor TalkToMe where 96 | fmap f Halt = Halt 97 | fmap f (Print s a) = Print s (f a) 98 | fmap f (Read sa) = Read (f . sa) 99 | -------------------------------------------------------------------------------- /src/Ch17-Applicative-Ex.hs: -------------------------------------------------------------------------------- 1 | 2 | module Apl3 where 3 | 4 | import Control.Applicative 5 | import Data.Monoid 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Checkers 8 | import Test.QuickCheck.Classes 9 | 10 | -- 1. Identity 11 | 12 | newtype Identity a = Identity a deriving (Show, Eq) 13 | instance Functor Identity where 14 | fmap f (Identity a) = Identity (f a) 15 | instance Applicative Identity where 16 | pure = Identity 17 | Identity f <*> Identity a = Identity (f a) 18 | instance Arbitrary a => Arbitrary (Identity a) where 19 | arbitrary = genId 20 | genId :: Arbitrary a => Gen (Identity a) 21 | genId = do 22 | a <- arbitrary 23 | return $ Identity a 24 | 25 | instance Eq a => EqProp (Identity a) where 26 | (=-=) = eq 27 | 28 | -- 2. Pair 29 | 30 | data Pair a = Pair a a deriving (Show, Eq) 31 | instance Functor Pair where 32 | fmap f (Pair a a') = Pair (f a) (f a') 33 | instance Applicative Pair where 34 | pure x = Pair x x 35 | Pair f f' <*> Pair x x' = Pair (f x) (f' x') 36 | instance Arbitrary a => Arbitrary (Pair a) where 37 | arbitrary = genPair 38 | genPair :: Arbitrary a => Gen (Pair a) 39 | genPair = do 40 | a <- arbitrary 41 | a' <- arbitrary 42 | return $ Pair a a' 43 | instance Eq a => EqProp (Pair a) where 44 | (=-=) = eq 45 | 46 | -- 3. Two 47 | data Two a b = Two a b deriving (Eq, Show) 48 | instance Functor (Two a) where 49 | fmap f (Two a b) = Two a (f b) 50 | instance Monoid a => Applicative (Two a) where 51 | pure = Two mempty 52 | Two m f <*> Two m' x = Two (m <> m') (f x) 53 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where 54 | arbitrary = genTwo 55 | genTwo :: (Arbitrary a, Arbitrary b) => Gen (Two a b) 56 | genTwo = do 57 | a <- arbitrary 58 | b <- arbitrary 59 | return $ Two a b 60 | instance (Eq a, Eq b) => EqProp (Two a b) where 61 | (=-=) = eq 62 | 63 | -- 4. Three 64 | data Three a b c = Three a b c deriving (Eq, Show) 65 | instance Functor (Three a b) where 66 | fmap f (Three a b c) = Three a b (f c) 67 | instance (Monoid a, Monoid b) => Applicative (Three a b) where 68 | pure = Three mempty mempty 69 | Three a b f <*> Three a' b' x = Three (a <> a') (b <> b') (f x) 70 | instance (Arbitrary a, Arbitrary b, Arbitrary c) 71 | => Arbitrary (Three a b c) where 72 | arbitrary = genThree 73 | genThree :: (Arbitrary a, Arbitrary b, Arbitrary c) 74 | => Gen (Three a b c) 75 | genThree = do 76 | a <- arbitrary 77 | b <- arbitrary 78 | c <- arbitrary 79 | return $ Three a b c 80 | instance (Eq a, Eq b, Eq c) => EqProp (Three a b c) where 81 | (=-=) = eq 82 | 83 | -- 5. Three' 84 | data Three' a b = Three' a b b deriving (Eq, Show) 85 | instance Functor (Three' a) where 86 | fmap f (Three' a b b') = Three' a (f b) (f b') 87 | instance (Monoid a) => Applicative (Three' a) where 88 | pure x = Three' mempty x x 89 | Three' m f f' <*> Three' m' x x' = Three' (m <> m') (f x) (f' x') 90 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Three' a b) where 91 | arbitrary = genThree' 92 | genThree' :: (Arbitrary a, Arbitrary b) => Gen (Three' a b) 93 | genThree' = do 94 | a <- arbitrary 95 | b <- arbitrary 96 | b' <- arbitrary 97 | return $ Three' a b b' 98 | instance (Eq a, Eq b) => EqProp (Three' a b) where 99 | (=-=) = eq 100 | 101 | -- 6. Four 102 | data Four a b c d = Four a b c d deriving (Eq, Show) 103 | instance Functor (Four a b c) where 104 | fmap f (Four a b c d) = Four a b c (f d) 105 | instance (Monoid a, Monoid b, Monoid c) 106 | => Applicative (Four a b c) where 107 | pure = Four mempty mempty mempty 108 | Four ma mb mc f <*> Four ma' mb' mc' x = 109 | Four (ma <> ma') (mb <> mb') (mc <> mc') (f x) 110 | instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) 111 | => Arbitrary (Four a b c d) where 112 | arbitrary = genFour 113 | genFour :: (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) 114 | => Gen (Four a b c d) 115 | genFour = do 116 | a <- arbitrary 117 | b <- arbitrary 118 | c <- arbitrary 119 | d <- arbitrary 120 | return $ Four a b c d 121 | instance (Eq a, Eq b, Eq c, Eq d) => EqProp (Four a b c d) where 122 | (=-=) = eq 123 | 124 | -- 7. Four' 125 | 126 | data Four' a b = Four' a a a b deriving (Eq, Show) 127 | instance Functor (Four' a) where 128 | fmap f (Four' a b c d) = Four' a b c (f d) 129 | instance Monoid a => Applicative (Four' a) where 130 | pure = Four' mempty mempty mempty 131 | Four' ma mb mc f <*> Four' ma' mb' mc' x = 132 | Four' (ma <> ma') (mb <> mb') (mc <> mc') (f x) 133 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Four' a b) where 134 | arbitrary = genFour' 135 | genFour' :: (Arbitrary a, Arbitrary b) => Gen (Four' a b) 136 | genFour' = do 137 | a <- arbitrary 138 | b <- arbitrary 139 | c <- arbitrary 140 | d <- arbitrary 141 | return $ Four' a b c d 142 | instance (Eq a, Eq b) => EqProp (Four' a b) where 143 | (=-=) = eq 144 | 145 | -- Test it 146 | 147 | type S = String 148 | type I = Int 149 | 150 | main :: IO () 151 | main = do 152 | putStr "\n-- Identity" 153 | quickBatch (applicative (undefined :: Identity (I, I, I))) 154 | putStr "\n-- Pair" 155 | quickBatch (applicative (undefined :: Pair (I, I, I))) 156 | putStr "\n-- Two" 157 | quickBatch (applicative (undefined :: Two (S, S, S) (I, I, I))) 158 | putStr "\n-- Three" 159 | quickBatch (applicative (undefined :: 160 | Three (S, S, S) (S, S, S) (I, I, I))) 161 | putStr "\n-- Three'" 162 | quickBatch (applicative (undefined :: 163 | Three' (S, S, S) (I, I, I))) 164 | putStr "\n-- Four" 165 | quickBatch (applicative (undefined :: 166 | Four (S, S, S) 167 | (S, S, S) 168 | (S, S, S) 169 | (I, I, I))) 170 | putStr "\n-- Four'" 171 | quickBatch (applicative (undefined :: 172 | Four' (S, S, S) 173 | (I, I, I))) 174 | 175 | -- Combinations 176 | 177 | stops, vowels :: String 178 | stops = "pbtdkg" 179 | vowels = "aeiou" 180 | 181 | combos :: [a] -> [b] -> [c] -> [(a, b, c)] 182 | combos = liftA3 (,,) 183 | -------------------------------------------------------------------------------- /src/Ch17-Applicative-QuickTest.hs: -------------------------------------------------------------------------------- 1 | 2 | module BadMonoid where 3 | 4 | import Data.Monoid 5 | import Test.QuickCheck 6 | import Test.QuickCheck.Checkers 7 | import Test.QuickCheck.Classes 8 | 9 | -- Bull (Fails left and right identity) 10 | 11 | data Bull = Fools | Twoo deriving (Eq, Show) 12 | 13 | instance Arbitrary Bull where 14 | arbitrary = frequency [ (1, return Fools) 15 | , (1, return Twoo) ] 16 | 17 | instance Monoid Bull where 18 | mempty = Fools 19 | mappend _ _ = Fools 20 | 21 | instance EqProp Bull where (=-=) = eq 22 | 23 | -- applicative 24 | 25 | -- applicative 26 | -- :: (Show a, Show (m a), Show (m (a -> b)), Show (m (b -> c)), 27 | -- Applicative m, CoArbitrary a, EqProp (m a), EqProp (m b), 28 | -- EqProp (m c), Arbitrary a, Arbitrary b, Arbitrary (m a), 29 | -- Arbitrary (m (a -> b)), Arbitrary (m (b -> c))) => 30 | -- m (a, b, b) -> TestBatch 31 | 32 | main :: IO () 33 | main = quickBatch (monoid Twoo) 34 | 35 | -------------------------------------------------------------------------------- /src/Ch17-Applicative-Validation.hs: -------------------------------------------------------------------------------- 1 | 2 | module Apl2 where 3 | 4 | import Control.Applicative 5 | import Data.Monoid hiding (Sum, First) 6 | import Test.QuickCheck hiding (Success) 7 | import Test.QuickCheck.Checkers 8 | import Test.QuickCheck.Classes 9 | 10 | data Sum a b = First a | Second b deriving (Eq, Show) 11 | data Validation e a = Error e | Success a deriving (Eq, Show) 12 | 13 | -- Sum instances 14 | 15 | instance Functor (Sum a) where 16 | fmap f (Second b) = Second (f b) 17 | fmap _ (First a) = First a 18 | 19 | instance Applicative (Sum a) where 20 | pure = Second 21 | First a <*> First _ = First a 22 | First a <*> Second _ = First a 23 | Second _ <*> First a = First a 24 | Second f <*> Second b = Second (f b) 25 | 26 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Sum a b) where 27 | arbitrary = genSum 28 | 29 | genSum :: (Arbitrary a, Arbitrary b) => Gen (Sum a b) 30 | genSum = do 31 | a <- arbitrary 32 | b <- arbitrary 33 | elements [First a, Second b] 34 | 35 | -- Validation instances 36 | 37 | instance Functor (Validation e) where 38 | fmap f (Success a) = Success (f a) 39 | fmap _ (Error e) = Error e 40 | 41 | instance Monoid e => Applicative (Validation e) where 42 | pure = Success 43 | Error e <*> Error e' = Error (e <> e') 44 | Error e <*> Success _ = Error e 45 | Success _ <*> Error e = Error e 46 | Success f <*> Success a = Success (f a) 47 | 48 | instance (Arbitrary e, Arbitrary a) => Arbitrary (Validation e a) where 49 | arbitrary = genValidation 50 | 51 | genValidation :: (Arbitrary e, Arbitrary a) => Gen (Validation e a) 52 | genValidation = do 53 | e <- arbitrary 54 | a <- arbitrary 55 | elements [Error e, Success a] 56 | 57 | -- Test it 58 | 59 | instance (Eq e, Eq a) => EqProp (Validation e a) where 60 | (=-=) = eq 61 | 62 | instance (Eq a, Eq b) => EqProp (Sum a b) where 63 | (=-=) = eq 64 | 65 | type S = String 66 | 67 | main :: IO () 68 | main = do 69 | putStrLn "-- applicative Validation" 70 | quickBatch (applicative (undefined :: Validation S (S, S, S))) 71 | putStrLn "-- applicative Sum" 72 | quickBatch (applicative (undefined :: Sum S (S, S, S))) 73 | 74 | -- This below seems rather useless to me. 75 | 76 | -- applyIfBothSecond :: (Sum e) (a -> b) 77 | -- -> (Sum e) a 78 | -- -> (Sum e) b 79 | 80 | -- applyMappendError :: Monoid e => 81 | -- (Validation e) (a -> b) 82 | -- -> (Validation e) a 83 | -- -> (Validation e) b 84 | -------------------------------------------------------------------------------- /src/Ch17-Applicative-zipList.hs: -------------------------------------------------------------------------------- 1 | 2 | module Apl1 where 3 | 4 | import Control.Applicative 5 | import Data.Monoid 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Checkers 8 | import Test.QuickCheck.Classes 9 | 10 | instance Monoid a => Monoid (ZipList a) where 11 | mempty = pure mempty 12 | mappend = liftA2 mappend 13 | 14 | instance Arbitrary a => Arbitrary (ZipList a) where 15 | arbitrary = ZipList <$> arbitrary 16 | 17 | instance Arbitrary a => Arbitrary (Sum a) where 18 | arbitrary = Sum <$> arbitrary 19 | 20 | instance Eq a => EqProp (ZipList a) where (=-=) = eq 21 | 22 | -- List Applicative 23 | 24 | data List a = Nil | Cons a (List a) deriving (Eq, Show) 25 | 26 | instance Functor List where 27 | fmap f Nil = Nil 28 | fmap f (Cons x xs) = Cons (f x) (fmap f xs) 29 | 30 | instance Monoid (List a) where 31 | mempty = Nil 32 | mappend = append 33 | 34 | append :: List a -> List a -> List a 35 | append Nil ys = ys 36 | append (Cons x xs) ys = Cons x (append xs ys) 37 | 38 | fold :: (a -> b -> b) -> b -> List a -> b 39 | fold _ b Nil = b 40 | fold f b (Cons h t) = f h (fold f b t) 41 | 42 | concat' :: List (List a) -> List a 43 | concat' = fold append Nil 44 | 45 | flatMap :: (a -> List b) -> List a -> List b 46 | flatMap f as = concat' $ fmap f as 47 | 48 | instance Applicative List where 49 | pure x = Cons x Nil 50 | _ <*> Nil = Nil 51 | Nil <*> _ = Nil 52 | Cons f fs <*> xs = append (fmap f xs) (fs <*> xs) 53 | 54 | instance Eq a => EqProp (List a) where 55 | xs =-= ys = xs' `eq` ys' 56 | where xs' = let l = xs 57 | in take' 3000 l 58 | ys' = let l = ys 59 | in take' 3000 l 60 | 61 | -- ZipList Applicative 62 | 63 | take' :: Int -> List a -> List a 64 | take' n xs = f n xs Nil 65 | where f n' (Cons h t) acc = 66 | if n' == 0 67 | then acc 68 | else f (n' - 1) t (Cons h acc) 69 | f _ Nil acc = acc 70 | 71 | newtype ZipList' a = ZipList' (List a) deriving (Eq, Show) 72 | 73 | instance Eq a => EqProp (ZipList' a) where 74 | xs =-= ys = xs' `eq` ys' 75 | where xs' = let (ZipList' l) = xs 76 | in take' 3000 l 77 | ys' = let (ZipList' l) = ys 78 | in take' 3000 l 79 | 80 | instance Functor ZipList' where 81 | fmap f (ZipList' xs) = ZipList' $ fmap f xs 82 | 83 | instance Applicative ZipList' where 84 | pure x = ZipList' (Cons x Nil) 85 | _ <*> ZipList' Nil = ZipList' Nil 86 | ZipList' Nil <*> _ = ZipList' Nil 87 | ZipList' (Cons f Nil) <*> ZipList' (Cons x xs) = 88 | ZipList' $ Cons (f x) (pure f <*> xs) 89 | ZipList' (Cons f fs) <*> ZipList' (Cons x Nil) = 90 | ZipList' $ Cons (f x) (fs <*> pure x) 91 | ZipList' (Cons f fs) <*> ZipList' (Cons x xs) = 92 | ZipList' $ Cons (f x) (fs <*> xs) 93 | 94 | instance Arbitrary a => Arbitrary (List a) where 95 | arbitrary = genList 96 | 97 | instance Arbitrary a => Arbitrary (ZipList' a) where 98 | arbitrary = genZipList 99 | 100 | genList :: Arbitrary a => Gen (List a) 101 | genList = do 102 | h <- arbitrary 103 | t <- genList 104 | frequency [(3, return $ Cons h t), 105 | (1, return Nil)] 106 | 107 | genZipList :: Arbitrary a => Gen (ZipList' a) 108 | genZipList = do 109 | l <- arbitrary 110 | return $ ZipList' l 111 | 112 | main :: IO () 113 | main = do 114 | putStrLn "-- applicative ZipList'" 115 | quickBatch (applicative $ ZipList' (Cons (undefined :: (Bool, Bool, Bool)) Nil)) 116 | -------------------------------------------------------------------------------- /src/Ch17-Applicative.hs: -------------------------------------------------------------------------------- 1 | 2 | import Data.Monoid 3 | import Data.Functor ((<$>)) 4 | import Control.Applicative --((<*>)) 5 | import qualified Data.Foldable as F 6 | 7 | import Data.List (elemIndex) 8 | 9 | f x = lookup x [(3, "hello"), (4, "julie"), (5, "kbai")] 10 | g y = lookup y [(7, "sup?"), (8, "chris"), (9, "aloha")] 11 | 12 | h z = lookup z [(2,3), (5,6), (7,8)] 13 | m x = lookup x [(4, 10), (8, 13), (1, 9001)] 14 | 15 | -- Short exercises 16 | -- 1. 17 | added :: Maybe Integer 18 | added = (+3) <$> (lookup 3 $ zip [1,2,3] [4,5,6]) 19 | 20 | -- 2. 21 | -- y :: Maybe Integer 22 | -- y = lookup 3 $ zip [1,2,3] [4,5,6] 23 | 24 | -- z :: Maybe Integer 25 | -- z = lookup 2 $ zip [1,2,3] [4,5,6] 26 | 27 | -- tupled :: Maybe (Integer, Integer) 28 | -- tupled = (,) <$> y <*> z 29 | 30 | -- 3. 31 | -- x :: Maybe Int 32 | -- x = elemIndex 3 [1,2,3,4,5] 33 | 34 | -- y :: Maybe Int 35 | -- y = elemIndex 4 [1,2,3,4,5] 36 | 37 | -- max' :: Int -> Int -> Int 38 | -- max' = max 39 | 40 | -- maxed :: Maybe Int 41 | -- maxed = max' <$> x <*> y 42 | 43 | -- 4. 44 | xs = [1,2,3] 45 | ys = [4,5,6] 46 | 47 | x :: Maybe Integer 48 | x = lookup 3 $ zip xs ys 49 | 50 | y :: Maybe Integer 51 | y = lookup 2 $ zip xs ys 52 | 53 | summed :: Maybe Integer 54 | summed = fmap F.sum $ (,) <$> x <*> y 55 | 56 | -- Identity 57 | 58 | newtype Identity a = Identity a deriving (Eq, Ord, Show) 59 | 60 | instance Functor Identity where 61 | fmap f (Identity a) = Identity (f a) 62 | instance Applicative Identity where 63 | pure = Identity 64 | Identity f <*> Identity a = Identity (f a) 65 | 66 | -- Constant 67 | 68 | newtype Constant a b = 69 | Constant { getConstant :: a } 70 | deriving (Eq, Ord, Show) 71 | 72 | instance Functor (Constant a) where 73 | fmap _ (Constant a) = Constant a 74 | 75 | instance Monoid a => Applicative (Constant a) where 76 | pure _ = Constant { getConstant = mempty } 77 | a <*> a' = Constant (getConstant a <> getConstant a') 78 | 79 | -- Maybe Applicative 80 | 81 | validateLength :: Int -> String -> Maybe String 82 | validateLength maxLen s = 83 | if (length s) > maxLen 84 | then Nothing 85 | else Just s 86 | 87 | newtype Name = Name String deriving (Eq, Show) 88 | newtype Address = Address String deriving (Eq, Show) 89 | 90 | mkName :: String -> Maybe Name 91 | mkName s = fmap Name $ validateLength 25 s 92 | 93 | mkAddress :: String -> Maybe Address 94 | mkAddress a = fmap Address $ validateLength 100 a 95 | 96 | data Person = 97 | Person Name Address 98 | deriving (Eq, Show) 99 | 100 | mkPerson :: String -> String -> Maybe Person 101 | mkPerson n a = 102 | Person <$> mkName n <*> mkAddress a 103 | 104 | -- Maybe 105 | 106 | data Cow = Cow { 107 | name :: String 108 | , age :: Int 109 | , weight :: Int 110 | } deriving (Eq, Show) 111 | 112 | noEmpty :: String -> Maybe String 113 | noEmpty "" = Nothing 114 | noEmpty str = Just str 115 | 116 | noNegative :: Int -> Maybe Int 117 | noNegative n = if n >= 0 118 | then Just n 119 | else Nothing 120 | 121 | cowFromString :: String -> Int -> Int -> Maybe Cow 122 | cowFromString name' age' weight' = 123 | Cow <$> noEmpty name' 124 | <*> noNegative age' 125 | <*> noNegative weight' 126 | 127 | -------------------------------------------------------------------------------- /src/Ch18-BadMonad.hs: -------------------------------------------------------------------------------- 1 | 2 | module BadMonad where 3 | 4 | import Test.QuickCheck 5 | import Test.QuickCheck.Checkers 6 | import Test.QuickCheck.Classes 7 | import Control.Applicative 8 | 9 | data CountMe a = CountMe Integer a deriving (Eq, Show) 10 | 11 | instance Functor CountMe where 12 | fmap f (CountMe i a) = CountMe i (f a) 13 | 14 | instance Applicative CountMe where 15 | pure = CountMe 0 16 | CountMe n f <*> CountMe n' a = CountMe (n + n') (f a) 17 | 18 | instance Monad CountMe where 19 | return = pure 20 | 21 | CountMe n a >>= f = 22 | let CountMe n' b = f a 23 | in CountMe (n + n') b 24 | 25 | instance Arbitrary a => Arbitrary (CountMe a) where 26 | arbitrary = CountMe <$> arbitrary <*> arbitrary 27 | 28 | instance Eq a => EqProp (CountMe a) where (=-=) = eq 29 | 30 | main :: IO () 31 | main = do 32 | let trigger = undefined :: CountMe (Int, String, Int) 33 | quickBatch $ functor trigger 34 | quickBatch $ applicative trigger 35 | quickBatch $ monad trigger 36 | -------------------------------------------------------------------------------- /src/Ch18-EitherMonad.hs: -------------------------------------------------------------------------------- 1 | 2 | module EitherMonad where 3 | 4 | import Control.Applicative 5 | 6 | -- years ago 7 | type Founded = Int 8 | -- number of programmers 9 | type Coders = Int 10 | 11 | data SoftwareShop = 12 | Shop { 13 | founded :: Founded 14 | , programmers :: Coders 15 | } deriving (Eq, Show) 16 | 17 | data FoundedError = NegativeYears Founded 18 | | TooManyYears Founded 19 | | NegativeCoders Coders 20 | | TooManyCoders Coders 21 | | TooManyCodersForYears Founded Coders 22 | deriving (Eq, Show) 23 | 24 | validateFounded :: Int -> Either FoundedError Founded 25 | validateFounded n 26 | | n < 0 = Left $ NegativeYears n 27 | | n > 500 = Left $ TooManyYears n 28 | | otherwise = Right n 29 | 30 | -- Tho, many programmers *are* negative. 31 | validateCoders :: Int -> Either FoundedError Coders 32 | validateCoders n 33 | | n < 0 = Left $ NegativeCoders n 34 | | n > 5000 = Left $ TooManyCoders n 35 | | otherwise = Right n 36 | 37 | mkSoftware :: Int -> Int -> Either FoundedError SoftwareShop 38 | mkSoftware years coders = do 39 | founded <- validateFounded years 40 | programmers <- validateCoders coders 41 | if programmers > div founded 10 42 | then Left $ TooManyCodersForYears founded programmers 43 | else Right $ Shop founded programmers 44 | 45 | -- Either monad 46 | 47 | data Sum a b = First a | Second b deriving (Eq, Show) 48 | 49 | instance Functor (Sum a) where 50 | fmap _ (First a) = First a 51 | fmap f (Second b) = Second (f b) 52 | 53 | instance Applicative (Sum a) where 54 | pure = Second 55 | First x <*> _ = First x 56 | Second _ <*> First x = First x 57 | Second f <*> Second x = Second (f x) 58 | 59 | instance Monad (Sum a) where 60 | return = pure 61 | First x >>= _ = First x 62 | Second x >>= f = f x 63 | 64 | -------------------------------------------------------------------------------- /src/Ch18-Monad.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad (join) 3 | import Control.Applicative ((*>)) 4 | 5 | bind :: (Monad m, Functor m) => (a -> m b) -> m a -> m b 6 | bind f x = join $ fmap f x 7 | 8 | sequencing :: IO () 9 | sequencing = do 10 | putStrLn "Blah" 11 | putStrLn "another thing" 12 | 13 | sequencing' :: IO () 14 | sequencing' = 15 | putStrLn "Blah" >> 16 | putStrLn "another thing" 17 | 18 | sequencing'' :: IO () 19 | sequencing'' = 20 | putStrLn "blah" *> 21 | putStrLn "another thing" 22 | 23 | binding :: IO () 24 | binding = do 25 | name <- getLine 26 | putStrLn name 27 | 28 | binding' :: IO () 29 | binding' = 30 | getLine >>= putStrLn 31 | 32 | bindingAndSequencing :: IO () 33 | bindingAndSequencing = do 34 | putStrLn "Name pls: " 35 | name <- getLine 36 | putStrLn ("y helo thar: " ++ name) 37 | 38 | bindingAndSequencing' :: IO () 39 | bindingAndSequencing' = 40 | putStrLn "name pls: " >> 41 | getLine >>= 42 | \name -> putStrLn ("y helo thar: " ++ name) 43 | 44 | twoBinds :: IO () 45 | twoBinds = do 46 | putStrLn "name pls: " 47 | name <- getLine 48 | putStrLn "age pls: " 49 | age <- getLine 50 | putStrLn ("y helo thar: " 51 | ++ name ++ " who is: " 52 | ++ age ++ " years old.") 53 | 54 | twoBinds' :: IO () 55 | twoBinds' = 56 | putStrLn "name pls: " >> 57 | getLine >>= 58 | \name -> 59 | putStrLn "age pls: " >> 60 | getLine >>= 61 | \age -> 62 | putStrLn ("y helo thar: " 63 | ++ name ++ " who is: " 64 | ++ age ++ " years old.") 65 | 66 | -- List monad 67 | 68 | inOut :: [a] -> [a] 69 | inOut xs = do 70 | x <- xs 71 | return x 72 | 73 | -- Maybe monad 74 | 75 | data Cow = Cow { 76 | name :: String 77 | , age :: Int 78 | , weight :: Int 79 | } deriving (Eq, Show) 80 | 81 | noEmpty :: String -> Maybe String 82 | noEmpty "" = Nothing 83 | noEmpty str = Just str 84 | 85 | noNegative :: Int -> Maybe Int 86 | noNegative n | n >= 0 = Just n 87 | | otherwise = Nothing 88 | 89 | weightCheck :: Cow -> Maybe Cow 90 | weightCheck c = 91 | let w = weight c 92 | n = name c 93 | in if n == "Bess" && w > 499 94 | then Nothing 95 | else Just c 96 | 97 | mkSphericalCow :: String -> Int -> Int -> Maybe Cow 98 | mkSphericalCow name' age' weight' = 99 | case noEmpty name' of 100 | Nothing -> Nothing 101 | Just nammy -> 102 | case noNegative age' of 103 | Nothing -> Nothing 104 | Just agey -> 105 | case noNegative weight' of 106 | Nothing -> Nothing 107 | Just weighty -> 108 | weightCheck (Cow nammy agey weighty) 109 | 110 | mkSphericalCow' :: String -> Int -> Int -> Maybe Cow 111 | mkSphericalCow' name' age' weight' = do 112 | nammy <- noEmpty name' 113 | agey <- noNegative age' 114 | weighty <- noNegative weight' 115 | weightCheck (Cow nammy agey weighty) 116 | 117 | mkSphericalCow'' :: String -> Int -> Int -> Maybe Cow 118 | mkSphericalCow'' name' age' weight' = 119 | noEmpty name' >>= 120 | \ nammy -> 121 | noNegative age' >>= 122 | \ agey -> 123 | noNegative weight' >>= 124 | \ weighty -> 125 | weightCheck (Cow nammy agey weighty) 126 | 127 | f :: Maybe Integer 128 | f = Just 1 129 | 130 | g :: Maybe String 131 | g = Just "1" 132 | 133 | h :: Maybe Integer 134 | h = Just 10191 135 | 136 | zed :: a -> b -> c -> (a, b, c) 137 | zed = (,,) 138 | 139 | doSomething = do 140 | a <- f 141 | b <- g 142 | c <- h 143 | return (zed a b c) 144 | 145 | zed' :: Monad m => a -> b -> c -> m (a, b, c) 146 | zed' a b c = return (a, b, c) 147 | 148 | doSomething' = do 149 | a <- f 150 | b <- g 151 | c <- h 152 | zed' a b c 153 | -------------------------------------------------------------------------------- /src/Ch18-MonadComposition.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Applicative 3 | import Control.Monad (join, (>=>)) 4 | import Data.Functor 5 | import Data.Monoid 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Checkers 8 | import Test.QuickCheck.Classes 9 | 10 | 11 | mcomp :: (Monad m, Functor m) => (b -> m c) -> (a -> m b) -> a -> m c 12 | mcomp f g a = join (f <$> (g a)) 13 | 14 | mcomp'' :: (Monad m, Functor m) => (b -> m c) -> (a -> m b) -> a -> m c 15 | mcomp'' f g a = g a >>= f 16 | 17 | sayHi :: String -> IO String 18 | sayHi greeting = do 19 | putStrLn greeting 20 | getLine 21 | 22 | readM :: Read a => String -> IO a 23 | readM = return . read 24 | 25 | getAge :: String -> IO Int 26 | getAge = sayHi >=> readM 27 | 28 | askForAge :: IO Int 29 | askForAge = getAge "Hello! How old are you? " 30 | 31 | -- 18.7 Chapter exercises 32 | 33 | -- 1. Nope 34 | 35 | data Nope a = NopeDotJpg deriving (Eq, Show) 36 | 37 | instance Functor Nope where 38 | fmap _ _ = NopeDotJpg 39 | 40 | instance Applicative Nope where 41 | pure _ = NopeDotJpg 42 | _ <*> _ = NopeDotJpg 43 | 44 | instance Monad Nope where 45 | return = pure 46 | _ >>= _ = NopeDotJpg 47 | 48 | instance Arbitrary a => Arbitrary (Nope a) where 49 | arbitrary = genNope 50 | 51 | genNope :: Gen (Nope a) 52 | genNope = return NopeDotJpg 53 | 54 | instance Eq a => EqProp (Nope a) where (=-=) = eq 55 | 56 | -- 2. Yes, I changed the name 57 | 58 | data PEither b a = Left a | Right b deriving (Eq, Show) 59 | 60 | instance Functor (PEither b) where 61 | fmap f (Main.Left a) = Main.Left (f a) 62 | fmap f (Main.Right b) = Main.Right b 63 | 64 | instance Applicative (PEither b) where 65 | pure = Main.Left 66 | Main.Left _ <*> Main.Right x = Main.Right x 67 | Main.Left f <*> Main.Left x = Main.Left (f x) 68 | Main.Right x <*> _ = Main.Right x 69 | 70 | instance Monad (PEither b) where 71 | return = pure 72 | Main.Left a >>= f = f a 73 | Main.Right b >>= _ = Main.Right b 74 | 75 | instance (Arbitrary b, Arbitrary a) => Arbitrary (PEither b a) where 76 | arbitrary = genPEither 77 | 78 | genPEither :: (Arbitrary b, Arbitrary a) => Gen (PEither b a) 79 | genPEither = do 80 | b <- arbitrary 81 | a <- arbitrary 82 | elements [Main.Right b, Main.Left a] 83 | 84 | instance (Eq b, Eq a) => EqProp (PEither b a) where (=-=) = eq 85 | 86 | -- 3. Identity 87 | 88 | newtype Identity a = Identity a deriving (Eq, Ord, Show) 89 | 90 | instance Functor Identity where 91 | fmap f (Identity x) = Identity (f x) 92 | 93 | instance Applicative Identity where 94 | pure = Identity 95 | Identity f <*> Identity x = Identity (f x) 96 | 97 | instance Monad Identity where 98 | return = pure 99 | Identity x >>= f = f x 100 | 101 | instance Arbitrary a => Arbitrary (Identity a) where 102 | arbitrary = genId 103 | 104 | genId :: Arbitrary a => Gen (Identity a) 105 | genId = do 106 | x <- arbitrary 107 | return $ Identity x 108 | 109 | instance Eq a => EqProp (Identity a) where (=-=) = eq 110 | 111 | -- 4. List 112 | 113 | data List a = Nil | Cons a (List a) deriving (Eq, Show) 114 | 115 | instance Functor List where 116 | fmap _ Nil = Nil 117 | fmap f (Cons h t) = Cons (f h) (fmap f t) 118 | 119 | instance Monoid (List a) where 120 | mempty = Nil 121 | mappend Nil lb = lb 122 | mappend (Cons a la) lb = Cons a (la `mappend` lb) 123 | 124 | instance Applicative List where 125 | pure a = Cons a Nil 126 | 127 | (<*>) Nil _ = Nil 128 | (<*>) (Cons f fs) as = mappend (fmap f as) (fs <*> as) 129 | 130 | instance Monad List where 131 | return x = Cons x Nil 132 | Nil >>= _f = Nil 133 | Cons head tail >>= f = append (f head) (tail >>= f) 134 | 135 | instance Arbitrary a => Arbitrary (List a) where 136 | arbitrary = genList 137 | 138 | genList :: Arbitrary a => Gen (List a) 139 | genList = do 140 | h <- arbitrary 141 | t <- genList 142 | frequency [(3, return $ Cons h t), 143 | (1, return Nil)] 144 | 145 | instance Eq a => EqProp (List a) where (=-=) = eq 146 | 147 | -- main 148 | 149 | type I = Int 150 | 151 | main :: IO () 152 | main = do 153 | putStr "\n-- Nope" 154 | quickBatch $ monad (undefined :: Nope (I, I, I)) 155 | putStr "\n-- PEither" 156 | quickBatch $ monad (undefined :: PEither I (I, I, I)) 157 | putStr "\n-- Identity" 158 | quickBatch $ monad (undefined :: Identity (I, I, I)) 159 | putStr "\n-- List" 160 | quickBatch $ monad (undefined :: List (I, I, I)) 161 | 162 | -- Functions 163 | 164 | j :: Monad m => m (m a) -> m a 165 | j = (=<<) id 166 | 167 | l1 :: (Functor m, Monad m) => (a -> b) -> m a -> m b 168 | l1 = fmap 169 | 170 | l2 :: (Applicative m, Monad m) => (a -> b -> c) -> m a -> m b -> m c 171 | l2 = liftA2 172 | 173 | a :: (Applicative m, Monad m) => m a -> m (a -> b) -> m b 174 | a = flip (<*>) 175 | 176 | meh :: (Functor m, Monad m) => [a] -> (a -> m b) -> m [b] 177 | meh [] _ = return [] 178 | meh (x:xs) f = do 179 | x' <- f x 180 | fmap ((:) x') (meh xs f) 181 | 182 | flipType :: (Functor m, Monad m) => [m a] -> m [a] 183 | flipType = (flip meh) id 184 | -------------------------------------------------------------------------------- /src/Ch20-Foldable.hs: -------------------------------------------------------------------------------- 1 | 2 | import Data.Foldable 3 | import Data.Monoid 4 | 5 | data Identity a = Identity a 6 | 7 | instance Foldable Identity where 8 | foldr f z (Identity x) = f x z 9 | foldl f z (Identity x) = f z x 10 | foldMap f (Identity x) = f x 11 | 12 | data Optional a = Nada | Yep a 13 | 14 | instance Foldable Optional where 15 | foldr _ z Nada = z 16 | foldr f z (Yep x) = f x z 17 | 18 | foldl _ z Nada = z 19 | foldl f z (Yep x) = f z x 20 | 21 | foldMap _ Nada = mempty 22 | foldMap f (Yep a) = f a 23 | 24 | mySum :: (Foldable t, Num a) => t a -> a 25 | mySum x = getSum $ foldMap Sum x 26 | 27 | myProduct :: (Foldable t, Num a) => t a -> a 28 | myProduct x = getProduct $ foldMap Product x 29 | 30 | myElem :: (Foldable t, Eq a) => a -> t a -> Bool 31 | myElem x xs = getAny $ foldMap (Any . (== x)) xs 32 | 33 | data Min a = Min { getMin :: Maybe a } deriving (Eq, Show) 34 | 35 | instance Ord a => Monoid (Min a) where 36 | mempty = Min Nothing 37 | Min Nothing `mappend` x = x 38 | x `mappend` Min Nothing = x 39 | mappend (Min a) (Min a') = Min (min a a') 40 | 41 | myMinimum :: (Foldable t, Ord a) => t a -> Maybe a 42 | myMinimum x = getMin $ foldMap (Min . Just) x 43 | 44 | data Max a = Max { getMax :: Maybe a } deriving (Eq, Show) 45 | 46 | instance Ord a => Monoid (Max a) where 47 | mempty = Max Nothing 48 | Max Nothing `mappend` x = x 49 | x `mappend` Max Nothing = x 50 | mappend (Max a) (Max a') = Max (max a a') 51 | 52 | myMaximum :: (Foldable t, Ord a) => t a -> Maybe a 53 | myMaximum x = getMax $ foldMap (Max . Just) x 54 | 55 | myNull :: (Foldable t) => t a -> Bool 56 | myNull = foldr (\_ _ -> False) True 57 | 58 | myLength :: (Foldable t) => t a -> Int 59 | myLength = foldr (\_ b -> b + 1) 0 60 | 61 | myToList :: (Foldable t) => t a -> [a] 62 | myToList = foldr (\a b -> a : b) [] 63 | 64 | myFold :: (Foldable t, Monoid m) => t m -> m 65 | myFold = foldMap id 66 | 67 | myFoldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m 68 | myFoldMap f = foldr (mappend . f) mempty 69 | 70 | -- 20.6 Chapter Exercises 71 | 72 | data Constant a b = Constant a 73 | 74 | instance Foldable (Constant a) where 75 | foldMap f (Constant x) = mempty 76 | 77 | data Two a b = Two a b 78 | 79 | instance Foldable (Two a) where 80 | foldMap f (Two a b) = f b 81 | 82 | data Three a b c = Three a b c 83 | 84 | instance Foldable (Three a b) where 85 | foldMap f (Three a b c) = f c 86 | 87 | data Three' a b = Three' a b b 88 | 89 | instance Foldable (Three' a) where 90 | foldMap f (Three' a b b') = mappend (f b) (f b') 91 | 92 | data Four' a b = Four' a b b b 93 | 94 | instance Foldable (Four' a) where 95 | foldMap f (Four' a x y z) = f x `mappend` f y `mappend` f z 96 | 97 | filterF :: (Applicative f, Foldable f, Monoid (f a)) => 98 | (a -> Bool) -> f a -> f a 99 | filterF f = foldMap (\a -> if f a then pure a else mempty) 100 | -------------------------------------------------------------------------------- /src/Ch21-Traversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | import Prelude hiding (Either, Left, Right) 4 | import Control.Monad (join) 5 | import Test.QuickCheck 6 | import Test.QuickCheck.Checkers 7 | import Test.QuickCheck.Classes 8 | 9 | -- Either 10 | 11 | data Either a b = Left a 12 | | Right b 13 | deriving (Eq, Ord, Show) 14 | 15 | instance Functor (Either a) where 16 | fmap _ (Left x) = Left x 17 | fmap f (Right y) = Right (f y) 18 | 19 | instance Applicative (Either e) where 20 | pure = Right 21 | Left e <*> _ = Left e 22 | Right f <*> r = fmap f r 23 | 24 | instance Foldable (Either a) where 25 | foldMap _ (Left _) = mempty 26 | foldMap f (Right y) = f y 27 | 28 | foldr _ z (Left _) = z 29 | foldr f z (Right y) = f y z 30 | 31 | instance Traversable (Either a) where 32 | traverse _ (Left x) = pure (Left x) 33 | traverse f (Right y) = Right <$> f y 34 | 35 | -- Tuple 36 | 37 | -- instance Functor ((,) a) where 38 | -- fmap f (x, y) = (x, f y) 39 | 40 | -- instance Monoid a => Applicative ((,) a) where 41 | -- pure x = (mempty, x) 42 | -- (u, f) <*> (v, x) = (u `mappend` v, f x) 43 | 44 | -- instance Traversable ((,) a) where 45 | -- traverse f (x, y) = (,) x <$> f y 46 | 47 | -- Identity 48 | 49 | newtype Identity a = Identity a deriving (Eq, Ord, Show) 50 | 51 | instance Functor Identity where 52 | fmap f (Identity x) = Identity (f x) 53 | 54 | instance Applicative Identity where 55 | pure = Identity 56 | Identity f <*> Identity x = Identity (f x) 57 | 58 | instance Foldable Identity where 59 | foldMap f (Identity x) = f x 60 | 61 | instance Traversable Identity where 62 | traverse f (Identity x) = Identity <$> f x 63 | 64 | instance Eq a => EqProp (Identity a) where 65 | (=-=) = eq 66 | 67 | instance Arbitrary a => Arbitrary (Identity a) where 68 | arbitrary = genId 69 | 70 | genId :: Arbitrary a => Gen (Identity a) 71 | genId = do 72 | x <- arbitrary 73 | return $ Identity x 74 | 75 | -- Constant 76 | 77 | newtype Constant a b = Constant { getConstant :: a } 78 | deriving (Show, Eq) 79 | 80 | instance Functor (Constant a) where 81 | fmap _ (Constant x) = Constant x 82 | 83 | instance Monoid a => Applicative (Constant a) where 84 | pure _ = Constant { getConstant = mempty } 85 | x <*> x' = Constant (getConstant x `mappend` getConstant x') 86 | 87 | instance Foldable (Constant a) where 88 | foldMap _ _ = mempty 89 | 90 | instance Traversable (Constant a) where 91 | traverse _ (Constant x) = Constant <$> pure x 92 | 93 | instance (Eq a, Eq b) => EqProp (Constant a b) where 94 | x =-= x' = getConstant x `eq` getConstant x' 95 | 96 | instance Arbitrary a => Arbitrary (Constant a b) where 97 | arbitrary = genConst 98 | 99 | genConst :: Arbitrary a => Gen (Constant a b) 100 | genConst = do 101 | a <- arbitrary 102 | return $ Constant a 103 | 104 | -- Maybe 105 | 106 | data Optional a = Nada | Yep a deriving (Eq, Show) 107 | 108 | instance Monoid a => Monoid (Optional a) where 109 | mempty = Nada 110 | Nada `mappend` _ = Nada 111 | _ `mappend` Nada = Nada 112 | Yep x `mappend` Yep x' = Yep (x `mappend` x') 113 | 114 | instance Functor Optional where 115 | fmap _ Nada = Nada 116 | fmap f (Yep x) = Yep (f x) 117 | 118 | instance Applicative Optional where 119 | pure = Yep 120 | Nada <*> _ = Nada 121 | _ <*> Nada = Nada 122 | (Yep f) <*> (Yep x) = Yep (f x) 123 | 124 | instance Foldable Optional where 125 | foldMap f Nada = mempty 126 | foldMap f (Yep x) = f x 127 | 128 | instance Traversable Optional where 129 | traverse _ Nada = pure Nada 130 | traverse f (Yep x) = Yep <$> f x 131 | 132 | instance Eq a => EqProp (Optional a) where 133 | (=-=) = eq 134 | 135 | instance Arbitrary a => Arbitrary (Optional a) where 136 | arbitrary = frequency [ (1, return Nada) 137 | , (2, genYep) ] 138 | 139 | genYep :: Arbitrary a => Gen (Optional a) 140 | genYep = do 141 | x <- arbitrary 142 | return $ Yep x 143 | 144 | -- List 145 | 146 | data List a = Nil | Cons a (List a) deriving (Eq, Show) 147 | 148 | instance Functor List where 149 | fmap _ Nil = Nil 150 | fmap f (Cons h t) = Cons (f h) (fmap f t) 151 | 152 | instance Foldable List where 153 | foldMap _ Nil = mempty 154 | foldMap f (Cons h t) = f h `mappend` foldMap f t 155 | 156 | instance Traversable List where 157 | traverse _ Nil = pure Nil 158 | traverse f (Cons h t) = Cons <$> f h <*> traverse f t 159 | 160 | instance Eq a => EqProp (List a) where (=-=) = eq 161 | 162 | instance Arbitrary a => Arbitrary (List a) where 163 | arbitrary = genList 164 | 165 | genList :: Arbitrary a => Gen (List a) 166 | genList = do 167 | h <- arbitrary 168 | t <- genList 169 | frequency [ (3, return $ Cons h t) 170 | , (1, return Nil) ] 171 | 172 | -- Big 173 | 174 | data Big a b = Big a b b 175 | deriving (Show, Eq) 176 | 177 | instance Functor (Big a) where 178 | fmap f (Big a b1 b2) = Big a (f b1) (f b2) 179 | 180 | instance Foldable (Big a) where 181 | foldMap f (Big _ b b') = f b <> f b' 182 | foldr f y (Big _ b b') = f b' y 183 | 184 | instance Traversable (Big a) where 185 | traverse f (Big a b b') = (Big a) <$> f b <*> f b' 186 | sequenceA (Big a b b') = (Big a) <$> b <*> b' 187 | -- Shorter alternative: sequenceA = traverse id 188 | 189 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Big a b) where 190 | arbitrary = Big <$> arbitrary <*> arbitrary <*> arbitrary 191 | 192 | instance (Eq a, Eq b) => EqProp (Big a b) where 193 | (=-=) = eq 194 | 195 | -- Bigger 196 | data Bigger a b = Bigger a b b b 197 | deriving (Show, Eq) 198 | 199 | instance Functor (Bigger a) where 200 | fmap f (Bigger a x y z) = Bigger a (f x) (f y) (f z) 201 | 202 | instance Foldable (Bigger a) where 203 | foldMap f (Bigger _ x y z) = f x <> f y <> f z 204 | 205 | instance Traversable (Bigger a) where 206 | traverse f (Bigger a x y z) = (Bigger a) <$> f x <*> f y <*> f z 207 | 208 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Bigger a b) where 209 | arbitrary = Bigger <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 210 | 211 | instance (Eq a, Eq b) => EqProp (Bigger a b) where 212 | (=-=) = eq 213 | 214 | -- S 215 | 216 | data S n a = S (n a) a deriving (Eq, Show) 217 | 218 | instance Functor n => Functor (S n) where 219 | fmap f (S n a) = S (fmap f n) (f a) 220 | 221 | instance Foldable n => Foldable (S n) where 222 | foldMap f (S n a) = foldMap f n `mappend` f a 223 | 224 | instance Traversable n => Traversable (S n) where 225 | traverse f (S n a) = S <$> traverse f n <*> f a 226 | 227 | instance (Eq (n a), Eq a) => EqProp (S n a) where 228 | (=-=) = eq 229 | 230 | instance (Arbitrary (n a), CoArbitrary (n a), 231 | Arbitrary a, CoArbitrary a) => 232 | Arbitrary (S n a) where 233 | arbitrary = genS 234 | 235 | genS :: (Arbitrary (n a), CoArbitrary (n a), 236 | Arbitrary a, CoArbitrary a) => 237 | Gen (S n a) 238 | genS = do 239 | n <- arbitrary 240 | a <- arbitrary 241 | return $ S (n a) a 242 | 243 | -- Tree 244 | 245 | data Tree a = Empty 246 | | Leaf a 247 | | Node (Tree a) a (Tree a) 248 | deriving (Eq, Show) 249 | 250 | instance Functor Tree where 251 | fmap _ Empty = Empty 252 | fmap f (Leaf x) = Leaf (f x) 253 | fmap f (Node n x n') = Node (fmap f n) (f x) (fmap f n') 254 | 255 | instance Foldable Tree where 256 | foldMap _ Empty = mempty 257 | foldMap f (Leaf x) = f x 258 | foldMap f (Node n x n') = 259 | foldMap f n `mappend` f x `mappend` foldMap f n' 260 | 261 | foldr _ y Empty = y 262 | foldr f y (Leaf x) = f x y 263 | foldr f y (Node l x r) = f x $ foldr f (foldr f y r) l 264 | 265 | instance Traversable Tree where 266 | traverse _ Empty = pure Empty 267 | traverse f (Leaf x) = Leaf <$> f x 268 | traverse f (Node n x n') = 269 | Node <$> traverse f n <*> f x <*> traverse f n' 270 | 271 | instance Eq a => EqProp (Tree a) where 272 | (=-=) = eq 273 | 274 | instance Arbitrary a => Arbitrary (Tree a) where 275 | arbitrary = genTree 276 | 277 | genTree :: Arbitrary a => Gen (Tree a) 278 | genTree = do 279 | x <- arbitrary 280 | n <- genTree 281 | n' <- genTree 282 | frequency [ (1, return Empty) 283 | , (2, return $ Leaf x) 284 | , (2, return $ Node n x n') ] 285 | 286 | -- 287 | 288 | idTrigger = undefined :: Identity (Int, Int, [Int]) 289 | constTrigger = undefined :: Constant Int (Int, Int, [Int]) 290 | opTrigger = undefined :: Optional (Int, Int, [Int]) 291 | listTrigger = undefined :: List (Int, Int, [Int]) 292 | bigTrigger = undefined :: Big Int Int (Int, Int, [Int]) 293 | biggerTrigger = undefined :: Bigger Int (Int, Int, [Int]) 294 | sTrigger = undefined :: S Maybe (Int, Int, [Int]) 295 | treeTrigger = undefined :: Tree (Int, Int, [Int]) 296 | 297 | main :: IO () 298 | main = do 299 | putStr "\nIdentity" 300 | quickBatch (traversable idTrigger) 301 | putStr "\nConstant" 302 | quickBatch (traversable constTrigger) 303 | putStr "\nOptional" 304 | quickBatch (traversable opTrigger) 305 | putStr "\nList" 306 | quickBatch (traversable listTrigger) 307 | putStr "\nBig" 308 | quickBatch (traversable bigTrigger) 309 | putStr "\nBigger" 310 | quickBatch (traversable biggerTrigger) 311 | putStr "\nS" 312 | quickBatch (traversable sTrigger) 313 | putStr "\nTree" 314 | quickBatch (traversable treeTrigger) 315 | -------------------------------------------------------------------------------- /src/Ch21-httpStuff.hs: -------------------------------------------------------------------------------- 1 | 2 | module HttpStuff where 3 | 4 | import Data.ByteString.Lazy hiding (map, head) 5 | import Network.Wreq 6 | 7 | urls :: [String] 8 | urls = [ "http://httpbin.com/ip" 9 | , "http://httpbin.org/bytes/5" 10 | ] 11 | 12 | mappingGet :: [IO (Response ByteString)] 13 | mappingGet = map get urls 14 | 15 | traversedUrls :: IO [Response ByteString] 16 | traversedUrls = traverse get urls 17 | -------------------------------------------------------------------------------- /src/Ch22-Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | import Control.Applicative 4 | import Control.Monad (join) 5 | import Data.Char 6 | 7 | -- Demo 8 | 9 | hurr :: Num a => a -> a 10 | hurr = (*2) 11 | 12 | durr :: Num a => a -> a 13 | durr = (+10) 14 | 15 | m :: Num a => a -> a 16 | m = hurr . durr 17 | 18 | m' :: Num a => a -> a 19 | m' = fmap hurr durr 20 | 21 | m2 :: Num a => a -> a 22 | m2 = (+) <$> hurr <*> durr 23 | 24 | m3 :: Num a => a -> a 25 | m3 = liftA2 (+) hurr durr 26 | 27 | hurrDurr :: Num a => a -> a 28 | hurrDurr = do 29 | a <- hurr 30 | b <- durr 31 | return (a + b) 32 | 33 | -- Short exercise 34 | 35 | cap :: [Char] -> [Char] 36 | cap = map toUpper 37 | 38 | rev :: [Char] -> [Char] 39 | rev = reverse 40 | 41 | composed :: [Char] -> [Char] 42 | composed = cap . rev 43 | 44 | fmapped :: [Char] -> [Char] 45 | fmapped = fmap cap rev 46 | 47 | tupled :: [Char] -> ([Char], [Char]) 48 | tupled = liftA2 (,) cap rev 49 | 50 | tupled' :: [Char] -> ([Char], [Char]) 51 | tupled' = (,) <$> rev <*> cap 52 | 53 | tupled'' :: [Char] -> ([Char], [Char]) 54 | tupled'' = do 55 | a <- cap 56 | b <- rev 57 | return (a, b) 58 | 59 | tupled''' :: [Char] -> ([Char], [Char]) 60 | tupled''' xs = fmap rev $ (cap >>= (,)) (xs) 61 | 62 | tupledM' :: [Char] -> ([Char], [Char]) 63 | tupledM' = rev <$> cap >>= (,) 64 | 65 | 66 | -- Another exercise 67 | 68 | newtype Reader r a = Reader { runReader :: r -> a } 69 | 70 | ask :: Reader a a 71 | ask = Reader id 72 | 73 | -- Demo 74 | 75 | newtype HumanName = HumanName String deriving (Eq, Show) 76 | newtype DogName = DogName String deriving (Eq, Show) 77 | newtype Address = Address String deriving (Eq, Show) 78 | 79 | data Person = Person { 80 | humanName :: HumanName 81 | , dogName :: DogName 82 | , address :: Address 83 | } deriving (Eq, Show) 84 | 85 | data Dog = Dog { 86 | dogsName :: DogName 87 | , dogsAddress :: Address 88 | } deriving (Eq, Show) 89 | 90 | pers :: Person 91 | pers = Person 92 | (HumanName "Big Bird") 93 | (DogName "Barkley") 94 | (Address "Sesame Street") 95 | 96 | chris :: Person 97 | chris = Person 98 | (HumanName "Chris Allen") 99 | (DogName "Papu") 100 | (Address "Austin") 101 | 102 | getDog :: Person -> Dog 103 | getDog p = Dog (dogName p) (address p) 104 | 105 | getDogR :: Person -> Dog 106 | getDogR = Dog <$> dogName <*> address 107 | 108 | getDogR' :: Person -> Dog 109 | getDogR' = liftA2 Dog dogName address 110 | 111 | -- Exercise 112 | 113 | myLiftA2 :: Applicative f => 114 | (a -> b -> c) 115 | -> f a -> f b -> f c 116 | myLiftA2 f a b = f <$> a <*> b 117 | 118 | asks :: (r -> a) -> Reader r a 119 | asks f = Reader f 120 | 121 | instance Functor (Reader a) where 122 | fmap f (Reader x) = 123 | Reader $ f . x 124 | 125 | instance Applicative (Reader r) where 126 | pure a = Reader (\r -> a) 127 | Reader f <*> Reader g = 128 | Reader (\r -> f r (g r)) 129 | 130 | instance Monad (Reader r) where 131 | return = pure 132 | 133 | (>>=) :: Reader r a 134 | -> (a -> Reader r b) 135 | -> Reader r b 136 | (Reader ra) >>= aRb = 137 | join $ Reader $ \r -> aRb (ra r) 138 | 139 | getDogR'' :: Reader Person Dog 140 | getDogR'' = Dog <$> Reader dogName <*> Reader address 141 | 142 | -- Monad of functions 143 | 144 | foo :: (Functor f, Num a) => f a -> f a 145 | foo r = fmap (+1) r 146 | 147 | bar :: Foldable f => t -> f a -> (t, Int) 148 | bar r t = (r, length t) 149 | 150 | froot :: Num a => [a] -> ([a], Int) 151 | froot r = (map (+1) r, length r) 152 | 153 | barOne :: Foldable t => t a -> (t a, Int) 154 | barOne r = (r, length r) 155 | 156 | barPlus r = (foo r, length r) 157 | 158 | frooty :: Num a => [a] -> ([a], Int) 159 | frooty r = bar (foo r) r 160 | 161 | frooty' :: Num a => [a] -> ([a], Int) 162 | frooty' = \r -> bar (foo r) r 163 | 164 | fooBind m k = \r -> k (m r) r 165 | 166 | getDogRm :: Person -> Dog 167 | getDogRm = do 168 | name <- dogName 169 | addy <- address 170 | return $ Dog name addy 171 | 172 | getDogRM' :: Reader Person Dog 173 | getDogRM' = Reader (Dog <$> dogName <*> address) 174 | -------------------------------------------------------------------------------- /src/Ch22-ReaderPractice.hs: -------------------------------------------------------------------------------- 1 | 2 | module ReaderPractice where 3 | 4 | import Control.Applicative 5 | import Data.Maybe 6 | 7 | x = [1,2,3] 8 | y = [4,5,6] 9 | z = [7,8,9] 10 | 11 | -- lookup :: Eq a => a -> [(a, b)] -> Maybe b 12 | 13 | xs :: Maybe Integer 14 | xs = lookup 3 $ zip x y 15 | 16 | ys :: Maybe Integer 17 | ys = lookup 6 $ zip y z 18 | 19 | zs :: Maybe Integer 20 | zs = lookup 4 $ zip x y 21 | 22 | z' :: Integer -> Maybe Integer 23 | z' n = lookup n $ zip x z 24 | 25 | x1 :: Maybe (Integer, Integer) 26 | x1 = (,) <$> xs <*> ys 27 | 28 | x2 :: Maybe (Integer, Integer) 29 | x2 = (,) <$> ys <*> zs 30 | 31 | x3 :: Integer -> (Maybe Integer, Maybe Integer) 32 | x3 x = (z' x, z' x) 33 | 34 | summed :: Num c => (c, c) -> c 35 | summed = uncurry (+) 36 | 37 | bolt :: Integer -> Bool 38 | bolt = (&&) <$> (>3) <*> (<8) 39 | 40 | sequA :: Integral a => a -> [Bool] 41 | sequA = sequenceA [(>3), (<8), even] 42 | 43 | s' :: Maybe Integer 44 | s' = summed <$> ((,) <$> xs <*> ys) 45 | 46 | main :: IO () 47 | main = do 48 | print $ sequenceA [Just 3, Just 2, Just 1] 49 | print $ sequenceA [x, y] 50 | print $ sequenceA [xs, ys] 51 | print $ summed <$> ((,) <$> xs <*> ys) 52 | print $ fmap summed ((,) <$> xs <*> zs) 53 | print $ bolt 7 54 | print $ fmap bolt z 55 | print $ sequenceA [(>3), (<8), even] 7 56 | print "My turn" 57 | print $ and <$> sequA <$> fromMaybe 0 $ xs 58 | print $ and <$> sequA <$> fromMaybe 0 $ s' 59 | print $ bolt <$> fromMaybe 0 $ ys 60 | print $ (fmap . fmap) bolt z' <$> fromMaybe 0 $ xs 61 | -------------------------------------------------------------------------------- /src/Ch23-FizzBuzz.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad.Trans.State 3 | 4 | fizzBuzz :: Integer -> String 5 | fizzBuzz n | n `mod` 15 == 0 = "FizzBuzz" 6 | | n `mod` 5 == 0 = "Fizz" 7 | | n `mod` 3 == 0 = "Buzz" 8 | | otherwise = show n 9 | 10 | fizzBuzzList :: [Integer] -> [String] 11 | fizzBuzzList list = 12 | execState (mapM_ addResult list) [] 13 | 14 | 15 | addResult :: Integer -> State [String] () 16 | addResult n = do 17 | xs <- get 18 | let result = fizzBuzz n 19 | put (result : xs) 20 | 21 | fizzbuzzFromTo :: Integer -> Integer -> [String] 22 | fizzbuzzFromTo x y 23 | | x == y = fizzBuzzList [x] 24 | | x < y && y - x == 1 = fizzBuzzList [y,x] 25 | | x < y = fizzBuzzList [y, y - 1 .. x] 26 | | otherwise = fizzbuzzFromTo y x 27 | 28 | main :: IO () 29 | main = mapM_ putStrLn $ fizzbuzzFromTo 1 100 30 | -------------------------------------------------------------------------------- /src/Ch23-MyState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | newtype State s a = State { runState :: s -> (a, s) } 4 | 5 | get :: State s s 6 | get = State $ \a -> (a, a) 7 | 8 | put :: s -> State s () 9 | put s = State $ \_ -> ((), s) 10 | 11 | exec :: State s a -> s -> s 12 | exec (State sa) x = let (_, s) = sa x 13 | in s 14 | 15 | eval :: State s a -> s -> a 16 | eval (State sa) x = let (a, _) = sa x 17 | in a 18 | 19 | -- We need instances here 20 | 21 | instance Functor (State s) where 22 | fmap :: (a -> b) 23 | -> State s a 24 | -> State s b 25 | fmap f (State g) = State $ \s -> let (a, b) = g s 26 | in (f a, b) 27 | 28 | instance Applicative (State s) where 29 | pure :: a -> State s a 30 | pure a = State $ \s -> (a, s) 31 | (<*>) :: State s (a -> b) 32 | -> State s a 33 | -> State s b 34 | (State f) <*> (State g) = State $ \s -> let (fab, s') = f s 35 | (a, s'') = g s' 36 | in (fab a, s'') 37 | 38 | instance Monad (State s) where 39 | return = pure 40 | (>>=) :: State s a 41 | -> (a -> State s b) 42 | -> State s b 43 | (State f) >>= g = State $ \s -> let (a, s') = f s 44 | ms = runState $ g a 45 | in ms s' 46 | (>>) :: State s a 47 | -> State s b 48 | -> State s b 49 | State f >> State g = State $ \s -> let (_, s') = f s 50 | in g s' 51 | 52 | -- 53 | 54 | modify :: (s -> s) -> State s () 55 | modify f = State $ \x -> ((), f x) 56 | -------------------------------------------------------------------------------- /src/Ch23-RandomExample.hs: -------------------------------------------------------------------------------- 1 | 2 | module RandomExample where 3 | 4 | import System.Random 5 | 6 | data Die = DieOne 7 | | DieTwo 8 | | DieThree 9 | | DieFour 10 | | DieFive 11 | | DieSix 12 | deriving (Eq, Show) 13 | 14 | intToDie :: Int -> Die 15 | intToDie n = 16 | case n of 17 | 1 -> DieOne 18 | 2 -> DieTwo 19 | 3 -> DieThree 20 | 4 -> DieFour 21 | 5 -> DieFive 22 | 6 -> DieSix 23 | -- Use this tactic _extremely_ sparingly. 24 | x -> error $ "intToDie got non 1-6 integer: " ++ show x 25 | 26 | rollDieThreeTimes :: (Die, Die, Die) 27 | rollDieThreeTimes = do 28 | -- this will produce the same results every 29 | -- time because it is free of effects. 30 | -- This is fine for this demonstration. 31 | let s = mkStdGen 0 32 | (d1, s1) = randomR (1, 6) s 33 | (d2, s2) = randomR (1, 6) s1 34 | (d3, _ ) = randomR (1, 6) s2 35 | (intToDie d1, intToDie d2, intToDie d3) 36 | -------------------------------------------------------------------------------- /src/Ch23-RandomExample2.hs: -------------------------------------------------------------------------------- 1 | 2 | module RandomExample2 where 3 | 4 | import Control.Applicative (liftA3) 5 | import Control.Monad (replicateM) 6 | import Control.Monad.Trans.State 7 | import System.Random 8 | 9 | data Die = DieOne 10 | | DieTwo 11 | | DieThree 12 | | DieFour 13 | | DieFive 14 | | DieSix 15 | deriving (Eq, Show) 16 | 17 | intToDie :: Int -> Die 18 | intToDie n = 19 | case n of 20 | 1 -> DieOne 21 | 2 -> DieTwo 22 | 3 -> DieThree 23 | 4 -> DieFour 24 | 5 -> DieFive 25 | 6 -> DieSix 26 | -- Use this tactic _extremely_ sparingly. 27 | x -> error $ "intToDie got non 1-6 integer: " ++ show x 28 | 29 | 30 | rollDie :: State StdGen Die 31 | rollDie = state $ do 32 | (n, s) <- randomR (1, 6) 33 | return (intToDie n, s) 34 | 35 | rollDie' :: State StdGen Die 36 | rollDie' = 37 | intToDie <$> state (randomR (1, 6)) 38 | 39 | rollDieThreeTimes' :: State StdGen (Die, Die, Die) 40 | rollDieThreeTimes' = 41 | liftA3 (,,) rollDie rollDie rollDie 42 | 43 | infiniteDie :: State StdGen [Die] 44 | infiniteDie = repeat <$> rollDie 45 | 46 | nDie :: Int -> State StdGen [Die] 47 | nDie n = replicateM n rollDie 48 | 49 | rollsToGetTwenty :: StdGen -> Int 50 | rollsToGetTwenty g = go 0 0 g 51 | where go :: Int -> Int -> StdGen -> Int 52 | go sum count gen 53 | | sum >= 20 = count 54 | | otherwise = 55 | let (die, nextGen) = randomR (1, 6) gen 56 | in go (sum + die) (count + 1) nextGen 57 | 58 | rollToGetN :: Int -> StdGen -> Int 59 | rollToGetN n g = go n 0 0 g 60 | where go :: Int -> Int -> Int -> StdGen -> Int 61 | go n' sum count gen 62 | | sum >= n' = count 63 | | otherwise = 64 | let (die, nextGen) = randomR (1, 6) gen 65 | in go n' (sum + die) (count + 1) nextGen 66 | 67 | rollsCountLogged :: Int -> StdGen -> (Int, [Die]) 68 | rollsCountLogged n g = go n 0 (0, []) g 69 | where go :: Int -> Int -> (Int, [Die]) -> StdGen -> (Int, [Die]) 70 | go n' sum (count, xs) gen 71 | | sum >= n' = (count, xs) 72 | | otherwise = 73 | let (die, nextGen) = randomR (1, 6) gen 74 | in go n' (sum + die) (count + 1, intToDie die : xs) nextGen 75 | -------------------------------------------------------------------------------- /src/Ch23-State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | module Moi where 4 | 5 | import Test.QuickCheck 6 | import Test.QuickCheck.Checkers 7 | import Test.QuickCheck.Classes 8 | 9 | newtype Moi s a = Moi { runMoi :: s -> (a, s) } 10 | 11 | instance Functor (Moi s) where 12 | fmap :: (a -> b) 13 | -> Moi s a 14 | -> Moi s b 15 | fmap f (Moi g) = Moi $ \s -> let (a, b) = g s 16 | in (f a, b) 17 | 18 | 19 | instance Applicative (Moi s) where 20 | pure :: a -> Moi s a 21 | pure a = Moi $ \s -> (a, s) 22 | (<*>) :: Moi s (a -> b) 23 | -> Moi s a 24 | -> Moi s b 25 | (Moi f) <*> (Moi g) = Moi $ \s -> let (fab, s') = f s 26 | (a, s'') = g s' 27 | in (fab a, s'') 28 | 29 | instance Monad (Moi s) where 30 | return = pure 31 | (>>=) :: Moi s a 32 | -> (a -> Moi s b) 33 | -> Moi s b 34 | (Moi f) >>= g = Moi $ \s -> let (a, s') = f s 35 | (Moi sb) = g a 36 | in sb s' 37 | -------------------------------------------------------------------------------- /src/Ch24-AltParsing.hs: -------------------------------------------------------------------------------- 1 | 2 | module AltParsing where 3 | 4 | import Control.Applicative 5 | import Text.Trifecta 6 | 7 | type NumberOrString = Either Integer String 8 | 9 | a = "blah" 10 | b = "123" 11 | c = "123blah789" 12 | 13 | parseNOS :: Parser NumberOrString 14 | parseNOS = 15 | (Left <$> integer) 16 | <|> (Right <$> some letter) 17 | 18 | main = do 19 | print $ parseString (some letter) mempty a 20 | print $ parseString integer mempty b 21 | print $ parseString parseNOS mempty a 22 | print $ parseString parseNOS mempty b 23 | print $ parseString (many parseNOS) mempty c 24 | print $ parseString (some parseNOS) mempty c 25 | -------------------------------------------------------------------------------- /src/Ch24-AltParsing2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module AltParsing where 4 | 5 | import Control.Applicative 6 | import Text.RawString.QQ 7 | import Text.Trifecta 8 | 9 | type NumberOrString = 10 | Either Integer String 11 | 12 | eitherOr :: String 13 | eitherOr = [r| 14 | 123 15 | abc 16 | 456 17 | def 18 | |] 19 | 20 | parseNos :: Parser NumberOrString 21 | parseNos = 22 | skipMany (oneOf "\n") 23 | >> (Left <$> integer) 24 | <|> (Right <$> some letter) 25 | 26 | main = do 27 | print $ parseString (some (token parseNos)) mempty eitherOr 28 | -------------------------------------------------------------------------------- /src/Ch24-Fractions-parsers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Text.Fractions where 4 | 5 | import Control.Applicative 6 | import Data.Attoparsec.Text (parseOnly) 7 | import Data.Ratio ((%)) 8 | import Data.String (IsString) 9 | import Text.Trifecta 10 | 11 | badFraction :: IsString s => s 12 | badFraction = "1/0" 13 | 14 | alsoBad :: IsString s => s 15 | alsoBad = "10" 16 | 17 | shouldWork :: IsString s => s 18 | shouldWork = "1/2" 19 | 20 | shouldAlsoWork :: IsString s => s 21 | shouldAlsoWork = "2/1" 22 | 23 | parseFraction :: (Monad m, TokenParsing m) => m Rational 24 | parseFraction = do 25 | numerator <- decimal 26 | _ <- char '/' 27 | denominator <- decimal 28 | case denominator of 29 | 0 -> fail "Denominator cannot be zero" 30 | _ -> return (numerator % denominator) 31 | 32 | main :: IO () 33 | main = do 34 | -- parseOnly is Attoparsec 35 | print $ parseOnly parseFraction badFraction 36 | print $ parseOnly parseFraction shouldWork 37 | print $ parseOnly parseFraction shouldAlsoWork 38 | print $ parseOnly parseFraction alsoBad 39 | 40 | -- parseString is Trifecta 41 | print $ parseString parseFraction mempty badFraction 42 | print $ parseString parseFraction mempty shouldWork 43 | print $ parseString parseFraction mempty shouldAlsoWork 44 | print $ parseString parseFraction mempty alsoBad 45 | -------------------------------------------------------------------------------- /src/Ch24-Fractions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Text.Fractions where 4 | 5 | import Control.Applicative 6 | import Data.Ratio ((%)) 7 | import Text.Trifecta 8 | 9 | badFraction = "1/0" 10 | alsoBad = "10" 11 | shouldWork = "1/2" 12 | shouldAlsoWork = "2/1" 13 | 14 | parseFraction :: Parser Rational 15 | parseFraction = do 16 | numerator <- decimal 17 | char '/' 18 | denominator <- decimal 19 | return (numerator % denominator) 20 | 21 | main :: IO () 22 | main = do 23 | print $ parseString parseFraction mempty shouldWork 24 | print $ parseString parseFraction mempty shouldAlsoWork 25 | print $ parseString parseFraction mempty alsoBad 26 | print $ parseString parseFraction mempty badFraction 27 | 28 | virtuousFraction :: Parser Rational 29 | virtuousFraction = do 30 | numerator <- decimal 31 | char '/' 32 | denominator <- decimal 33 | case denominator of 34 | 0 -> fail "Denominator cannot be zero" 35 | _ -> return (numerator % denominator) 36 | 37 | testVirtuous :: IO () 38 | testVirtuous = do 39 | print $ parseString virtuousFraction mempty badFraction 40 | print $ parseString virtuousFraction mempty alsoBad 41 | print $ parseString virtuousFraction mempty shouldWork 42 | print $ parseString virtuousFraction mempty shouldAlsoWork 43 | 44 | -- Intermission: Exercise 45 | 46 | returnRational :: Parser Integer 47 | returnRational = do 48 | x <- decimal 49 | eof 50 | return x 51 | 52 | testReturn :: IO () 53 | testReturn = do 54 | print $ parseString returnRational mempty "a123" 55 | print $ parseString returnRational mempty "1a23" 56 | print $ parseString returnRational mempty "123a" 57 | print $ parseString returnRational mempty "a" 58 | print $ parseString returnRational mempty "123" 59 | -------------------------------------------------------------------------------- /src/Ch24-FractionsEx.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes #-} 2 | 3 | module Text.Fractions where 4 | 5 | import Control.Applicative 6 | import Data.Ratio ((%)) 7 | import Text.RawString.QQ 8 | import Text.Trifecta 9 | 10 | type FractionOrDecimal = 11 | Either Rational Integer 12 | 13 | eitherSuccess :: String 14 | eitherSuccess = [r| 15 | 123 16 | 1/2 17 | 23 18 | 3/23 19 | |] 20 | 21 | eitherFail :: String 22 | eitherFail = [r| 23 | 123 24 | 1/2 25 | 3/0 26 | |] 27 | 28 | parseFraction :: Parser Rational 29 | parseFraction = do 30 | numerator <- decimal 31 | char '/' 32 | denominator <- decimal 33 | case denominator of 34 | 0 -> fail "Denominator cannot be zero" 35 | _ -> return (numerator % denominator) 36 | 37 | parseDecimal :: Parser Integer 38 | parseDecimal = do 39 | x <- decimal 40 | c <- anyChar 41 | case c of 42 | '\n' -> return x 43 | _ -> fail "Unexpected character" 44 | 45 | parseEither :: Parser FractionOrDecimal 46 | parseEither = 47 | skipMany (oneOf "\n") 48 | >> (Left <$> try parseFraction) 49 | <|> (Right <$> parseDecimal) -- I want errors to fail here 50 | -- 'try' will silence errors 51 | -- and let successes pass 52 | 53 | main = do 54 | print $ parseString (some (token parseEither)) mempty eitherSuccess 55 | print $ parseString (some (token parseEither)) mempty eitherFail 56 | -------------------------------------------------------------------------------- /src/Ch24-LearnParsers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module LearnParsers where 4 | 5 | import Text.Trifecta 6 | import Text.Parser.Combinators 7 | 8 | stop :: Parser a 9 | stop = unexpected "stop" 10 | 11 | one = char '1' 12 | two = char '2' 13 | three = char '3' 14 | 15 | one' = one >> stop 16 | 17 | -- read two characters, '1' and '2' 18 | oneTwo = char '1' >> char '2' 19 | 20 | -- read two characters, '1' and '2', then die 21 | oneTwo' = oneTwo >> stop 22 | 23 | testParse :: Parser Char -> IO () 24 | testParse p = 25 | print $ parseString p mempty "123" 26 | 27 | testEOF :: Parser () -> IO () 28 | testEOF p = 29 | print $ parseString p mempty "123" 30 | 31 | -- string parsers 32 | 33 | type S = forall m. CharParsing m => m String 34 | 35 | oneS :: S 36 | oneS = string "1" 37 | 38 | oneTwoS :: S 39 | oneTwoS = string "12" 40 | 41 | oneTwoThreeS :: S 42 | oneTwoThreeS = string "123" 43 | 44 | testParse' :: Parser String -> IO () 45 | testParse' p = 46 | print $ parseString p mempty "123" 47 | 48 | -- One Parser rules them all 49 | -- how do we prevent >> to drop it on the floor? 50 | 51 | -- 52 | 53 | pNL s = putStrLn ('\n' : s) 54 | 55 | main = do 56 | pNL "stop:" 57 | testParse stop 58 | pNL "one:" 59 | testParse one 60 | pNL "one':" 61 | testParse one' 62 | pNL "oneTwo:" 63 | testParse oneTwo 64 | pNL "oneTwo':" 65 | testParse oneTwo' 66 | pNL "one >> EOF:" 67 | testEOF (one >> eof) 68 | pNL "oneTwo >> EOF" 69 | testEOF (oneTwo >> eof) 70 | pNL "string \"1\", \"12\", \"123\"" 71 | testParse' (choice [ oneTwoThreeS 72 | , oneTwoS 73 | , oneS 74 | , stop ]) 75 | pNL "char \"1\", \"12\", \"123\"" 76 | testParse (choice [ one >> two >> three 77 | , one >> two 78 | , one 79 | , stop ]) 80 | -------------------------------------------------------------------------------- /src/Ch24-LogFile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes #-} 2 | 3 | module LogFile where 4 | 5 | import Control.Applicative 6 | import Data.ByteString (ByteString) 7 | import Data.List (genericLength) 8 | import Data.Map (Map) 9 | import qualified Data.Map as M 10 | import qualified Data.Set as S 11 | import Text.Printf (printf) 12 | import Text.RawString.QQ 13 | import Text.Trifecta 14 | 15 | logEx :: ByteString 16 | logEx = [r| 17 | -- wheee a comment 18 | 19 | # 2025-02-05 20 | 08:00 Breakfast 21 | 09:00 Sanitizing moisture collector 22 | 11:00 Exercising in high-grav gym 23 | 12:00 Lunch 24 | 13:00 Programming 25 | 17:00 Commuting home in rover 26 | 17:30 R&R 27 | 19:00 Dinner 28 | 21:00 Shower 29 | 21:15 Read 30 | 22:00 Sleep 31 | 32 | # 2025-02-07 -- dates not nececessarily sequential 33 | 08:00 Breakfast -- should I try skippin bfast? 34 | 09:00 Bumped head, passed out 35 | 13:36 Wake up, headache 36 | 13:37 Go to medbay 37 | 13:40 Patch self up 38 | 13:45 Commute home for rest 39 | 14:15 Read 40 | 21:00 Dinner 41 | 21:15 Read 42 | 22:00 Sleep 43 | |] 44 | 45 | type Day = Integer 46 | type Month = Integer 47 | type Year = Integer 48 | type Activity = String 49 | 50 | newtype Time = Time Integer deriving (Eq, Ord) 51 | data Entry = Entry Time Activity deriving (Eq, Show) 52 | type Section = Map Time Activity 53 | 54 | miniLog :: ByteString 55 | miniLog = [r| 56 | # 2025-02-05 57 | 08:00 Breakfast 58 | 09:00 Sanitizing moisture collector 59 | 11:00 Exercising in high-grav gym 60 | |] 61 | 62 | parseActivity :: Parser String 63 | parseActivity = do 64 | a <- try 65 | (manyTill (noneOf "\n") comment) 66 | <|> many (noneOf "\n") 67 | 68 | skipOptional skipLine 69 | return a 70 | 71 | comment :: Parser String 72 | comment = try (someSpace >> string "--") 73 | <|> string "--" 74 | 75 | skipLine :: Parser () 76 | skipLine = skipMany (noneOf "\n") >> skipOptional (char '\n') >> return () 77 | 78 | parseDate :: Parser Time 79 | parseDate = do 80 | _ <- string "# " 81 | year <- count 4 digit 82 | _ <- char '-' 83 | month <- count 2 digit 84 | _ <- char '-' 85 | day <- count 2 digit 86 | let ym = read year * 525600 87 | mm = read month * 43800 88 | dm = read day * 1440 89 | return $ Time (ym + mm + dm) 90 | 91 | parseEntry :: Parser Entry 92 | parseEntry = do 93 | h <- count 2 digit 94 | _ <- char ':' 95 | m <- count 2 digit 96 | _ <- char ' ' 97 | e <- parseActivity 98 | let hm = read h * 60 99 | mm = read m 100 | return $ Entry (Time (hm + mm)) e 101 | 102 | skipComment :: Parser () 103 | skipComment = skipOptional (comment >> skipLine) 104 | 105 | parseSection :: Parser Section 106 | parseSection = do 107 | skipMany (noneOf "#") 108 | d <- parseDate 109 | skipComment 110 | whiteSpace 111 | entries <- some parseEntry 112 | return $ M.fromList $ readEntry d <$> entries 113 | 114 | readEntry :: Time -> Entry -> (Time, Activity) 115 | readEntry d (Entry t a) = (d + t, a) 116 | 117 | -- parseByteString (some parseSection) mempty logEx 118 | 119 | parseLog :: Parser Section 120 | parseLog = do 121 | xs <- some (M.toList <$> parseSection) 122 | return $ M.fromList $ concat xs 123 | 124 | -- parseByteString parseLog mempty logEx 125 | 126 | instance Show Time where 127 | show (Time rawmin) = let 128 | ym = 525600 129 | mm = 43800 130 | dm = 1440 131 | hm = 60 132 | y = quot rawmin ym 133 | yr = rem rawmin ym 134 | mo = quot yr mm 135 | mr = rem yr mm 136 | d = quot mr dm 137 | dr = rem mr dm 138 | h = quot dr hm 139 | m = rem dr hm 140 | in printf "%04d" y ++ "-" ++ 141 | printf "%02d" mo ++ "-" ++ 142 | printf "%02d" d ++ " " ++ 143 | printf "%02d" h ++ ":" ++ 144 | printf "%02d" (abs m) 145 | 146 | instance Num Time where 147 | (Time m) + (Time m') = Time (m + m') 148 | (Time m) - (Time m') = Time (m - m') 149 | fromInteger = Time 150 | (Time m) * (Time m') = Time (m * m') 151 | abs (Time m) = Time (abs m) 152 | signum (Time m) = Time (signum m) 153 | 154 | instance Fractional Time where 155 | fromRational m = Time (floor m) 156 | Time m / Time m' = fromRational (fromInteger m / fromInteger m') 157 | 158 | maybeSuccess :: Result a -> Maybe a 159 | maybeSuccess (Success a) = Just a 160 | maybeSuccess _ = Nothing 161 | 162 | -- Now just sum all activity times and divide by number of days 163 | -- I really should drop sleep as an activity. Sleep should be 164 | -- just the end time of the last activity. 165 | 166 | withinDay :: (Activity, Time) -> Bool 167 | withinDay (_, t) = t < Time 1440 && t > Time 0 168 | 169 | activityTime :: Result Section -> [(Activity, Time)] 170 | activityTime (Success ms) = 171 | let xs = M.toList ms 172 | endTime :: Time -> Map Time Activity -> Time 173 | endTime k ms' = 174 | case M.lookupGT k ms' of 175 | Nothing -> k 176 | Just (t', _) -> t' 177 | timeSpent :: Map Time Activity 178 | -> (Time, Activity) 179 | -> (Activity, Time) 180 | timeSpent ms' (t, a) = (a, endTime t ms' - t) 181 | in filter withinDay $ map (timeSpent ms) xs 182 | activityTime _ = [] 183 | 184 | parsedLog :: Result Section 185 | parsedLog = parseByteString parseLog mempty logEx 186 | 187 | activitySum :: Map Activity Time 188 | activitySum = M.fromListWith (+) 189 | $ activityTime 190 | $ parseByteString parseLog mempty logEx 191 | 192 | -- activityTime $ parseByteString parseSection mempty miniLog 193 | 194 | -- two passes, suck it. I'm a n00b with deadlines. 195 | extractDates :: Result Section -> [String] 196 | extractDates (Success ms) = 197 | let xs = M.toList ms 198 | in map (\(t, _) -> take 10 (show t)) xs 199 | extractDates _ = [] 200 | 201 | countDays :: [String] -> Integer 202 | countDays xs = 203 | let unique = S.toList . S.fromList 204 | in genericLength $ unique xs 205 | 206 | -- countDays $ extractDates parsedLog 207 | 208 | avgActTimePerDay :: Result Section -> Map Activity Time 209 | avgActTimePerDay pLog = 210 | let days = countDays $ extractDates pLog 211 | sumTime = M.fromListWith (+) $ activityTime pLog 212 | in (/ fromInteger days) <$> sumTime -- division, not lambda! 213 | -------------------------------------------------------------------------------- /src/Ch24-Marshalling.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes #-} 2 | 3 | module Marshalling where 4 | 5 | import Control.Applicative 6 | import Data.Aeson 7 | import Data.ByteString.Lazy (ByteString) 8 | import qualified Data.Text as T 9 | import Data.Text (Text) 10 | import Text.RawString.QQ 11 | 12 | sectionJson :: ByteString 13 | sectionJson = [r| 14 | { "section": {"host": "wikipedia.org"}, 15 | "whatisit":{"red": "intoothandclaw"} 16 | } 17 | |] 18 | 19 | data TestData = TestData { 20 | section :: Host 21 | , what :: Color 22 | } deriving (Eq, Show) 23 | 24 | newtype Host = Host String deriving (Eq, Show) 25 | 26 | type Annotation = String 27 | 28 | data Color = Red Annotation 29 | | Blue Annotation 30 | | Yellow Annotation 31 | deriving (Eq, Show) 32 | 33 | main = do 34 | let d = decode sectionJson :: Maybe TestData 35 | print d 36 | 37 | instance FromJSON TestData where 38 | parseJSON (Object v) = 39 | TestData <$> v .: "section" 40 | <*> v .: "whatisit" 41 | parseJSON _ = 42 | fail "Expected an object for TestData" 43 | 44 | instance FromJSON Host where 45 | parseJSON (Object v) = 46 | Host <$> v .: "host" 47 | parseJSON _ = 48 | fail "Expected an object for Host" 49 | 50 | instance FromJSON Color where 51 | parseJSON (Object v) = (Red <$> v .: "red") 52 | <|> (Blue <$> v .: "blue") 53 | <|> (Yellow <$> v .: "yellow") 54 | parseJSON _ = fail "Expected an object for Color" 55 | 56 | -------------------------------------------------------------------------------- /src/Ch24-ParsePhone.hs: -------------------------------------------------------------------------------- 1 | 2 | module ParsePhone where 3 | 4 | import Control.Applicative 5 | import Text.Trifecta 6 | 7 | type NumberingPlanArea = Int -- aka area code 8 | type Exchange = Int 9 | type LineNumber = Int 10 | 11 | data PhoneNumber = 12 | PhoneNumber NumberingPlanArea Exchange LineNumber 13 | deriving (Eq, Show) 14 | 15 | parsePhone :: Parser PhoneNumber 16 | parsePhone = do 17 | _ <- optional (string "1-") 18 | _ <- optional (char '(') 19 | npa <- count 3 digit 20 | _ <- optional (char ')') 21 | _ <- optional (oneOf " -") 22 | exc <- count 3 digit 23 | _ <- optional (oneOf " -") 24 | ln <- count 4 digit 25 | eof 26 | return $ PhoneNumber (read npa) (read exc) (read ln) 27 | -------------------------------------------------------------------------------- /src/Ch24-PositiveInteger.hs: -------------------------------------------------------------------------------- 1 | 2 | module PositiveInteger where 3 | 4 | import Control.Applicative 5 | import Text.Trifecta 6 | 7 | parseDigit :: Parser Char 8 | parseDigit = oneOf "0123456789" "a digit between 0 and 9" 9 | 10 | base10Integer :: Parser Integer 11 | base10Integer = read <$> some parseDigit 12 | 13 | base10Integer' :: Parser Integer 14 | base10Integer' = do 15 | sign <- optional (char '-') 16 | xs <- some parseDigit 17 | case sign of 18 | Nothing -> return (read xs) 19 | Just x -> return (read $ x:xs) 20 | -------------------------------------------------------------------------------- /src/Ch24-Semver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Semver where 4 | 5 | import Control.Applicative 6 | import Data.Monoid ((<>)) 7 | import Text.Trifecta 8 | 9 | 10 | data NumberOrString = NOSS String 11 | | NOSI Integer 12 | deriving (Show, Eq) 13 | 14 | type Major = Integer 15 | type Minor = Integer 16 | type Patch = Integer 17 | newtype Release = Release [NumberOrString] deriving (Show, Eq) 18 | type Metadata = [NumberOrString] 19 | 20 | data SemVer = SemVer Major Minor Patch Release Metadata 21 | deriving (Show, Eq) 22 | 23 | ver :: String 24 | ver = "1.0.0-x.7.z.92" 25 | 26 | parseNOS :: Parser NumberOrString 27 | parseNOS = (NOSI <$> try (decimal <* notFollowedBy letter)) 28 | <|> (NOSS <$> some (letter <|> digit)) 29 | 30 | parsePrerelease :: Parser NumberOrString 31 | parsePrerelease = skipMany (oneOf ".") >> parseNOS 32 | 33 | parseSemVer :: Parser SemVer 34 | parseSemVer = SemVer 35 | <$> decimal 36 | <*> (char '.' *> decimal) 37 | <*> (char '.' *> decimal) 38 | <*> (Release <$> (char '-' *> some parsePrerelease <|> mempty)) 39 | <*> (char '+' *> some parsePrerelease <|> mempty) 40 | 41 | instance Ord NumberOrString where 42 | (NOSI _) `compare` (NOSS _) = GT 43 | (NOSS _) `compare` (NOSI _) = LT 44 | (NOSI x) `compare` (NOSI x') = x `compare` x' 45 | (NOSS x) `compare` (NOSS x') = x `compare` x' 46 | 47 | instance Ord Release where 48 | (Release []) `compare` (Release []) = EQ 49 | (Release []) `compare` (Release _) = GT 50 | (Release _) `compare` (Release []) = LT 51 | (Release x) `compare` (Release x') = x `compare` x' 52 | 53 | instance Ord SemVer where 54 | (SemVer mj mn p r _) `compare` (SemVer mj' mn' p' r' _) = 55 | compare mj mj' 56 | <> compare mn mn' 57 | <> compare p p' 58 | <> compare r r' 59 | 60 | -- still need to test 61 | 62 | -- This is all correct as per semver.org: 63 | -- λ> SemVer 2 1 1 (Release [NOSI 1]) [] > SemVer 2 1 0 (Release []) [] 64 | -- True 65 | -- λ> SemVer 2 1 0 (Release [NOSI 1]) [] > SemVer 2 1 0 (Release []) [] 66 | -- False 67 | -------------------------------------------------------------------------------- /src/Ch24-ini.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes #-} 2 | 3 | module Data.Ini where 4 | 5 | import Control.Applicative 6 | import Data.ByteString hiding (foldr) 7 | import Data.Char (isAlpha) 8 | import Data.Map (Map) 9 | import qualified Data.Map as M 10 | import Data.Text (Text) 11 | import qualified Data.Text.IO as TIO 12 | import Test.Hspec 13 | import Text.RawString.QQ 14 | import Text.Trifecta 15 | 16 | headerEx :: ByteString 17 | headerEx = "[blah]" 18 | 19 | -- "[blah]" -> Section "blah" 20 | newtype Header = Header String deriving (Eq, Ord, Show) 21 | 22 | parseBracketPair :: Parser a -> Parser a 23 | parseBracketPair p = char '[' *> p <* char ']' 24 | -- these operators mean the brackets will be 25 | -- parsed and then discarded 26 | -- but the p will remain as our result 27 | 28 | parseHeader :: Parser Header 29 | parseHeader = 30 | parseBracketPair (Header <$> some letter) 31 | 32 | assignmentEx :: ByteString 33 | assignmentEx = "woot=1" 34 | 35 | type Name = String 36 | type Value = String 37 | type Assignments = Map Name Value 38 | 39 | parseAssignment :: Parser (Name, Value) 40 | parseAssignment = do 41 | name <- some letter 42 | _ <- char '=' 43 | val <- some (noneOf "\n") 44 | skipEOL -- important! 45 | return (name, val) 46 | 47 | -- / Skip end of line and whitespace beyond. 48 | skipEOL :: Parser () 49 | skipEOL = skipMany (oneOf "\n") 50 | 51 | commentEx :: ByteString 52 | commentEx = "; last modified 1 April 2001 by John Doe" 53 | 54 | commentEx' :: ByteString 55 | commentEx' = "; blah\n; woot\n \n;hah" 56 | 57 | -- / Skip comments starting at the beginning of the line. 58 | skipComments :: Parser () 59 | skipComments = 60 | skipMany (do _ <- char ';' <|> char '#' 61 | skipMany (noneOf "\n") 62 | skipEOL) 63 | 64 | sectionEx :: ByteString 65 | sectionEx = 66 | "; ignore me\n[states]\nChris=Texas" 67 | 68 | sectionEx' :: ByteString 69 | sectionEx' = [r| 70 | ; ignore me 71 | [states] 72 | Chris=Texas 73 | |] 74 | 75 | sectionEx'' :: ByteString 76 | sectionEx'' = [r| 77 | ; comment 78 | [section] 79 | host=wikipedia.org 80 | alias=claw 81 | 82 | [whatisit] 83 | red=intoothandclaw 84 | |] 85 | 86 | data Section = Section Header Assignments deriving (Eq, Show) 87 | 88 | newtype Config = Config (Map Header Assignments) deriving (Eq, Show) 89 | 90 | skipWhiteSpace :: Parser () 91 | skipWhiteSpace = 92 | skipMany (char ' ' <|> char '\n') 93 | 94 | parseSection :: Parser Section 95 | parseSection = do 96 | skipWhiteSpace 97 | skipComments 98 | h <- parseHeader 99 | skipEOL 100 | assignments <- some parseAssignment 101 | return $ Section h (M.fromList assignments) 102 | 103 | rollup :: Section 104 | -> Map Header Assignments 105 | -> Map Header Assignments 106 | rollup (Section h a) m = M.insert h a m 107 | 108 | parseIni :: Parser Config 109 | parseIni = do 110 | sections <- some parseSection 111 | let mapOfSections = 112 | foldr rollup M.empty sections 113 | return (Config mapOfSections) 114 | 115 | maybeSuccess :: Result a -> Maybe a 116 | maybeSuccess (Success a) = Just a 117 | maybeSuccess _ = Nothing 118 | 119 | main :: IO () 120 | main = hspec $ do 121 | 122 | describe "Assignment Parsing" $ 123 | it "can parse a simple assignment" $ do 124 | let m = parseByteString parseAssignment 125 | mempty assignmentEx 126 | r' = maybeSuccess m 127 | print m 128 | r' `shouldBe` Just ("woot", "1") 129 | 130 | describe "Header Parsing" $ 131 | it "can parse a simple header" $ do 132 | let m = parseByteString parseHeader mempty headerEx 133 | r' = maybeSuccess m 134 | print m 135 | r' `shouldBe` Just (Header "blah") 136 | 137 | describe "Comment parsing" $ 138 | it "Can skip a comment before a header" $ do 139 | let p = skipComments >> parseHeader 140 | i = "; woot\n[blah]" 141 | m = parseByteString p mempty i 142 | r' = maybeSuccess m 143 | print m 144 | r' `shouldBe` Just (Header "blah") 145 | 146 | describe "Section parsing" $ 147 | it "Can parse a simple section" $ do 148 | let m = parseByteString parseSection 149 | mempty sectionEx 150 | r' = maybeSuccess m 151 | states = M.fromList [("Chris","Texas")] 152 | expected' = Just (Section 153 | (Header "states") 154 | states) 155 | print m 156 | r' `shouldBe` expected' 157 | 158 | describe "INI parsing" $ 159 | it "Can parse multiple sections" $ do 160 | let m = parseByteString parseIni mempty sectionEx'' 161 | r' = maybeSuccess m 162 | sectionValues = M.fromList 163 | [ ("alias","claw") 164 | , ("host", "wikipedia.org")] 165 | whatisitValues = M.fromList 166 | [("red", "intoothandclaw")] 167 | expected' = Just (Config 168 | (M.fromList 169 | [ (Header "section" 170 | , sectionValues) 171 | , (Header "whatisit" 172 | , whatisitValues)])) 173 | print m 174 | r' `shouldBe` expected' 175 | -------------------------------------------------------------------------------- /src/Ch24-ipv6.hs: -------------------------------------------------------------------------------- 1 | 2 | module IPv6 where 3 | 4 | import Data.List (elemIndex) 5 | import Data.Maybe 6 | import Data.Word 7 | import Numeric 8 | import Test.Hspec 9 | import Text.Trifecta 10 | import IPv4 hiding (main) 11 | 12 | data IPAddress6 = 13 | IPAddress6 Word64 Word64 14 | deriving (Eq, Ord) 15 | 16 | instance Show IPAddress6 where 17 | show = show <$> ip6ToInteger 18 | 19 | ip6ToInteger :: IPAddress6 -> Integer 20 | ip6ToInteger (IPAddress6 q r) = 21 | (toInteger q) 22 | * (toInteger (maxBound :: Word)) 23 | + (toInteger r) 24 | 25 | hex :: [Char] 26 | hex = ['0'..'9'] ++ ['A'..'F'] ++ ['a'..'f'] 27 | 28 | parseBlock :: Parser [Char] 29 | parseBlock = many $ oneOf hex 30 | 31 | parseBlocks :: Parser [String] 32 | parseBlocks = sepBy1 parseBlock (char ':') 33 | 34 | fillAbbrev :: [String] -> [String] 35 | fillAbbrev xs = -- I'm sure this can be shortened 36 | if "" `elem` xs 37 | then 38 | if length xs > 8 39 | then catMaybes $ (\a -> if a == "" then Nothing else Just a) <$> xs 40 | else let i = fromJust $ elemIndex "" xs 41 | t = splitAt i xs 42 | in fillAbbrev (fst t ++ ["0"] ++ snd t) 43 | else xs 44 | 45 | parseIPv6 :: Parser IPAddress6 46 | parseIPv6 = do 47 | xs <- parseBlocks 48 | let xs' = concat $ spewPart 49 | <$> initState 16 50 | <$> fst 51 | <$> (catMaybes $ listToMaybe 52 | <$> readHex 53 | <$> fillAbbrev xs) 54 | x = bitToIntegral (0, xs') 55 | ip = quotRem x (fromIntegral (maxBound :: Word)) 56 | return $ IPAddress6 (fromIntegral $ fst ip) (fromIntegral $ snd ip) 57 | 58 | main :: IO () 59 | main = hspec $ do 60 | 61 | describe "Test some IP values" $ do 62 | let ip1 = "FE80::0202:B3FF:FE1E:8329" 63 | ip2 = "0:0:0:0:0:ffff:cc78:f" 64 | it ("can parse " ++ ip1) $ do 65 | -- Nonexhaustive, I know 66 | let (Success x) = parseString parseIPv6 mempty ip1 67 | r = ip6ToInteger x 68 | r `shouldBe` 338288524927261089654163772891438416681 69 | 70 | it ("can parse " ++ ip2) $ do 71 | let (Success x) = parseString parseIPv6 mempty ip2 72 | r = ip6ToInteger x 73 | r `shouldBe` 281474112159759 74 | 75 | -------------------------------------------------------------------------------- /src/Ch25-IdentityT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | module IdentityT where 4 | 5 | import Control.Monad (join) 6 | 7 | newtype Identity a = 8 | Identity { runIdentity :: a } 9 | deriving (Eq, Show) 10 | 11 | newtype IdentityT f a = 12 | IdentityT { runIdentityT :: f a } 13 | deriving (Eq, Show) 14 | 15 | instance Functor Identity where 16 | fmap f (Identity a) = Identity (f a) 17 | 18 | instance (Functor m) => Functor (IdentityT m) where 19 | fmap f (IdentityT fa) = IdentityT (fmap f fa) 20 | 21 | instance Applicative Identity where 22 | pure = Identity 23 | (Identity f) <*> (Identity a) = Identity (f a) 24 | 25 | instance (Applicative m) => Applicative (IdentityT m) where 26 | pure x = IdentityT (pure x) 27 | (IdentityT fab) <*> (IdentityT fa) = 28 | IdentityT (fab <*> fa) 29 | 30 | instance Monad Identity where 31 | return = pure 32 | (Identity a) >>= f = f a 33 | 34 | instance (Monad m) => Monad (IdentityT m) where 35 | return = pure 36 | (>>=) :: IdentityT m a 37 | -> (a -> IdentityT m b) 38 | -> IdentityT m b 39 | (IdentityT ma) >>= f = 40 | IdentityT $ ma >>= runIdentityT . f 41 | -------------------------------------------------------------------------------- /src/Ch25-Twinplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | module Twinplicative where 4 | 5 | import Prelude hiding (Either, Left, Right) 6 | 7 | newtype Compose f g a = 8 | Compose { getCompose :: f (g a) } 9 | deriving (Eq, Show) 10 | 11 | instance (Functor f, Functor g) => 12 | Functor (Compose f g) where 13 | fmap f (Compose fga) = 14 | Compose $ (fmap . fmap) f fga 15 | 16 | instance (Applicative f, Applicative g) => 17 | Applicative (Compose f g) where 18 | pure :: a -> Compose f g a 19 | pure x = Compose $ (pure . pure) x 20 | 21 | (<*>) :: Compose f g (a -> b) 22 | -> Compose f g a 23 | -> Compose f g b 24 | (Compose f) <*> (Compose a) = 25 | Compose $ ((<*>) <$> f) <*> a 26 | 27 | instance (Foldable f, Foldable g) => 28 | Foldable (Compose f g) where 29 | foldMap f (Compose fga) = 30 | (foldMap . foldMap) f fga 31 | 32 | instance (Traversable f, Traversable g) => 33 | Traversable (Compose f g) where 34 | traverse :: Applicative f1 => (a -> f1 b) 35 | -> Compose f g a 36 | -> f1 (Compose f g b) 37 | traverse f (Compose fga) = 38 | Compose <$> (traverse . traverse) f fga 39 | 40 | class Bifunctor p where 41 | {-# MINIMAL bimap | first, second #-} 42 | 43 | bimap :: (a -> b) -> (c -> d) -> p a c -> p b d 44 | bimap f g = first f . second g 45 | 46 | first :: (a -> b) -> p a c -> p b c 47 | first f = bimap f id 48 | 49 | second :: (b -> c) -> p a b -> p a c 50 | second = bimap id 51 | 52 | data Deux a b = Deux a b 53 | 54 | instance Bifunctor Deux where 55 | bimap f g (Deux a b) = Deux (f a) (g b) 56 | first f (Deux a b) = Deux (f a) b 57 | second f (Deux a b) = Deux a (f b) 58 | 59 | data Const a b = Const a 60 | 61 | instance Bifunctor Const where 62 | bimap f _ (Const a) = Const (f a) 63 | first f (Const a) = Const (f a) 64 | second _ (Const a) = Const a 65 | 66 | data Drei a b c = Drei a b c 67 | 68 | instance Bifunctor (Drei a) where 69 | bimap f g (Drei a b c) = Drei a (f b) (g c) 70 | first f (Drei a b c) = Drei a (f b) c 71 | second g (Drei a b c) = Drei a b (g c) 72 | 73 | data SuperDrei a b c = SuperDrei a b 74 | 75 | instance Bifunctor (SuperDrei a) where 76 | bimap f _ (SuperDrei a b) = SuperDrei a (f b) 77 | first f (SuperDrei a b) = SuperDrei a (f b) 78 | second _ (SuperDrei a b) = SuperDrei a b 79 | 80 | data SemiDrei a b c = SemiDrei a 81 | 82 | instance Bifunctor (SemiDrei a) where 83 | bimap _ _ (SemiDrei a) = SemiDrei a 84 | first _ (SemiDrei a) = SemiDrei a 85 | second _ (SemiDrei a) = SemiDrei a 86 | 87 | data Quadriceps a b c d = Quadzzz a b c d 88 | 89 | instance Bifunctor (Quadriceps a b) where 90 | bimap f g (Quadzzz a b c d) = Quadzzz a b (f c) (g d) 91 | first f (Quadzzz a b c d) = Quadzzz a b (f c) d 92 | second g (Quadzzz a b c d) = Quadzzz a b c (g d) 93 | 94 | data Either a b = Left a 95 | | Right b 96 | 97 | instance Bifunctor Either where 98 | bimap f _ (Left a) = Left (f a) 99 | bimap _ g (Right b) = Right (g b) 100 | first f (Left a) = Left (f a) 101 | first _ (Right b) = Right b 102 | second _ (Left a) = Left a 103 | second g (Right b) = Right (g b) 104 | 105 | -------------------------------------------------------------------------------- /src/Ch26-Ex.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | 5 | module Exercises where 6 | 7 | import Control.Monad.IO.Class 8 | import Control.Monad.Trans.Maybe 9 | import Control.Monad.Trans.Reader 10 | import Control.Monad.Trans.State 11 | import Data.Functor.Identity 12 | 13 | rDec :: Num a => Reader a a 14 | rDec = reader $ flip (-) 1 15 | 16 | rShow :: Show a => ReaderT a Identity String 17 | rShow = ReaderT $ Identity . show 18 | 19 | rPrintAndInc :: (Num a, Show a) => ReaderT a IO a 20 | rPrintAndInc = ReaderT $ \r -> do 21 | liftIO . putStrLn $ "hi: " ++ show r 22 | return $ r + 1 23 | 24 | sPrintIncAccum :: (Num a, Show a) => StateT a IO String 25 | sPrintIncAccum = StateT $ \s -> do 26 | liftIO . putStrLn $ "Hi: " ++ show s 27 | return $ (show s, s + 1) 28 | 29 | isValid :: String -> Bool 30 | isValid v = '!' `elem` v 31 | 32 | maybeExcite :: MaybeT IO String 33 | maybeExcite = MaybeT $ do 34 | v <- getLine 35 | case isValid v of 36 | True -> return $ Just v 37 | False -> return Nothing 38 | 39 | doExcite :: IO () 40 | doExcite = do 41 | putStrLn "say something excite!" 42 | excite <- runMaybeT maybeExcite 43 | case excite of 44 | Nothing -> putStrLn "MOAR EXCITE" 45 | Just e -> putStrLn ("Good, was very excite: " ++ e) 46 | -------------------------------------------------------------------------------- /src/Ch26-HitCounter.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Control.Monad.IO.Class 7 | import Control.Monad.Trans.Class 8 | import Control.Monad.Trans.Reader 9 | import Data.IORef 10 | import qualified Data.Map as M 11 | import Data.Maybe (fromMaybe) 12 | import Data.Text.Lazy (Text) 13 | import qualified Data.Text.Lazy as TL 14 | import System.Environment (getArgs) 15 | import Web.Scotty.Trans 16 | 17 | data Config = 18 | Config { 19 | -- that's one, one click! 20 | -- two...two clicks! 21 | -- Three BEAUTIFUL clicks! ah ah ahhhh 22 | counts :: IORef (M.Map Text Integer) 23 | , prefix :: Text 24 | } 25 | 26 | -- Stuff inside ScottyT is, except for things that escape 27 | -- via IO, effectively read-only so we can't use StateT. 28 | -- It would overcomplicate things to attempt to do so and 29 | -- you should be using a proper database for production 30 | -- applications. 31 | 32 | type Scotty = ScottyT Text (ReaderT Config IO) 33 | type Handler = ActionT Text (ReaderT Config IO) 34 | 35 | bumpBoomp :: Text 36 | -> M.Map Text Integer 37 | -> (M.Map Text Integer, Integer) 38 | bumpBoomp k m = (M.insert k bump m, bump) 39 | where bump = (fromMaybe 0 (M.lookup k m)) + 1 40 | 41 | app :: Scotty () 42 | app = 43 | get "/:key" $ do 44 | unprefixed <- param "key" 45 | config <- lift ask 46 | let key' = mappend (prefix config) unprefixed 47 | ref = counts config 48 | map' = readIORef ref 49 | (newMap, newInteger) <- liftIO (bumpBoomp key' <$> map') 50 | liftIO $ writeIORef ref newMap 51 | 52 | html $ mconcat [ "

Success! Count was: " 53 | , TL.pack $ show newInteger 54 | , "

" 55 | ] 56 | 57 | main :: IO () 58 | main = do 59 | [prefixArg] <- getArgs 60 | counter <- newIORef M.empty 61 | let config = Config counter (TL.pack prefixArg) 62 | runR r = runReaderT r config 63 | scottyT 3000 runR app 64 | -------------------------------------------------------------------------------- /src/Ch26-MaybeT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | module MaybeT where 4 | 5 | newtype MaybeT m a = 6 | MaybeT { runMaybeT :: m (Maybe a) } 7 | 8 | -- instance (Functor f, Functor g) => 9 | -- Functor (Compose f g) where 10 | -- fmap f (Compose fga) = 11 | -- Compose $ (fmap . fmap) f fga 12 | 13 | instance (Functor m) => Functor (MaybeT m) where 14 | fmap f (MaybeT ma) = MaybeT $ (fmap . fmap) f ma 15 | 16 | instance (Applicative m) => Applicative (MaybeT m) where 17 | pure x = MaybeT (pure (pure x)) 18 | MaybeT fab <*> MaybeT mma = 19 | MaybeT $ (<*>) <$> fab <*> mma 20 | 21 | instance (Monad m) => Monad (MaybeT m) where 22 | return = pure 23 | 24 | (>>=) :: MaybeT m a 25 | -> (a -> MaybeT m b) 26 | -> MaybeT m b 27 | MaybeT ma >>= f = 28 | MaybeT $ do 29 | v <- ma 30 | case v of 31 | Nothing -> return Nothing 32 | Just y -> runMaybeT (f y) 33 | 34 | 35 | newtype EitherT e m a = 36 | EitherT { runEitherT :: m (Either e a) } 37 | 38 | instance Functor m => Functor (EitherT e m) where 39 | fmap f (EitherT mea) = EitherT $ (fmap . fmap) f mea 40 | 41 | instance Applicative m => Applicative (EitherT e m) where 42 | pure x = EitherT (pure (pure x)) 43 | EitherT fab <*> EitherT mma = 44 | EitherT $ (<*>) <$> fab <*> mma 45 | 46 | instance Monad m => Monad (EitherT e m) where 47 | return = pure 48 | 49 | (>>=) :: EitherT e m a 50 | -> (a -> EitherT e m b) 51 | -> EitherT e m b 52 | EitherT ma >>= f = 53 | EitherT $ do 54 | v <- ma 55 | case v of 56 | Left e -> return $ Left e 57 | Right a -> runEitherT (f a) 58 | 59 | swapEither :: Either e a -> Either a e 60 | swapEither x = 61 | case x of 62 | Left e -> Right e 63 | Right a -> Left a 64 | 65 | swapEitherT :: (Functor m) => EitherT e m a -> EitherT a m e 66 | swapEitherT (EitherT x) = EitherT $ swapEither <$> x 67 | 68 | either' :: (a -> c) -> (b -> c) -> Either a b -> c 69 | either' fe _ (Left e) = fe e 70 | either' _ fa (Right a) = fa a 71 | 72 | eitherT :: Monad m => 73 | (a -> m c) 74 | -> (b -> m c) 75 | -> EitherT a m b 76 | -> m c 77 | eitherT fa fb (EitherT x) = x >>= either fa fb 78 | -------------------------------------------------------------------------------- /src/Ch26-MonadTrans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | module MonadTrans where 4 | 5 | import Control.Monad 6 | 7 | import Control.Monad.IO.Class (MonadIO (liftIO)) 8 | import Control.Monad.Trans.Class (MonadTrans (lift)) 9 | 10 | instance MonadTrans IdentityT where 11 | lift :: Monad m => m a -> IdentityT m a 12 | lift = IdentityT 13 | 14 | instance MonadTrans MaybeT where 15 | lift :: Monad m => m a -> MaybeT m a 16 | lift ma = MaybeT $ fmap Just ma 17 | 18 | instance MonadTrans (ReaderT r) where 19 | -- Equivalent to ReaderT const 20 | lift ma = ReaderT $ \r -> ma 21 | 22 | instance MonadTrans (EitherT e) where 23 | -- Pointfree version of: lift ma = EitherT $ fmap Right ma 24 | lift = EitherT . fmap Right 25 | 26 | instance MonadTrans (StateT s) where 27 | lift ma = StateT $ \s -> fmap (\a -> (a, s)) ma 28 | 29 | instance MonadIO m => MonadIO (IdentityT m) where 30 | liftIO :: IO a -> IdentityT m a 31 | liftIO ioA = IdentityT ma 32 | -- Use m's liftIO to put ioA into m 33 | where 34 | ma = liftIO ioA 35 | 36 | instance MonadIO m => MonadIO (EitherT e m) where 37 | liftIO :: IO a -> EitherT e m a 38 | -- This is m's liftIO and EitherT's lift 39 | liftIO = lift . liftIO 40 | -- Equivalent to: 41 | -- liftIO ioA = EitherT $ fmap Right ma 42 | -- where ma = liftIO ioA 43 | 44 | instance MonadIO m => MonadIO (MaybeT m) where 45 | liftIO = lift . liftIO 46 | -- Equivalent to: 47 | -- liftIO ioA = MaybeT mMaybeA 48 | -- where mMaybeA = fmap Just ma 49 | -- ma = liftIO ioA 50 | 51 | instance MonadIO m => MonadIO (ReaderT r m) where 52 | liftIO ioA = ReaderT rToMa 53 | where 54 | rToMa r = liftIO ioA 55 | 56 | instance MonadIO m => MonadIO (StateT s m) where 57 | liftIO ioA = StateT smas 58 | where 59 | smas s = fmap (\a -> (a, s)) ma 60 | ma = liftIO ioA 61 | -------------------------------------------------------------------------------- /src/Ch26-Morra.hs: -------------------------------------------------------------------------------- 1 | 2 | module Morra where 3 | 4 | import Control.Monad (replicateM_) 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Trans.Reader 7 | import Data.Bifunctor 8 | import Data.IORef 9 | import System.Exit 10 | import System.IO 11 | import System.Random 12 | 13 | 14 | data Command a = Valid a | Invalid | Quit 15 | 16 | type PersonGuess = Int 17 | type PersonScore = Int 18 | type Name = String 19 | type Names = (Name, Name) 20 | type Score = (PersonScore, PersonScore) 21 | type Turn = (PersonGuess, PersonGuess) 22 | data Mode = AI2P | P2P 23 | data GameState = GameState { score :: Score 24 | , turns :: [Turn] 25 | } 26 | data Game = Game { 27 | gameState :: IORef GameState 28 | , mode :: Mode 29 | } 30 | 31 | updateScore :: Turn -> Score -> Score 32 | updateScore (cg, pg) = 33 | if even $ cg + pg 34 | then first (+1) 35 | else second (+1) 36 | 37 | gameWinner :: Names -> Score -> String 38 | gameWinner (p1, p2) s = 39 | case uncurry compare s of 40 | GT -> "Way to go, " ++ p1 ++ "!" 41 | EQ -> "It is a draw!" 42 | LT -> "Way to go, " ++ p2 ++ "!" 43 | 44 | turnWinner :: Names -> Turn -> String 45 | turnWinner ns ts = 46 | if even $ uncurry (+) ts 47 | then "- " ++ fst ns ++ " wins" 48 | else "- " ++ snd ns ++ " wins" 49 | 50 | parseInput :: Char -> Command PersonGuess 51 | parseInput ch 52 | | ch `elem` "Qq" = Quit 53 | | ch `elem` "12" = Valid $ read [ch] 54 | | otherwise = Invalid 55 | 56 | parseMode :: Char -> Either String Mode 57 | parseMode ch 58 | | ch `elem` "Pp" = Right P2P 59 | | ch `elem` "Cc" = Right AI2P 60 | | otherwise = Left $ "Key pressed: " ++ [ch] 61 | 62 | invalid :: IO () 63 | invalid = putStrLn "Type 1, 2 or Q for quit" 64 | 65 | quit :: Names -> Score -> IO () 66 | quit (p1, p2) (s1, s2) = do 67 | putStrLn $ concat [ "Final score -- " ++ p1 ++ ": " 68 | , show $ s1 69 | , " " ++ p2 ++ ": " 70 | , show $ s2 ] 71 | putStrLn $ gameWinner (p1, p2) (s1, s2) 72 | putStrLn "Quitting..." 73 | exitSuccess 74 | 75 | p2p :: Name -> IO (Command PersonGuess) 76 | p2p p = do 77 | putStr $ p ++ ": " 78 | input <- getChar 79 | _ <- getChar 80 | replicateM_ 12 $ putStrLn "\n" -- poor man's blank screen 81 | return $ parseInput input 82 | 83 | ai :: [Turn] -> IO PersonGuess 84 | ai ts = 85 | if length ts < 3 86 | then guess 87 | else 88 | let pattern = take 2 $ snd <$> ts 89 | recall = lookup pattern $ trigrams ts 90 | in case recall of 91 | Nothing -> guess 92 | Just r -> return r 93 | where guess = randomRIO (1,2) :: IO PersonGuess 94 | 95 | trigrams :: [Turn] -> [([PersonGuess], PersonGuess)] 96 | trigrams ts = 97 | if length ts < 3 98 | then [] 99 | else 100 | let [c,b,a] = take 3 $ snd <$> ts 101 | in ([b,a],c) : trigrams (tail ts) 102 | 103 | rules :: Names -> IO () 104 | rules (p1, p2) = 105 | putStrLn $ concat [ 106 | "-- " 107 | , p2 108 | , " is odds, " 109 | , p1 110 | , " is evens." 111 | ] 112 | 113 | gameRoutine :: Game -> IO () 114 | gameRoutine (Game ref m) = do 115 | st <- readIORef ref 116 | let score' = score st 117 | turns' = turns st 118 | case m of 119 | AI2P -> do 120 | let players = ("C", "P") :: Names 121 | quit' = quit players score' 122 | rules players 123 | pg <- p2p $ snd players 124 | case pg of 125 | Quit -> quit' 126 | Invalid -> invalid 127 | Valid personGuess -> do 128 | aiGuess <- ai turns' -- AI guess 129 | putStrLn (fst players ++ ": " ++ show aiGuess) -- reveal AI guess 130 | let turn = (aiGuess, personGuess) :: Turn 131 | writeIORef ref $ GameState (updateScore turn score') (turn:turns') 132 | putStrLn $ turnWinner players turn 133 | gameRoutine (Game ref AI2P) 134 | P2P -> do 135 | let players = ("P1", "P2") :: Names 136 | quit' = quit players score' 137 | rules players 138 | g1 <- p2p $ fst players 139 | g2 <- p2p $ snd players 140 | case g1 of 141 | Quit -> quit' 142 | Invalid -> invalid 143 | Valid g1' -> 144 | case g2 of 145 | Quit -> quit' 146 | Invalid -> invalid 147 | Valid g2' -> do 148 | let turn = (g1', g2') :: Turn 149 | writeIORef ref $ GameState (updateScore turn score') turns' 150 | putStrLn $ turnWinner players turn 151 | gameRoutine (Game ref P2P) 152 | 153 | app :: ReaderT Game IO () 154 | app = do 155 | config <- ask 156 | liftIO $ gameRoutine config 157 | app 158 | 159 | main :: IO () 160 | main = do 161 | hSetBuffering stdout NoBuffering 162 | putStrLn "*********Set game mode: *********" 163 | putStrLn "* P for Person to Person *" 164 | putStrLn "* C for Person vs AI (Computer) *" 165 | putStrLn "******any other key to quit******" 166 | putStr "Selection: " 167 | m <- getChar 168 | _ <- getChar 169 | case parseMode m of 170 | Left e -> putStrLn e >> exitSuccess 171 | Right m' -> do 172 | newGame <- newIORef $ GameState (0,0) [] 173 | let config = Game newGame m' 174 | run r = runReaderT r config 175 | run app 176 | -------------------------------------------------------------------------------- /src/Ch26-MorraState.hs: -------------------------------------------------------------------------------- 1 | 2 | -- I know, it is a long file. Normally I would place it in a 3 | -- self-contained project with its own Module hierarchy. But 4 | -- I'm keeping it here with the other haskellbook exercises. 5 | 6 | module MorraState where 7 | 8 | import Control.Monad (replicateM_) 9 | import Control.Monad.IO.Class 10 | import Control.Monad.Trans.Reader 11 | import Control.Monad.Trans.Except 12 | import Control.Monad.Trans.State.Lazy 13 | import Data.Word8 14 | import System.Exit 15 | import System.IO 16 | import System.Random 17 | 18 | data Player = A | B deriving Show 19 | 20 | data Guess = Odd | Even deriving (Bounded, Enum, Eq, Show) 21 | 22 | data Turn = Turn { turnA :: Guess 23 | , turnB :: Guess } 24 | deriving Show 25 | 26 | data Score = Score { scoreA :: Word8 27 | , scoreB :: Word8 } 28 | deriving Show 29 | 30 | data Mode = AI2P | P2P 31 | 32 | -- Scores 33 | 34 | updateScore :: Player -> Score -> Score 35 | updateScore p s = 36 | case p of 37 | A -> Score { scoreA = scoreA s + 1, scoreB = scoreB s } 38 | B -> Score { scoreA = scoreA s, scoreB = scoreB s + 1 } 39 | 40 | getWinner :: Turn -> Player 41 | getWinner (Turn a b) = 42 | if a == b 43 | then A 44 | else B 45 | 46 | getScore :: [Turn] -> Score 47 | getScore = foldr (updateScore . getWinner) (Score 0 0) 48 | 49 | finalWinner :: Score -> Player 50 | finalWinner s = 51 | if scoreA s > scoreB s 52 | then A 53 | else B 54 | 55 | -- Random generator 56 | 57 | instance Random Guess where 58 | random g = case randomR (fromEnum Odd, fromEnum Even) g of 59 | (r, g') -> (toEnum r, g') 60 | randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of 61 | (r, g') -> (toEnum r, g') 62 | 63 | -- AI 64 | 65 | aiTurn :: [Turn] -> IO Guess 66 | aiTurn ts = 67 | if length ts < 3 68 | then guess 69 | else 70 | let pattern = take 2 $ turnB <$> ts 71 | recall = lookup pattern $ trigrams ts 72 | in case recall of 73 | Nothing -> guess 74 | Just r -> return r 75 | where guess = randomIO :: IO Guess 76 | 77 | trigrams :: [Turn] -> [([Guess], Guess)] 78 | trigrams ts = 79 | if length ts < 3 80 | then [] 81 | else 82 | let [c,b,a] = take 3 $ turnB <$> ts 83 | in ([b,a],c) : trigrams (tail ts) 84 | 85 | -- As we approach IO land, things get messier 86 | -- Strings 87 | 88 | type Name = String 89 | 90 | player :: Mode -> Player -> Name 91 | player AI2P A = "Computer" 92 | player AI2P B = "Person" 93 | player P2P A = "Person 1" 94 | player P2P B = "Person 2" 95 | 96 | printRules :: ReaderT Mode IO () 97 | printRules = do 98 | m <- ask 99 | liftIO $ do 100 | putStrLn "Press 1 for odds, 2 for evens." 101 | putStrLn $ player m A ++ " is evens," 102 | putStrLn $ player m B ++ " is odds." 103 | 104 | -- Person input 105 | 106 | promptInput :: Name -> IO Char 107 | promptInput n = do 108 | putStr $ n ++ ": " 109 | c <- getChar 110 | _ <- getChar 111 | return c 112 | 113 | parseInput :: Char -> ExceptT (IO ()) IO Guess 114 | parseInput c 115 | | c `elem` "12" = return $ (toEnum . (subtract 1) . read) [c] 116 | | otherwise = throwE $ exceptHandler c 117 | 118 | exceptHandler :: Char -> IO () 119 | exceptHandler c 120 | | c `elem` "Qq" = putStrLn "Quitting..." >> exitSuccess 121 | | otherwise = putStrLn "Press '1' for Odd, '2' for Even, and Q for Quit" 122 | 123 | personGuess :: MonadIO m 124 | => Player 125 | -> ReaderT Mode m (Either (IO ()) Guess) 126 | personGuess p = do 127 | m <- ask 128 | c <- liftIO $ promptInput $ player m p 129 | c' <- liftIO $ runExceptT $ parseInput c 130 | return c' 131 | 132 | -- Modes 133 | 134 | parseMode :: Char -> ExceptT (IO ()) IO Mode 135 | parseMode c 136 | | c `elem` "Pp" = return $ P2P 137 | | c `elem` "Cc" = return $ AI2P 138 | | otherwise = throwE $ 139 | (putStrLn $ "Key pressed: " ++ [c]) 140 | >> putStrLn "Quitting..." 141 | 142 | promptMode :: IO Char 143 | promptMode = do 144 | putStrLn "*********Set game mode: *********" 145 | putStrLn "* P for Person to Person *" 146 | putStrLn "* C for Person vs AI (Computer) *" 147 | putStrLn "******any other key to quit******" 148 | putStr "Selection: " 149 | c <- getChar 150 | _ <- getChar 151 | return c 152 | 153 | ai2p :: StateT [Turn] IO () 154 | ai2p = do 155 | ts <- get 156 | aig <- liftIO $ aiTurn ts 157 | pg' <- liftIO $ runReaderT (personGuess B) AI2P 158 | case pg' of 159 | Right pg -> do 160 | let turn = Turn aig pg 161 | w = player AI2P $ getWinner turn 162 | c = player AI2P A 163 | put $ turn:ts 164 | liftIO $ putStrLn $ c ++ ": " ++ show aig 165 | liftIO $ putStrLn $ "- " ++ w ++ " wins" 166 | ai2p 167 | Left e -> liftIO $ printScore AI2P ts 168 | >> e >> runStateT ai2p ts >> return () 169 | 170 | printScore :: Mode -> [Turn] -> IO () 171 | printScore m ts = do 172 | let score = getScore ts 173 | putStrLn $ "***** Score *****" 174 | putStrLn $ player m A ++ ": " ++ (show . scoreA) score 175 | putStrLn $ player m B ++ ": " ++ (show . scoreB) score 176 | putStrLn $ "Way to go, " ++ (player m $ finalWinner score) ++ "!" 177 | putStrLn $ "*****************" 178 | 179 | p2pGuess :: Player -> IO Guess 180 | p2pGuess p = do 181 | pg <- runReaderT (personGuess p) P2P 182 | case pg of 183 | Right g -> 184 | replicateM_ 12 (putStrLn "\n") >> return g -- poor man's blank screen 185 | Left e -> 186 | e >> p2pGuess p 187 | 188 | p2p :: StateT [Turn] IO () 189 | p2p = do 190 | g' <- liftIO $ p2pGuess A 191 | g'' <- liftIO $ p2pGuess B 192 | ts <- get 193 | let turn = Turn g' g'' 194 | ts' = turn:ts 195 | liftIO $ do 196 | putStrLn $ "- " ++ (player P2P $ getWinner turn) ++ " wins" 197 | printScore P2P ts' 198 | put ts' 199 | p2p 200 | 201 | main :: IO () 202 | main = do 203 | hSetBuffering stdout NoBuffering 204 | m'' <- promptMode 205 | m' <- runExceptT $ parseMode m'' 206 | case m' of 207 | Right AI2P -> do 208 | runReaderT printRules AI2P 209 | runStateT ai2p [] >> return () 210 | Right P2P -> do 211 | runReaderT printRules P2P 212 | runStateT p2p [] >> return () 213 | Left e -> e 214 | -------------------------------------------------------------------------------- /src/Ch26-OuterInner.hs: -------------------------------------------------------------------------------- 1 | 2 | module OuterInner where 3 | 4 | import Control.Monad.Trans.Except 5 | import Control.Monad.Trans.Maybe 6 | import Control.Monad.Trans.Reader 7 | 8 | embedded :: MaybeT (ExceptT String (ReaderT () IO)) Int 9 | embedded = return 1 10 | 11 | maybeUnwrap :: ExceptT String (ReaderT () IO) (Maybe Int) 12 | maybeUnwrap = runMaybeT embedded 13 | 14 | eitherUnwrap :: ReaderT () IO (Either String (Maybe Int)) 15 | eitherUnwrap = runExceptT maybeUnwrap 16 | 17 | readerUnwrap :: () -> IO (Either String (Maybe Int)) 18 | readerUnwrap = runReaderT eitherUnwrap 19 | 20 | embeddedAgain :: MaybeT (ExceptT String (ReaderT () IO)) Int 21 | embeddedAgain = MaybeT . ExceptT . ReaderT $ \() -> pure (const (Right (Just 1)) ()) 22 | -------------------------------------------------------------------------------- /src/Ch26-ReaderT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module ReaderT where 5 | 6 | import Data.Bifunctor 7 | 8 | 9 | newtype ReaderT r m a = 10 | ReaderT { runReaderT :: r -> m a } 11 | 12 | instance Functor m => Functor (ReaderT r m) where 13 | fmap f (ReaderT rma) = ReaderT $ (fmap . fmap) f rma 14 | 15 | instance Applicative m => Applicative (ReaderT r m) where 16 | pure x = ReaderT $ pure (pure x) 17 | ReaderT frma <*> ReaderT rma = 18 | ReaderT $ (<*>) <$> frma <*> rma 19 | 20 | instance Monad m => Monad (ReaderT r m) where 21 | return = pure 22 | (>>=) :: ReaderT r m a 23 | -> (a -> ReaderT r m b) 24 | -> ReaderT r m b 25 | ReaderT rma >>= f = 26 | ReaderT $ \r -> do 27 | a <- rma r 28 | runReaderT (f a) r 29 | 30 | 31 | newtype StateT s m a = 32 | StateT { runStateT :: s -> m (a, s) } 33 | 34 | instance (Functor m) => Functor (StateT s m) where 35 | fmap :: (a -> b) 36 | -> StateT s m a 37 | -> StateT s m b 38 | fmap f (StateT sma) = StateT $ 39 | \s -> let r = sma s 40 | in first f <$> r 41 | 42 | instance Monad m => Applicative (StateT s m) where 43 | pure a = StateT $ \s -> pure (a, s) 44 | 45 | (<*>) :: StateT s m (a -> b) 46 | -> StateT s m a 47 | -> StateT s m b 48 | 49 | StateT fma <*> StateT ma = StateT $ 50 | \s -> do 51 | (f, s') <- fma s 52 | (a, s'') <- ma s' 53 | return (f a, s'') 54 | 55 | instance (Monad m) => Monad (StateT s m) where 56 | return = pure 57 | 58 | (>>=) :: StateT s m a 59 | -> (a -> StateT s m b) 60 | -> StateT s m b 61 | 62 | StateT ma >>= f = StateT $ 63 | \s -> do 64 | (a, s') <- ma s 65 | (runStateT $ f a) s' 66 | -------------------------------------------------------------------------------- /src/Ch26-Scotty-2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.IO.Class 6 | import Data.Maybe (fromMaybe) 7 | import Data.Text.Lazy (Text) 8 | import Web.Scotty 9 | 10 | param' :: Parsable a => Text -> ActionM (Maybe a) 11 | param' k = rescue (Just <$> param k) 12 | (const (return Nothing)) 13 | 14 | main = scotty 3000 $ do 15 | get "/:word" $ do 16 | beam' <- param' "word" 17 | let beam = fromMaybe "" beam' 18 | i <- param' "num" 19 | liftIO $ print (i :: Maybe Integer) 20 | html $ mconcat ["

Scotty, ", beam, " me up!

"] 21 | -------------------------------------------------------------------------------- /src/Ch26-Scotty-3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Trans.Class 7 | import Control.Monad.Trans.Maybe 8 | import Data.Text.Lazy (Text) 9 | import Web.Scotty 10 | 11 | param' :: Parsable a => Text -> MaybeT ActionM a 12 | param' k = MaybeT $ 13 | rescue (Just <$> param k) 14 | (const (return Nothing)) 15 | 16 | type Reco = (Integer, Integer, Integer, Integer) 17 | 18 | main :: IO () 19 | main = scotty 3000 $ do 20 | get "/:word" $ do 21 | beam <- param "word" 22 | reco <- runMaybeT $ do 23 | a <- param' "1" 24 | liftIO $ print a 25 | b <- param' "2" 26 | c <- param' "3" 27 | d <- param' "4" 28 | (lift . lift) $ print b 29 | return ((a, b, c, d) :: Reco) 30 | liftIO $ print reco 31 | html $ mconcat ["

Scotty, ", beam, " me up!

"] 32 | -------------------------------------------------------------------------------- /src/Ch26-Scotty-4.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Trans.Class 7 | import Control.Monad.Trans.Except 8 | import Data.Text.Lazy (Text) 9 | import qualified Data.Text.Lazy as TL 10 | import Web.Scotty 11 | 12 | param' :: Parsable a => Text -> ExceptT String ActionM a 13 | param' k = ExceptT $ 14 | rescue (Right <$> param k) 15 | (const 16 | (return 17 | (Left $ "They key: " 18 | ++ show k 19 | ++ " was missing!"))) 20 | 21 | type Reco = (Integer, Integer, Integer, Integer) 22 | 23 | tshow :: Reco -> Text 24 | tshow = TL.pack . show 25 | 26 | main :: IO () 27 | main = scotty 3000 $ do 28 | get "/" $ do 29 | reco <- runExceptT $ do 30 | a <- param' "1" 31 | liftIO $ print a 32 | b <- param' "2" 33 | c <- param' "3" 34 | d <- param' "4" 35 | (lift . lift) $ print b 36 | return ((a, b, c, d) :: Reco) 37 | case reco of 38 | (Left e) -> text (TL.pack e) 39 | (Right r) -> 40 | html $ mconcat ["

Success! Reco was: ", tshow r, "

"] 41 | -------------------------------------------------------------------------------- /src/Ch26-Scotty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Scotty where 4 | 5 | import Web.Scotty 6 | 7 | import Control.Monad.IO.Class 8 | 9 | main :: IO () 10 | main = scotty 3000 $ do 11 | get "/:word" $ do 12 | beam <- param "word" 13 | liftIO (putStrLn "hello") 14 | html $ mconcat ["

Scotty, ", beam, " me up!

"] 15 | 16 | -------------------------------------------------------------------------------- /src/Ch26-StepByStep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- from the tutorial by 3 | -- Martin Grabmuller 4 | -- https://page.mi.fu-berlin.de/scravy/realworldhaskell/materialien/monad-transformers-step-by-step.pdf 5 | 6 | module Transformers where 7 | 8 | import Control.Monad.Identity 9 | import Control.Monad.Except 10 | import Control.Monad.Reader 11 | import Control.Monad.State 12 | import Control.Monad.Writer 13 | 14 | import Data.Maybe 15 | import qualified Data.Map as Map 16 | 17 | type Name = String -- variable names 18 | 19 | data Exp = Lit Integer -- expressions 20 | | Var Name 21 | | Plus Exp Exp 22 | | Abs Name Exp 23 | | App Exp Exp 24 | deriving (Show) 25 | 26 | data Value = IntVal Integer -- values 27 | | FunVal Env Name Exp 28 | deriving (Show) 29 | 30 | type Env = Map.Map Name Value -- mapping from names to values 31 | 32 | -- Without Monad Transformers 33 | 34 | eval0 :: Env -> Exp -> Value 35 | eval0 _ (Lit i) = IntVal i 36 | eval0 env (Var n) = fromJust (Map.lookup n env) 37 | eval0 env (Plus e1 e2) = let IntVal i1 = eval0 env e1 38 | IntVal i2 = eval0 env e2 39 | in IntVal (i1 + i2) 40 | eval0 env (Abs n e) = FunVal env n e 41 | eval0 env (App e1 e2) = let val1 = eval0 env e1 42 | val2 = eval0 env e2 43 | in case val1 of 44 | FunVal env' n body -> 45 | eval0 (Map.insert n val2 env') body 46 | 47 | exampleExp :: Exp 48 | exampleExp = Lit 12 `Plus` (App (Abs "x" (Var "x")) (Lit 4 `Plus` Lit 2)) 49 | 50 | -- λ> eval0 Map.empty exampleExp 51 | -- IntVal 18 52 | 53 | -- With Monad Transformers 54 | 55 | type Eval1 a = Identity a 56 | 57 | runEval1 :: Eval1 a -> a 58 | runEval1 ev = runIdentity ev 59 | 60 | eval1 :: Env -> Exp -> Eval1 Value 61 | eval1 _ (Lit i) = return $ IntVal i 62 | eval1 env (Var n) = return $ fromJust $ Map.lookup n env 63 | eval1 env (Plus e1 e2) = do IntVal i1 <- eval1 env e1 64 | IntVal i2 <- eval1 env e2 65 | return $ IntVal (i1 + i2) 66 | eval1 env (Abs n e) = return $ FunVal env n e 67 | eval1 env (App e1 e2) = do val1 <- eval1 env e1 68 | val2 <- eval1 env e2 69 | case val1 of 70 | FunVal env' n body -> 71 | eval1 (Map.insert n val2 env') body 72 | 73 | -- λ> runEval1 (eval1 Map.empty exampleExp) 74 | -- IntVal 18 75 | 76 | -- Adding Error Handling 77 | 78 | type Eval2 a = ExceptT String Identity a 79 | 80 | runEval2 :: Eval2 a -> Either String a 81 | runEval2 ev = runIdentity (runExceptT ev) 82 | 83 | eval2a :: Env -> Exp -> Eval2 Value 84 | eval2a _ (Lit i) = return $ IntVal i 85 | eval2a env (Var n) = case Map.lookup n env of 86 | Just val -> return val 87 | Nothing -> throwError ("unbound variable: " ++ n) 88 | eval2a env (Plus e1 e2) = do e1' <- eval2a env e1 89 | e2' <- eval2a env e2 90 | case (e1', e2') of 91 | (IntVal i1, IntVal i2) -> 92 | return $ IntVal (i1 + i2) 93 | _ -> throwError "type error in addition" 94 | eval2a env (Abs n e) = return $ FunVal env n e 95 | eval2a env (App e1 e2) = do val1 <- eval2a env e1 96 | val2 <- eval2a env e2 97 | case val1 of 98 | FunVal env' n body -> 99 | eval2a (Map.insert n val2 env') body 100 | _ -> throwError "type error in application" 101 | 102 | -- λ> runEval2 (eval2a Map.empty exampleExp) 103 | -- Right (IntVal 18) 104 | 105 | -- λ> runEval2 (eval2a Map.empty (Plus (Lit 1) (Abs "x" (Var "x")))) 106 | -- Left "type error in addition" 107 | 108 | -- Hiding the Environment 109 | 110 | type Eval3 a = ReaderT Env (ExceptT String Identity) a 111 | 112 | runEval3 :: Env -> Eval3 a -> Either String a 113 | runEval3 env ev = runIdentity (runExceptT (runReaderT ev env)) 114 | 115 | eval3 :: Exp -> Eval3 Value 116 | eval3 (Lit i) = return $ IntVal i 117 | eval3 (Var n) = do env <- ask 118 | case Map.lookup n env of 119 | Just val -> return val 120 | Nothing -> throwError ("unbound variable: " ++ n) 121 | eval3 (Plus e1 e2) = do e1' <- eval3 e1 122 | e2' <- eval3 e2 123 | case (e1', e2') of 124 | (IntVal i1, IntVal i2) -> 125 | return $ IntVal (i1 + i2) 126 | _ -> throwError "type error in addition" 127 | eval3 (Abs n e) = do env <- ask 128 | return $ FunVal env n e 129 | eval3 (App e1 e2) = do val1 <- eval3 e1 130 | val2 <- eval3 e2 131 | case val1 of 132 | FunVal env' n body -> 133 | local (const (Map.insert n val2 env')) (eval3 body) 134 | _ -> throwError "type error in application" 135 | 136 | -- λ> runEval3 Map.empty (eval3 exampleExp) 137 | -- Right (IntVal 18) 138 | 139 | 140 | -- Adding State 141 | 142 | type Eval4 a = ReaderT Env (ExceptT String (StateT Integer Identity)) a 143 | 144 | runEval4 :: Env -> Integer -> Eval4 a -> (Either String a, Integer) 145 | runEval4 env st ev = 146 | runIdentity (runStateT (runExceptT (runReaderT ev env)) st) 147 | 148 | tick :: (Num s, MonadState s m) => m () 149 | tick = do st <- get 150 | put (st + 1) 151 | 152 | eval4 :: (Num s 153 | , MonadError [Char] m 154 | , MonadReader (Map.Map Name Value) m, 155 | MonadState s m) 156 | => Exp -> m Value 157 | eval4 (Lit i) = do tick 158 | return $ IntVal i 159 | eval4 (Var n) = do tick 160 | env <- ask 161 | case Map.lookup n env of 162 | Nothing -> throwError ("unbound variable: " ++ n) 163 | Just val -> return val 164 | eval4 (Plus e1 e2) = do tick 165 | e1' <- eval4 e1 166 | e2' <- eval4 e2 167 | case (e1', e2') of 168 | (IntVal i1, IntVal i2) -> 169 | return $ IntVal (i1 + i2) 170 | _ -> throwError "type error in addition" 171 | eval4 (Abs n e) = do tick 172 | env <- ask 173 | return $ FunVal env n e 174 | eval4 (App e1 e2) = do tick 175 | val1 <- eval4 e1 176 | val2 <- eval4 e2 177 | case val1 of 178 | FunVal env' n body -> 179 | local (const (Map.insert n val2 env')) (eval4 body) 180 | _ -> throwError "type error in application" 181 | 182 | -- λ> runEval4 Map.empty 0 (eval4 (exampleExp)) 183 | -- (Right (IntVal 18),8) 184 | 185 | -- Alternate StateT and ExceptT 186 | 187 | type Eval4' a = ReaderT Env (StateT Integer (ExceptT String Identity)) a 188 | 189 | runEval4' :: Env -> Integer -> Eval4' a -> (Either String (a, Integer)) 190 | runEval4' env st ev = 191 | runIdentity (runExceptT (runStateT (runReaderT ev env) st)) 192 | 193 | -- Adding Logging 194 | 195 | type Eval5 a = ReaderT Env (ExceptT String 196 | (WriterT [String] (StateT Integer Identity))) a 197 | 198 | runEval5 :: Env -> Integer -> Eval5 a -> ((Either String a, [String]), Integer) 199 | runEval5 env st ev = 200 | runIdentity (runStateT (runWriterT (runExceptT (runReaderT ev env))) st) 201 | 202 | eval5 :: Exp -> Eval5 Value 203 | eval5 (Lit i) = do tick 204 | return $ IntVal i 205 | eval5 (Var n) = do tick 206 | tell [n] 207 | env <- ask 208 | case Map.lookup n env of 209 | Nothing -> throwError ("unbound variable: " ++ n) 210 | Just val -> return val 211 | eval5 (Plus e1 e2) = do tick 212 | e1' <- eval5 e1 213 | e2' <- eval5 e2 214 | case (e1', e2') of 215 | (IntVal i1, IntVal i2) -> 216 | return $ IntVal (i1 + i2) 217 | _ -> throwError "type error in addition" 218 | eval5 (Abs n e) = do tick 219 | env <- ask 220 | return $ FunVal env n e 221 | eval5 (App e1 e2) = do tick 222 | val1 <- eval5 e1 223 | val2 <- eval5 e2 224 | case val1 of 225 | FunVal env' n body -> 226 | local (const (Map.insert n val2 env')) (eval5 body) 227 | _ -> throwError "type error in application" 228 | 229 | -- λ> runEval5 Map.empty 0 (eval5 exampleExp) 230 | -- ((Right (IntVal 18),["x"]),8) 231 | -- λ> runEval5 Map.empty 0 (eval5 $ Var "x") 232 | -- ((Left "unbound variable: x",["x"]),1) 233 | 234 | -- What about I/O? 235 | 236 | type Eval6 a = ReaderT Env (ExceptT String 237 | (WriterT [String] (StateT Integer IO))) a 238 | 239 | runEval6 :: Env -> Integer -> Eval6 a 240 | -> IO ((Either String a, [String]), Integer) 241 | runEval6 env st ev = 242 | runStateT (runWriterT (runExceptT (runReaderT ev env))) st 243 | 244 | eval6 :: Exp -> Eval6 Value 245 | eval6 (Lit i) = do tick 246 | liftIO $ print i 247 | return $ IntVal i 248 | eval6 (Var n) = do tick 249 | tell [n] 250 | env <- ask 251 | case Map.lookup n env of 252 | Nothing -> throwError ("unbound variable: " ++ n) 253 | Just val -> return val 254 | eval6 (Plus e1 e2) = do tick 255 | e1' <- eval6 e1 256 | e2' <- eval6 e2 257 | case (e1', e2') of 258 | (IntVal i1, IntVal i2) -> 259 | return $ IntVal (i1 + i2) 260 | _ -> throwError "type error in addition" 261 | eval6 (Abs n e) = do tick 262 | env <- ask 263 | return $ FunVal env n e 264 | eval6 (App e1 e2) = do tick 265 | val1 <- eval6 e1 266 | val2 <- eval6 e2 267 | case val1 of 268 | FunVal env' n body -> 269 | local (const (Map.insert n val2 env')) (eval6 body) 270 | _ -> throwError "type error in application" 271 | 272 | -- λ> runEval6 Map.empty 0 (eval6 exampleExp) 273 | -- 12 274 | -- 4 275 | -- 2 276 | -- ((Right (IntVal 18),["x"]),8) 277 | 278 | -- λ> runEval6 Map.empty 0 (eval6 $ Var "x") 279 | -- ((Left "unbound variable: x",["x"]),1) 280 | -------------------------------------------------------------------------------- /src/Ch26-lookMa.hs: -------------------------------------------------------------------------------- 1 | 2 | module LookMa where 3 | 4 | import Control.Monad.Trans.Reader 5 | import Control.Monad.IO.Class 6 | 7 | foo :: IO () 8 | foo = flip runReaderT 10 $ do 9 | liftIO $ putStrLn "Hello! I'm in `ReaderT Int IO ()`!" 10 | val <- ask :: ReaderT Int IO Int 11 | liftIO $ print val 12 | -------------------------------------------------------------------------------- /src/Ch27-Bang.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module ManualBang where 4 | 5 | doesntEval :: Bool -> Int 6 | doesntEval b = 1 7 | 8 | manualSeq :: Bool -> Int 9 | manualSeq b = b `seq` 1 10 | 11 | banging :: Bool -> Int 12 | banging !b = 1 13 | 14 | data Foo = Foo Int !Int 15 | 16 | first (Foo x _) = x 17 | second (Foo _ y) = y 18 | 19 | data DoesntForce = TisLazy Int String 20 | 21 | gibString :: DoesntForce -> String 22 | gibString (TisLazy _ s) = s 23 | 24 | data BangBang = SheShotMeDown !Int !String 25 | 26 | gimmeString :: BangBang -> String 27 | gimmeString (SheShotMeDown _ s) = s 28 | -------------------------------------------------------------------------------- /src/Ch27-CoreDump.hs: -------------------------------------------------------------------------------- 1 | 2 | module CoreDump where 3 | 4 | data Test = A Test2 5 | | B Test2 6 | deriving (Show) 7 | 8 | data Test2 = C Int 9 | | D Int 10 | deriving (Show) 11 | 12 | forceNothing :: Test -> Int 13 | forceNothing _ = 0 14 | 15 | forceTest :: Test -> Int 16 | forceTest (A _) = 1 17 | forceTest (B _) = 2 18 | 19 | forceTest2 :: Test -> Int 20 | forceTest2 (A (C i)) = i 21 | forceTest2 (B (C i)) = i 22 | forceTest2 (A (D i)) = i 23 | forceTest2 (B (D i)) = i 24 | 25 | discriminatory :: Bool -> Int 26 | discriminatory b = 27 | case b of 28 | False -> 0 29 | True -> 1 30 | -------------------------------------------------------------------------------- /src/Ch27-Kaboom.hs: -------------------------------------------------------------------------------- 1 | 2 | module Kaboom where 3 | 4 | import Prelude hiding (foldr) 5 | 6 | possiblyKaboom = 7 | \f -> f fst snd (0, undefined) 8 | 9 | true :: a -> a -> a 10 | true = \a -> (\b -> a) 11 | 12 | false :: a -> a -> a 13 | false = \a -> (\b -> b) 14 | 15 | foldr k z xs = go xs 16 | where 17 | go [] = z 18 | go (y:ys) = y `k` go ys 19 | 20 | c = foldr const 'z' ['a'..'e'] 21 | -------------------------------------------------------------------------------- /src/Ch27-OutsideIn.hs: -------------------------------------------------------------------------------- 1 | 2 | module OutsideIn where 3 | 4 | hypo :: IO () 5 | hypo = do 6 | let x :: Int 7 | x = undefined 8 | s <- getLine 9 | case s of 10 | "hi" -> print x 11 | _ -> putStrLn "hello" 12 | 13 | hypo' :: IO () 14 | hypo' = do 15 | let x :: Integer 16 | x = undefined 17 | s <- getLine 18 | case x `seq` s of 19 | "hi" -> print x 20 | _ -> putStrLn "hello" 21 | 22 | data Test = A Test2 23 | | B Test2 24 | deriving (Show) 25 | 26 | data Test2 = C Int 27 | | D Int 28 | deriving (Show) 29 | 30 | forceNothing :: Test -> Int 31 | forceNothing _ = 0 32 | 33 | forceTest :: Test -> Int 34 | forceTest (A _) = 1 35 | forceTest (B _) = 2 36 | 37 | forceTest2 :: Test -> Int 38 | forceTest2 (A (C i)) = i 39 | forceTest2 (B (C i)) = i 40 | forceTest2 (A (D i)) = i 41 | forceTest2 (B (D i)) = i 42 | 43 | discriminatory :: Bool -> Int 44 | discriminatory b = 45 | let x = undefined 46 | in case b of 47 | False -> 0 48 | True -> 1 49 | 50 | hypo'' :: IO () 51 | hypo'' = do 52 | let x :: Integer 53 | x = undefined 54 | s <- x `seq` getLine 55 | case s of 56 | "hi" -> print x 57 | _ -> putStrLn "hello" 58 | 59 | 60 | -------------------------------------------------------------------------------- /src/Ch27-StrictTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Strict #-} 2 | 3 | module StrictTest where 4 | 5 | blah x = 1 6 | 7 | main = print (blah undefined) 8 | 9 | 10 | -------------------------------------------------------------------------------- /src/Ch27-StrictTest1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module StrictTest1 where 4 | 5 | data List a = Nil | Cons !a !(List a) deriving Show 6 | 7 | sTake :: Int -> List a -> List a 8 | sTake n _ 9 | | n <= 0 = Nil 10 | sTake n Nil = Nil 11 | sTake n (Cons x xs) = (Cons x (sTake (n-1) xs)) 12 | 13 | twoEls = Cons 1 (Cons undefined Nil) 14 | oneEl = sTake 1 twoEls 15 | 16 | threeElements = Cons 2 twoEls 17 | oneElT = sTake 1 threeElements 18 | -------------------------------------------------------------------------------- /src/Ch27-Trace.hs: -------------------------------------------------------------------------------- 1 | 2 | import Debug.Trace 3 | 4 | inc = (+1) 5 | 6 | twice = inc . inc 7 | 8 | howManyTimes = 9 | inc (trace "I got eval'd" (1 + 1)) 10 | + twice (trace "I got eval'd" (1 + 1)) 11 | 12 | howManyTimes' = 13 | let onePlusOne = trace "I got eval'd" (1 + 1) 14 | in inc onePlusOne + twice onePlusOne 15 | -------------------------------------------------------------------------------- /src/IPv4.hs: -------------------------------------------------------------------------------- 1 | 2 | module IPv4 where 3 | 4 | import Data.Word 5 | import Test.Hspec 6 | import Text.Trifecta 7 | 8 | data IPAddress = 9 | IPAddress Word32 10 | deriving (Eq, Ord, Show) 11 | 12 | type Rem = Integer 13 | type Bit = Integer 14 | type Pos = Integer 15 | 16 | data ParseState = 17 | ParseState { 18 | remainder :: Rem 19 | , bits :: [Bit] 20 | , posit :: Pos 21 | } deriving (Show) 22 | 23 | spewBit :: ParseState -> ParseState 24 | spewBit ps = 25 | let p' = (posit ps) - 1 26 | b = 2 ^ p' :: Pos 27 | (q, r) = (remainder ps) `quotRem` b 28 | xs = q : (bits ps) 29 | in ParseState {remainder = r, bits = xs, posit = p'} 30 | 31 | spewPart :: ParseState -> [Bit] 32 | spewPart ps = 33 | if posit ps == 0 34 | then reverse $ bits ps 35 | else spewPart $ spewBit ps 36 | 37 | initState :: Pos -> Pos -> ParseState 38 | initState p n = ParseState {remainder = n, bits = mempty, posit = p} 39 | 40 | parseIPv4 :: Parser IPAddress 41 | parseIPv4 = do 42 | n <- decimal 43 | _ <- char '.' 44 | n' <- decimal 45 | _ <- char '.' 46 | sn <- decimal 47 | _ <- char '.' 48 | h <- decimal 49 | let xs = concat $ spewPart <$> initState 8 <$> fromIntegral <$> [n,n',sn,h] 50 | return $ IPAddress (fromIntegral $ bitToIntegral (0, xs)) 51 | 52 | spewIntegral :: (Pos, [Bit]) -> (Pos, [Bit]) 53 | spewIntegral (s, xs) = 54 | let l = length xs - 1 55 | t = 2 ^ l 56 | in (s + head xs * t, tail xs) 57 | 58 | bitToIntegral :: (Pos, [Bit]) -> Pos 59 | bitToIntegral (i, xs) = 60 | if null xs 61 | then i 62 | else bitToIntegral $ spewIntegral (i, xs) 63 | 64 | main :: IO () 65 | main = hspec $ do 66 | 67 | describe "Test some IP values" $ do 68 | let ip1 = "172.16.254.1" 69 | ip2 = "204.120.0.15" 70 | it ("can parse " ++ ip1) $ do 71 | -- Nonexhaustive, I know 72 | let (Success x) = parseString parseIPv4 mempty ip1 73 | x `shouldBe` IPAddress 2886794753 74 | 75 | it ("can parse " ++ ip2) $ do 76 | let (Success x) = parseString parseIPv4 mempty ip2 77 | x `shouldBe` IPAddress 3430416399 78 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /src/notes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | data FixMePls a = FixMe | Pls a deriving (Eq, Show) 4 | 5 | instance Functor FixMePls where 6 | fmap _ FixMe = FixMe 7 | fmap f (Pls a) = Pls (f a) 8 | 9 | data WhoCares a = ItDoesnt | Matter a | WhatThisIsCalled 10 | deriving (Eq, Show) 11 | 12 | instance Functor WhoCares where 13 | fmap _ ItDoesnt = WhatThisIsCalled 14 | fmap f WhatThisIsCalled = ItDoesnt 15 | fmap f (Matter a) = Matter (f a) 16 | 17 | data CountingBad a = Heisenberg Int a deriving (Eq, Show) 18 | 19 | instance Functor CountingBad where 20 | fmap f (Heisenberg n a) = Heisenberg (n) (f a) 21 | 22 | -- lmls ~ List (Maybe (List String)) 23 | 24 | -- lmls ~ [Maybe [[Char]]] 25 | -- [Maybe [[Char]]] -> [Maybe Char] 26 | -- [Maybe [[Char]]] -> [Maybe [Char]] 27 | -- [Maybe [[Char]]] -> [Maybe [[Char]]] 28 | 29 | -- Lifting 30 | 31 | a = fmap (+1) $ read "[1]" :: [Int] 32 | 33 | b = (fmap . fmap) (++ "lol") (Just ["Hi,", "Hello"]) 34 | 35 | c = fmap (* 2) (\x -> x - 2) 36 | 37 | d = fmap ((return '1' ++) . show) (\x -> [x, 1..3]) 38 | 39 | e :: IO Integer 40 | e = let ioi = readIO "1" :: IO Integer 41 | changed = fmap read (fmap ("123"++) (fmap show ioi)) 42 | in fmap (* 3) changed 43 | 44 | -- Maybe 45 | 46 | incIfJust :: Num a => Maybe a -> Maybe a 47 | incIfJust (Just n) = Just $ n + 1 48 | incIfJust Nothing = Nothing 49 | 50 | showIfJust :: Show a => Maybe a -> Maybe String 51 | showIfJust (Just s) = Just $ show s 52 | showIfJust Nothing = Nothing 53 | 54 | incMaybe :: Num a => Maybe a -> Maybe a 55 | incMaybe m = fmap (+1) m 56 | 57 | showMaybe :: Show a => Maybe a -> Maybe String 58 | showMaybe s = fmap show s 59 | 60 | liftedInc :: (Functor f, Num b) => f b -> f b 61 | liftedInc = fmap (+1) 62 | 63 | liftedShow :: (Functor f, Show a) => f a -> f String 64 | liftedShow = fmap show 65 | 66 | data Possibly a = LolNope | Yeppers a deriving (Eq, Show) 67 | instance Functor Possibly where 68 | fmap f LolNope = LolNope 69 | fmap f (Yeppers a) = Yeppers (f a) 70 | 71 | -- Either 72 | 73 | incIfRight :: Num a => Either e a -> Either e a 74 | incIfRight (Right n) = Right $ n + 1 75 | incIfRight (Left e) = Left e 76 | 77 | showIfRight :: Show a => Either e a -> Either e String 78 | showIfRight (Right s) = Right $ show s 79 | showIfRight (Left e) = Left e 80 | 81 | incEither :: Num a => Either e a -> Either e a 82 | incEither = fmap (+1) 83 | 84 | showEither :: Show a => Either e a -> Either e String 85 | showEither = fmap show 86 | 87 | -- liftedInc :: (Functor f, Num b) => f b -> f b 88 | -- liftedInc = fmap (+1) 89 | 90 | -- liftedShow :: (Functor f, Show a) => f a -> f String 91 | -- liftedShow = fmap show 92 | 93 | -- Exercise 94 | 95 | data Sum a b = First a | Second b deriving (Eq, Show) 96 | 97 | instance Functor (Sum a) where 98 | fmap _ (First a) = First a 99 | fmap f (Second b) = Second (f b) 100 | 101 | -- 16.12 102 | 103 | newtype Constant a b = Constant { getConstant :: a } 104 | deriving (Eq, Show) 105 | 106 | instance Functor (Constant m) where 107 | fmap _ (Constant v) = Constant v 108 | 109 | -- 16.13 110 | 111 | data Wrap f a = Wrap (f a) deriving (Eq, Show) 112 | 113 | -- instance Functor (Wrap f) where 114 | -- fmap f (Wrap fa) = Wrap (f fa) 115 | 116 | -- instance Functor (Wrap f) where 117 | -- fmap f (Wrap fa) = Wrap (fmap f fa) 118 | 119 | instance Functor f => Functor (Wrap f) where 120 | fmap f (Wrap fa) = Wrap (fmap f fa) 121 | 122 | -- 16.14 123 | 124 | getInt :: IO Int 125 | getInt = fmap read getLine 126 | 127 | -- getLine abhors emacs 128 | -- meTooIsm :: IO String 129 | -- meTooIsm = do 130 | -- input <- getLine 131 | -- return (input ++ " and me too!") 132 | 133 | bumpIt :: IO Int 134 | bumpIt = do 135 | intVal <- getInt 136 | return (intVal + 1) 137 | 138 | -- 16.15 139 | 140 | type Nat f g = forall a. f a -> g a 141 | 142 | maybeToList :: Nat Maybe [] 143 | maybeToList Nothing = [] 144 | maybeToList (Just a) = [a] 145 | 146 | -- Applicative ZipList' 147 | 148 | -- applicative ZipList' 149 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: lts-6.7 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: 12 | - alternative-io-0.0.1 13 | 14 | # Override default flag values for local packages and extra-deps 15 | flags: {} 16 | 17 | # Extra package databases containing global packages 18 | extra-package-dbs: [] 19 | 20 | # Control whether we use the GHC we find on the path 21 | # system-ghc: true 22 | 23 | # Require a specific version of stack, using version ranges 24 | # require-stack-version: -any # Default 25 | # require-stack-version: >= 1.0.0 26 | 27 | # Override the architecture used by stack, especially useful on Windows 28 | # arch: i386 29 | # arch: x86_64 30 | 31 | # Extra directories used by stack for building 32 | # extra-include-dirs: [/path/to/dir] 33 | # extra-lib-dirs: [/path/to/dir] 34 | 35 | # Allow a newer minor version of GHC than the snapshot specifies 36 | # compiler-check: newer-minor 37 | --------------------------------------------------------------------------------