├── 10 ├── 10.05-understanding-folds.hs ├── 10.06-database-processing.hs ├── 10.08-scans-exercises.hs ├── 10.10-rewriting-functions-using-folds.hs └── 10.10-warm-up-and-review.hs ├── 11 ├── 11.06-vehicles.hs ├── 11.08-cardinality.hs ├── 11.08-for-example.hs ├── 11.09-logic-goats.hs ├── 11.10-pity-the-bool.hs ├── 11.12-how-does-your-garden-grow.hs ├── 11.13-programmers.hs ├── 11.13-sum-and-product.hs ├── 11.14-the-quad.hs ├── 11.17-binary-tree.hs ├── 11.18-as-patterns.hs ├── 11.18-ciphers.hs ├── 11.18-huttons-razor.hs ├── 11.18-language-exercises.hs ├── 11.18-multiple-choice.hs └── 11.18-phone-exercise.hs ├── 12 ├── 12.02-how-i-learned-to-stop-worrying-and-love-nothing.hs ├── 12.03-bleating-either.hs ├── 12.05-binary-tree.hs ├── 12.05-determine-the-kinds.hs ├── 12.05-its-only-natural.hs ├── 12.05-small-library-for-either.hs ├── 12.05-small-library-for-maybe.hs ├── 12.05-string-processing.hs ├── 12.05-unfolds.hs └── 12.05-validate-the-word.hs ├── 13 ├── chapter-exercises │ ├── palindrome.hs │ └── person.hs ├── hangman │ ├── .gitignore │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── hangman.cabal │ ├── src │ │ └── Main.hs │ └── stack.yaml ├── hello │ ├── .gitignore │ ├── Setup.hs │ ├── exe │ │ └── Main.hs │ ├── hello.cabal │ ├── src │ │ ├── DogsRule.hs │ │ └── Hello.hs │ └── stack.yaml └── notes.hs ├── 14 ├── 14.03-addition │ ├── Addition.hs │ ├── LICENSE │ ├── addition.cabal │ └── stack.yaml ├── 14.05-morse │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── morse.cabal │ ├── src │ │ ├── Main.hs │ │ └── Morse.hs │ ├── stack.yaml │ └── tests │ │ └── tests.hs ├── 14.06-arbitrary-instances.hs ├── 14.06-coarbitrary.hs ├── 14.07-failure.hs ├── 14.07-gen-random-generator.hs ├── 14.07-idempotence.hs ├── 14.07-using-quickcheck.hs └── 14.07-word-number-test │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── src │ └── WordNumber.hs │ ├── stack.yaml │ ├── test │ └── WordNumberTest.hs │ └── word-number-test.cabal ├── 15 ├── 15.10-optional-monoid.hs ├── 15.10-orphan-instance │ ├── Listy.hs │ └── ListyInstances.hs ├── 15.11-madness.hs ├── 15.12-maybe-another-monoid.hs ├── 15.15-monoid-exercises.hs └── 15.15-semigroup-exercises.hs ├── 16 ├── 16.04-be-kind.hs ├── 16.07-heavy-lifting.hs ├── 16.07-replace-experiment.hs ├── 16.10-instances-of-func.hs ├── 16.11-possibly.hs ├── 16.11-short-exercise.hs ├── 16.17-chapter-exercises-1.hs ├── 16.17-chapter-exercises-2.hs └── 16.17-chapter-exercises-3.hs ├── 17 ├── 17.05-constant-instance.hs ├── 17.05-fixer-upper.hs ├── 17.05-identity-instance.hs ├── 17.05-lookups.hs ├── 17.07-bad-monoid.hs ├── 17.08-apl1.hs ├── 17.08-list-applicative-exercise.hs ├── 17.08-validations-on-either.hs ├── 17.08-ziplist-applicative-exercise.hs ├── 17.09-chapter-exercises-1.hs ├── 17.09-chapter-exercises-2.hs └── 17.09-chapter-exercises-3.hs ├── 18 ├── 18.02-bind.hs ├── 18.03-do-syntax-and-monads.hs ├── 18.04-either-monad.hs ├── 18.04-maybe-monad.hs ├── 18.05-bad-monad.hs ├── 18.07-chapter-exercises-1.hs └── 18.07-chapter-exercises-2.hs ├── 19 ├── 19.02-templating-content-in-scotty.hs └── 19.06-shawty │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── app │ └── Main.hs │ ├── shawty.cabal │ └── stack.yaml ├── 20 ├── 20.04-demonstrating-foldable-instances.hs ├── 20.05-library-functions.hs └── 20.06-chapter-exercises.hs ├── 21 ├── 21.06-morse-code-revisited.hs ├── 21.07-axing-tedious-code.hs ├── 21.08-http-stuff.hs ├── 21.09-either.hs ├── 21.09-tuple.hs ├── 21.12-instances-for-tree.hs ├── 21.12-ski-free.hs └── 21.12-traversable-instances.hs ├── 22 ├── 22.02-a-new-beginning.hs ├── 22.02-warming-up.hs ├── 22.05-ask.hs ├── 22.06-demonstrating-the-function-applicative.hs ├── 22.06-reading-comprehension.hs ├── 22.07-reader-monad.hs ├── 22.08-pretty-reader.hs ├── 22.11-reader-practice.hs └── 22.11-shawty-prime │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── app │ └── Main.hs │ ├── shawty-prime.cabal │ └── stack.yaml ├── 23 ├── 23.05-random-example-2.hs ├── 23.05-random-example.hs ├── 23.05-roll-your-own.hs ├── 23.06-write-state-for-yourself.hs ├── 23.07-fizzbuzz-differently.hs └── 23.08-chapter-exercises.hs ├── 24 ├── 24.03-learn-parsers.hs ├── 24.03-parsing-practice.hs ├── 24.04-parsing-fractions.hs ├── 24.04-unit-of-success.hs ├── 24.06-alt-parsing.hs ├── 24.06-quasimodo.hs ├── 24.06-try-try.hs ├── 24.07-parsing-configuration-files.hs ├── 24.09-backtracking.hs ├── 24.10-marshalling.hs ├── 24.11-chapter-exercises.hs └── stack.yaml ├── 25 ├── 25.04-twinplicative.hs ├── 25.06-bifunctor.hs ├── 25.06-compose-instances.hs └── 25.08-identity-t.hs ├── 26 ├── 26.02-maybe-t.hs ├── 26.03-either-t.hs ├── 26.04-reader-t.hs ├── 26.05-state-t.hs ├── 26.08-outer-inner.hs ├── 26.08-wrap-it-up.hs ├── 26.09-lift-more.hs ├── 26.09-scotty.hs ├── 26.10-some-instances.hs ├── 26.11-except-t.hs ├── 26.14-fix-the-code.hs ├── 26.14-hit-counter.hs └── 26.14-write-the-code.hs ├── 27 ├── 27.09-debug.trace.hs └── 27.14-strict-list.hs ├── 28 ├── 28.02-benchmarking-with-criterion │ ├── .gitignore │ └── 28.02-bench.hs ├── 28.04-constant-applicative-forms.hs ├── 28.05-map.hs ├── 28.06-benchmark-practice.hs ├── 28.06-set.hs ├── 28.07-sequence.hs ├── 28.08-vector.hs ├── 28.09-text.hs ├── 28.10-a-simple-queue.hs └── 28.10-difference-list.hs ├── 29 ├── 29.04-what-happens.hs ├── 29.09-config-directories │ ├── .gitignore │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── app │ │ └── Main.hs │ ├── ini-parser.cabal │ ├── package.yaml │ ├── src │ │ ├── Parser.hs │ │ └── Run.hs │ └── stack.yaml └── 29.09-file-io-with-vigenere │ ├── .gitignore │ ├── ChangeLog.md │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── app │ └── Main.hs │ ├── package.yaml │ ├── src │ ├── Cipher.hs │ └── Vigenere.hs │ ├── stack.yaml │ └── vigenere.cabal ├── 30 ├── 30.02-why-some-exception.hs ├── 30.03-write-pls.hs ├── 30.04-try-except.hs ├── 30.05-stopping-the-party.hs └── 30.07-our-exceptions.hs ├── 31 ├── 31.03-fingerd │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── finger.db │ ├── fingerd.cabal │ ├── src │ │ ├── Debug.hs │ │ └── Main.hs │ └── stack.yaml └── 31.05-chapter-exercises.hs ├── .gitignore ├── 01 └── notes.md ├── 02 ├── chapter-exercises.hs ├── notes.md ├── practice.hs └── test.hs ├── 03 ├── print-1.hs ├── print-2.hs ├── print-3-flipped.hs ├── print-3.hs └── top-or-local.hs ├── 04 ├── notes.md └── practice.hs ├── 05 ├── chapter-exercises │ ├── determine-the-type.hs │ ├── does-it-compile.hs │ ├── fix-it.hs │ ├── multiple-choice.hs │ ├── type-kwan-do.hs │ ├── type-variable-or-constructor.hs │ ├── write-a-type-signature.hs │ └── write-the-function.hs ├── parametricity.hs ├── type-arguments.hs ├── type-inference.hs └── type-matching.hs ├── 06 ├── 06.05-day-of-week.hs ├── 06.05-eq-instances.hs ├── 06.08-will-they-work.hs ├── 06.12-numberish.hs ├── 06.14-does-it-typecheck.hs ├── 06.14-match-the-types.hs ├── 06.14-multiple-choice.hs ├── 06.14-type-kwon-do-two.hs └── 06.14-what-can-we-do.hs ├── 07 ├── 07.03-grab-bag.hs ├── 07.04-registered-user.hs ├── 07.04-tuple-functions.hs ├── 07.04-variety-pack.hs ├── 07.04-where-penguins-live.hs ├── 07.05-case-practice.hs ├── 07.05-greet-if-cool-3.hs ├── 07.06-artful-dodgy.hs ├── 07.06-employee-rank.hs ├── 07.07-guard-duty.hs ├── 07.11-lets-write-code.hs └── 07.11-multiple-choice.hs ├── 08 ├── 08.02-exercise.hs ├── 08.06-fixing-divided-by.hs ├── 08.06-mccarthy-91-function.hs ├── 08.06-recursion.hs ├── 08.06-review-of-types.hs ├── 08.06-reviewing-currying.hs └── 08.06-word-number.hs ├── 09 ├── 09.05-enum-from-to.hs ├── 09.06-thy-fearful-symmetry.hs ├── 09.07-comprehend-thy-lists.hs ├── 09.07-square-cube.hs ├── 09.08-is-it-in-normal-form.hs ├── 09.08-will-it-blow-up.hs ├── 09.09-more-bottoms.hs ├── 09.10-filtering.hs ├── 09.11-zipping-lists.hs ├── 09.12-ciphers.hs ├── 09.12-data-char.hs └── 09.12-writing-your-own-standard-functions.hs └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | .swp 20 | -------------------------------------------------------------------------------- /02/chapter-exercises.hs: -------------------------------------------------------------------------------- 1 | -- Source 2 | -- z = 7 3 | -- y = z + 8 4 | -- x = y ^ 2 5 | -- waxOn = x * 5 6 | 7 | -- REPL safe 8 | 9 | -- let z = 7 10 | -- let y = z + 8 11 | -- let x = y ^ 2 12 | -- waxOn = x * 5 13 | 14 | -- where clause 15 | waxOn = x * 5 16 | where z = 7 17 | y = z + 8 18 | x = y ^ 2 19 | 20 | triple x = x * 3 21 | 22 | waxOff x = triple x -------------------------------------------------------------------------------- /02/practice.hs: -------------------------------------------------------------------------------- 1 | mult1 = x * y 2 | where x = 5 3 | y = 6 4 | 5 | -- 1. 6 | -- let x = 3 7 | -- y = 1000 in x * 3 + y 8 | -- 2. 9 | -- let y = 10 10 | -- x = 10 * 5 + y in x * 5 11 | -- 3. 12 | -- let x = 7 13 | -- y = negate x 14 | -- z = y * 10 in z / x + y 15 | 16 | one = x * 3 + y 17 | where x = 3 18 | y = 1000 19 | 20 | two = x * 5 21 | where y = 10 22 | x = 10 * 5 + y 23 | 24 | three = z / x + y 25 | where x = 7 26 | y = negate x 27 | z = y * 10 -------------------------------------------------------------------------------- /02/test.hs: -------------------------------------------------------------------------------- 1 | sayHello :: String -> IO () 2 | sayHello x = putStrLn ("Hello, " ++ x ++ "!") -------------------------------------------------------------------------------- /03/print-1.hs: -------------------------------------------------------------------------------- 1 | module Print1 where 2 | 3 | main :: IO () 4 | main = putStrLn "hello world!" -------------------------------------------------------------------------------- /03/print-2.hs: -------------------------------------------------------------------------------- 1 | module Print2 where 2 | 3 | main :: IO () 4 | main = do 5 | putStrLn "Count to four for me:" 6 | putStr "one, two" 7 | putStrLn ", three, and" 8 | putStrLn " fourty four hundred!" -------------------------------------------------------------------------------- /03/print-3-flipped.hs: -------------------------------------------------------------------------------- 1 | module Print3Flipped where 2 | 3 | myGreeting :: String 4 | myGreeting = (++) "hello" " dudeface!" 5 | 6 | hello :: String 7 | hello = "hello" 8 | 9 | world :: String 10 | world = "world!" 11 | 12 | main :: IO () 13 | main = do 14 | putStrLn myGreeting 15 | putStrLn secondGreeting 16 | where secondGreeting = 17 | (++) hello ((++) " " world) -------------------------------------------------------------------------------- /03/print-3.hs: -------------------------------------------------------------------------------- 1 | module Print3 where 2 | 3 | myGreeting :: String 4 | myGreeting = "hello" ++ " world!" 5 | 6 | hello :: String 7 | hello = "hello" 8 | 9 | world :: String 10 | world = "world!" 11 | 12 | main :: IO () 13 | main = do 14 | putStrLn myGreeting 15 | putStrLn secondGreeting 16 | where secondGreeting = concat [hello, " ", world] -------------------------------------------------------------------------------- /03/top-or-local.hs: -------------------------------------------------------------------------------- 1 | module TopOrLocal where 2 | 3 | topLevelFunction :: Integer -> Integer 4 | topLevelFunction x = x + woot + topLevelValue 5 | where woot :: Integer 6 | woot = 10 7 | 8 | topLevelValue :: Integer 9 | topLevelValue = 5 -------------------------------------------------------------------------------- /04/practice.hs: -------------------------------------------------------------------------------- 1 | module Practice04 where 2 | 3 | x = (+) 4 | 5 | oneMoreThanLength xs = x 1 w 6 | where w = length xs 7 | 8 | identity x = x 9 | 10 | getFirst (a, b) = a -------------------------------------------------------------------------------- /05/chapter-exercises/determine-the-type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module DetermineTheType where 4 | 5 | -- 1. 6 | -- a) 7 | (* 9) 6 8 | 54 :: Num a => a 9 | 10 | -- b) 11 | head [(0, "doge"), (1, "kitteh")] 12 | (0, "doge") :: Num t => (t, [Char]) 13 | 14 | -- c) 15 | head [(0 :: Integer, "doge"), (1, "kitteh")] 16 | (0, "doge") :: (Integer, [Char]) 17 | 18 | -- d) 19 | if False then True else False 20 | False :: Bool 21 | 22 | -- e) 23 | length [1, 2, 3, 4, 5] 24 | 5 :: Int 25 | 26 | -- f) 27 | (length [1, 2, 3, 4]) > (length "TACOCAT") 28 | False :: Bool 29 | 30 | -- 2. 31 | x = 5 32 | y = x + 5 33 | w = y * 10 34 | w :: Num a => a 35 | 36 | -- 3. 37 | z y = y * 10 38 | z :: Num a => a -> a 39 | 40 | -- 4. 41 | f0 = 4 / y 42 | f0 :: Fractional a => a 43 | 44 | -- 5. 45 | x' = "Julie" 46 | y' = " <3 " 47 | z' = "Haskell" 48 | f1 = x' ++ y' ++ z' 49 | f1 :: [Char] 50 | 51 | -------------------------------------------------------------------------------- /05/chapter-exercises/does-it-compile.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | bigNum = (^) 5 3 | wahoo = bigNum $ 10 4 | 5 | -- 2. 6 | x = print 7 | y = print "woohoo!" 8 | z = x "hello world!" 9 | 10 | -- 3. 11 | a = (+) 12 | b = 5 13 | -- c = b 10 14 | -- d = c 200 15 | 16 | -- 4. 17 | a = 12 + b 18 | -- b = 10000 * c 19 | -------------------------------------------------------------------------------- /05/chapter-exercises/fix-it.hs: -------------------------------------------------------------------------------- 1 | module Sing where 2 | 3 | -- 1. 4 | fstString :: [Char] -> [Char] 5 | fstString x = x ++ " in the rain" 6 | 7 | sndString :: [Char] -> [Char] 8 | sndString x = x ++ " over the rainbow" 9 | 10 | -- 2. 11 | sing = 12 | if (x < y) 13 | then fstString x 14 | else sndString y 15 | where x = "Singin" 16 | y = "Somewhere" 17 | 18 | -- 3. 19 | main :: IO () 20 | main = do 21 | print ((+) 1 2) 22 | print 10 23 | print (negate (-1)) 24 | print ((+) 0 blah) 25 | where blah = negate 1 26 | -------------------------------------------------------------------------------- /05/chapter-exercises/multiple-choice.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- A value of type `[a]` is 3 | -- c) a list whose elements are all of some type `a` 4 | 5 | -- 2. 6 | -- A function of type `[[a]] -> [a]` could 7 | -- a) take a list of strings as an argument 8 | 9 | -- 3. 10 | -- A function of type `[a] -> Int -> a` 11 | -- b) returns one element of type `a` from a list 12 | 13 | -- 4. 14 | -- A function of type `(a, b) -> a` 15 | -- c) takes a tuple argument and returns the first value 16 | -------------------------------------------------------------------------------- /05/chapter-exercises/type-kwan-do.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | f :: Int -> String 3 | f = undefined 4 | 5 | g :: String -> Char 6 | g = undefined 7 | 8 | h :: Int -> Char 9 | h n = g . f $ n 10 | 11 | -- 2. 12 | data A 13 | data B 14 | data C 15 | 16 | q :: A -> B 17 | q = undefined 18 | 19 | w :: B -> C 20 | w = undefined 21 | 22 | e :: A -> C 23 | e a = w . q $ a 24 | 25 | -- 3. 26 | data X 27 | data Y 28 | data Z 29 | 30 | xz :: X -> Z 31 | xz = undefined 32 | 33 | yz :: Y -> Z 34 | yz = undefined 35 | 36 | xform :: (X, Y) -> (Z, Z) 37 | xform (x, y) = (xz x, yz y) 38 | 39 | -- 4. 40 | munge :: (x -> y) 41 | -> (y -> (w, z)) 42 | -> x 43 | -> w 44 | munge xY yWZ x = fst . yWZ $ xY x 45 | -------------------------------------------------------------------------------- /05/chapter-exercises/type-variable-or-constructor.hs: -------------------------------------------------------------------------------- 1 | -- Choices for the following are: 2 | -- fully polymorphic type variable 3 | -- constrained polymorphic type variable 4 | -- concrete type constructor 5 | 6 | -- 1. 7 | f0 :: Num a => a -> b -> Int -> Int 8 | -- [0] [1] [2] [3] 9 | -- 0 constrained polymorphic type variable 10 | -- 1 fully polymorphic type variable 11 | -- 2 concrete type constructor 12 | -- 3 concrete type constructor 13 | 14 | -- 2. 15 | f1 :: zed -> Zed -> Blah 16 | -- [0] [1] [2] 17 | -- 0 fully polymorphic type variable 18 | -- 1 concrete type constructor 19 | -- 2 concrete type constructor 20 | 21 | -- 3. 22 | f2 :: Enum b => a -> b -> C 23 | -- [0] [1] [2] [3] 24 | -- 0 constrained polymorphic type variable 25 | -- 1 fully polymorphic type variable 26 | -- 2 constrained polymorphic type variable 27 | -- 3 concrete type constructor 28 | 29 | -- 4. 30 | f3 :: f -> g -> C 31 | -- [0] [1] [2] 32 | -- 0 fully polymorphic type variable 33 | -- 1 fully polymorphic type variable 34 | -- 2 concrete type constructor 35 | 36 | -------------------------------------------------------------------------------- /05/chapter-exercises/write-a-type-signature.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | functionH :: [a] -> a 3 | functionH (x:_) = x 4 | 5 | -- 2. 6 | functionC :: Ord a => a -> a -> Bool 7 | functionC x y = if (x > y) then True else False 8 | 9 | -- 3. 10 | functionS :: (a, b) -> b 11 | functionS (x, y) = y 12 | -------------------------------------------------------------------------------- /05/chapter-exercises/write-the-function.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | i :: a -> a 3 | i = id 4 | 5 | -- 2. 6 | c :: a -> b -> a 7 | c x y = x 8 | 9 | -- 3. 10 | c'' :: b -> a -> b 11 | c'' = c 12 | 13 | -- 4. 14 | c' :: a -> b -> b 15 | c' x y = y 16 | 17 | -- 5. 18 | r :: [a] -> [a] 19 | r xs = reverse xs 20 | -- or 21 | -- r xs = id xs 22 | 23 | -- 6. 24 | co :: (b -> c) -> (a -> b) -> a -> c 25 | co f g x = f . g $ x 26 | 27 | -- 7. 28 | a :: (a -> c) -> a -> a 29 | a f x = x 30 | 31 | -- 8. 32 | a' :: (a -> b) -> a -> b 33 | a' f x = f x 34 | 35 | -------------------------------------------------------------------------------- /05/parametricity.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | f1 :: a -> a 3 | f1 x = x 4 | 5 | -- 2. 6 | f2 :: a -> a -> a 7 | -- f2 x y = x 8 | -- or 9 | -- f x y = y 10 | 11 | -- 3. 12 | f3 :: a -> b -> b 13 | f3 x y = b 14 | -------------------------------------------------------------------------------- /05/type-arguments.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | f :: a -> a -> a -> a 3 | x :: Char 4 | -- Answer a. 5 | f x :: Char -> Char -> Char 6 | 7 | -- 2. 8 | g :: a -> b -> c -> b 9 | -- Answer d. 10 | g 0 'c' "woot" :: Char 11 | 12 | -- 3. 13 | h :: (Num a, Num b) => a -> b -> b 14 | -- Answer d. 15 | h 1.0 2 :: Num b => b 16 | 17 | -- 4. 18 | h 1 (5.5 :: Double) :: Double 19 | -- Answer c. 20 | 21 | -- 5. 22 | jackal :: (Ord a, Eq b) => a -> b -> a 23 | -- Answer a. 24 | jackal "keyboard" "has the word jackal in it" :: [Char] 25 | 26 | -- 6. 27 | jackal "keyboard" :: Eq b => b -> [Char] 28 | -- Answer e. 29 | 30 | -- 7. 31 | kessel :: (Ord a, Num b) => a -> b -> a 32 | -- Answer d. 33 | kessel 1 2 :: (Ord a, Num a) => a 34 | 35 | -- 8. 36 | kessel 1 (2 :: Integer) :: (Ord a , Num a) => a 37 | -- Answer a. 38 | 39 | -- 9. 40 | kessel (1 :: Integer) 2 :: Integer 41 | -- Answer c. 42 | -------------------------------------------------------------------------------- /05/type-inference.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | myConcat :: [Char] -> [Char] 3 | myConcat x = x ++ " yo" 4 | 5 | -- 2. 6 | myMult :: Fractional a => a -> a 7 | myMult x = (x / 3) * 5 8 | 9 | -- 3. 10 | myTake :: Int -> [Char] 11 | myTake x = take x "hey you" 12 | 13 | -- 4. 14 | myCom :: Int -> Bool 15 | myCom x = x > (length [1..10]) 16 | 17 | -- 5. 18 | myAlph :: Char -> Bool 19 | myAlph x = x < 'z' 20 | -------------------------------------------------------------------------------- /05/type-matching.hs: -------------------------------------------------------------------------------- 1 | module TypeMatching where 2 | 3 | -- 1a. 4 | -- Answer - 2c. 5 | not :: Bool -> Bool 6 | 7 | -- 1b. 8 | -- Answer - 2d. 9 | length :: [a] -> Int 10 | 11 | -- 1c. 12 | -- Answer - 2b. 13 | concat :: [[a]] -> [a] 14 | 15 | -- 1d. 16 | -- Answer - 2a. 17 | head :: [a] -> a 18 | 19 | -- 1e. 20 | -- Answer - 2.e 21 | (<) :: Ord a => a -> a -> Bool 22 | -------------------------------------------------------------------------------- /06/06.05-day-of-week.hs: -------------------------------------------------------------------------------- 1 | data DayOfWeek = Mon 2 | | Tue 3 | | Wed 4 | | Thu 5 | | Fri 6 | | Sat 7 | | Sun 8 | deriving Show 9 | 10 | data Date = Date DayOfWeek Int 11 | deriving Show 12 | 13 | instance Eq DayOfWeek where 14 | (==) Mon Mon = True 15 | (==) Tue Tue = True 16 | (==) Wed Wed = True 17 | (==) Thu Thu = True 18 | (==) Fri Fri = True 19 | (==) Sat Sat = True 20 | (==) Sun Sun = True 21 | (==) _ _ = False 22 | 23 | instance Eq Date where 24 | (==) (Date wd n) (Date wd' n') = wd == wd' && n == n' 25 | 26 | -------------------------------------------------------------------------------- /06/06.05-eq-instances.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | data TisAnInteger = TisAn Integer 3 | deriving Show 4 | 5 | instance Eq TisAnInteger where 6 | (==) (TisAn x) (TisAn y) = x == y 7 | 8 | ----------------------------------------------------------------------------- 9 | -- 2. 10 | data TwoIntegers = Two Integer Integer 11 | deriving Show 12 | 13 | instance Eq TwoIntegers where 14 | (==) (Two x y) (Two x' y') = x == x' && y == y' 15 | 16 | ----------------------------------------------------------------------------- 17 | -- 3. 18 | data StringOrInt = TisAnInt Int 19 | | TisAString String 20 | deriving Show 21 | 22 | instance Eq StringOrInt where 23 | (==) (TisAnInt x) (TisAnInt y) = x == y 24 | (==) (TisAString x) (TisAString y) = x == y 25 | (==) _ _ = False 26 | 27 | ----------------------------------------------------------------------------- 28 | -- 4. 29 | data Pair a = Pair a a 30 | deriving Show 31 | 32 | instance Eq a => Eq (Pair a) where 33 | (==) (Pair x y) (Pair x' y') = x == x' && y == y' 34 | 35 | ----------------------------------------------------------------------------- 36 | -- 5. 37 | data Tuple a b = Tuple a b 38 | deriving Show 39 | 40 | instance (Eq a, Eq b) => Eq (Tuple a b) where 41 | (==) (Tuple x y) (Tuple x' y') = x == x' && y == y' 42 | 43 | ----------------------------------------------------------------------------- 44 | -- 6. 45 | data Which a = ThisOne a 46 | | ThatOne a 47 | deriving Show 48 | 49 | instance Eq a => Eq (Which a) where 50 | (==) (ThisOne x) (ThisOne x') = x == x' 51 | (==) (ThatOne x) (ThatOne x') = x == x' 52 | (==) _ _ = False 53 | 54 | ----------------------------------------------------------------------------- 55 | -- 7. 56 | data EitherOr a b = Hello a 57 | | Goodbye b 58 | deriving Show 59 | 60 | instance (Eq a, Eq b) => Eq (EitherOr a b) where 61 | (==) (Hello x) (Hello x') = x == x' 62 | (==) (Goodbye x) (Goodbye x') = x == x' 63 | (==) _ _ = False 64 | 65 | 66 | -------------------------------------------------------------------------------- /06/06.08-will-they-work.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- max (length [1, 2, 3,]) (length [8, 9, 10, 11, 12]) 3 | -- 4 | -- Answer: 5 5 | 6 | ----------------------------------------------------------------------------- 7 | -- 2. 8 | -- compare (3 * 4) (3 * 5) 9 | -- Answer: LT 10 | 11 | ----------------------------------------------------------------------------- 12 | -- 3. 13 | -- compare "Julie" True 14 | -- Answer: error 15 | 16 | ----------------------------------------------------------------------------- 17 | -- 4. 18 | -- (5 + 3) > (3 + 6) 19 | -- Answer: False 20 | -------------------------------------------------------------------------------- /06/06.12-numberish.hs: -------------------------------------------------------------------------------- 1 | class Numberish a where 2 | fromNumber :: Integer -> a 3 | toNumber :: a -> Integer 4 | defaultNumber :: a 5 | 6 | newtype Age = Age Integer 7 | deriving (Eq, Show) 8 | 9 | instance Numberish Age where 10 | fromNumber n = Age n 11 | toNumber (Age n) = n 12 | defaultNumber = Age 65 13 | 14 | newtype Year = Year Integer 15 | deriving (Eq, Show) 16 | 17 | instance Numberish Year where 18 | fromNumber n = Year n 19 | toNumber (Year n) = n 20 | defaultNumber = Year 1988 21 | 22 | sumNumberish :: Numberish a => a -> a -> a 23 | sumNumberish a a' = fromNumber summed 24 | where 25 | integerOfA = toNumber a 26 | integerOfAPrime = toNumber a' 27 | summed = integerOfA + integerOfAPrime 28 | -------------------------------------------------------------------------------- /06/06.14-does-it-typecheck.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | data Person = Person Bool 3 | 4 | instance Show Person where 5 | show (Person x) = show x 6 | 7 | printPerson :: Person -> IO () 8 | printPerson person = putStrLn (show person) 9 | 10 | ----------------------------------------------------------------------------- 11 | -- 2. 12 | data Mood = Blah 13 | | Woot 14 | deriving Show 15 | 16 | instance Eq Mood where 17 | (==) Blah Blah = True 18 | (==) Woot Woot = True 19 | (==) _ _ = False 20 | 21 | settleDown :: Mood -> Mood 22 | settleDown x = if x == Woot 23 | then Blah 24 | else x 25 | 26 | ----------------------------------------------------------------------------- 27 | -- 3. 28 | -- If you were able to get `settleDown` to typecheck: 29 | -- 30 | -- a) What values are acceptable inputs to that function? 31 | -- Answer: `Blah` or `Woot` 32 | -- 33 | -- b) What will happen if you try to run `settleDown 9`? 34 | -- Answer: error - argument must be of type `Mood` 35 | -- 36 | -- c) What will happen if you try to run `Blah > Woot`? 37 | -- Answer: error - no instance for `Ord` 38 | 39 | ----------------------------------------------------------------------------- 40 | -- 4. 41 | type Subject = String 42 | type Verb = String 43 | type Object = String 44 | 45 | data Sentence = Sentence Subject Verb Object 46 | | Incomplete Subject Verb 47 | deriving (Eq, Show) 48 | 49 | s1 :: Sentence 50 | s1 = Incomplete "dogs" "drool" -- previously missing an argument 51 | 52 | s2 :: Sentence 53 | s2 = Sentence "Julie" "loves" "dogs" 54 | -------------------------------------------------------------------------------- /06/06.14-multiple-choice.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- The Eq class 3 | -- Answer: 4 | -- c) makes equality tests possible 5 | 6 | ----------------------------------------------------------------------------- 7 | -- 2. 8 | -- The typeclass Ord 9 | -- Answer: 10 | -- b) is a subclass of Eq 11 | 12 | ----------------------------------------------------------------------------- 13 | -- 3. 14 | -- What is the type of `>`? 15 | -- Answer: 16 | -- a) Ord a => a -> a -> Bool 17 | 18 | ----------------------------------------------------------------------------- 19 | -- 4. 20 | -- In `x = divMod 16 12` 21 | -- Answer: 22 | -- c) the type of x is a tuple 23 | 24 | ----------------------------------------------------------------------------- 25 | -- 5. 26 | -- The typeclass Integal includes 27 | -- Answer: 28 | -- a) Int and Integer numbers 29 | -------------------------------------------------------------------------------- /06/06.14-type-kwon-do-two.hs: -------------------------------------------------------------------------------- 1 | chk :: Eq b => (a -> b) -> a -> b -> Bool 2 | chk f x y = f x == y 3 | 4 | arith :: Num b => (a -> b) -> Integer -> a -> b 5 | arith f n x = fromIntegral n + f x 6 | -------------------------------------------------------------------------------- /06/06.14-what-can-we-do.hs: -------------------------------------------------------------------------------- 1 | data Rocks = Rocks String 2 | deriving (Eq, Show) 3 | 4 | data Yeah = Yeah Bool 5 | deriving (Eq, Show) 6 | 7 | data Papu = Papu Yeah 8 | deriving (Eq, Show) 9 | 10 | ----------------------------------------------------------------------------- 11 | -- 1. 12 | -- phew = Papu "chases" True 13 | -- 14 | -- Answer: error - the second argument should be of type `Yeah` which itself 15 | -- should contain a value of type `Bool` 16 | 17 | ----------------------------------------------------------------------------- 18 | -- 2. 19 | -- truth = Papu (Rocks "chomskydoz") (Yeah True) 20 | -- 21 | -- Answer: error - there is one too many arguments 22 | 23 | ----------------------------------------------------------------------------- 24 | -- 3. 25 | equalityForall :: Papu -> Papu -> Bool 26 | equalityForall p p' = p == p' 27 | -- 28 | -- Answer: Typechecks. 29 | 30 | ----------------------------------------------------------------------------- 31 | -- 4. 32 | -- comparePapus :: Papu -> Papu -> Bool 33 | -- comparePapus p p' = p > p' 34 | -- 35 | -- Answer: error - no instance of `Ord` 36 | -------------------------------------------------------------------------------- /07/07.03-grab-bag.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- Which (two or more) of the following are equivalent? 3 | -- 4 | -- Answer: 5 | -- All choices. 6 | 7 | ----------------------------------------------------------------------------- 8 | -- 2. 9 | -- The type of `mTh` is `Num a => a -> a -> a -> a`. 10 | -- Which is the type of `mTh 3`? 11 | -- 12 | -- Answer: 13 | -- d) Num a => a -> a -> a 14 | 15 | ----------------------------------------------------------------------------- 16 | -- 3. 17 | -- a) Rewrite the `f` function in the where clause. 18 | addOneIfOdd n = case odd n of 19 | True -> f n 20 | False -> n 21 | where 22 | f = (+1) 23 | 24 | -- b) Rewrite the following to use anonymous lambda syntax. 25 | addFive = \x -> \y -> (if x > y then y else x) + 5 26 | 27 | -- c) Rewrite the following so that it doesn't use anonymous lambda syntax. 28 | mflip f x y = f y x 29 | -------------------------------------------------------------------------------- /07/07.04-registered-user.hs: -------------------------------------------------------------------------------- 1 | module RegisteredUser where 2 | 3 | newtype Username = Username String 4 | 5 | newtype AccountNumber = AccountNumber Integer 6 | 7 | data User = UnregisteredUser 8 | | RegisteredUser Username AccountNumber 9 | 10 | printUser :: User -> IO () 11 | printUser UnregisteredUser = putStrLn "UnregisteredUser" 12 | printUser (RegisteredUser (Username name) (AccountNumber acctNum)) = putStrLn $ 13 | name ++ " " ++ show acctNum 14 | -------------------------------------------------------------------------------- /07/07.04-tuple-functions.hs: -------------------------------------------------------------------------------- 1 | module TupleFunctions where 2 | 3 | addEmUp2 :: Num a => (a, a) -> a 4 | addEmUp2 (x, y) = x + y 5 | 6 | addEmUp2Alt :: Num a => (a, a) -> a 7 | addEmUp2Alt tup = (fst tup) + (snd tup) 8 | 9 | fst3 :: (a, b, c) -> a 10 | fst3 (x, _, _) = x 11 | 12 | third3 :: (a, b, c) -> c 13 | third3 (_, _, x) = x 14 | -------------------------------------------------------------------------------- /07/07.04-variety-pack.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- a) What is the type of `k`? 3 | k :: (a, b) -> a 4 | k (x, y) = x 5 | 6 | -- b) What is the type of `k2`? Is it the same type as `k1` or `k3`? 7 | k1 :: Integer 8 | k1 = k ((4 - 1), 10) 9 | 10 | k2 :: [Char] 11 | k2 = k ("three", (1 + 2)) 12 | 13 | k3 :: Integer 14 | k3 = k (3, True) 15 | -- c) Of `k1`, `k2`, `k3`, which will return the number 3 as the result? 16 | -- 17 | -- Answer: 18 | -- `k1` and `k3` 19 | 20 | ----------------------------------------------------------------------------- 21 | -- 2. 22 | f :: (a, b, c) -> (d, e, f) -> ((a, d), (c, f)) 23 | f (x, y, z) (x', y', z') = ((x, x'), (z, z')) 24 | -------------------------------------------------------------------------------- /07/07.04-where-penguins-live.hs: -------------------------------------------------------------------------------- 1 | data WherePenguinsLive = Galapagos 2 | | Antarctica 3 | | Australia 4 | | SouthAfrica 5 | | SouthAmerica 6 | deriving (Eq, Show) 7 | 8 | data Penguin = Peng WherePenguinsLive 9 | deriving (Eq, Show) 10 | 11 | isSouthAfrica :: WherePenguinsLive -> Bool 12 | isSouthAfrica SouthAfrica = True 13 | isSouthAfrica Galapagos = False 14 | isSouthAfrica Antarctica = False 15 | isSouthAfrica Australia = False 16 | isSouthAfrica SouthAmerica = False 17 | 18 | isSouthAfrica' :: WherePenguinsLive -> Bool 19 | isSouthAfrica' SouthAfrica = True 20 | isSouthAfrica' _ = False 21 | 22 | gimmeWhereTheyLive :: Penguin -> WherePenguinsLive 23 | gimmeWhereTheyLive (Peng whereitlives) = whereitlives 24 | 25 | humboldt = Peng SouthAmerica 26 | gentoo = Peng Antarctica 27 | macaroni = Peng Antarctica 28 | little = Peng Australia 29 | galapagos = Peng Galapagos 30 | 31 | galapagosPenguin :: Penguin -> Bool 32 | galapagosPenguin (Peng Galapagos) = True 33 | galapagosPenguin _ = False 34 | 35 | antarcticPenguin :: Penguin -> Bool 36 | antarcticPenguin (Peng Antarctica) = True 37 | antarcticPenguin _ = False 38 | 39 | antarcticOrGalapagos :: Penguin -> Bool 40 | antarcticOrGalapagos p = (galapagosPenguin p) || (antarcticPenguin p) 41 | -------------------------------------------------------------------------------- /07/07.05-case-practice.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | functionC :: Ord a => a -> a -> a 3 | functionC x y = case (x > y) of 4 | True -> x 5 | False -> y 6 | 7 | ----------------------------------------------------------------------------- 8 | -- 2. 9 | ifEvenAdd2 :: Integral a => a -> a 10 | ifEvenAdd2 n = case even n of 11 | True -> n + 2 12 | False -> n 13 | 14 | ----------------------------------------------------------------------------- 15 | -- 3. 16 | nums :: (Ord a, Num a, Num b) => a -> b 17 | nums x = case compare x 0 of 18 | LT -> -1 19 | GT -> 1 20 | EQ -> 0 21 | -------------------------------------------------------------------------------- /07/07.05-greet-if-cool-3.hs: -------------------------------------------------------------------------------- 1 | module GreetIfCool3 where 2 | 3 | greetIfCool :: String -> IO () 4 | greetIfCool coolness = case cool of 5 | True -> putStrLn "eyyyyy. What's shakin'?" 6 | False -> putStrLn "pshhhh." 7 | where 8 | cool = coolness == "why do these examples gotta be so corny" 9 | -------------------------------------------------------------------------------- /07/07.06-artful-dodgy.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | dodgy :: Num a => a -> a -> a 3 | dodgy x y = x + y * 10 4 | 5 | oneIsOne :: Num a => a -> a 6 | oneIsOne = dodgy 1 7 | 8 | oneIsTwo :: Num a => a -> a 9 | oneIsTwo = (flip dodgy) 2 10 | 11 | ----------------------------------------------------------------------------- 12 | -- 2. 13 | q2 :: Integer 14 | q2 = dodgy 1 1 15 | -- 16 | -- Answer: 17 | -- 11 18 | 19 | ----------------------------------------------------------------------------- 20 | -- 3. 21 | q3 :: Integer 22 | q3 = dodgy 2 2 23 | -- 24 | -- Answer: 25 | -- 22 26 | 27 | ----------------------------------------------------------------------------- 28 | -- 4. 29 | q4 :: Integer 30 | q4 = dodgy 1 2 31 | -- 32 | -- Answer: 33 | -- 21 34 | 35 | ----------------------------------------------------------------------------- 36 | -- 5. 37 | q5 :: Integer 38 | q5 = dodgy 2 1 39 | -- 40 | -- Answer: 41 | -- 12 42 | 43 | ----------------------------------------------------------------------------- 44 | -- 6. 45 | q6 :: Integer 46 | q6 = oneIsOne 1 47 | -- 48 | -- Answer: 49 | -- 11 50 | 51 | ----------------------------------------------------------------------------- 52 | -- 7. 53 | q7 :: Integer 54 | q7 = oneIsOne 2 55 | -- 56 | -- Answer: 57 | -- 21 58 | 59 | ----------------------------------------------------------------------------- 60 | -- 8. 61 | q8 :: Integer 62 | q8 = oneIsTwo 1 63 | -- 64 | -- Answer: 65 | -- 21 66 | 67 | ----------------------------------------------------------------------------- 68 | -- 9. 69 | q9 :: Integer 70 | q9 = oneIsTwo 2 71 | -- 72 | -- Answer: 73 | -- 22 74 | 75 | ----------------------------------------------------------------------------- 76 | -- 10. 77 | q10 :: Integer 78 | q10 = oneIsOne 3 79 | -- 80 | -- Answer: 81 | -- 31 82 | 83 | ----------------------------------------------------------------------------- 84 | -- 11. 85 | q11 :: Integer 86 | q11 = oneIsTwo 3 87 | -- 88 | -- Answer: 89 | -- 23 90 | -------------------------------------------------------------------------------- /07/07.06-employee-rank.hs: -------------------------------------------------------------------------------- 1 | data Employee = Coder 2 | | Manager 3 | | Veep 4 | | CEO 5 | deriving (Eq, Ord, Show) 6 | 7 | reportBoss :: Employee -> Employee -> IO () 8 | reportBoss e e' = putStrLn $ show e ++ " is the boss of " ++ show e' 9 | 10 | codersRuleCEOsDrool :: Employee -> Employee -> Ordering 11 | codersRuleCEOsDrool Coder Coder = EQ 12 | codersRuleCEOsDrool Coder _ = GT 13 | codersRuleCEOsDrool _ Coder = LT 14 | codersRuleCEOsDrool e e' = compare e e' 15 | 16 | employeeRank :: (Employee -> Employee -> Ordering) 17 | -> Employee 18 | -> Employee 19 | -> IO () 20 | employeeRank f e e' = case f e e' of 21 | GT -> reportBoss e e' 22 | EQ -> putStrLn "Neither employee is the boss" 23 | LT -> (flip reportBoss) e e' 24 | -------------------------------------------------------------------------------- /07/07.11-lets-write-code.hs: -------------------------------------------------------------------------------- 1 | module Arith4 where 2 | 3 | -- 1. 4 | -- The following function returns the tens digit of an integral argument. 5 | tensDigit :: Integral a => a -> a 6 | tensDigit x = d 7 | where 8 | xLast = x `div` 10 9 | d = xLast `mod` 10 10 | -- a) 11 | -- Rewrite it using `divMod`. 12 | tensDigit' :: Integral a => a -> a 13 | tensDigit' x = (fst . divMod x $ 10) `mod` 10 14 | 15 | -- b) 16 | -- Does the `divMod` version have the same type as the original version? 17 | -- 18 | -- Answer: 19 | -- No. 20 | 21 | -- c) 22 | -- Change it so that we're getting the hundreds digit instead. 23 | hundsD :: Integral a => a -> a 24 | hundsD x = (fst . divMod x $ 100) `mod` 10 25 | 26 | ----------------------------------------------------------------------------- 27 | -- 2. 28 | -- Implement the following function once each using a case expression and once 29 | -- with a guard. 30 | foldBool1 :: a -> a -> Bool -> a 31 | foldBool1 x y b = case b of 32 | False -> x 33 | True -> y 34 | 35 | 36 | foldBool2 :: a -> a -> Bool -> a 37 | foldBool2 x y b 38 | | b = y 39 | | otherwise = x 40 | 41 | ----------------------------------------------------------------------------- 42 | -- 3. 43 | g :: (a -> b) -> (a, c) -> (b, c) 44 | g f (x, y) = (f x, y) 45 | 46 | ----------------------------------------------------------------------------- 47 | -- 4. 48 | roundTrip :: (Show a, Read a) => a -> a 49 | roundTrip a = read (show a) 50 | 51 | main :: IO () 52 | main = do 53 | putStrLn "Composed:" 54 | print (roundTrip 4) 55 | putStrLn "Pointfree:" 56 | print (roundTrip' 4) 57 | putStrLn "Assert:" 58 | print ((roundTrip'' 4) :: Int) 59 | 60 | ----------------------------------------------------------------------------- 61 | -- 5. 62 | roundTrip' :: (Show a, Read a) => a -> a 63 | roundTrip' = read . show 64 | 65 | ----------------------------------------------------------------------------- 66 | -- 6. 67 | roundTrip'' :: (Show a, Read b) => a -> b 68 | roundTrip'' = read . show 69 | -------------------------------------------------------------------------------- /07/07.11-multiple-choice.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- A polymorphic function 3 | -- 4 | -- Answer: 5 | -- d) may resolve to values of different types, depending on inputs 6 | 7 | ----------------------------------------------------------------------------- 8 | -- 2. 9 | -- Two functions named `f` and `g` have types `Char -> String` and `String -> 10 | -- [String]` respectively. The composed function `g . f` has the type 11 | -- 12 | -- Answer: 13 | -- b) Char -> [String] 14 | 15 | ----------------------------------------------------------------------------- 16 | -- 3. 17 | -- A function `f` has the type `Ord a => a -> a -> Bool` and we apply it to 18 | -- one numeric value. What is the type now? 19 | -- 20 | -- Answer: 21 | -- d) (Ord a, Num a) => a -> Bool 22 | 23 | ----------------------------------------------------------------------------- 24 | -- 4. 25 | -- A function with the type `(a -> b) -> c` 26 | -- 27 | -- Answer: 28 | -- b) is a higher-order function 29 | 30 | ----------------------------------------------------------------------------- 31 | -- 5. 32 | -- Given the following definition of `f`, what is the type of `f True`? 33 | f :: a -> a 34 | f x = x 35 | -- Answer: 36 | -- a) f True :: Bool 37 | -------------------------------------------------------------------------------- /08/08.02-exercise.hs: -------------------------------------------------------------------------------- 1 | applyTimes :: (Eq a, Num a) => a -> (b -> b) -> b -> b 2 | applyTimes 0 f b = b 3 | applyTimes n f b = f . applyTimes (n -1) f $ b 4 | 5 | at :: Int 6 | at = applyTimes 5 (+1) 5 7 | 8 | at' :: Int 9 | at' = (+1) $ (+1) $ (+1) $ (+1) $ (+1) $ 5 10 | 11 | -- Evaluates as follows: 12 | -- 13 | -- (+1) (applyTimes (5 - 1) (+1) 5) 14 | -- (+1) ((+1) (applyTimes (4 - 1) (+1) 5)) 15 | -- (+1) ((+1) ((+1) (applyTimes (3 - 1) (+1) 5))) 16 | -- (+1) ((+1) ((+1) ((+1) (applyTimes (2 - 1) (+1) 5)))) 17 | -- (+1) ((+1) ((+1) ((+1) ((+1) (applyTimes (1 - 1) (+1) 5))))) 18 | -- (+1) ((+1) ((+1) ((+1) ((+1) (5))))) 19 | -------------------------------------------------------------------------------- /08/08.06-fixing-divided-by.hs: -------------------------------------------------------------------------------- 1 | data DividedResult = Result Integer 2 | | DividedByZero 3 | deriving Show 4 | 5 | dividedBy :: Integral a => a -> a -> DividedResult 6 | dividedBy num denom = go num denom 0 7 | where 8 | go n d count 9 | | d == 0 = DividedByZero 10 | | n < d = Result count 11 | | otherwise = go (n - d) d (count + 1) 12 | -------------------------------------------------------------------------------- /08/08.06-mccarthy-91-function.hs: -------------------------------------------------------------------------------- 1 | mc91 :: Integer -> Integer 2 | mc91 x | x > 100 = x - 10 3 | | otherwise = 91 4 | -------------------------------------------------------------------------------- /08/08.06-recursion.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | dividedBy :: Integral a => a -> a -> (a, a) 3 | dividedBy num denom = go num denom 0 4 | where 5 | go n d count 6 | | n < d = (count, n) 7 | | otherwise = go (n - d) d (count + 1) 8 | 9 | -- Steps for reducing `dividedBy 15 2` to its final answer: 10 | -- 11 | -- 15 2 0 12 | -- (15 - 2) 2 (0 + 1) 13 | -- (13 - 2) 2 (1 + 1) 14 | -- (11 - 2) 2 (2 + 1) 15 | -- (9 - 2) 2 (3 + 1) 16 | -- (7 - 2) 2 (4 + 1) 17 | -- (5 - 2) 2 (5 + 1) 18 | -- (3 - 2) 2 (6 + 1) 19 | -- 1 2 7 20 | -- (7, 1) 21 | 22 | ----------------------------------------------------------------------------- 23 | -- 2. 24 | -- Write a function that recursively sums all numbers from 1 to n. If n was 25 | -- 5, you'd add 1 + 2 + 3 + 4 + 5 to get 15. 26 | sumToN :: (Eq a, Num a) => a -> a 27 | sumToN 0 = 0 28 | sumToN n = sumToN (n -1) + n 29 | 30 | ----------------------------------------------------------------------------- 31 | -- 3. 32 | -- Write a function that multiplies two integral numbers using recursive 33 | -- summation. 34 | mult :: Integral a => a -> a -> a 35 | mult x y 36 | | x > 0 = y + mult (x - 1) y 37 | | x < 0 = (negate y) + mult (x + 1) y 38 | | otherwise = 0 39 | -------------------------------------------------------------------------------- /08/08.06-review-of-types.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- What is the type of [[True, False], [True, True], [False, True]] ? 3 | -- 4 | -- Answer: 5 | -- d) [[Bool]] 6 | 7 | ----------------------------------------------------------------------------- 8 | -- 2. 9 | -- Which of the following has the same type as 10 | -- [[True, False], [True, True], [False, True]] ? 11 | -- 12 | -- Answer: 13 | -- b) [[3 == 3], [6 > 5], [3 < 4]] 14 | 15 | ----------------------------------------------------------------------------- 16 | -- 3. 17 | -- Which is true about the following function? 18 | func :: [a] -> [a] -> [a] 19 | func x y = x ++ y 20 | -- Answer: 21 | -- d) all of the above 22 | 23 | ----------------------------------------------------------------------------- 24 | -- 4. 25 | -- For the `func` code above, which is a valid application of `func` to bot 26 | -- its arguments? 27 | -- 28 | -- Answer: 29 | -- b) func "Hello" "World" 30 | -------------------------------------------------------------------------------- /08/08.06-reviewing-currying.hs: -------------------------------------------------------------------------------- 1 | cattyConny :: String -> String -> String 2 | cattyConny x y = x ++ " mrow " ++ y 3 | 4 | flippy :: String -> String -> String 5 | flippy = flip cattyConny 6 | 7 | appedCatty :: String -> String 8 | appedCatty = cattyConny "woops" 9 | 10 | frappe :: String -> String 11 | frappe = flippy "haha" 12 | 13 | ----------------------------------------------------------------------------- 14 | -- 1. 15 | appedCatty' :: String 16 | appedCatty' = appedCatty "woohoo!" 17 | 18 | ----------------------------------------------------------------------------- 19 | -- 2. 20 | frappe' :: String 21 | frappe' = frappe "1" 22 | 23 | ----------------------------------------------------------------------------- 24 | -- 3. 25 | frappe'' :: String 26 | frappe'' = frappe (appedCatty "2") 27 | 28 | ----------------------------------------------------------------------------- 29 | -- 4. 30 | appedCatty'' :: String 31 | appedCatty'' = appedCatty (frappe "blue") 32 | 33 | ----------------------------------------------------------------------------- 34 | -- 5. 35 | cattyConny' :: String 36 | cattyConny' = cattyConny (frappe "pink") 37 | (cattyConny "green" (appedCatty "blue")) 38 | 39 | ----------------------------------------------------------------------------- 40 | -- 6. 41 | cattyConny'' :: String 42 | cattyConny'' = cattyConny (flippy "Pugs" "are") "awesome" 43 | -------------------------------------------------------------------------------- /08/08.06-word-number.hs: -------------------------------------------------------------------------------- 1 | module WordNumber where 2 | 3 | import Data.List (intersperse) 4 | 5 | digitToWord :: Int -> String 6 | digitToWord n = case n of 7 | 0 -> "zero" 8 | 1 -> "one" 9 | 2 -> "two" 10 | 3 -> "three" 11 | 4 -> "four" 12 | 5 -> "five" 13 | 6 -> "six" 14 | 7 -> "seven" 15 | 8 -> "eight" 16 | 9 -> "nine" 17 | 18 | digits :: Int -> [Int] 19 | digits n = go n [] 20 | where 21 | go 0 xs = xs 22 | go x xs = go (div x 10) ([mod x 10] ++ xs) 23 | 24 | wordNumber :: Int -> String 25 | wordNumber n = concat . (intersperse "-") . (map digitToWord) $ digits n 26 | -------------------------------------------------------------------------------- /09/09.05-enum-from-to.hs: -------------------------------------------------------------------------------- 1 | eftBool :: Bool -> Bool -> [Bool] 2 | eftBool True False = [] 3 | eftBool True True = [True] 4 | eftBool False True = [False, True] 5 | eftBool False False = [False] 6 | 7 | eftOrd :: Ordering -> Ordering -> [Ordering] 8 | eftOrd LT LT = [LT] 9 | eftOrd LT EQ = [LT, EQ] 10 | eftOrd LT GT = [LT, EQ, GT] 11 | eftOrd EQ EQ = [EQ] 12 | eftOrd EQ GT = [EQ, GT] 13 | eftOrd GT GT = [GT] 14 | eftOrd _ _ = [] 15 | 16 | eftInt :: Int -> Int -> [Int] 17 | eftInt x y | x > y = [] 18 | | x == y = [x] 19 | | otherwise = [x] ++ (eftInt (x + 1) y) 20 | 21 | eftChar :: Char -> Char -> [Char] 22 | eftChar x y | x > y = [] 23 | | x == y = [x] 24 | | otherwise = [x] ++ eftChar (succ x) y 25 | -------------------------------------------------------------------------------- /09/09.06-thy-fearful-symmetry.hs: -------------------------------------------------------------------------------- 1 | module PoemLines where 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 1. 5 | -- Using `takeWhile` and `dropWhile`, write a function that takes a string and 6 | -- returns a list of strings, using spaces to separate the elements of the 7 | -- string into words. 8 | myWords :: String -> [String] 9 | myWords [] = [] 10 | myWords (' ':xs) = myWords xs 11 | myWords xs = takeWhile (/=' ') xs : (myWords $ dropWhile (/=' ') xs) 12 | 13 | ----------------------------------------------------------------------------- 14 | -- 2. 15 | firstSen = "Tyger Tyger, burning bright\n" 16 | secondSen = "In the forest of the night\n" 17 | thirdSen = "What immortal hand or eye\n" 18 | fourthSen = "Could frame thy fearful symmetry?" 19 | sentences = firstSen ++ secondSen ++ thirdSen ++ fourthSen 20 | 21 | myLines :: String -> [String] 22 | myLines [] = [] 23 | myLines ('\n':xs) = myLines xs 24 | myLines xs = takeWhile (/='\n') xs : (myLines $ dropWhile (/='\n') xs) 25 | 26 | shouldEqual :: [String] 27 | shouldEqual = [ "Tyger Tyger, burning bright" 28 | , "In the forest of the night" 29 | , "What immortal hand or eye" 30 | , "Could frame thy fearful symmetry?" 31 | ] 32 | 33 | ----------------------------------------------------------------------------- 34 | -- 3. 35 | breakOnChar :: Char -> String -> [String] 36 | breakOnChar c [] = [] 37 | breakOnChar c (x:xs) = if c == x then breakOnChar c xs else breakOnChar c (x:xs) 38 | breakOnChar c xs = takeWhile (/=c) xs : (breakOnChar c $ dropWhile (/=c) xs) 39 | 40 | myWords' :: String -> [String] 41 | myWords' xs = breakOnChar ' ' xs 42 | 43 | myLines' :: String -> [String] 44 | myLines' xs = breakOnChar '\n' xs 45 | 46 | main :: IO () 47 | main = print $ "Are they equal? " ++ show (myLines sentences == shouldEqual) 48 | -------------------------------------------------------------------------------- /09/09.07-comprehend-thy-lists.hs: -------------------------------------------------------------------------------- 1 | mySqr :: [Integer] 2 | mySqr = [x^2 | x <- [1..10]] 3 | 4 | pairOfIntegers :: [(Integer, Integer)] 5 | pairOfIntegers = [(x, y) | x <- mySqr, 6 | y <- mySqr, 7 | x < 50, 8 | y > 50] 9 | 10 | pairOfIntegers' :: [(Integer, Integer)] 11 | pairOfIntegers' = take 5 [(x, y) | x <- mySqr, 12 | y <- mySqr, 13 | x < 50, 14 | y > 50] 15 | 16 | 17 | -------------------------------------------------------------------------------- /09/09.07-square-cube.hs: -------------------------------------------------------------------------------- 1 | mySqr :: [Integer] 2 | mySqr = [x^2 | x <- [1..5]] 3 | 4 | myCube :: [Integer] 5 | myCube = [y^3 | y <- [1..5]] 6 | 7 | ----------------------------------------------------------------------------- 8 | -- 1. 9 | sqrCubePairs :: [(Integer, Integer)] 10 | sqrCubePairs = [(x, y) | x <- mySqr, y <- myCube] 11 | 12 | ----------------------------------------------------------------------------- 13 | -- 2. 14 | sqrCubePairs' :: [(Integer, Integer)] 15 | sqrCubePairs' = [(x, y) | x <- mySqr, y <- myCube, x < 50, y < 50] 16 | 17 | ----------------------------------------------------------------------------- 18 | -- 3. 19 | sqrCubePairsLength :: Int 20 | sqrCubePairsLength = length sqrCubePairs' 21 | 22 | -------------------------------------------------------------------------------- /09/09.08-is-it-in-normal-form.hs: -------------------------------------------------------------------------------- 1 | -- For each expression, determin whether its in: 2 | -- 1. normal form, which implies weak head normal form 3 | -- 2. weak head normal form only 4 | -- 3. neither 5 | 6 | ----------------------------------------------------------------------------- 7 | -- 1. 8 | -- [1, 2, 3, 4, 5] 9 | -- Answer: 10 | -- normal form only 11 | 12 | ----------------------------------------------------------------------------- 13 | -- 2. 14 | -- 1 : 2 : 3 : 4 : _ 15 | -- Answer: 16 | -- weak head normal form 17 | 18 | ----------------------------------------------------------------------------- 19 | -- 3. 20 | -- enumFromTo 1 10 21 | -- Answer: 22 | -- neither 23 | 24 | ----------------------------------------------------------------------------- 25 | -- 4. 26 | -- length [1, 2, 3, 4, 5] 27 | -- Answer: 28 | -- neither 29 | 30 | ----------------------------------------------------------------------------- 31 | -- 5. 32 | -- sum (enumFromTo 1 10) 33 | -- Answer: 34 | -- neither 35 | 36 | ----------------------------------------------------------------------------- 37 | -- 6. 38 | -- ['a'..'m'] ++ ['n'..'z'] 39 | -- Answer: 40 | -- neither 41 | 42 | ----------------------------------------------------------------------------- 43 | -- 7. 44 | --- (_, 'b') 45 | -- Answer: 46 | -- weak head normal form 47 | -------------------------------------------------------------------------------- /09/09.08-will-it-blow-up.hs: -------------------------------------------------------------------------------- 1 | -- Will the following expressions return a value or bottom? 2 | -- 3 | ----------------------------------------------------------------------------- 4 | -- 1. 5 | -- [x^y | x <- [1..5], y <- [2, undefined]] 6 | -- Answer: 7 | -- Bottom 8 | 9 | ----------------------------------------------------------------------------- 10 | -- 2. 11 | -- take 1 $ [x^y | x <- [1..5], y <- [2, undefined]] 12 | -- Answer: 13 | -- [1] 14 | 15 | ----------------------------------------------------------------------------- 16 | -- 3. 17 | -- sum [1, undefined, 3] 18 | -- Answer: 19 | -- Bottom 20 | 21 | ----------------------------------------------------------------------------- 22 | -- 4. 23 | -- length [1, 2, undefined] 24 | -- Answer: 25 | -- 3 26 | 27 | ----------------------------------------------------------------------------- 28 | -- 5. 29 | -- length $ [1, 2, 3] ++ undefined 30 | -- Answer: 31 | -- Bottom 32 | 33 | ----------------------------------------------------------------------------- 34 | -- 6. 35 | -- take 1 $ filter even [1, 2, 3, undefined] 36 | -- Answer: 37 | -- [2] 38 | 39 | ----------------------------------------------------------------------------- 40 | -- 7. 41 | -- take 1 $ filter even [1, 3, undefined] 42 | -- Answer: 43 | -- Bottom 44 | 45 | ----------------------------------------------------------------------------- 46 | -- 8. 47 | -- take 1 $ filter odd [1, 3, undefined] 48 | -- Answer: 49 | -- [1] 50 | 51 | ----------------------------------------------------------------------------- 52 | -- 9. 53 | -- take 2 $ filter odd [1, 3, undefined] 54 | -- Answer: 55 | -- [1,3] 56 | 57 | ----------------------------------------------------------------------------- 58 | -- 10. 59 | -- take 3 $ filter odd [1, 3, undefined] 60 | -- Answer: 61 | -- Bottom 62 | -------------------------------------------------------------------------------- /09/09.09-more-bottoms.hs: -------------------------------------------------------------------------------- 1 | import Data.Bool (bool) 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 1. 5 | -- take 1 $ map (+1) [undefined, 2, 3] 6 | -- Answer: 7 | -- Bottom 8 | 9 | ----------------------------------------------------------------------------- 10 | -- 2. 11 | -- take 1 $ map (+1) [1, undefined, 3] 12 | -- Answer: 13 | -- [2] 14 | 15 | ----------------------------------------------------------------------------- 16 | -- 3. 17 | -- take 2 $ map (+1) [1, undefined, 3] 18 | -- Answer: 19 | -- Bottom 20 | 21 | ----------------------------------------------------------------------------- 22 | -- 4. 23 | itIsMystery :: String -> [Bool] 24 | itIsMystery xs = map (\x -> elem x "aeiou") xs 25 | -- returns a list of boolean values where a vowel returns True 26 | 27 | ----------------------------------------------------------------------------- 28 | -- 5. 29 | -- a) map (^2) [1..10] 30 | -- [1,4,9,16,25,36,49,64,81,100] 31 | -- b) map minimum [[1..10], [10..20], [20..30]] 32 | -- [1,10,20] 33 | -- c) map sum [[1..5], [1..5], [1..5]] 34 | -- [15,15,15] 35 | 36 | ----------------------------------------------------------------------------- 37 | -- 6. 38 | mapBool :: (Num b, Eq b) => [b] -> [b] 39 | mapBool = map (\x -> bool x (-x) (x == 3)) 40 | -------------------------------------------------------------------------------- /09/09.10-filtering.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | multiplesOfThree :: [Int] -> [Int] 3 | multiplesOfThree = filter (\x -> x `mod` 3 == 0) 4 | 5 | ----------------------------------------------------------------------------- 6 | -- 2. 7 | multiplesOfThreeLength :: [Int] -> Int 8 | multiplesOfThreeLength = length . multiplesOfThree 9 | 10 | ----------------------------------------------------------------------------- 11 | -- 3. 12 | myFilter :: String -> [String] 13 | myFilter = filter (\xs -> not $ elem xs ["the", "a", "an"]) . words 14 | -------------------------------------------------------------------------------- /09/09.11-zipping-lists.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | zip' :: [a] -> [b] -> [(a, b)] 3 | zip' xs ys = [(x, y) | x <- xs, y <- ys] 4 | 5 | ----------------------------------------------------------------------------- 6 | -- 2. 7 | zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c] 8 | zipWith' f xs ys = [f x y | x <- xs, y <- ys] 9 | 10 | ----------------------------------------------------------------------------- 11 | -- 3. 12 | zip'' :: [a] -> [b] -> [(a, b)] 13 | zip'' xs ys = zipWith' (,) xs ys 14 | -------------------------------------------------------------------------------- /09/09.12-ciphers.hs: -------------------------------------------------------------------------------- 1 | module Cipher where 2 | 3 | import Data.Char 4 | 5 | tooHigh :: Int -> Bool 6 | tooHigh = (>122) 7 | 8 | tooLow :: Int -> Bool 9 | tooLow = (<97) 10 | 11 | trim :: Int -> Int 12 | trim n = mod n 122 13 | 14 | pad :: Int -> Int 15 | pad n = mod 97 n 16 | 17 | shiftInt :: Int -> Char -> Int 18 | shiftInt n c = shiftWrap $ (ord c) + n 19 | 20 | unshiftInt :: Int -> Char -> Int 21 | unshiftInt n c = unshiftWrap $ (ord c) - n 22 | 23 | shiftWrap :: Int -> Int 24 | shiftWrap n = if tooHigh n 25 | then 96 + trim n 26 | else n 27 | 28 | unshiftWrap :: Int -> Int 29 | unshiftWrap n = if tooLow n 30 | then 123 - pad n 31 | else n 32 | 33 | caesar :: Int -> String -> String 34 | caesar n xs = map (chr . (shiftInt n)) xs 35 | 36 | unCaesar :: Int -> String -> String 37 | unCaesar n xs = map (chr . (unshiftInt n)) xs 38 | 39 | -------------------------------------------------------------------------------- /09/09.12-data-char.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 1. 5 | -- 6 | -- isUpper :: Char -> Bool 7 | -- toUpper :: Char -> Char 8 | 9 | ----------------------------------------------------------------------------- 10 | -- 2. 11 | filterUpper :: String -> String 12 | filterUpper = filter isUpper 13 | 14 | ----------------------------------------------------------------------------- 15 | -- 3. 16 | caps :: String -> String 17 | caps [] = [] 18 | caps xs = toUpper (head xs) : tail xs 19 | 20 | ----------------------------------------------------------------------------- 21 | -- 4. 22 | allCaps :: String -> String 23 | allCaps [] = [] 24 | allCaps (x:xs) = toUpper x : allCaps xs 25 | 26 | ----------------------------------------------------------------------------- 27 | -- 5. 28 | toUpperFirst :: String -> Char 29 | toUpperFirst xs = toUpper $ head xs 30 | 31 | ----------------------------------------------------------------------------- 32 | -- 7. 33 | toUpperFirst' :: String -> Char 34 | toUpperFirst' = toUpper . head 35 | -------------------------------------------------------------------------------- /10/10.05-understanding-folds.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | foldr (*) 1 [1..5] 3 | -- will return the same result as: 4 | -- 5 | -- Answer: 6 | -- c) foldl (*) [1..5] 7 | 8 | -- 2. 9 | -- Write out the evaluation steps for: 10 | foldl (flip (*)) 1 [1..3] 11 | -- 12 | -- Answer: 13 | -- ((1 * 1) * 2) * 3 14 | 15 | -- 3. 16 | -- One difference between `foldr` and `foldl` is: 17 | -- Answer: 18 | -- c) `foldr`, but not `foldl`, associates to the right 19 | 20 | -- 4. 21 | -- Folds are catamorphisms, which means they are generally used to: 22 | -- Answer: 23 | -- a) reduce structure 24 | 25 | -- 5. 26 | -- Fix the following: 27 | -- a) foldr (++) ["woot", "WOOT", "woot"] 28 | foldr (++) [] ["woot", "WOOT", "woot"] 29 | -- b) foldr max [] "fear is the little death" 30 | foldr max (minBound :: Char) "fear is the little death" 31 | -- c) foldr and True [False, True] 32 | foldr (&&) True [False, True] 33 | -- d) foldr (||) True [False, True] 34 | foldr (||) False [False, True] 35 | -- e) foldl ((++) . show) "" [1..5] 36 | foldl (flip ((++) . show)) "" [1..5] 37 | -- f) foldr const 'a' [1..5] 38 | foldr (flip const) 'a' [1..5] 39 | -- g) foldr const 0 "tacos" 40 | foldr (flip const) 0 "tacos" 41 | -- h) foldl (flip const) 0 "burritos" 42 | foldl const 0 "burritos" 43 | -- i) foldl (flip const) 'z' [1..5] 44 | foldl const 'z' [1..5] 45 | -------------------------------------------------------------------------------- /10/10.06-database-processing.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 (fromGregorian 1911 5 1) (secondsToDiffTime 34123)) 11 | , DbNumber 9001 12 | , DbString "Hello, world!" 13 | , DbDate (UTCTime (fromGregorian 1921 5 1) (secondsToDiffTime 34123)) 14 | ] 15 | 16 | -- 1. 17 | -- Write a function that filters for `DbDate` values and returns a list of 18 | -- `UTCTime` values inside them. 19 | filterDbDate :: [DatabaseItem] -> [UTCTime] 20 | filterDbDate = go 21 | where 22 | go [] = [] 23 | go ((DbDate y):ys) = y : go ys 24 | go (_:ys) = go ys 25 | 26 | -- 2. 27 | -- Write a function that filters for `DbNumber` values and returns a list 28 | -- of the `Integer` values inside them. 29 | filterDbNumber :: [DatabaseItem] -> [Integer] 30 | filterDbNumber = go 31 | where 32 | go [] = [] 33 | go ((DbNumber x):xs) = x : go xs 34 | go (_:xs) = go xs 35 | 36 | -- 3. 37 | -- Write a function that gets the most recent date. 38 | mostRecent :: [DatabaseItem] -> UTCTime 39 | mostRecent dbs = go $ filterDbDate dbs 40 | where 41 | go (x:xs) = foldl (\a b -> max a b) x xs 42 | 43 | -- 4. 44 | -- Write a function that sums all of the DbNumber values. 45 | sumDb :: [DatabaseItem] -> Integer 46 | sumDb dbs = foldl (+) 0 $ filterDbNumber dbs 47 | 48 | -- 5. 49 | -- Write a function that gets the average of the `DbNumber` values. 50 | avgDb :: [DatabaseItem] -> Double 51 | avgDb dbs = go $ fmap fromIntegral $ filterDbNumber dbs 52 | where 53 | go xs = fromIntegral $ div (foldl (\a b -> a + b) 0 xs) (length xs) 54 | -------------------------------------------------------------------------------- /10/10.08-scans-exercises.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- Modify the `fibs` function to only return the first 20 Fibonacci numbers. 3 | fibs :: [Integer] 4 | fibs = 1 : scanl (+) 1 fibs 5 | 6 | first20Fibs :: [Integer] 7 | first20Fibs = take 20 fibs 8 | 9 | -- 2. 10 | -- Modify `fibs` to return the Fibonacci numbers that are less than 100. 11 | lessThan100Fibs :: [Integer] 12 | lessThan100Fibs = takeWhile (<100) fibs 13 | 14 | -- 3. 15 | -- Write the `factorial` function as a scan. 16 | factorial :: [Integer] 17 | factorial = take 20 $ scanl (*) 1 [2..] 18 | -------------------------------------------------------------------------------- /10/10.10-warm-up-and-review.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- Given the following set of consonants and vowels: 3 | stops :: String 4 | stops = "pbtdkg" 5 | 6 | vowels :: String 7 | vowels = "aeiou" 8 | 9 | -- a) 10 | -- Write a function that takes inputs from `stops` and `vowels` and makes 11 | -- 3-tuples of all possible stop-vowel-stop combinations. 12 | stopVowelStop :: [(Char, Char, Char)] 13 | stopVowelStop = [(s, v, s') | s <- stops, v <- vowels, s' <- stops] 14 | 15 | -- b) 16 | -- Modify that function so that it only returns the combinations that 17 | -- begin with a 'p'. 18 | stopVowelStopP :: [(Char, Char, Char)] 19 | stopVowelStopP = [(s, v, s') | s <- stops, v <- vowels, s' <- stops, s == 'p'] 20 | 21 | -- c) 22 | -- Set up lists of nouns and verbs and modify the function to make tuples 23 | -- representing possible noun-verb-noun sentences. 24 | nouns :: [String] 25 | nouns = [ "car" 26 | , "computer" 27 | , "shoe" 28 | , "refrigerator" 29 | ] 30 | 31 | verbs :: [String] 32 | verbs = [ "slap" 33 | , "slip" 34 | , "sleep" 35 | , "slam" 36 | ] 37 | 38 | nounVerbNoun :: [(String, String, String)] 39 | nounVerbNoun = [(n, v, n') | n <- nouns, v <- verbs, n' <- nouns] 40 | 41 | -- 2. 42 | -- What does the following function do and what is its type? 43 | seekritFunc :: String -> Int 44 | seekritFunc x = div (sum (map length (words x))) (length (words x)) 45 | -- Answer: 46 | -- Gets the average word length of a sentence. 47 | 48 | -- 3. 49 | -- Rewrite the function above using fractional division. 50 | seekritFunc' :: Fractional a => String -> a 51 | seekritFunc' x = 52 | fromIntegral (sum $ map length $ words x) / 53 | fromIntegral (length $ words x) 54 | -------------------------------------------------------------------------------- /11/11.06-vehicles.hs: -------------------------------------------------------------------------------- 1 | data Price = Price Integer deriving (Eq, Show) 2 | 3 | data Manufacturer = 4 | Mini 5 | | Mazda 6 | | Tata 7 | deriving (Eq, Show) 8 | 9 | data Airline = 10 | PapuAir 11 | | CatapultsR'Us 12 | | TakeYourChancesUnited 13 | deriving (Eq, Show) 14 | 15 | data Vehicle = 16 | Car Manufacturer Price 17 | | Plane Airline Size 18 | deriving (Eq, Show) 19 | 20 | -- Added for question 5. 21 | data Size = 22 | S 23 | | M 24 | | L 25 | | XL 26 | deriving (Eq, Show) 27 | 28 | myCar = Car Mini (Price 14000) 29 | urCar = Car Mazda (Price 20000) 30 | clownCar = Car Tata (Price 7000) 31 | doge = Plane PapuAir XL 32 | 33 | -- 1. 34 | -- What is the type of myCar? 35 | -- myCar :: Vehicle 36 | 37 | -- 2. 38 | -- Define the functions. 39 | isCar :: Vehicle -> Bool 40 | isCar (Car _ _) = True 41 | isCar _ = False 42 | 43 | isPlane :: Vehicle -> Bool 44 | isPlane (Plane _ _) = True 45 | isPlane _ = False 46 | 47 | areCars :: [Vehicle] -> [Bool] 48 | areCars = fmap isCar 49 | 50 | -- 3. 51 | -- Write a function that returns the manufacturer of a piece of data. 52 | getManu :: Vehicle -> Manufacturer 53 | getManu (Car x _) = x 54 | getManu _ = error "\n\nNo manufacturer found.\n" 55 | 56 | -- 4. 57 | -- What will happen if you use `getManu` on `Plane` data? 58 | -- Non-exhaustive patterns exception 59 | 60 | -- 5. 61 | -- Add the size of a plane as an argument to the `Plane` constructor. 62 | -------------------------------------------------------------------------------- /11/11.08-cardinality.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- Calculate the cardinality. 3 | data PugType = PugData 4 | -- Answer: 1 5 | 6 | -- 2. 7 | -- Calculate the cardinality. 8 | data Airline = 9 | PapuAir 10 | | CatapultsR'Us 11 | | TakeYourChancesUnited 12 | -- Answer: 3 13 | 14 | -- 3. 15 | -- What is the cardinality of Int16? 16 | -- (minBound :: Int16) == -32768 17 | -- (maxBound :: Int16) == 32767 18 | -- (32768 + 1 + 32767) == 65536 19 | -- 20 | -- Answer: 65536 21 | 22 | -- 4. 23 | -- What can you say about the cardinality of `Int` and `Integer` based off 24 | -- using `maxBound` and `minBound` in the REPL. 25 | -- 26 | -- Answer: `Integer` type has no instance of the `Bounded` typeclass. 27 | 28 | -- 5. 29 | -- What is the connection between 8 in `Int8` and that type's cardinality 30 | -- of 256? 31 | -- 2 ^ 8 == 256 32 | -- Answer: A bit is either a 0 or a 1, which give a cardinality of 2. 33 | -------------------------------------------------------------------------------- /11/11.08-for-example.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- What is the type of data constructor `MakeExample`? What happens if you 3 | -- query the type of `Example`? 4 | data Example = MakeExample deriving Show 5 | -- Answer: Nullary. You can query the type of a data constructor but 6 | -- it makes no sense to query the type of a type constructor since itself 7 | -- is a type. 8 | 9 | -- 2. What happens if you query the info on `Example` and can you determine 10 | -- what typeclass instances are defined for it? 11 | -- Answer: The definition is printed along with the instances it has. 12 | 13 | -- 3. 14 | -- What gets printed in the REPL if you make a new datatype like `Example` 15 | -- but with a single type argument added to `MakeExample`? 16 | data Example' = MakeExample' Int deriving Show 17 | -- Answer: MakeExample' :: Int -> Example' 18 | -------------------------------------------------------------------------------- /11/11.09-logic-goats.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-} 2 | 3 | class TooMany a where 4 | tooMany :: a -> Bool 5 | 6 | instance TooMany Int where 7 | tooMany n = n > 42 8 | 9 | newtype Goats = Goats Int deriving (Eq, Show, TooMany) 10 | newtype Cows = Cows Int deriving (Eq, Show) 11 | 12 | tooManyGoats :: Goats -> Bool 13 | tooManyGoats (Goats n) = n > 42 14 | 15 | -- 1. 16 | -- Write an instance for the type `(Int, String)` using the `TooMany` 17 | -- typeclass. 18 | data IntString = IntString (Int, String) deriving (Eq, Show) 19 | 20 | instance TooMany IntString where 21 | tooMany (IntString (n, _)) = tooMany n 22 | 23 | -- 2. 24 | -- Write another `TooMany` instance for (Int, Int) and summ the values 25 | -- together under the assumption this is a count of goats from two fields. 26 | data IntInt = IntInt (Int, Int) deriving (Eq, Show) 27 | 28 | instance TooMany IntInt where 29 | tooMany (IntInt (n, n')) = tooMany (n + n') 30 | 31 | -- 3. 32 | -- Write another `TooMany` instance for (Num a, TooMany a) => (a, a). 33 | data NumTooMany = NumTooMany IntInt deriving (Eq, Show) 34 | 35 | instance TooMany NumTooMany where 36 | tooMany (NumTooMany (IntInt (n, n'))) = tooMany (n * n') 37 | -------------------------------------------------------------------------------- /11/11.10-pity-the-bool.hs: -------------------------------------------------------------------------------- 1 | import Data.Int 2 | 3 | -- 1. 4 | -- What is the cardinality of this datatype? 5 | data BigSmall = 6 | Big Bool 7 | | Small Bool 8 | deriving (Eq, Show) 9 | -- Answer: 2 10 | 11 | -- 2. 12 | -- What is the cardinality of `NumberOrBool` and what happens if you try to 13 | -- create a `Numba` with a numerical literal larger than 127 and also with a 14 | -- numerical literal smaller than (-128)? 15 | data NumberOrBool = 16 | Numba Int8 17 | | BoolyBool Bool 18 | deriving (Eq, Show) 19 | 20 | n = (-128) 21 | x = Numba n 22 | -- Answer: The cardinality of `NumberOrBool` is 258. If a numeric literal 23 | -- is out of the bounds of the `Int8` type then the compiler uses the 24 | -- remainder of the difference as the value. 25 | -------------------------------------------------------------------------------- /11/11.12-how-does-your-garden-grow.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- What is the normal form of `Garden`? 3 | data FlowerType = 4 | Gardenia 5 | | Daisy 6 | | Rose 7 | | Lilac 8 | deriving Show 9 | 10 | type Gardener = String 11 | 12 | data Garden = Garden Gardener FlowerType deriving Show 13 | 14 | data Garden' = 15 | Gardener Gardenia 16 | | Gardener Daisy 17 | | Gardener Rose 18 | | Gardener Lilac 19 | deriving Show 20 | -------------------------------------------------------------------------------- /11/11.14-the-quad.hs: -------------------------------------------------------------------------------- 1 | -- Determine how many unique inhabitants each type has? 2 | data Quad = One 3 | | Two 4 | | Three 5 | | Four 6 | deriving (Eq, Show) 7 | 8 | -- 1. 9 | eQuad :: Either Quad Quad 10 | eQuad = undefined 11 | -- Answer: 12 | -- Either = Quad 4 | Quad 4 13 | -- 8 = 4 + 4 14 | -- 15 | -- There are 8 different possible implementations. 16 | 17 | -- 2. 18 | prodQuad :: (Quad, Quad) 19 | prodQuad = undefined 20 | -- Answer: 21 | -- (Quad 4, Quad 4) 22 | -- 16 = 4 * 4 23 | -- 24 | -- There are 16 different possible implementations. 25 | 26 | -- 3. 27 | funcQuad :: Quad -> Quad 28 | funcQuad = undefined 29 | -- Answer: 30 | -- Quad 4 -> Quad 4 31 | -- 256 = 4 ^ 4 32 | -- 33 | -- There are 256 different possible implementations. 34 | 35 | -- 4. 36 | prodTBool :: (Bool, Bool, Bool) 37 | prodTBool = undefined 38 | -- Answer: 39 | -- (Bool 2, Bool 2, Bool 2) 40 | -- 8 = 2 * 2 * 2 41 | -- 42 | -- There are 8 different possible implementations. 43 | 44 | -- 5. 45 | gTwo :: Bool -> Bool -> Bool 46 | gTwo = undefined 47 | -- Answer: 48 | -- Bool 2 -> Bool 2 -> Bool 2 49 | -- 16 = 2 ^ 2 ^ 2 50 | -- 51 | -- There are 16 different possible implementations. 52 | 53 | fTwo :: Bool -> Quad -> Quad 54 | fTwo = undefined 55 | -- Answer: 56 | -- Bool 2 -> Quad 4 -> Quad 4 57 | -- 65536 = (2 ^ 4) ^ 4 58 | -- 59 | -- There are 65536 different possible implementations. 60 | 61 | 62 | -------------------------------------------------------------------------------- /11/11.18-as-patterns.hs: -------------------------------------------------------------------------------- 1 | import Data.Char (toUpper) 2 | 3 | -- 1. 4 | -- This should return `True` if (and only if) all the values in the first list 5 | -- appear in the second list. 6 | isSubseqOf :: (Eq a) => [a] -> [a] -> Bool 7 | isSubseqOf [] _ = True 8 | isSubseqOf _ [] = False 9 | isSubseqOf (x:xs) (y:ys) = case x == y of 10 | True -> isSubseqOf xs ys 11 | False -> False 12 | 13 | -- 2. 14 | -- Split a sentence into words, then tuple each word with the capitalized form 15 | -- of each. 16 | capitalizeWords :: String -> [(String, String)] 17 | capitalizeWords xs = map f $ words xs 18 | where 19 | f word@(y:ys) = (word, toUpper y : ys) 20 | 21 | -------------------------------------------------------------------------------- /11/11.18-ciphers.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | charCodes :: [Int] 4 | charCodes = fmap ord ['a'..'z'] 5 | 6 | wrapLeft :: Int -> Int 7 | wrapLeft n 8 | | n > (last charCodes) = n - (last charCodes) + (head charCodes - 1) 9 | | otherwise = n 10 | 11 | wrapRight :: Int -> Int 12 | wrapRight n 13 | | n < (head charCodes) = n + (last charCodes) - (head charCodes - 1) 14 | | otherwise = n 15 | 16 | shiftChar :: Int -> Char -> Char 17 | shiftChar n ch = chr $ wrapLeft (n + ord ch) 18 | 19 | unshiftChar :: Int -> Char -> Char 20 | unshiftChar n co = chr $ wrapRight (ord co - n) 21 | 22 | caesar :: Int -> String -> String 23 | caesar _ [] = [] 24 | caesar n xs = fmap (shiftChar n) xs 25 | 26 | uncaesar :: Int -> String -> String 27 | uncaesar _ [] = [] 28 | uncaesar n xs = fmap (unshiftChar n) xs 29 | 30 | table :: [(Char, Int)] 31 | table = zip ['a'..'z'] [0..] 32 | 33 | -------------------------------------------------------------------------------- /11/11.18-huttons-razor.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- Write a function which reduces an expression to a final sum. 3 | data Expr = Lit Integer 4 | | Add Expr Expr 5 | deriving (Eq, Show) 6 | 7 | eval :: Expr -> Integer 8 | eval (Lit x) = x 9 | eval (Add x y) = (eval x) + (eval y) 10 | 11 | -- 2. 12 | -- Write a printer for the expressions. 13 | printExpr :: Expr -> String 14 | printExpr (Lit x) = show x 15 | printExpr (Add x y) = (printExpr x) ++ " + " ++ (printExpr y) 16 | -------------------------------------------------------------------------------- /11/11.18-language-exercises.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Data.List 3 | import Data.List.Split 4 | 5 | -- 1. 6 | -- Write a function that capitalizes a word. 7 | capitalizeWord :: String -> String 8 | capitalizeWord [] = [] 9 | capitalizeWord (x:xs) = toUpper x : xs 10 | 11 | -- 2. 12 | -- Write a function that captializes sentences in a paragraph. Reuse the 13 | -- `capitalizeWord` function. 14 | capitalizeParagraph :: String -> String 15 | capitalizeParagraph [] = [] 16 | capitalizeParagraph xs = joinAndConcat . splitAndCapitalize $ xs 17 | 18 | splitAndCapitalize :: String -> [String] 19 | splitAndCapitalize = fmap capitalizeWord . splitOn ". " 20 | 21 | joinAndConcat :: [String] -> String 22 | joinAndConcat xs = concatMap (\ys -> ys ++ ". ") (init xs) ++ (last xs) 23 | -------------------------------------------------------------------------------- /11/11.18-multiple-choice.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | data Weekday = Monday 3 | | Tuesday 4 | | Wednesday 5 | | Thursday 6 | | Friday 7 | -- Answer: 8 | -- a) Weekday is a type with five data constructors. 9 | 10 | -- 2. 11 | -- What is the type of the function `f`? 12 | f Friday = "Miller Time" 13 | -- Answer: 14 | -- c) f :: Weekday -> String 15 | 16 | -- 3. 17 | -- Types defined with the `data` keyword 18 | -- Answer: 19 | -- b) must begin with a capital letter 20 | 21 | -- 4. 22 | g xs = xs !! (length xs - 1) 23 | -- Answer: 24 | -- d) delivers the final element of `xs` 25 | -------------------------------------------------------------------------------- /12/12.02-how-i-learned-to-stop-worrying-and-love-nothing.hs: -------------------------------------------------------------------------------- 1 | ifEvenAdd2 :: Integer -> Maybe Integer 2 | ifEvenAdd2 n = if even n 3 | then Just (n + 2) 4 | else Nothing 5 | 6 | type Name = String 7 | type Age = Integer 8 | 9 | data Person = Person Name Age 10 | deriving Show 11 | 12 | mkPerson :: Name -> Age -> Maybe Person 13 | mkPerson name age 14 | | name /= "" && age >= 0 = Just $ Person name age 15 | | otherwise = Nothing 16 | -------------------------------------------------------------------------------- /12/12.03-bleating-either.hs: -------------------------------------------------------------------------------- 1 | type Name = String 2 | type Age = Integer 3 | type ValidatePerson a = Either [PersonInvalid] a 4 | 5 | data Person = Person Name Age 6 | deriving Show 7 | 8 | data PersonInvalid = NameEmpty 9 | | AgeTooLow 10 | deriving (Eq, Show) 11 | 12 | toString :: PersonInvalid -> String 13 | toString NameEmpty = "NameEmpty" 14 | toString AgeTooLow = "AgeTooLow" 15 | 16 | ageOkay :: Age -> Either [PersonInvalid] Age 17 | ageOkay age = case age >= 0 of 18 | True -> Right age 19 | False -> Left [AgeTooLow] 20 | 21 | nameOkay :: Name -> Either [PersonInvalid] Name 22 | nameOkay name = case name /= "" of 23 | True -> Right name 24 | False -> Left [NameEmpty] 25 | 26 | mkPerson :: Name -> Age -> ValidatePerson Person 27 | mkPerson name age 28 | | name /= "" && age >= 0 = Right $ Person name age 29 | | name == "" = Left NameEmpty 30 | | otherwise = Left AgeTooLow 31 | 32 | mkPerson' :: ValidatePerson Name -> ValidatePerson Age -> ValidatePerson Person 33 | mkPerson' (Right nameOk) (Right ageOk) = Right (Person nameOk ageOk) 34 | mkPerson' (Left badName) (Left badAge) = Left (badName ++ badAge) 35 | mkPerson' (Left badName) _ = Left badName 36 | mkPerson' _ (Left badAge) = Left badAge 37 | -------------------------------------------------------------------------------- /12/12.05-binary-tree.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- Write `unfold` for `BinaryTree`. 3 | data BinaryTree a = Leaf 4 | | Node (BinaryTree a) a (BinaryTree a) 5 | deriving (Eq, Ord, Show) 6 | 7 | -- myUnfoldr :: (b -> Maybe (a, b)) -> b -> [a] 8 | -- myUnfoldr f x = doIt (f x) 9 | -- where 10 | -- doIt Nothing = [] 11 | -- doIt (Just (x, y)) = x : myUnfoldr f y 12 | 13 | unfold :: (a -> Maybe (a, b, a)) -> a -> BinaryTree b 14 | unfold f x = doIt (f x) 15 | where 16 | doIt Nothing = Leaf 17 | doIt (Just (x, y, x')) = Node (unfold f x) y (unfold f x') 18 | 19 | -- 2. 20 | -- Using the `unfold` function, write the following: 21 | treeBuild :: Integer -> BinaryTree Integer 22 | treeBuild n = unfold build 0 23 | where 24 | build a 25 | | a < n = Just (a + 1, a, a + 1) 26 | | otherwise = Nothing 27 | -------------------------------------------------------------------------------- /12/12.05-determine-the-kinds.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- What is the kind of `a`? 3 | id :: a -> a 4 | id = undefined 5 | -- Answer: 6 | -- * :: * 7 | 8 | -- 2. 9 | -- What are the kinds of `a` and `f`? 10 | r :: a -> f a 11 | r = undefined 12 | -- Answer: 13 | -- a :: * 14 | -- f :: * -> * 15 | -------------------------------------------------------------------------------- /12/12.05-its-only-natural.hs: -------------------------------------------------------------------------------- 1 | -- Convert naturals into integers and integers into naturals. 2 | data Nat = Zero 3 | | Succ Nat 4 | deriving (Eq, Show) 5 | 6 | natToInteger :: Nat -> Integer 7 | natToInteger Zero = 0 8 | natToInteger (Succ x) = 1 + natToInteger x 9 | 10 | integerToNat :: Integer -> Maybe Nat 11 | integerToNat n 12 | | n < 0 = Nothing 13 | | otherwise = Just $ doIt n 14 | where 15 | doIt 0 = Zero 16 | doIt n = Succ $ doIt (n - 1) 17 | -------------------------------------------------------------------------------- /12/12.05-small-library-for-either.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- Try to eventually arrive at a solution that uses `foldr`, even if earlier 3 | -- versions don't use `foldr`. 4 | lefts' :: [Either a b] -> [a] 5 | lefts' = foldr doIt [] 6 | where 7 | doIt (Left x) y = x : y 8 | doIt (Right _) y = y 9 | 10 | -- 2. 11 | -- Same as last one. Use `foldr` eventually. 12 | rights' :: [Either a b] -> [b] 13 | rights' = foldr doIt [] 14 | where 15 | doIt (Right x) y = x : y 16 | doIt (Left _) y = y 17 | 18 | -- 3. 19 | partitionEithers' :: [Either a b] -> ([a], [b]) 20 | partitionEithers' = foldr doIt ([], []) 21 | where 22 | doIt (Left l) (ls, rs) = (l : ls, rs) 23 | doIt (Right r) (ls, rs) = (ls, r : rs) 24 | 25 | -- 4. 26 | eitherMaybe' :: (b -> c) -> Either a b -> Maybe c 27 | eitherMaybe' _ (Left _) = Nothing 28 | eitherMaybe' f (Right x) = Just (f x) 29 | 30 | -- 5. 31 | -- Write the general catamorphism for `Either` values. 32 | either' :: (a -> c) -> (b -> c) -> Either a b -> c 33 | either' f _ (Left a) = f a 34 | either' _ g (Right b) = g b 35 | 36 | -- 6. 37 | -- Same as before, but use the `either'` function above. 38 | eitherMaybe'' :: (b -> c) -> Either a b -> Maybe c 39 | eitherMaybe'' f e = either' (\_ -> Nothing) (\x -> Just $ f x) e 40 | -------------------------------------------------------------------------------- /12/12.05-small-library-for-maybe.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- Write a function for simple boolean checks for Maybe values. 3 | isJust :: Maybe a -> Bool 4 | isJust Nothing = False 5 | isJust _ = True 6 | 7 | isNothing :: Maybe a -> Bool 8 | isNothing Nothing = True 9 | isNothing _ = False 10 | 11 | -- 2. 12 | -- Write the definition for the following `Maybe` catamorphism. 13 | mayybee :: b -> (a -> b) -> Maybe a -> b 14 | mayybee b f Nothing = b 15 | mayybee b f (Just a) = f a 16 | 17 | -- 3. 18 | -- Write the definition for providing a fallback value. 19 | fromMaybe :: a -> Maybe a -> a 20 | fromMaybe a Nothing = a 21 | fromMaybe _ (Just a) = a 22 | 23 | -- 4. 24 | -- Write the definitions for covertng `List` and `Maybe`. 25 | listToMaybe :: [a] -> Maybe a 26 | listToMaybe [] = Nothing 27 | listToMaybe (x:xs) = Just x 28 | 29 | maybeToList :: Maybe a -> [a] 30 | maybeToList Nothing = [] 31 | maybeToList (Just xs) = [xs] 32 | 33 | -- 5. 34 | -- Write the definition for dropping the `Nothing` values from a list. 35 | catMaybes :: [Maybe a] -> [a] 36 | catMaybes [] = [] 37 | catMaybes (Nothing:xs) = catMaybes xs 38 | catMaybes ((Just x):xs) = x : catMaybes xs 39 | 40 | -- 6. 41 | -- Write an function that flips `[Maybe a]` to a `Maybe [a]` where a `Nothing` 42 | -- found in the list returns the sole value of `Nothing`. 43 | flipMaybe :: [Maybe a] -> Maybe [a] 44 | flipMaybe = foldl doIt (Just []) 45 | where 46 | doIt Nothing _ = Nothing 47 | doIt _ Nothing = Nothing 48 | doIt (Just xs) (Just x) = Just (xs ++ [x]) 49 | -------------------------------------------------------------------------------- /12/12.05-string-processing.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | -- 1. 4 | -- Write a recursive function which takes text, breaks it into words and 5 | -- replaces each instance of "the" with "a". 6 | notThe :: String -> Maybe String 7 | notThe xs = if xs == "the" 8 | then Nothing 9 | else Just xs 10 | 11 | swapOutThe :: Maybe String -> String 12 | swapOutThe Nothing = "a" 13 | swapOutThe (Just xs) = xs 14 | 15 | replaceThe :: String -> String 16 | replaceThe xs = unwords $ (fmap swapOutThe) $ (fmap notThe) (words xs) 17 | 18 | -- 2. 19 | -- Write a recursive function that takes text, breaks it into words, and 20 | -- counts the number of instance of "the" followed by a vowel-inital word. 21 | wordsToMaybes :: String -> [Maybe String] 22 | wordsToMaybes xs = fmap notThe $ words xs 23 | 24 | countTheBeforeVowel :: String -> Integer 25 | countTheBeforeVowel str = doIt (wordsToMaybes str) 26 | where 27 | doIt [] = 0 28 | doIt [_] = 0 29 | doIt (Just _ : _ : xs) = doIt xs 30 | doIt (Nothing : Just x : xs) = if elem (head x) "aeiou" 31 | then 1 + doIt xs 32 | else doIt xs 33 | 34 | -- 3. 35 | -- Return the number of letters that are vowels in a word. 36 | addOneIfVowel :: Integer -> Char -> Integer 37 | addOneIfVowel acc x = if elem x "aeiou" 38 | then acc + 1 39 | else acc 40 | 41 | countVowels :: String -> Integer 42 | countVowels xs = foldl addOneIfVowel 0 xs 43 | -------------------------------------------------------------------------------- /12/12.05-unfolds.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- Write a function `myIterate` using direct recursion. 3 | myIterate :: (a -> a) -> a -> [a] 4 | myIterate f x = x : myIterate f (f x) 5 | 6 | -- 2. 7 | -- Write a function `myUnfoldr` using direct recursion. 8 | myUnfoldr :: (b -> Maybe (a, b)) -> b -> [a] 9 | myUnfoldr f x = doIt (f x) 10 | where 11 | doIt Nothing = [] 12 | doIt (Just (x, y)) = x : myUnfoldr f y 13 | 14 | -- 3. 15 | -- Rewrite `myIterate` into `betterIterate` using `myUnfoldr`. 16 | betterIterate :: (a -> a) -> a -> [a] 17 | betterIterate f x = myUnfoldr (\b -> Just (b, f b)) x 18 | -------------------------------------------------------------------------------- /12/12.05-validate-the-word.hs: -------------------------------------------------------------------------------- 1 | -- Use the `Maybe` type to write a function that counts the number of 2 | -- vowels in a string and the number of consonants. If the number of vowels 3 | -- exceeds the number of consonants, the function returns `Nothing`. 4 | newtype Word' = Word' String 5 | deriving (Eq, Show) 6 | 7 | vowels :: String 8 | vowels = "aeiou" 9 | 10 | vowelConsonantCounter :: (Int, Int) -> Char -> (Int, Int) 11 | vowelConsonantCounter (v, c) x = if elem x "aeiou" 12 | then (v + 1, c) 13 | else (v, c + 1) 14 | 15 | getSums :: String -> (Int, Int) 16 | getSums = foldl vowelConsonantCounter (0, 0) 17 | 18 | mkWord :: String -> Maybe Word' 19 | mkWord xs 20 | | (fst $ getSums xs) <= (snd $ getSums xs) = Just (Word' xs) 21 | | otherwise = Nothing 22 | -------------------------------------------------------------------------------- /13/chapter-exercises/palindrome.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import System.Exit (exitSuccess) 3 | import Data.Char (isAlphaNum, toLower) 4 | 5 | normalizeString :: String -> String 6 | normalizeString = map toLower . filter isAlphaNum 7 | 8 | checkSentence :: String -> Bool 9 | checkSentence s = (normalizeString s) == (reverse $ normalizeString s) 10 | 11 | palindrome :: IO () 12 | palindrome = forever $ do 13 | line1 <- getLine 14 | if checkSentence line1 15 | then do putStrLn "It's a palindrome" 16 | return () 17 | else do putStrLn "Nah" 18 | putStrLn "Not that one." 19 | putStrLn "We're leaving, bye." 20 | putStrLn "" 21 | putStrLn "(The following Exception is not real.)" 22 | exitSuccess -------------------------------------------------------------------------------- /13/chapter-exercises/person.hs: -------------------------------------------------------------------------------- 1 | type Name = String 2 | type Age = Integer 3 | 4 | data Person = Person Name Age 5 | deriving (Eq, Show) 6 | 7 | data PersonInvalid = NameEmpty 8 | | AgeTooLow 9 | | PersonInvalidUnknown String 10 | deriving (Eq, Show) 11 | 12 | mkPerson :: Name 13 | -> Age 14 | -> Either PersonInvalid Person 15 | mkPerson name age 16 | | name /= "" && age > 0 = Right $ Person name age 17 | | name == "" = Left NameEmpty 18 | | not (age > 0) = Left AgeTooLow 19 | | otherwise = Left $ PersonInvalidUnknown $ 20 | "Name was: " ++ show name ++ 21 | " Age was: " ++ show age 22 | 23 | gimmePerson :: IO () 24 | gimmePerson = do 25 | putStrLn "What's your name?" 26 | name <- getLine 27 | putStrLn "What's your age?" 28 | age <- getLine 29 | print $ mkPerson name (read age) -------------------------------------------------------------------------------- /13/hangman/.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | 20 | data/dict.txt 21 | -------------------------------------------------------------------------------- /13/hangman/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Evan Turner (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /13/hangman/README.md: -------------------------------------------------------------------------------- 1 | ``` 2 | ██▀███ ▓█████ ▄▄▄ ▓█████▄ ███▄ ▄███▓▓█████ 3 | ▓██ ▒ ██▒▓█ ▀▒████▄ ▒██▀ ██▌▓██▒▀█▀ ██▒▓█ ▀ 4 | ▓██ ░▄█ ▒▒███ ▒██ ▀█▄ ░██ █▌▓██ ▓██░▒███ 5 | ▒██▀▀█▄ ▒▓█ ▄░██▄▄▄▄██ ░▓█▄ ▌▒██ ▒██ ▒▓█ ▄ 6 | ░██▓ ▒██▒░▒████▒▓█ ▓██▒░▒████▓ ▒██▒ ░██▒░▒████▒ 7 | ░ ▒▓ ░▒▓░░░ ▒░ ░▒▒ ▓▒█░ ▒▒▓ ▒ ░ ▒░ ░ ░░░ ▒░ ░ 8 | ░▒ ░ ▒░ ░ ░ ░ ▒ ▒▒ ░ ░ ▒ ▒ ░ ░ ░ ░ ░ ░ 9 | ░░ ░ ░ ░ ▒ ░ ░ ░ ░ ░ ░ 10 | ░ ░ ░ ░ ░ ░ ░ ░ ░ 11 | ░ 12 | ``` -------------------------------------------------------------------------------- /13/hangman/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /13/hangman/hangman.cabal: -------------------------------------------------------------------------------- 1 | name: hangman 2 | version: 0.1.0.0 3 | synopsis: Hangman For People That Are Currently Awake 4 | homepage: https://github.com/evturn/haskell-programming 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Evan Turner 8 | maintainer: evturn.com 9 | category: Game 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | extra-source-files: data/dict.txt 13 | 14 | executable hangman 15 | hs-source-dirs: src 16 | main-is: Main.hs 17 | default-language: Haskell2010 18 | build-depends: base >= 4.7 && < 5 19 | , random 20 | , split -------------------------------------------------------------------------------- /13/hello/.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | -------------------------------------------------------------------------------- /13/hello/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /13/hello/exe/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import DogsRule 4 | import Hello 5 | import System.IO 6 | 7 | main :: IO () 8 | main = do 9 | hSetBuffering stdout NoBuffering 10 | putStr "And your name is? -> " 11 | name <- getLine 12 | sayHello name 13 | dogs -------------------------------------------------------------------------------- /13/hello/hello.cabal: -------------------------------------------------------------------------------- 1 | name: hello 2 | version: 0.1.0.0 3 | synopsis: Simple project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/evturn/haskell-programming 6 | author: Evan Turner 7 | maintainer: ev@evturn.com 8 | copyright: 2017, Ev 9 | category: Web 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable hello 14 | hs-source-dirs: exe 15 | main-is: Main.hs 16 | default-language: Haskell2010 17 | build-depends: base >= 4.7 && < 5 18 | , hello 19 | 20 | library 21 | hs-source-dirs: src 22 | exposed-modules: DogsRule 23 | , Hello 24 | build-depends: base >= 4.7 && < 5 25 | default-language: Haskell2010 -------------------------------------------------------------------------------- /13/hello/src/DogsRule.hs: -------------------------------------------------------------------------------- 1 | module DogsRule 2 | ( dogs ) 3 | where 4 | 5 | dogs :: IO () 6 | dogs = do 7 | putStrLn "Please call me Scruffy." 8 | putStrLn "Dr. Scruffy DDS" -------------------------------------------------------------------------------- /13/hello/src/Hello.hs: -------------------------------------------------------------------------------- 1 | module Hello 2 | ( sayHello ) 3 | where 4 | 5 | sayHello :: String -> IO () 6 | sayHello name = putStrLn ("Sup " ++ name ++ "!") -------------------------------------------------------------------------------- /13/hello/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-5.14 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 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | -------------------------------------------------------------------------------- /13/notes.hs: -------------------------------------------------------------------------------- 1 | -- `do` notation 2 | 3 | -- main = do 4 | -- [1] 5 | 6 | -- x1 <- getLine 7 | -- [2] [3] [4] 8 | 9 | -- x2 <- getLine 10 | -- [5] 11 | 12 | -- return (x1 ++ x2) 13 | -- [6] [7] 14 | 15 | -- 1. `do` introduces the block of IO actions. 16 | 17 | -- 2. `x1` is a variable representing the value obtained from the IO action `getLine` 18 | 19 | -- 3. `<-` binds the variable on the left to the result of the IO action on the right. 20 | 21 | -- 4. `getLine` has the type `IO String` and takes user input of a string value. In this case, 22 | -- the string the user inputs will be the value bound to the `x1` name. 23 | 24 | -- 5. `x2` is a variable representing the value obtained from our second `getLine`. 25 | 26 | -- 6. `return` is the concludeing action of our `do` block. 27 | 28 | -- 7. This is the value `return` returns. The conjunction of the two strings we obtained. -------------------------------------------------------------------------------- /14/14.03-addition/LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/evturn/haskellbook/3d310d0ddd4221ffc5b9fd7ec6476b2a0731274a/14/14.03-addition/LICENSE -------------------------------------------------------------------------------- /14/14.03-addition/addition.cabal: -------------------------------------------------------------------------------- 1 | name: addition 2 | version: 0.1.0.0 3 | license-file: LICENSE 4 | author: Ev 5 | maintainer: bgates@microsoft.com 6 | category: Text 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | library 11 | exposed-modules: Addition 12 | ghc-options: -Wall -fwarn-tabs 13 | build-depends: base >=4.7 && <5 14 | , hspec 15 | , QuickCheck 16 | hs-source-dirs: . 17 | default-language: Haskell2010 -------------------------------------------------------------------------------- /14/14.05-morse/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Evan Turner (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Turner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /14/14.05-morse/README.md: -------------------------------------------------------------------------------- 1 | # morse 2 | -------------------------------------------------------------------------------- /14/14.05-morse/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /14/14.05-morse/morse.cabal: -------------------------------------------------------------------------------- 1 | name: morse 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Evan Turner 8 | maintainer: ev@evturn.com 9 | copyright: Copyright: (c) 2017 Evan Turner 10 | category: Text 11 | build-type: Simple 12 | extra-source-files: README.md 13 | cabal-version: >=1.10 14 | 15 | library 16 | exposed-modules: Morse 17 | ghc-options: -Wall -fwarn-tabs 18 | build-depends: base >= 4.7 && < 5 19 | , containers 20 | , QuickCheck 21 | hs-source-dirs: src 22 | default-language: Haskell2010 23 | 24 | executable morse 25 | main-is: Main.hs 26 | ghc-options: -Wall -fwarn-tabs 27 | hs-source-dirs: src 28 | build-depends: base >= 4.7 && < 5 29 | , containers 30 | , morse 31 | , QuickCheck 32 | default-language: Haskell2010 33 | 34 | test-suite tests 35 | ghc-options: -Wall -fno-warn-orphans 36 | type: exitcode-stdio-1.0 37 | hs-source-dirs: tests 38 | main-is: tests.hs 39 | build-depends: base 40 | , containers 41 | , morse 42 | , QuickCheck 43 | default-language: Haskell2010 44 | 45 | source-repository head 46 | type: git 47 | location: https://github.com/evturn/morse 48 | -------------------------------------------------------------------------------- /14/14.05-morse/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (forever, when) 4 | import Data.List (intercalate) 5 | import Data.Traversable (traverse) 6 | import Morse (morseToChar, stringToMorse) 7 | import System.Environment (getArgs) 8 | import System.Exit (exitFailure, exitSuccess) 9 | import System.IO (hGetLine, hIsEOF, stdin) 10 | 11 | convertToMorse :: IO () 12 | convertToMorse = forever $ do 13 | weAreDone <- hIsEOF stdin 14 | when weAreDone exitSuccess 15 | line <- hGetLine stdin 16 | convertLine line 17 | where 18 | convertLine line = do 19 | let morse = stringToMorse line 20 | case morse of 21 | (Just str) -> putStrLn (intercalate " " str) 22 | Nothing -> do 23 | putStrLn $ "ERROR: " ++ line 24 | exitFailure 25 | 26 | convertFromMorse :: IO () 27 | convertFromMorse = forever $ do 28 | weAreDone <- hIsEOF stdin 29 | when weAreDone exitSuccess 30 | line <- hGetLine stdin 31 | convertLine line 32 | where 33 | convertLine line = do 34 | let decoded :: Maybe String 35 | decoded = traverse morseToChar (words line) 36 | case decoded of 37 | (Just s) -> putStrLn s 38 | Nothing -> do 39 | putStrLn $ "ERROR: " ++ line 40 | exitFailure 41 | 42 | main :: IO () 43 | main = do 44 | mode <- getArgs 45 | case mode of 46 | [arg] -> case arg of 47 | "from" -> convertFromMorse 48 | "to" -> convertToMorse 49 | _ -> argError 50 | _ -> argError 51 | where 52 | argError = do 53 | putStrLn "Please specify the first argument 'from' or 'to' morse." 54 | exitFailure 55 | -------------------------------------------------------------------------------- /14/14.05-morse/tests/tests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Map as M 4 | import Morse 5 | import Test.QuickCheck 6 | 7 | allowedChars :: [Char] 8 | allowedChars = M.keys letterToMorse 9 | 10 | allowedMorse :: [Morse] 11 | allowedMorse = M.elems letterToMorse 12 | 13 | charGen :: Gen Char 14 | charGen = elements allowedChars 15 | 16 | morseGen :: Gen Morse 17 | morseGen = elements allowedMorse 18 | 19 | prop_thereAndBackAgain :: Property 20 | prop_thereAndBackAgain = forAll 21 | charGen (\c -> ((charToMorse c) >>= morseToChar) == Just c) 22 | 23 | main :: IO () 24 | main = quickCheck prop_thereAndBackAgain 25 | 26 | 27 | -------------------------------------------------------------------------------- /14/14.06-coarbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module CoArbitrary where 4 | 5 | import GHC.Generics 6 | import Test.QuickCheck 7 | 8 | data Bool' = True' 9 | | False' 10 | deriving Generic 11 | 12 | instance CoArbitrary Bool' 13 | 14 | trueGen :: Gen Int 15 | trueGen = coarbitrary True' arbitrary 16 | 17 | falseGen :: Gen Int 18 | falseGen = coarbitrary False' arbitrary 19 | -------------------------------------------------------------------------------- /14/14.07-failure.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | 3 | square x = x * x 4 | 5 | prop_squareIdentity :: Positive Double -> Bool 6 | prop_squareIdentity (Positive x) = (square . sqrt) x == x 7 | 8 | main :: IO () 9 | main = do 10 | putStrLn "Property should not hold" 11 | quickCheck prop_squareIdentity 12 | 13 | 14 | -------------------------------------------------------------------------------- /14/14.07-gen-random-generator.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 1. 5 | data Fool = Fulse 6 | | Frue 7 | deriving (Eq, Show) 8 | 9 | genEqualFoolDatatypes :: Gen Fool 10 | genEqualFoolDatatypes = elements [Fulse, Frue] 11 | 12 | ----------------------------------------------------------------------------- 13 | -- 2. 14 | genThirdFoolDatatypes :: Gen Fool 15 | genThirdFoolDatatypes = do 16 | frequency [ (2, return $ Fulse) 17 | , (1, return $ Frue) 18 | ] 19 | 20 | main :: IO () 21 | main = do 22 | putStrLn "1. Equal probability of Fool datatypes" 23 | sample genEqualFoolDatatypes 24 | putStrLn "1. 2/3 Fulse 1/13 Frue probability of Fool datatypes" 25 | sample genThirdFoolDatatypes 26 | 27 | -------------------------------------------------------------------------------- /14/14.07-idempotence.hs: -------------------------------------------------------------------------------- 1 | import Data.Char (toUpper) 2 | import Data.List (sort) 3 | import Test.QuickCheck 4 | 5 | twice f = f . f 6 | 7 | fourTimes = twice . twice 8 | 9 | ----------------------------------------------------------------------------- 10 | -- 1. 11 | prop_idempotence :: String -> Bool 12 | prop_idempotence xs = capsTwice xs && capsFourTimes xs 13 | where 14 | capsTwice x = (capitalizeWord x == twice capitalizeWord x) 15 | capsFourTimes x = (capitalizeWord x == fourTimes capitalizeWord x) 16 | 17 | capitalizeWord :: String -> String 18 | capitalizeWord = fmap toUpper 19 | 20 | ----------------------------------------------------------------------------- 21 | -- 2. 22 | prop_idempotence' :: String -> Bool 23 | prop_idempotence' xs = sortTwice xs && sortFourTimes xs 24 | where 25 | sortTwice x = (sort x == twice sort x) 26 | sortFourTimes x = (sort x == fourTimes sort x) 27 | 28 | main :: IO () 29 | main = do 30 | putStrLn "1. Idempotence check" 31 | quickCheck prop_idempotence 32 | putStrLn "2. Idempotence check" 33 | quickCheck prop_idempotence' 34 | 35 | -------------------------------------------------------------------------------- /14/14.07-word-number-test/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Evan Turner (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Turner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /14/14.07-word-number-test/README.md: -------------------------------------------------------------------------------- 1 | # word-number-test 2 | -------------------------------------------------------------------------------- /14/14.07-word-number-test/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /14/14.07-word-number-test/src/WordNumber.hs: -------------------------------------------------------------------------------- 1 | module WordNumber 2 | ( digitToWord 3 | , digits 4 | , wordNumber 5 | ) where 6 | 7 | import Data.List (intersperse) 8 | 9 | digitToWord :: Int -> String 10 | digitToWord n = [ "zero" 11 | , "one" 12 | , "two" 13 | , "three" 14 | , "four" 15 | , "five" 16 | , "six" 17 | , "seven" 18 | , "eight" 19 | , "nine" 20 | ] !! n 21 | 22 | digits :: Int -> [Int] 23 | digits n 24 | | n == 0 = [] 25 | | otherwise = digits (div n 10) ++ [mod n 10] 26 | 27 | wordNumber :: Int -> String 28 | wordNumber = joinWords . getWords 29 | where 30 | joinWords = concat . intersperse "-" 31 | getWords n = map digitToWord $ digits n 32 | 33 | -------------------------------------------------------------------------------- /14/14.07-word-number-test/test/WordNumberTest.hs: -------------------------------------------------------------------------------- 1 | module WordNumberTest where 2 | 3 | import Test.Hspec 4 | import WordNumber (digitToWord, digits, wordNumber) 5 | 6 | main :: IO () 7 | main = hspec $ do 8 | describe "digitToWord" $ do 9 | it "returns zero for 0" $ do 10 | digitToWord 0 `shouldBe` "zero" 11 | it "returns one for 1" $ do 12 | digitToWord 1 `shouldBe` "one" 13 | 14 | describe "digits" $ do 15 | it "returns [1] for 1" $ do 16 | digits 1 `shouldBe` [1] 17 | it "returns [1, 0, 0] for 100" $ do 18 | digits 100 `shouldBe` [1, 0, 0] 19 | 20 | describe "wordNumber" $ do 21 | it "one-zero-zero given 100" $ do 22 | wordNumber 100 `shouldBe` "one-zero-zero" 23 | it "nine-zero-zero-one for 9001" $ do 24 | wordNumber 9001 `shouldBe` "nine-zero-zero-one" 25 | -------------------------------------------------------------------------------- /14/14.07-word-number-test/word-number-test.cabal: -------------------------------------------------------------------------------- 1 | name: word-number-test 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/evturn/haskellbook 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Evan Turner 9 | maintainer: ev@evturn.com 10 | copyright: Copyright: (c) 2017 Evan Turner 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | exposed-modules: WordNumber 18 | , WordNumberTest 19 | ghc-options: -Wall -fwarn-tabs 20 | hs-source-dirs: src 21 | , test 22 | build-depends: base >= 4.7 && < 5 23 | , hspec 24 | default-language: Haskell2010 25 | -------------------------------------------------------------------------------- /15/15.10-optional-monoid.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | data Optional a = Nada 4 | | Only a 5 | deriving (Eq, Show) 6 | 7 | instance Monoid a => Monoid (Optional a) where 8 | mempty = Nada 9 | mappend (Only a) (Only b) = Only (mappend a b) 10 | mappend Nada (Only b) = Only b 11 | mappend (Only a) Nada = Only a 12 | mappend Nada Nada = Nada 13 | -------------------------------------------------------------------------------- /15/15.10-orphan-instance/Listy.hs: -------------------------------------------------------------------------------- 1 | module Listy where 2 | 3 | newtype Listy a = Listy [a] 4 | deriving (Eq, Show) 5 | 6 | -- instance Monoid (Listy a) where 7 | -- mempty = Listy [] 8 | -- mappend (Listy l) (Listy l') = Listy $ mappend l l' 9 | -------------------------------------------------------------------------------- /15/15.10-orphan-instance/ListyInstances.hs: -------------------------------------------------------------------------------- 1 | module ListyInstances where 2 | 3 | import Data.Monoid 4 | import Listy 5 | 6 | instance Monoid (Listy a) where 7 | mempty = Listy [] 8 | mappend (Listy l) (Listy l') = Listy $ mappend l l' 9 | -------------------------------------------------------------------------------- /15/15.11-madness.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | type Verb = String 4 | type Adjective = String 5 | type Adverb = String 6 | type Noun = String 7 | type Exclamation = String 8 | 9 | madlibbin' :: Exclamation -> Adverb -> Noun -> Adjective -> String 10 | madlibbin' e adv noun adj = 11 | e <> "! he said " <> 12 | adv <> " as he jumped into his car " <> 13 | noun <> " and drove off with his " <> 14 | adj <> " wife." 15 | 16 | madlibbinBetter' :: Exclamation -> Adverb -> Noun -> Adjective -> String 17 | madlibbinBetter' e adv noun adj = mconcat 18 | [ e 19 | , "! he said " 20 | , adv 21 | , " as he jumped into his car " 22 | , noun 23 | , " and drove off with his " 24 | , adj 25 | , " wife." 26 | ] 27 | -------------------------------------------------------------------------------- /15/15.12-maybe-another-monoid.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | import Test.QuickCheck 3 | 4 | data Optional a = Nada 5 | | Only a 6 | deriving (Eq, Show) 7 | 8 | instance Monoid a => Monoid (Optional a) where 9 | mempty = Nada 10 | mappend (Only a) (Only b) = Only (mappend a b) 11 | mappend Nada (Only b) = Only b 12 | mappend (Only a) Nada = Only a 13 | mappend Nada Nada = Nada 14 | 15 | monoidAssoc :: (Eq m, Monoid m) => m -> m -> m -> Bool 16 | monoidAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c) 17 | 18 | monoidLeftIdentity :: (Eq m, Monoid m) => m -> Bool 19 | monoidLeftIdentity a = (mempty <> a) == a 20 | 21 | monoidRightIdentity :: (Eq m, Monoid m) => m -> Bool 22 | monoidRightIdentity a = (a <> mempty) == a 23 | 24 | newtype First' a = First' 25 | { getFirst' :: Optional a } 26 | deriving (Eq, Show) 27 | 28 | instance Monoid a => Monoid (First' a) where 29 | mempty = First' Nada 30 | mappend (First' a) (First' b) = First' (mappend a b) 31 | 32 | instance Arbitrary a => Arbitrary (First' a) where 33 | arbitrary = do 34 | a <- arbitrary 35 | frequency [ (1, return $ First' $ Only a) 36 | , (1, return $ First' Nada) 37 | ] 38 | 39 | firstMappend :: Monoid a => First' a -> First' a -> First' a 40 | firstMappend = mappend 41 | 42 | type FirstMappend = First' String -> First' String -> First' String -> Bool 43 | type FstId = First' String -> Bool 44 | 45 | main :: IO () 46 | main = do 47 | quickCheck (monoidAssoc :: FirstMappend) 48 | quickCheck (monoidLeftIdentity :: FstId) 49 | quickCheck (monoidRightIdentity :: FstId) 50 | -------------------------------------------------------------------------------- /16/16.04-be-kind.hs: -------------------------------------------------------------------------------- 1 | -- 1. 2 | -- What's the kind of `a`? 3 | -- a -> a 4 | -- 5 | -- Answer: 6 | -- a :: * 7 | 8 | ----------------------------------------------------------------------------- 9 | -- 2. 10 | -- What are the kinds of `b` and `T`? 11 | -- a -> b a -> T (b a) 12 | -- 13 | -- Answer: 14 | -- b :: * -> * 15 | -- T :: * -> * 16 | 17 | ----------------------------------------------------------------------------- 18 | -- 3. 19 | -- What's the kind of `c`? 20 | -- c a b -> c b a 21 | -- 22 | -- Answer: 23 | -- c :: * -> * -> * 24 | -------------------------------------------------------------------------------- /16/16.07-heavy-lifting.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 1. 3 | a = fmap (+1) $ read "[1]" :: [Int] 4 | 5 | ----------------------------------------------------------------------------- 6 | -- 2. 7 | b = (fmap . fmap) (++ "lol") (Just ["Hi,", "Hello"]) 8 | 9 | ----------------------------------------------------------------------------- 10 | -- 3. 11 | c = fmap (*2) $ (\x -> x - 2) 12 | 13 | ----------------------------------------------------------------------------- 14 | -- 4. 15 | d = fmap ((return '1' ++) . show) (\x -> [x, 1..3]) 16 | 17 | ----------------------------------------------------------------------------- 18 | -- 5. 19 | e :: IO Integer 20 | e = let ioi = readIO "1" :: IO Integer 21 | changed = fmap (fmap read (fmap ("123"++) show)) ioi 22 | in fmap (*3) changed 23 | -------------------------------------------------------------------------------- /16/16.07-replace-experiment.hs: -------------------------------------------------------------------------------- 1 | module ReplaceExperiment where 2 | 3 | replaceWithP :: b -> Char 4 | replaceWithP = const 'p' 5 | 6 | lms :: [Maybe [Char]] 7 | lms = [ Just "Ave" 8 | , Nothing 9 | , Just "woohoo" 10 | ] 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) => f (f1 a) -> f (f1 Char) 22 | twiceLifted = (fmap . fmap) replaceWithP 23 | 24 | twiceLifted' :: [Maybe [Char]] -> [Maybe Char] 25 | twiceLifted' = twiceLifted 26 | 27 | thriceLifted :: ( Functor f2 28 | , Functor f1 29 | , Functor f 30 | ) => f (f1 (f2 a)) -> f (f1 (f2 Char)) 31 | thriceLifted = (fmap . fmap . fmap) replaceWithP 32 | 33 | thriceLifted' :: [Maybe [Char]] -> [Maybe [Char]] 34 | thriceLifted' = thriceLifted 35 | 36 | main :: IO () 37 | main = do 38 | putStr "replaceWithP' lms: " 39 | print (replaceWithP' lms) 40 | 41 | putStr "liftedReplace lms: " 42 | print (liftedReplace lms) 43 | 44 | putStr "liftedReplace' lms: " 45 | print (liftedReplace' lms) 46 | 47 | putStr "twiceLifted lms: " 48 | print (twiceLifted lms) 49 | 50 | putStr "twiceLifted' lms: " 51 | print (twiceLifted' lms) 52 | 53 | putStr "thriceLifted lms: " 54 | print (thriceLifted lms) 55 | 56 | putStr "thriceLifted' lms: " 57 | print (thriceLifted' lms) 58 | -------------------------------------------------------------------------------- /16/16.11-possibly.hs: -------------------------------------------------------------------------------- 1 | incIfJust :: Num a => Maybe a -> Maybe a 2 | incIfJust (Just n) = Just $ n + 1 3 | incIfJust Nothing = Nothing 4 | 5 | showIfJust :: Show a => Maybe a -> Maybe String 6 | showIfJust (Just s) = Just $ show s 7 | showIfJust Nothing = Nothing 8 | 9 | incMaybe :: Num a => Maybe a -> Maybe a 10 | incMaybe = fmap (+1) 11 | 12 | showMaybe :: Show a => Maybe a -> Maybe String 13 | showMaybe = fmap show 14 | 15 | liftedInc :: (Functor f, Num a) => f a -> f a 16 | liftedInc = fmap (+1) 17 | 18 | liftedShow :: (Functor f, Show a) => f a -> f String 19 | liftedShow = fmap show 20 | 21 | ----------------------------------------------------------------------------- 22 | data Possibly a = LolNope 23 | | Yeppers a 24 | deriving (Eq, Show) 25 | 26 | instance Functor Possibly where 27 | fmap _ LolNope = LolNope 28 | fmap f (Yeppers x) = Yeppers (f x) 29 | 30 | runPossibly :: String 31 | runPossibly = liftedShow Yeppers [1..10] 32 | -------------------------------------------------------------------------------- /16/16.11-short-exercise.hs: -------------------------------------------------------------------------------- 1 | incIfRight :: Num a => Either e a -> Either e a 2 | incIfRight (Right n) = Right $ n + 1 3 | incIfRight (Left e) = Left e 4 | 5 | showIfRight :: Show a => Either e a -> Either e String 6 | showIfRight (Right s) = Right $ show s 7 | showIfRight (Left e) = Left e 8 | 9 | incEither :: Num a => Either e a -> Either e a 10 | incEither = fmap (+1) 11 | 12 | showEither :: Show a => Either e a -> Either e String 13 | showEither = fmap show 14 | 15 | liftedInc :: (Functor f, Num a) => f a -> f a 16 | liftedInc = fmap (+1) 17 | 18 | liftedShow :: (Functor f, Show a) => f a -> f String 19 | liftedShow = fmap show 20 | 21 | ----------------------------------------------------------------------------- 22 | -- 1. 23 | data Sum a b = First a 24 | | Second b 25 | deriving (Eq, Show) 26 | 27 | instance Functor (Sum a) where 28 | fmap _ (First x) = First x 29 | fmap f (Second y) = Second (f y) 30 | 31 | applyIfSecond :: (a -> b) -> (Sum e) a -> (Sum e) b 32 | applyIfSecond f s = fmap f s 33 | 34 | ----------------------------------------------------------------------------- 35 | -- 2. 36 | -- Why is a `Functor` instance that applies the function only to `First`, 37 | -- `Either`'s `Left`, impossible? 38 | -- 39 | -- Answer: 40 | -- A type constructor with more than two type arguments must include all 41 | -- type arguments except the inner-most argument as part of the Functorial 42 | -- structure being preserved. 43 | -------------------------------------------------------------------------------- /16/16.17-chapter-exercises-2.hs: -------------------------------------------------------------------------------- 1 | -- Rearrange the arguments of the type constuctor of the datatype so 2 | -- the `Functor` instance works. 3 | -- 4 | ----------------------------------------------------------------------------- 5 | -- 1. 6 | data Sum b a = First a 7 | | Second b 8 | 9 | instance Functor (Sum e) where 10 | fmap f (First a) = First (f a) 11 | fmap f (Second b) = Second b 12 | 13 | ----------------------------------------------------------------------------- 14 | -- 2. 15 | data Company a c b = DeepBlue a c 16 | | Something b 17 | 18 | instance Functor (Company e e') where 19 | fmap f (Something b) = Something (f b) 20 | fmap _ (DeepBlue a c) = DeepBlue a c 21 | 22 | ----------------------------------------------------------------------------- 23 | -- 3. 24 | data More b a = L a b a 25 | | R b a b 26 | deriving (Eq, Show) 27 | 28 | instance Functor (More x) where 29 | fmap f (L a b a') = L (f a) b (f a') 30 | fmap f (R b a b') = R b (f a) b' 31 | -------------------------------------------------------------------------------- /17/17.05-constant-instance.hs: -------------------------------------------------------------------------------- 1 | -- Write an `Applicative` instance for `Constant` 2 | -- 3 | newtype Constant a b = Constant 4 | { getConstant :: a } 5 | deriving (Eq, Ord, Show) 6 | 7 | instance Functor (Constant a) where 8 | fmap _ (Constant x) = Constant x 9 | 10 | instance Monoid a => Applicative (Constant a) where 11 | pure _ = Constant mempty 12 | Constant x <*> Constant y = Constant (x `mappend` y) 13 | -------------------------------------------------------------------------------- /17/17.05-fixer-upper.hs: -------------------------------------------------------------------------------- 1 | -- Use `(<$>)` from `Functor`, `(<*>)` and `pure` from `Applicative` to fill 2 | -- in missing bits of the broken code to make it work. 3 | -- 4 | ----------------------------------------------------------------------------- 5 | -- 1. 6 | f1 :: Maybe String 7 | f1 = const <$> Just "Hello" <*> pure "World" 8 | 9 | -- 2. 10 | f2 :: Maybe (Int, Int, String, [Int]) 11 | f2 = (,,,) <$> Just 90 <*> Just 10 <*> Just "Tierness" <*> pure [1, 2, 3] 12 | -------------------------------------------------------------------------------- /17/17.05-identity-instance.hs: -------------------------------------------------------------------------------- 1 | -- Write an `Applicative` instance for `Identity` 2 | -- 3 | ----------------------------------------------------------------------------- 4 | newtype Identity a = Identity a 5 | deriving (Eq, Ord, Show) 6 | 7 | instance Functor Identity where 8 | fmap f (Identity x) = Identity (f x) 9 | 10 | instance Applicative Identity where 11 | pure = Identity 12 | Identity f <*> Identity y = Identity (f y) 13 | -------------------------------------------------------------------------------- /17/17.05-lookups.hs: -------------------------------------------------------------------------------- 1 | import Data.List (elemIndex) 2 | 3 | -- Use the following terms to make the expressions typecheck: 4 | -- 1. `pure` 5 | -- 2. `<$>` 6 | -- 3. `<*>` 7 | -- 8 | ----------------------------------------------------------------------------- 9 | -- 1. 10 | added :: Maybe Integer 11 | added = pure (+3) <*> (lookup 3 $ zip [1, 2, 3] [4, 5, 6]) 12 | 13 | ----------------------------------------------------------------------------- 14 | -- 2. 15 | y :: Maybe Integer 16 | y = lookup 2 $ zip [1, 2, 3] [4, 5, 6] 17 | 18 | z :: Maybe Integer 19 | z = lookup 2 $ zip [1, 2, 3] [4, 5, 6] 20 | 21 | tupled :: Maybe (Integer, Integer) 22 | tupled = (,) <$> y <*> z 23 | 24 | ----------------------------------------------------------------------------- 25 | -- 3. 26 | x :: Maybe Int 27 | x = elemIndex 3 [1, 2, 3, 4, 5] 28 | 29 | y' :: Maybe Int 30 | y' = elemIndex 4 [1, 2, 3, 4, 5] 31 | 32 | max' :: Int -> Int -> Int 33 | max' = max 34 | 35 | maxed :: Maybe Int 36 | maxed = max' <$> x <*> y' 37 | 38 | ----------------------------------------------------------------------------- 39 | -- 4. 40 | xs = [1, 2, 3] 41 | ys = [4, 5, 6] 42 | 43 | x' :: Maybe Integer 44 | x' = lookup 3 $ zip xs ys 45 | 46 | y'' :: Maybe Integer 47 | y'' = lookup 2 $ zip xs ys 48 | 49 | summed :: Maybe Integer 50 | summed = fmap sum $ (,) <$> x' <*> y'' 51 | -------------------------------------------------------------------------------- /17/17.07-bad-monoid.hs: -------------------------------------------------------------------------------- 1 | module BadMonoid where 2 | 3 | import Data.Monoid 4 | import Test.QuickCheck 5 | import Test.QuickCheck.Checkers 6 | import Test.QuickCheck.Classes 7 | 8 | data Bull = Fools 9 | | Twoo 10 | deriving (Eq, Show) 11 | 12 | instance Arbitrary Bull where 13 | arbitrary = frequency [ (1, return Fools) 14 | , (1, return Twoo) 15 | ] 16 | 17 | instance Monoid Bull where 18 | mempty = Fools 19 | mappend _ _ = Fools 20 | 21 | instance EqProp Bull where 22 | (=-=) = eq 23 | 24 | type SSI = (String, String, Int) 25 | 26 | trigger :: [SSI] 27 | trigger = undefined 28 | 29 | main :: IO () 30 | main = do 31 | quickBatch $ monoid Twoo 32 | quickBatch $ applicative trigger 33 | 34 | -------------------------------------------------------------------------------- /17/17.08-apl1.hs: -------------------------------------------------------------------------------- 1 | module Apl1 where 2 | 3 | import Control.Applicative 4 | import Data.Monoid 5 | import Test.QuickCheck 6 | import Test.QuickCheck.Checkers 7 | import Test.QuickCheck.Classes 8 | 9 | instance Monoid a => Monoid (ZipList a) where 10 | mempty = pure mempty 11 | mappend = liftA2 mappend 12 | 13 | instance Arbitrary a => Arbitrary (ZipList a) where 14 | arbitrary = ZipList <$> arbitrary 15 | 16 | instance Arbitrary a => Arbitrary (Sum a) where 17 | arbitrary = Sum <$> arbitrary 18 | 19 | instance Eq a => EqProp (ZipList a) where 20 | (=-=) = eq 21 | 22 | main :: IO () 23 | main = quickBatch $ monoid (ZipList [1 :: Sum Int]) 24 | -------------------------------------------------------------------------------- /17/17.08-list-applicative-exercise.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | import Test.QuickCheck.Checkers 3 | import Test.QuickCheck.Classes 4 | 5 | data List a = Nil 6 | | Cons a (List a) 7 | deriving (Eq, Show) 8 | 9 | instance Functor List where 10 | fmap _ Nil = Nil 11 | fmap f (Cons x xs) = Cons (f x) (fmap f xs) 12 | 13 | instance Applicative List where 14 | pure x = Cons x Nil 15 | _ <*> Nil = Nil 16 | Nil <*> _ = Nil 17 | Cons f fs <*> xs = append (f <$> xs) (fs <*> xs) 18 | 19 | instance Arbitrary a => Arbitrary (List a) where 20 | arbitrary = do 21 | x <- arbitrary 22 | return $ Cons x Nil 23 | 24 | instance Eq a => EqProp (List a) where 25 | (=-=) = eq 26 | 27 | listAp :: List (String, String, Int) 28 | listAp = undefined 29 | 30 | ----------------------------------------------------------------------------- 31 | 32 | main :: IO () 33 | main = do 34 | putStrLn "\n-- List" 35 | quickBatch $ functor listAp 36 | quickBatch $ applicative listAp 37 | 38 | append :: List a -> List a -> List a 39 | append Nil ys = ys 40 | append (Cons x xs) ys = Cons x $ xs `append` ys 41 | 42 | fold :: (a -> b -> b) -> b -> List a -> b 43 | fold _ b Nil = b 44 | fold f b (Cons h t) = f h (fold f b t) 45 | 46 | concat' :: List (List a) -> List a 47 | concat' = fold append Nil 48 | 49 | flatMap :: (a -> List b) -> List a -> List b 50 | flatMap f as = fold (\a b -> append (f a) b) Nil as 51 | -------------------------------------------------------------------------------- /17/17.08-validations-on-either.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck hiding (Failure, Success) 2 | import Test.QuickCheck.Checkers 3 | import Test.QuickCheck.Classes 4 | 5 | data Validation err a = Failure err 6 | | Success a 7 | deriving (Eq, Show) 8 | 9 | instance Functor (Validation e) where 10 | fmap _ (Failure e) = Failure e 11 | fmap f (Success x) = Success (f x) 12 | 13 | instance Monoid e => Applicative (Validation e) where 14 | pure = Success 15 | Success f <*> Success x = Success (f x) 16 | Success _ <*> Failure y = Failure y 17 | Failure x <*> Success _ = Failure x 18 | Failure x <*> Failure y = Failure $ x `mappend` y 19 | 20 | instance (Arbitrary e, Arbitrary a) => Arbitrary (Validation e a) where 21 | arbitrary = do 22 | x <- arbitrary 23 | y <- arbitrary 24 | elements [ Failure x 25 | , Success y 26 | ] 27 | 28 | instance (Eq e, Eq a) => EqProp (Validation e a) where 29 | (=-=) = eq 30 | 31 | validAp :: Validation String (String, String, Int) 32 | validAp = undefined 33 | 34 | main :: IO () 35 | main = do 36 | quickBatch $ applicative validAp 37 | -------------------------------------------------------------------------------- /17/17.08-ziplist-applicative-exercise.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | import Test.QuickCheck.Checkers 3 | import Test.QuickCheck.Classes 4 | 5 | data List a = Nil 6 | | Cons a (List a) 7 | deriving (Eq, Show) 8 | 9 | take' :: Int -> List a -> List a 10 | take' _ Nil = Nil 11 | take' 0 _ = Nil 12 | take' n (Cons x xs) = Cons x (take' (n - 1) xs) 13 | 14 | instance Functor List where 15 | fmap _ Nil = Nil 16 | fmap f (Cons x xs) = Cons (f x) (fmap f xs) 17 | 18 | instance Applicative List where 19 | pure x = Cons x Nil 20 | _ <*> Nil = Nil 21 | Nil <*> _ = Nil 22 | Cons f fs <*> xs = append (f <$> xs) (fs <*> xs) 23 | 24 | instance Arbitrary a => Arbitrary (List a) where 25 | arbitrary = do 26 | x <- arbitrary 27 | return $ Cons x Nil 28 | 29 | instance Eq a => EqProp (List a) where 30 | (=-=) = eq 31 | 32 | append :: List a -> List a -> List a 33 | append Nil ys = ys 34 | append (Cons x xs) ys = Cons x $ xs `append` ys 35 | 36 | newtype ZipList' a = ZipList' (List a) 37 | deriving (Eq, Show) 38 | 39 | instance Eq a => EqProp (ZipList' a) where 40 | xs =-= ys = xs' `eq` ys' 41 | where 42 | xs' = let (ZipList' l) = xs 43 | in take' 3000 l 44 | ys' = let (ZipList' l) = ys 45 | in take' 3000 l 46 | 47 | instance Functor ZipList' where 48 | fmap f (ZipList' xs) = ZipList' $ fmap f xs 49 | 50 | instance Applicative ZipList' where 51 | pure x = ZipList' $ pure x 52 | ZipList' _ <*> ZipList' Nil = ZipList' Nil 53 | ZipList' Nil <*> ZipList' _ = ZipList' Nil 54 | ZipList' fs <*> ZipList' xs = ZipList' $ fs <*> xs 55 | 56 | instance Arbitrary a => Arbitrary (ZipList' a) where 57 | arbitrary = ZipList' <$> arbitrary 58 | 59 | main :: IO () 60 | main = do 61 | putStrLn "\n- ZipList'" 62 | quickBatch $ applicative $ ZipList' $ Cons ('a', 'b', 'c') Nil 63 | -------------------------------------------------------------------------------- /17/17.09-chapter-exercises-1.hs: -------------------------------------------------------------------------------- 1 | -- Given a type that has an instance of `Applicative`, specialize the types 2 | -- of the methods. 3 | -- 4 | ----------------------------------------------------------------------------- 5 | -- 1. 6 | -- [] 7 | pure :: a -> [a] 8 | (<*>) :: [(a -> b)] -> [a] -> [b] 9 | 10 | ----------------------------------------------------------------------------- 11 | -- 2. 12 | -- IO 13 | pure :: a -> IO a 14 | (<*>) :: IO (a -> b) -> IO a -> IO b 15 | 16 | ----------------------------------------------------------------------------- 17 | -- 3. 18 | -- (,) a 19 | pure :: Monoid a => b -> (a, b) 20 | (<*>) :: Monoid c => (c, (a -> b)) -> (c, a) -> (c, b) 21 | 22 | ----------------------------------------------------------------------------- 23 | -- 4. 24 | -- (->) e 25 | pure :: a -> (e -> a) 26 | (<*>) :: e -> (a -> b) -> (e -> a) -> (e -> b) 27 | 28 | -------------------------------------------------------------------------------- /17/17.09-chapter-exercises-3.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative (liftA3) 2 | 3 | stops :: String 4 | stops = "pbtdkg" 5 | 6 | vowels :: String 7 | vowels = "aeiou" 8 | 9 | combos :: [a] -> [b] -> [c] -> [(a, b, c)] 10 | combos = liftA3 (,,) 11 | -------------------------------------------------------------------------------- /18/18.02-bind.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad (join) 2 | 3 | -- Write `bind` in terms of `fmap` and `join`. 4 | bind :: Monad m => (a -> m b) -> m a -> m b 5 | bind f x = join $ f <$> x 6 | -------------------------------------------------------------------------------- /18/18.03-do-syntax-and-monads.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative ((*>)) 2 | 3 | sequencing :: IO () 4 | sequencing = do 5 | putStrLn "blah" 6 | putStrLn "another thing" 7 | 8 | sequencing' :: IO () 9 | sequencing' = 10 | putStrLn "blah" >> 11 | putStrLn "another thing" 12 | 13 | sequencing'' :: IO () 14 | sequencing'' = 15 | putStrLn "blah" *> 16 | putStrLn "another thing" 17 | 18 | 19 | binding :: IO () 20 | binding = do 21 | name <- getLine 22 | putStrLn name 23 | 24 | binding' :: IO () 25 | binding' = getLine >>= putStrLn 26 | 27 | bindingAndSequencing :: IO () 28 | bindingAndSequencing = do 29 | putStrLn "name pls:" 30 | name <- getLine 31 | putStrLn ("y helo thar: " ++ name) 32 | 33 | bindingAndSequencing' :: IO () 34 | bindingAndSequencing' = 35 | putStrLn "name pls:" >> 36 | getLine >>= \name -> 37 | putStrLn ("y helo thar: " ++ name) 38 | 39 | twoBinds :: IO () 40 | twoBinds = do 41 | putStrLn "name pls:" 42 | name <- getLine 43 | putStrLn "age pls:" 44 | age <- getLine 45 | putStrLn ("y helo thar: " ++ name ++ " who is: " ++ age ++ " years old.") 46 | 47 | twoBinds' :: IO () 48 | twoBinds' = 49 | putStrLn "name pls:" >> 50 | getLine >>= \name -> 51 | putStrLn "age pls:" >> 52 | getLine >>= \age -> 53 | putStrLn ("y helo thar: " ++ name ++ " who is " ++ age ++ " years old.") 54 | -------------------------------------------------------------------------------- /18/18.04-either-monad.hs: -------------------------------------------------------------------------------- 1 | data Sum a b = First a 2 | | Second b 3 | deriving (Eq, Show) 4 | 5 | instance Functor (Sum a) where 6 | fmap _ (First x) = First x 7 | fmap f (Second x) = Second (f x) 8 | 9 | instance Applicative (Sum a) where 10 | pure = Second 11 | First x <*> _ = First x 12 | _ <*> First x = First x 13 | Second f <*> Second x = Second (f x) 14 | 15 | instance Monad (Sum a) where 16 | return = pure 17 | First x >>= _ = First x 18 | Second x >>= f = f x 19 | -------------------------------------------------------------------------------- /18/18.05-bad-monad.hs: -------------------------------------------------------------------------------- 1 | module BadMonad where 2 | 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Checkers 5 | import Test.QuickCheck.Classes 6 | 7 | data CountMe a = CountMe Integer a 8 | deriving (Eq, Show) 9 | 10 | instance Functor CountMe where 11 | fmap f (CountMe i a) = CountMe i (f a) 12 | 13 | instance Applicative CountMe where 14 | pure = CountMe 0 15 | CountMe n f <*> CountMe n' a = CountMe (n + n') (f a) 16 | 17 | instance Monad CountMe where 18 | return = pure 19 | CountMe n a >>= f = let CountMe n' b = f a 20 | in CountMe (n + n') b 21 | 22 | instance Arbitrary a => Arbitrary (CountMe a) where 23 | arbitrary = CountMe <$> arbitrary <*> arbitrary 24 | 25 | instance Eq a => EqProp (CountMe a) where 26 | (=-=) = eq 27 | 28 | trigger :: CountMe (Int, String, Int) 29 | trigger = undefined 30 | 31 | main = do 32 | quickBatch $ functor trigger 33 | quickBatch $ applicative trigger 34 | quickBatch $ monad trigger 35 | 36 | -------------------------------------------------------------------------------- /18/18.07-chapter-exercises-2.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 1. 5 | j :: Monad m => m (m a) -> m a 6 | j = join 7 | 8 | ----------------------------------------------------------------------------- 9 | -- 2. 10 | l1 :: Monad m => (a -> b) -> m a -> m b 11 | l1 f x = f <$> x 12 | 13 | ----------------------------------------------------------------------------- 14 | -- 3. 15 | l2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c 16 | l2 f ma mb = ma >>= (\a -> f a <$> mb) 17 | 18 | ----------------------------------------------------------------------------- 19 | -- 4. 20 | a :: Monad m => m a -> m (a -> b) -> m b 21 | a ma mf = ma >>= (\a -> fmap (\f -> f a) mf) 22 | 23 | ----------------------------------------------------------------------------- 24 | -- 5. 25 | meh :: Monad m => [a] -> (a -> m b) -> m [b] 26 | meh [] _ = return [] 27 | meh (x:xs) f = f x >>= (\b -> ((:) b) <$> (meh xs f)) 28 | 29 | ----------------------------------------------------------------------------- 30 | -- 6. 31 | flipType :: Monad m => [m a] -> m [a] 32 | flipType = flip meh $ id 33 | -------------------------------------------------------------------------------- /19/19.02-templating-content-in-scotty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Web.Scotty 4 | import Data.Monoid (mconcat) 5 | 6 | main = scotty 3000 $ do 7 | get "/word" $ do 8 | beam <- param "word" 9 | html 10 | (mconcat 11 | [ "

Scotty, " 12 | , beam 13 | , " me up!

"]) 14 | -------------------------------------------------------------------------------- /19/19.06-shawty/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Evan Turner (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Turner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /19/19.06-shawty/README.md: -------------------------------------------------------------------------------- 1 | ``` 2 | __ __ 3 | _____/ /_ ____ __ __/ /___ __ 4 | / ___/ __ \/ __ `/ | /| / / __/ / / / 5 | (__ ) / / / /_/ /| |/ |/ / /_/ /_/ / 6 | /____/_/ /_/\__,_/ |__/|__/\__/\__, / 7 | /____/ 8 | ``` 9 | 10 | -------------------------------------------------------------------------------- /19/19.06-shawty/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /19/19.06-shawty/shawty.cabal: -------------------------------------------------------------------------------- 1 | name: shawty 2 | version: 0.1.0.0 3 | synopsis: First they took his daughter. Now they're coming for him. 4 | description: A former CIA agent reluctantly lets his daughter go on a trip 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Evan Turner 8 | maintainer: ev@evturn.com 9 | copyright: Copyright: (c) 2017 Evan Turner 10 | category: Web 11 | build-type: Simple 12 | extra-source-files: README.md 13 | cabal-version: >=1.10 14 | 15 | executable shawty 16 | hs-source-dirs: app 17 | main-is: Main.hs 18 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 19 | build-depends: base 20 | , bytestring 21 | , hedis 22 | , mtl 23 | , network-uri 24 | , random 25 | , scotty 26 | , semigroups 27 | , text 28 | , transformers 29 | default-language: Haskell2010 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/evturn/haskellbook 34 | -------------------------------------------------------------------------------- /20/20.04-demonstrating-foldable-instances.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 5 | -- Identity 6 | -- 7 | ----------------------------------------------------------------------------- 8 | data Identity a = Identity a 9 | deriving (Eq, Show) 10 | 11 | instance Foldable Identity where 12 | foldr f z (Identity x) = f x z 13 | 14 | foldl f z (Identity x) = f z x 15 | 16 | foldMap f (Identity x) = f x 17 | 18 | ----------------------------------------------------------------------------- 19 | -- 20 | -- Maybe 21 | -- 22 | ----------------------------------------------------------------------------- 23 | data Optional a = Nada 24 | | Yep a 25 | deriving (Eq, Show) 26 | 27 | instance Foldable Optional where 28 | foldr _ z Nada = z 29 | foldr f z (Yep x) = f x z 30 | 31 | foldl _ z Nada = z 32 | foldl f z (Yep x) = f z x 33 | 34 | foldMap _ Nada = mempty 35 | foldMap f (Yep a) = f a 36 | -------------------------------------------------------------------------------- /20/20.06-chapter-exercises.hs: -------------------------------------------------------------------------------- 1 | import Data.Foldable 2 | import Data.Monoid 3 | 4 | ----------------------------------------------------------------------------- 5 | -- 1. 6 | data Constant a b = Constant b 7 | deriving (Eq, Show) 8 | 9 | instance Foldable (Constant a) where 10 | foldMap f (Constant x) = f x 11 | 12 | ----------------------------------------------------------------------------- 13 | -- 2. 14 | data Two a b = Two a b 15 | deriving (Eq, Show) 16 | 17 | instance Foldable (Two a) where 18 | foldMap f (Two x y) = f y 19 | 20 | ----------------------------------------------------------------------------- 21 | -- 3. 22 | data Three a b c = Three a b c 23 | deriving (Eq, Show) 24 | 25 | instance Foldable (Three a b) where 26 | foldMap f (Three x y z) = f z 27 | 28 | ----------------------------------------------------------------------------- 29 | -- 4. 30 | data Three' a b = Three' a b b 31 | deriving (Eq, Show) 32 | 33 | instance Foldable (Three' a) where 34 | foldMap f (Three' x y y') = f y `mappend` f y' 35 | 36 | ----------------------------------------------------------------------------- 37 | -- 5. 38 | data Four' a b = Four' a b b b 39 | deriving (Eq, Show) 40 | 41 | instance Foldable (Four' a) where 42 | foldMap f (Four' x y y' y'') = f y `mappend` f y' `mappend` f y'' 43 | 44 | ----------------------------------------------------------------------------- 45 | -- Write a filter function for `Foldable` types using `FoldMap`. 46 | -- 47 | filterF :: ( Applicative f 48 | , Foldable t 49 | , Monoid (f a) 50 | ) => (a -> Bool) -> t a -> f a 51 | filterF f = foldMap go 52 | where 53 | go x = if f x 54 | then pure x 55 | else mempty 56 | -------------------------------------------------------------------------------- /21/21.07-axing-tedious-code.hs: -------------------------------------------------------------------------------- 1 | data Query = Query 2 | data SomeObj = SomeObj 3 | data IoOnlyObj = IoOnlyObj 4 | data Err = Err 5 | 6 | decodeFn :: String -> Either Err SomeObj 7 | decodeFn = undefined 8 | 9 | fetchFn :: Query -> IO [String] 10 | fetchFn = undefined 11 | 12 | makeIoOnlyObj :: [SomeObj] -> IO [(SomeObj, IoOnlyObj)] 13 | makeIoOnlyObj = undefined 14 | 15 | pipelineFn :: Query -> IO (Either Err [(SomeObj, IoOnlyObj)]) 16 | pipelineFn = (traverse makeIoOnlyObj . traverse decodeFn =<<) . fetchFn 17 | -------------------------------------------------------------------------------- /21/21.08-http-stuff.hs: -------------------------------------------------------------------------------- 1 | module HttpStuff where 2 | 3 | import Data.ByteString.Lazy hiding (map) 4 | import Network.Wreq 5 | 6 | urls :: [String] 7 | urls = [ "http://httpbin.org/ip" 8 | , "http://httpbin.org/bytes/5" 9 | ] 10 | 11 | mappingGet :: [IO (Response ByteString)] 12 | mappingGet = map get urls 13 | 14 | traversedUrls :: IO [Response ByteString] 15 | traversedUrls = traverse get urls 16 | -------------------------------------------------------------------------------- /21/21.09-either.hs: -------------------------------------------------------------------------------- 1 | data Either a b = Left a 2 | | Right b 3 | deriving (Eq, Ord, Show) 4 | 5 | instance Functor (Either a) where 6 | fmap _ (Left x) = Left x 7 | fmap f (Right y) = Right (f y) 8 | 9 | instance Applicative (Either e) where 10 | pure = Right 11 | Left e <*> _ = Left e 12 | Right f <*> r = fmap f r 13 | 14 | instance Foldable (Either a) where 15 | foldMap _ (Left _) = mempty 16 | foldMap f (Right y) = f y 17 | 18 | foldr _ z (Left _) = z 19 | foldr f z (Right y) = f y z 20 | 21 | instance Traversable (Either a) where 22 | traverse _ (Left x) = pure (Left x) 23 | traverse f (Right y) = Right <$> f y 24 | -------------------------------------------------------------------------------- /21/21.09-tuple.hs: -------------------------------------------------------------------------------- 1 | instance Functor ((,) a) where 2 | fmap f (x, y) = (x, f y) 3 | 4 | instance Monoid a => Applicative ((,) a) where 5 | pure x = (mempty, x) 6 | (u, f) <*> (v, x) = (u `mappend` v, f x) 7 | 8 | instance Foldable ((,) a) where 9 | foldMap f (_, y) = f y 10 | foldr f z (_, y) = f y z 11 | 12 | instance Traversable ((,) a) where 13 | traverse f (x, y) = (,) x <$> f y 14 | -------------------------------------------------------------------------------- /21/21.12-instances-for-tree.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | import Test.QuickCheck.Checkers 3 | import Test.QuickCheck.Classes 4 | 5 | data Tree a = Empty 6 | | Leaf a 7 | | Node (Tree a) a (Tree a) 8 | deriving (Eq, Show) 9 | 10 | instance Functor Tree where 11 | fmap _ Empty = Empty 12 | fmap f (Leaf x) = Leaf (f x) 13 | fmap f (Node l x r) = Node (fmap f l) (f x) (fmap f r) 14 | 15 | instance Foldable Tree where 16 | foldMap _ Empty = mempty 17 | foldMap f (Leaf x) = f x 18 | foldMap f (Node l x r) = foldMap f l `mappend` f x `mappend` foldMap f r 19 | 20 | instance Traversable Tree where 21 | traverse _ Empty = pure Empty 22 | traverse f (Leaf x) = Leaf <$> f x 23 | traverse f (Node l x r) = Node <$> traverse f l <*> f x <*> traverse f r 24 | 25 | instance Arbitrary a => Arbitrary (Tree a) where 26 | arbitrary = do 27 | x <- arbitrary 28 | y <- arbitrary 29 | z <- arbitrary 30 | return $ Node (Leaf x) y (Leaf z) 31 | 32 | instance Eq a => EqProp (Tree a) where 33 | (=-=) = eq 34 | 35 | tree :: Tree (Int, Int, [Int]) 36 | tree = undefined 37 | 38 | main :: IO () 39 | main = do 40 | quickBatch $ functor tree 41 | quickBatch $ traversable tree 42 | -------------------------------------------------------------------------------- /21/21.12-ski-free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module SkiFree where 4 | 5 | import Test.QuickCheck 6 | import Test.QuickCheck.Checkers 7 | import Test.QuickCheck.Classes 8 | 9 | data S n a = S (n a) a 10 | deriving (Eq, Show) 11 | 12 | instance Functor n => Functor (S n) where 13 | fmap f (S x y) = S (fmap f x) (f y) 14 | 15 | instance Foldable n => Foldable (S n) where 16 | foldMap f (S x y) = foldMap f x `mappend` f y 17 | 18 | instance Traversable n => Traversable (S n) where 19 | traverse f (S x y) = S <$> traverse f x <*> f y 20 | 21 | instance ( Arbitrary (n a) 22 | , CoArbitrary (n a) 23 | , Arbitrary a 24 | , CoArbitrary a 25 | ) => Arbitrary (S n a) where 26 | arbitrary = do 27 | x <- arbitrary 28 | y <- arbitrary 29 | return $ S (x y) y 30 | 31 | instance (Eq (n a), Eq a) => EqProp (S n a) where 32 | (=-=) = eq 33 | 34 | sTraversable :: S [] (Int, Int, [Int]) 35 | sTraversable = undefined 36 | 37 | main = do 38 | quickBatch $ functor sTraversable 39 | quickBatch $ traversable sTraversable 40 | -------------------------------------------------------------------------------- /22/22.02-a-new-beginning.hs: -------------------------------------------------------------------------------- 1 | module Web.Shipping.Utils ((<||>)) where 2 | 3 | import Control.Applicative (liftA2) 4 | 5 | boop = (*2) 6 | doop = (+10) 7 | 8 | bip :: Integer -> Integer 9 | bip = boop . doop 10 | 11 | bloop :: Integer -> Integer 12 | bloop = fmap boop doop 13 | 14 | bbop :: Integer -> Integer 15 | bbop = (+) <$> boop <*> doop 16 | 17 | duwop :: Integer -> Integer 18 | duwop = liftA2 (+) boop doop 19 | 20 | (<||>) :: (a -> Bool) -> (a -> Bool) -> a -> Bool 21 | (<||>) = liftA2 (||) 22 | 23 | boopDoop :: Integer -> Integer 24 | boopDoop = do 25 | a <- boop 26 | b <- doop 27 | return (a + b) 28 | -------------------------------------------------------------------------------- /22/22.02-warming-up.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | cap :: [Char] -> [Char] 4 | cap xs = map toUpper xs 5 | 6 | rev :: [Char] -> [Char] 7 | rev xs = reverse xs 8 | 9 | composed :: [Char] -> [Char] 10 | composed = rev . cap 11 | 12 | fmapped :: [Char] -> [Char] 13 | fmapped = fmap rev cap 14 | 15 | tupled :: [Char] -> ([Char], [Char]) 16 | tupled = do 17 | x <- cap 18 | y <- rev 19 | return (x, y) 20 | 21 | tupled' :: [Char] -> ([Char], [Char]) 22 | tupled' = rev >>= \x -> 23 | cap >>= \y -> 24 | return (x, y) 25 | -------------------------------------------------------------------------------- /22/22.05-ask.hs: -------------------------------------------------------------------------------- 1 | newtype Reader r a = Reader 2 | { runReader :: a -> r } 3 | 4 | ask :: Reader a a 5 | ask = Reader id 6 | -------------------------------------------------------------------------------- /22/22.06-demonstrating-the-function-applicative.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative (liftA2) 2 | 3 | newtype HumanName = HumanName String 4 | deriving (Eq, Show) 5 | 6 | newtype DogName = DogName String 7 | deriving (Eq, Show) 8 | 9 | newtype Address = Address String 10 | deriving (Eq, Show) 11 | 12 | data Person = Person 13 | { humanName :: HumanName 14 | , dogName :: DogName 15 | , address :: Address 16 | } deriving (Eq, Show) 17 | 18 | data Dog = Dog 19 | { dogsName :: DogName 20 | , dogsAddress :: Address 21 | } deriving (Eq, Show) 22 | 23 | pers :: Person 24 | pers = Person (HumanName "Big Bird") 25 | (DogName "Barkley") 26 | (Address "Sesame Street") 27 | 28 | chris :: Person 29 | chris = Person (HumanName "Chris Allen") 30 | (DogName "Papu") 31 | (Address "Austin") 32 | 33 | getDog :: Person -> Dog 34 | getDog p = Dog (dogName p) (address p) 35 | 36 | getDogR :: Person -> Dog 37 | getDogR = Dog <$> dogName <*> address 38 | 39 | (<$->>) :: (a -> b) -> (r -> a) -> (r -> b) 40 | (<$->>) = (<$>) 41 | 42 | (<*->>) :: (r -> a -> b) -> (r -> a) -> (r -> b) 43 | (<*->>) = (<*>) 44 | 45 | getDogR' :: Person -> Dog 46 | getDogR' = Dog <$->> dogName <*->> address 47 | 48 | getDogR'' :: Person -> Dog 49 | getDogR'' = liftA2 Dog dogName address 50 | -------------------------------------------------------------------------------- /22/22.06-reading-comprehension.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | newtype Reader r a = Reader 4 | { runReader :: r -> a} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- 1. 8 | myLiftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c 9 | myLiftA2 f x y = f <$> x <*> y 10 | 11 | ----------------------------------------------------------------------------- 12 | -- 2. 13 | asks :: (r -> a) -> Reader r a 14 | asks f = Reader f 15 | 16 | ----------------------------------------------------------------------------- 17 | -- 3. 18 | instance Functor (Reader r) where 19 | fmap f (Reader r) = Reader $ f . r 20 | 21 | instance Applicative (Reader r) where 22 | pure :: a -> Reader r a 23 | pure a = Reader $ \r -> a 24 | 25 | (<*>) :: Reader r (a -> b) -> Reader r a -> Reader r b 26 | (Reader rab) <*> (Reader ra) = Reader $ \r -> rab r (ra r) 27 | -------------------------------------------------------------------------------- /22/22.07-reader-monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | newtype Reader r a = Reader 4 | { runReader :: r -> a } 5 | 6 | instance Functor (Reader r) where 7 | fmap f (Reader r) = Reader $ f . r 8 | 9 | instance Applicative (Reader r) where 10 | pure :: a -> Reader r a 11 | pure a = Reader $ \r -> a 12 | 13 | (<*>) :: Reader r (a -> b) -> Reader r a -> Reader r b 14 | (Reader rab) <*> (Reader ra) = Reader $ \r -> rab r (ra r) 15 | 16 | ----------------------------------------------------------------------------- 17 | -- 1. 18 | instance Monad (Reader r) where 19 | return = pure 20 | 21 | (>>=) :: Reader r a -> (a -> Reader r b) -> Reader r b 22 | Reader ra >>= f = Reader $ \r -> runReader (f (ra r)) r 23 | 24 | ----------------------------------------------------------------------------- 25 | -- 2. 26 | newtype HumanName = HumanName String 27 | deriving (Eq, Show) 28 | 29 | newtype DogName = DogName String 30 | deriving (Eq, Show) 31 | 32 | newtype Address = Address String 33 | deriving (Eq, Show) 34 | 35 | data Person = Person 36 | { humanName :: HumanName 37 | , dogName :: DogName 38 | , address :: Address 39 | } deriving (Eq, Show) 40 | 41 | data Dog = Dog 42 | { dogsName :: DogName 43 | , dogsAddress :: Address 44 | } deriving (Eq, Show) 45 | 46 | pers :: Person 47 | pers = Person (HumanName "Big Bird") 48 | (DogName "Barkley") 49 | (Address "Sesame Street") 50 | 51 | chris :: Person 52 | chris = Person (HumanName "Chris Allen") 53 | (DogName "Papu") 54 | (Address "Austin") 55 | 56 | getDogRM :: Person -> Dog 57 | getDogRM = do 58 | name <- dogName 59 | addy <- address 60 | return $ Dog name addy 61 | 62 | getDogRM' :: Reader Person Dog 63 | getDogRM' = Reader $ getDogRM 64 | -------------------------------------------------------------------------------- /22/22.08-pretty-reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module PrettyReader where 4 | 5 | flip :: (a -> b -> c) -> (b -> a -> c) 6 | flip f a b = f b a 7 | 8 | const :: a -> b -> a 9 | const a b = a 10 | 11 | (.) :: (b -> c) -> (a -> b) -> (a -> c) 12 | f . g = \a -> f (g a) 13 | 14 | class Functor f where 15 | fmap :: (a -> b) -> f a -> f b 16 | 17 | class Functor f => Applicative f where 18 | pure :: a -> f a 19 | (<*>) :: f (a -> b) -> f a -> f b 20 | 21 | class Applicative f => Monad f where 22 | return :: a -> f a 23 | (>>=) :: f a -> (a -> f b) -> f b 24 | 25 | instance Functor ((->) r) where 26 | fmap = (.) 27 | 28 | instance Applicative ((->) r) where 29 | pure = const 30 | 31 | f <*> a = \r -> f r (a r) 32 | 33 | instance Monad ((->) r) where 34 | return = pure 35 | m >>= k = flip k <*> m 36 | 37 | withReaderT :: (r' -> r) -> ReaderT r m a -> ReaderT r' m a 38 | withReaderT f m = ReaderT $ runReaderT m . f 39 | -------------------------------------------------------------------------------- /22/22.11-reader-practice.hs: -------------------------------------------------------------------------------- 1 | module ReaderPractice where 2 | 3 | import Control.Applicative 4 | import Data.Maybe 5 | 6 | x :: [Integer] 7 | x = [1, 2, 3] 8 | 9 | y :: [Integer] 10 | y = [4, 5, 6] 11 | 12 | z :: [Integer] 13 | z = [7, 8, 9] 14 | 15 | xs :: Maybe Integer 16 | xs = lookup 3 $ zip x y 17 | 18 | ys :: Maybe Integer 19 | ys = lookup 6 $ zip y z 20 | 21 | zs :: Maybe Integer 22 | zs = lookup 4 $ zip x y 23 | 24 | z' :: Integer -> Maybe Integer 25 | z' n = lookup n $ zip x z 26 | 27 | x1 :: Maybe (Integer, Integer) 28 | x1 = (,) <$> xs <*> ys 29 | 30 | x2 :: Maybe (Integer, Integer) 31 | x2 = (,) <$> ys <*> zs 32 | 33 | x3 :: Integer -> (Maybe Integer, Maybe Integer) 34 | x3 = (,) <$> z' <*> z' 35 | 36 | summed :: Num c => (c, c) -> c 37 | summed = uncurry (+) 38 | 39 | bolt :: Integer -> Bool 40 | bolt = (&&) <$> (>3) <*> (<8) 41 | 42 | sequA :: Integral a => a -> [Bool] 43 | sequA m = sequenceA [(>3), (<8), even] m 44 | 45 | s' :: Maybe Integer 46 | s' = summed <$> ((,) <$> xs <*> ys) 47 | 48 | ----------------------------------------------------------------------------- 49 | -- 1. 50 | sequenceAll :: Integer -> Bool 51 | sequenceAll n = foldr (&&) True $ sequA n 52 | 53 | ----------------------------------------------------------------------------- 54 | -- 2. 55 | sequenceSum :: [Bool] 56 | sequenceSum = sequA $ fromMaybe 0 s' 57 | 58 | ----------------------------------------------------------------------------- 59 | -- 3. 60 | liftAll :: Bool 61 | liftAll = bolt $ fromMaybe 0 ys 62 | 63 | 64 | main :: IO () 65 | main = do 66 | print $ sequenceAll 6 67 | print sequenceSum 68 | print liftAll 69 | -------------------------------------------------------------------------------- /22/22.11-shawty-prime/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Evan Turner (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Turner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /22/22.11-shawty-prime/README.md: -------------------------------------------------------------------------------- 1 | ``` 2 | __ __ _ 3 | _____/ /_ ____ __ __/ /___ __ ____ _____(_)___ ___ ___ 4 | / ___/ __ \/ __ `/ | /| / / __/ / / /_____/ __ \/ ___/ / __ `__ \/ _ \ 5 | (__ ) / / / /_/ /| |/ |/ / /_/ /_/ /_____/ /_/ / / / / / / / / / __/ 6 | /____/_/ /_/\__,_/ |__/|__/\__/\__, / / .___/_/ /_/_/ /_/ /_/\___/ 7 | /____/ /_/ 8 | ``` 9 | 10 | -------------------------------------------------------------------------------- /22/22.11-shawty-prime/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /22/22.11-shawty-prime/shawty-prime.cabal: -------------------------------------------------------------------------------- 1 | name: shawty-prime 2 | version: 0.1.0.0 3 | synopsis: First they took his daughter. Now they're coming for him. 4 | description: A former CIA agent reluctantly lets his daughter go on a trip 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Evan Turner 8 | maintainer: ev@evturn.com 9 | copyright: Copyright: (c) 2017 Evan Turner 10 | category: Web 11 | build-type: Simple 12 | extra-source-files: README.md 13 | cabal-version: >=1.10 14 | 15 | executable shawty-prime 16 | hs-source-dirs: app 17 | main-is: Main.hs 18 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 19 | build-depends: base 20 | , bytestring 21 | , hedis 22 | , mtl 23 | , network-uri 24 | , random 25 | , scotty 26 | , semigroups 27 | , text 28 | , transformers 29 | default-language: Haskell2010 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/evturn/haskellbook 34 | -------------------------------------------------------------------------------- /23/23.05-random-example-2.hs: -------------------------------------------------------------------------------- 1 | module RandomExample2 where 2 | 3 | import Control.Applicative (liftA3) 4 | import Control.Monad (replicateM) 5 | import Control.Monad.Trans.State 6 | import System.Random 7 | 8 | data Die = DieOne 9 | | DieTwo 10 | | DieThree 11 | | DieFour 12 | | DieFive 13 | | DieSix 14 | deriving (Eq, Show) 15 | 16 | intToDie :: Int -> Die 17 | intToDie n = case n of 18 | 1 -> DieOne 19 | 2 -> DieTwo 20 | 3 -> DieThree 21 | 4 -> DieFour 22 | 5 -> DieFive 23 | 6 -> DieSix 24 | x -> error $ "intToDie got non 1-6 integer: " ++ show x 25 | 26 | rollDieThreeTimes :: (Die, Die, Die) 27 | rollDieThreeTimes = do 28 | let s = mkStdGen 0 29 | (d1, s1) = randomR (1, 6) s 30 | (d2, s2) = randomR (1, 6) s1 31 | (d3, _) = randomR (1, 6) s2 32 | (intToDie d1, intToDie d2, intToDie d3) 33 | 34 | rollDie :: State StdGen Die 35 | rollDie = state $ do 36 | (n, s) <- randomR (1, 6) 37 | return (intToDie n, s) 38 | 39 | rollToDie' :: State StdGen Die 40 | rollToDie' = intToDie <$> state (randomR (1, 6)) 41 | 42 | rollDieThreeTimes' :: State StdGen (Die, Die, Die) 43 | rollDieThreeTimes' = liftA3 (,,) rollDie rollDie rollDie 44 | 45 | infiniteDie :: State StdGen [Die] 46 | infiniteDie = repeat <$> rollDie 47 | 48 | nDie :: Int -> State StdGen [Die] 49 | nDie n = replicateM n rollDie 50 | 51 | rollsToGetTwenty :: StdGen -> Int 52 | rollsToGetTwenty g = go 0 0 g 53 | where 54 | go :: Int -> Int -> StdGen -> Int 55 | go sum count gen 56 | | sum >= 20 = count 57 | | otherwise = let (die, nextGen) = randomR (1, 6) gen 58 | in go (sum + die) (count + 1) nextGen 59 | 60 | 61 | -------------------------------------------------------------------------------- /23/23.05-random-example.hs: -------------------------------------------------------------------------------- 1 | module RandomExample where 2 | 3 | import System.Random 4 | 5 | data Die = DieOne 6 | | DieTwo 7 | | DieThree 8 | | DieFour 9 | | DieFive 10 | | DieSix 11 | deriving (Eq, Show) 12 | 13 | intToDie :: Int -> Die 14 | intToDie n = case n of 15 | 1 -> DieOne 16 | 2 -> DieTwo 17 | 3 -> DieThree 18 | 4 -> DieFour 19 | 5 -> DieFive 20 | 6 -> DieSix 21 | x -> error $ "intToDie got non 1-6 integer: " ++ show x 22 | 23 | rollDieThreeTimes :: (Die, Die, Die) 24 | rollDieThreeTimes = do 25 | let s = mkStdGen 0 26 | (d1, s1) = randomR (1, 6) s 27 | (d2, s2) = randomR (1, 6) s1 28 | (d3, _) = randomR (1, 6) s2 29 | (intToDie d1, intToDie d2, intToDie d3) 30 | -------------------------------------------------------------------------------- /23/23.05-roll-your-own.hs: -------------------------------------------------------------------------------- 1 | module RandomExample2 where 2 | 3 | import System.Random 4 | 5 | data Die = DieOne 6 | | DieTwo 7 | | DieThree 8 | | DieFour 9 | | DieFive 10 | | DieSix 11 | deriving (Eq, Show) 12 | 13 | intToDie :: Int -> Die 14 | intToDie n = case n of 15 | 1 -> DieOne 16 | 2 -> DieTwo 17 | 3 -> DieThree 18 | 4 -> DieFour 19 | 5 -> DieFive 20 | 6 -> DieSix 21 | x -> error $ "intToDie got non 1-6 integer: " ++ show x 22 | 23 | ----------------------------------------------------------------------------- 24 | -- 1. 25 | rollsToGetN :: Int -> StdGen -> Int 26 | rollsToGetN n g = go 0 0 g 27 | where 28 | go :: Int -> Int -> StdGen -> Int 29 | go sum count gen 30 | | sum >= n = count 31 | | otherwise = let (die, nextGen) = randomR (1, 6) gen 32 | in go (sum + die) (count + 1) nextGen 33 | 34 | ----------------------------------------------------------------------------- 35 | -- 2. 36 | rollsCountLogged :: Int -> StdGen -> (Int, [Die]) 37 | rollsCountLogged n g = go 0 0 g [] 38 | where 39 | go :: Int -> Int -> StdGen -> [Die] -> (Int, [Die]) 40 | go sum count gen xs 41 | | sum >= n = (count, xs) 42 | | otherwise = let (die, nextGen) = randomR (1, 6) gen 43 | in go (sum + die) (count + 1) nextGen (intToDie die : xs) 44 | -------------------------------------------------------------------------------- /23/23.06-write-state-for-yourself.hs: -------------------------------------------------------------------------------- 1 | newtype Moi s a = Moi 2 | { runMoi :: s -> (a, s) } 3 | 4 | instance Functor (Moi s) where 5 | fmap f (Moi g) = Moi $ \s -> 6 | let (x, s') = g s 7 | in (f x, s') 8 | 9 | instance Applicative (Moi s) where 10 | pure a = Moi $ \s -> (a, s) 11 | 12 | Moi f <*> Moi g = Moi $ \s -> 13 | let (h, s') = f s 14 | (x, s'') = g s' 15 | in (h x, s'') 16 | 17 | 18 | instance Monad (Moi s) where 19 | return = pure 20 | 21 | Moi f >>= g = Moi $ \s -> 22 | let (x, s') = f s 23 | (Moi h) = g x 24 | in h s' 25 | -------------------------------------------------------------------------------- /23/23.07-fizzbuzz-differently.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Control.Monad.Trans.State 3 | import qualified Data.DList as DL 4 | 5 | fizzBuzz :: Integer -> String 6 | fizzBuzz n | n `mod` 15 == 0 = "FizzBuzz" 7 | | n `mod` 5 == 0 = "Buzz" 8 | | n `mod` 3 == 0 = "Fizz" 9 | | otherwise = show n 10 | 11 | fizzbuzzList :: [Integer] -> DL.DList String 12 | fizzbuzzList list = execState (mapM_ addResult list) DL.empty 13 | 14 | addResult :: Integer -> State (DL.DList String) () 15 | addResult n = do 16 | xs <- get 17 | let result = fizzBuzz n 18 | put (DL.snoc xs result) 19 | 20 | fizzbuzzFromTo :: Integer -> Integer -> [String] 21 | fizzbuzzFromTo x y 22 | | x < y = fizzBuzz y : fizzbuzzFromTo x (y - 1) 23 | | x == y = [fizzBuzz x] 24 | 25 | main :: IO () 26 | main = do 27 | mapM_ putStrLn $ fizzbuzzList [1..100] 28 | mapM_ putStrLn $ fizzbuzzFromTo 1 100 29 | -------------------------------------------------------------------------------- /23/23.08-chapter-exercises.hs: -------------------------------------------------------------------------------- 1 | newtype State s a = State 2 | { runState :: s -> (a, s) } 3 | 4 | ----------------------------------------------------------------------------- 5 | -- 1. 6 | get :: State s s 7 | get = State $ \x -> (x, x) 8 | 9 | ----------------------------------------------------------------------------- 10 | -- 2. 11 | put :: s -> State s () 12 | put x = State $ \_ -> ((), x) 13 | 14 | ----------------------------------------------------------------------------- 15 | -- 3. 16 | exec :: State s a -> s -> s 17 | exec (State sa) s = snd $ runState (State $ \_ -> sa s) s 18 | 19 | ----------------------------------------------------------------------------- 20 | -- 4. 21 | eval :: State s a -> s -> a 22 | eval (State sa) = \x -> fst $ sa x 23 | 24 | ----------------------------------------------------------------------------- 25 | -- 5. 26 | modify :: (s -> s) -> State s () 27 | modify = \f -> State $ \x -> ((), f x) 28 | -------------------------------------------------------------------------------- /24/24.03-learn-parsers.hs: -------------------------------------------------------------------------------- 1 | module LearnParsers where 2 | 3 | import Control.Monad.Trans.State 4 | import Text.Trifecta 5 | 6 | stop :: Parser a 7 | stop = unexpected "stop" 8 | 9 | one :: Parser Char 10 | one = char '1' 11 | 12 | one' :: Parser b 13 | one' = one >> stop 14 | 15 | type Token = Char 16 | 17 | type Parser' a = String -> Maybe (a, String) 18 | newtype Parser'' a = P ([Token] -> [(a, [Token])]) 19 | type Parser''' a = String -> [(a, String)] 20 | 21 | oneTwo :: Parser Char 22 | oneTwo = char '1' >> char '2' 23 | 24 | oneTwo' :: Parser b 25 | oneTwo' = oneTwo >> stop 26 | 27 | testParse :: Parser Char -> IO () 28 | testParse p = print $ parseString p mempty "123" 29 | 30 | pNL :: String -> IO () 31 | pNL s = putStrLn ('\n' : s) 32 | 33 | main :: IO () 34 | main = do 35 | pNL "stop:" 36 | testParse stop 37 | pNL "one:" 38 | testParse one 39 | pNL "one':" 40 | testParse one' 41 | pNL "oneTwo:" 42 | testParse oneTwo 43 | pNL "oneTwo':" 44 | testParse oneTwo' 45 | -------------------------------------------------------------------------------- /24/24.03-parsing-practice.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Trans.State 2 | import Text.Parser.Combinators 3 | import Text.Trifecta 4 | 5 | one :: Parser Char 6 | one = char '1' 7 | 8 | oneTwo :: Parser Char 9 | oneTwo = char '1' >> char '2' 10 | 11 | two :: Parser Char 12 | two = char '2' 13 | 14 | testParse :: Parser Char -> IO () 15 | testParse p = print $ parseString p mempty "123" 16 | 17 | pNL :: String -> IO () 18 | pNL s = putStrLn ('\n' : s) 19 | 20 | ----------------------------------------------------------------------------- 21 | -- 1. 22 | testEOF :: Parser () -> IO () 23 | testEOF p = print $ parseString p mempty "123" 24 | 25 | three :: Parser Char 26 | three = char '3' 27 | 28 | ----------------------------------------------------------------------------- 29 | -- 2. 30 | testString :: Parser String -> IO () 31 | testString p = print $ parseString p mempty "123" 32 | 33 | strParser :: String -> Parser String 34 | strParser s = string s 35 | 36 | ----------------------------------------------------------------------------- 37 | -- 3. 38 | rStrParser :: String -> Parser String 39 | rStrParser [] = return [] 40 | rStrParser (x:xs) = do 41 | char x 42 | rStrParser xs 43 | return (x:xs) 44 | 45 | 46 | main :: IO () 47 | main = do 48 | pNL "one:" 49 | testEOF $ one >> eof 50 | pNL "oneTwo:" 51 | testEOF $ oneTwo >> eof 52 | pNL "1 >> 2 >> 3 >> eof:" 53 | testEOF $ one >> two >> three >> eof 54 | pNL "String parsers:" 55 | testString $ strParser "1" 56 | testString $ strParser "12" 57 | testString $ strParser "123" 58 | pNL "String parser using char:" 59 | testString $ rStrParser "1" 60 | testString $ rStrParser "12" 61 | testString $ rStrParser "123" 62 | -------------------------------------------------------------------------------- /24/24.04-parsing-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 :: String 10 | badFraction = "1/0" 11 | 12 | alsoBad :: String 13 | alsoBad = "10" 14 | 15 | shouldWork :: String 16 | shouldWork = "1/2" 17 | 18 | shouldAlsoWork :: String 19 | shouldAlsoWork = "2/1" 20 | 21 | parseFraction :: Parser Rational 22 | parseFraction = do 23 | numerator <- decimal 24 | char '/' 25 | denominator <- decimal 26 | return (numerator % denominator) 27 | 28 | virtuousFraction :: Parser Rational 29 | virtuousFraction = do 30 | numerator <- decimal 31 | char '/' 32 | denominator <- decimal 33 | case denominator of 34 | 0 -> fail "Denominato cannot be zero" 35 | _ -> return (numerator % denominator) 36 | 37 | testVirtuous :: IO () 38 | testVirtuous = do 39 | let virtuousFraction' = parseString virtuousFraction mempty 40 | print $ virtuousFraction' badFraction 41 | print $ virtuousFraction' alsoBad 42 | print $ virtuousFraction' shouldWork 43 | print $ virtuousFraction' shouldAlsoWork 44 | 45 | main :: IO () 46 | main = do 47 | let parseFraction' = parseString parseFraction mempty 48 | print $ parseFraction' shouldWork 49 | print $ parseFraction' shouldAlsoWork 50 | print $ parseFraction' alsoBad 51 | print $ parseFraction' badFraction 52 | -------------------------------------------------------------------------------- /24/24.04-unit-of-success.hs: -------------------------------------------------------------------------------- 1 | import Text.Trifecta 2 | 3 | parseInteger :: Parser Integer 4 | parseInteger = do 5 | x <- integer 6 | e <- eof 7 | return x 8 | 9 | parseSuccess :: Result Integer 10 | parseSuccess = parseString parseInteger mempty "123" 11 | 12 | parseFailure :: Result Integer 13 | parseFailure = parseString parseInteger mempty "123abc" 14 | 15 | main :: IO () 16 | main = do 17 | print parseSuccess 18 | print parseFailure 19 | -------------------------------------------------------------------------------- /24/24.06-alt-parsing.hs: -------------------------------------------------------------------------------- 1 | module AltParsing where 2 | 3 | import Control.Applicative 4 | import Text.Trifecta 5 | 6 | type NumberOrString = Either Integer String 7 | 8 | a :: String 9 | a = "blah" 10 | 11 | b :: String 12 | b = "123" 13 | 14 | c :: String 15 | c = "123blah789" 16 | 17 | parseNos :: Parser NumberOrString 18 | parseNos = (Left <$> integer) <|> (Right <$> some letter) 19 | 20 | main :: IO () 21 | main = do 22 | let p f i = parseString f mempty i 23 | print $ p (some letter) a 24 | print $ p integer b 25 | print $ p parseNos a 26 | print $ p parseNos b 27 | print $ p (many parseNos) c 28 | print $ p (some parseNos) c 29 | -------------------------------------------------------------------------------- /24/24.06-quasimodo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Quasimodo where 4 | 5 | import Control.Applicative 6 | import Text.RawString.QQ 7 | import Text.Trifecta 8 | 9 | type NumberOrString = Either Integer String 10 | 11 | parseNos :: Parser NumberOrString 12 | parseNos = skipMany (oneOf "\n") 13 | >> (Left <$> integer) 14 | <|> (Right <$> some letter) 15 | 16 | eitherOr :: String 17 | eitherOr = [r| 18 | 123 19 | abc 20 | 456 21 | def|] 22 | 23 | main :: IO () 24 | main = do 25 | let p f i = parseString f mempty i 26 | print $ p parseNos eitherOr 27 | -------------------------------------------------------------------------------- /24/24.06-try-try.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module TryTry where 4 | 5 | import Control.Applicative 6 | import Data.Ratio ((%)) 7 | import Text.Trifecta 8 | 9 | type DecimalOrFraction = Either Rational Integer 10 | 11 | parseFraction :: Parser Rational 12 | parseFraction = do 13 | numerator <- decimal 14 | char '/' 15 | denominator <- decimal 16 | return (numerator % denominator) 17 | 18 | parseNum :: Parser DecimalOrFraction 19 | parseNum = try (Left <$> parseFraction) 20 | <|> (Right <$> decimal) 21 | 22 | main :: IO () 23 | main = do 24 | let p f i = parseString f mempty i 25 | print $ p parseNum "1/2" 26 | print $ p parseNum "4321" 27 | print $ p parseNum "3/4" 28 | print $ p parseNum "3" 29 | -------------------------------------------------------------------------------- /24/24.09-backtracking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module BT where 4 | 5 | import Control.Applicative 6 | import Data.Attoparsec.ByteString (parseOnly) 7 | import qualified Data.Attoparsec.ByteString as A 8 | import Data.ByteString (ByteString) 9 | import Text.Parsec (Parsec, parseTest) 10 | import Text.Trifecta hiding (parseTest) 11 | 12 | trifP :: Show a => Parser a -> String -> IO () 13 | trifP p i = print $ parseString p mempty i 14 | 15 | parsecP :: Show a => Parsec String () a -> String -> IO () 16 | parsecP = parseTest 17 | 18 | attoP :: Show a => A.Parser a -> ByteString -> IO () 19 | attoP p i = print $ parseOnly p i 20 | 21 | nobackParse :: (Monad f, CharParsing f) => f Char 22 | nobackParse = (char '1' >> char '2') <|> char '3' 23 | 24 | tryParse :: (Monad f, CharParsing f) => f Char 25 | tryParse = try (char '1' >> char '2') <|> char '3' 26 | 27 | tryAnnot :: (Monad f, CharParsing f) => f Char 28 | tryAnnot = (try (char '1' >> char '2') "Tried 12") 29 | <|> (char '3' "Tried 3") 30 | 31 | main :: IO () 32 | main = do 33 | trifP nobackParse "12" 34 | trifP tryParse "3" 35 | 36 | parsecP nobackParse "12" 37 | parsecP tryParse "3" 38 | 39 | attoP nobackParse "12" 40 | attoP tryParse "3" 41 | 42 | -------------------------------------------------------------------------------- /24/24.11-chapter-exercises.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Text.Trifecta 3 | 4 | ----------------------------------------------------------------------------- 5 | -- 1. 6 | data NumberOrString = NOSS String 7 | | NOSI Integer 8 | deriving (Eq, Show) 9 | 10 | type Major = Integer 11 | type Minor = Integer 12 | type Patch = Integer 13 | type Release = [NumberOrString] 14 | type Metadata = [NumberOrString] 15 | 16 | data SemVer = SemVer Major Minor Patch Release Metadata 17 | deriving (Eq, Show) 18 | 19 | parseNOS :: Parser NumberOrString 20 | parseNOS = (NOSI <$> integer) <|> (NOSS <$> some letter) 21 | 22 | parseMeta :: Parser [NumberOrString] 23 | parseMeta = do 24 | skipDelimiter 25 | x <- parseNOS 26 | skipDelimiter 27 | y <- parseNOS 28 | return [x, y] 29 | 30 | skipDelimiter :: Parser () 31 | skipDelimiter = skipMany (char '.' <|> char '-') 32 | 33 | parseSemVer :: Parser SemVer 34 | parseSemVer = do 35 | major <- integer 36 | skipDelimiter 37 | minor <- integer 38 | skipDelimiter 39 | patch <- integer 40 | release <- parseMeta 41 | return $ SemVer major minor patch release [] 42 | 43 | main :: IO () 44 | main = do 45 | print $ parseString parseSemVer mempty "2.1.1-x.7" 46 | -------------------------------------------------------------------------------- /25/25.04-twinplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | import Control.Applicative 4 | 5 | newtype Compose f g a = Compose 6 | { getCompose :: f (g a) 7 | } deriving (Eq, Show) 8 | 9 | instance (Functor f, Functor g) => Functor (Compose f g) where 10 | fmap f (Compose x) = Compose $ (fmap . fmap) f x 11 | 12 | instance (Applicative f, Applicative g) => Applicative (Compose f g) where 13 | pure :: a -> Compose f g a 14 | pure x = Compose $ (pure . pure) x 15 | 16 | (<*>) :: Compose f g (a -> b) -> Compose f g a -> Compose f g b 17 | Compose f <*> Compose x = Compose (liftA2 (<*>) f x) 18 | -------------------------------------------------------------------------------- /25/25.06-compose-instances.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | 3 | newtype Compose f g a = Compose 4 | { getCompose :: f (g a) 5 | } deriving (Eq, Show) 6 | 7 | instance (Functor f, Functor g) => Functor (Compose f g) where 8 | fmap f (Compose x) = Compose $ (fmap . fmap) f x 9 | 10 | instance (Applicative f, Applicative g) => Applicative (Compose f g) where 11 | pure x = Compose $ (pure . pure) x 12 | Compose f <*> Compose x = Compose (liftA2 (<*>) f x) 13 | 14 | ----------------------------------------------------------------------------- 15 | -- 1. 16 | instance (Foldable f, Foldable g) => Foldable (Compose f g) where 17 | foldMap f (Compose x) = (foldMap . foldMap) f x 18 | 19 | ----------------------------------------------------------------------------- 20 | -- 2. 21 | instance (Traversable f, Traversable g) => Traversable (Compose f g) where 22 | traverse f (Compose x) = Compose <$> (traverse . traverse) f x 23 | -------------------------------------------------------------------------------- /25/25.08-identity-t.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | 3 | newtype IdentityT f a = IdentityT 4 | { runIdentityT :: f a 5 | } deriving (Eq, Show) 6 | 7 | instance Functor m => Functor (IdentityT m) where 8 | fmap f (IdentityT fa) = IdentityT (fmap f fa) 9 | 10 | instance Applicative m => Applicative (IdentityT m) where 11 | pure x = IdentityT (pure x) 12 | IdentityT fab <*> IdentityT fa = IdentityT (fab <*> fa) 13 | 14 | instance Monad m => Monad (IdentityT m) where 15 | return = pure 16 | 17 | (>>=) :: IdentityT m a -> (a -> IdentityT m b) -> IdentityT m b 18 | IdentityT ma >>= f = IdentityT $ ma >>= runIdentityT . f 19 | -------------------------------------------------------------------------------- /26/26.02-maybe-t.hs: -------------------------------------------------------------------------------- 1 | newtype MaybeT m a = MaybeT 2 | { runMaybeT :: m (Maybe a) } 3 | 4 | instance Functor m => Functor (MaybeT m) where 5 | fmap f (MaybeT x) = MaybeT $ (fmap . fmap) f x 6 | 7 | instance Applicative m => Applicative (MaybeT m) where 8 | pure x = MaybeT (pure (pure x)) 9 | MaybeT f <*> MaybeT x = MaybeT $ (<*>) <$> f <*> x 10 | 11 | instance Monad m => Monad (MaybeT m) where 12 | return = pure 13 | MaybeT m >>= f = MaybeT $ do 14 | v <- m 15 | case v of 16 | Nothing -> return Nothing 17 | Just x -> runMaybeT (f x) 18 | -------------------------------------------------------------------------------- /26/26.03-either-t.hs: -------------------------------------------------------------------------------- 1 | newtype EitherT e m a = EitherT 2 | { runEitherT :: m (Either e a) } 3 | 4 | ----------------------------------------------------------------------------- 5 | -- 1. 6 | instance Functor m => Functor (EitherT e m) where 7 | fmap f (EitherT x) = EitherT $ (fmap . fmap) f x 8 | 9 | ----------------------------------------------------------------------------- 10 | -- 2. 11 | instance Applicative m => Applicative (EitherT e m) where 12 | pure x = EitherT (pure (pure x)) 13 | EitherT f <*> EitherT x = EitherT $ (<*>) <$> f <*> x 14 | 15 | ----------------------------------------------------------------------------- 16 | -- 3. 17 | instance Monad m => Monad (EitherT e m) where 18 | return = pure 19 | EitherT m >>= f = EitherT $ do 20 | x <- m 21 | case x of 22 | Left y -> return (Left y) 23 | Right z -> runEitherT $ f z 24 | 25 | ----------------------------------------------------------------------------- 26 | -- 4. 27 | swapEitherT :: Functor m => EitherT e m a -> EitherT a m e 28 | swapEitherT (EitherT x) = EitherT $ fmap go x 29 | where 30 | go (Left e) = Right e 31 | go (Right a) = Left a 32 | 33 | ----------------------------------------------------------------------------- 34 | -- 5. 35 | eitherT :: Monad m => (a -> m c) -> (b -> m c) -> EitherT a m b -> m c 36 | eitherT f g (EitherT m) = do 37 | x <- m 38 | case x of 39 | Left a -> f a 40 | Right b -> g b 41 | -------------------------------------------------------------------------------- /26/26.04-reader-t.hs: -------------------------------------------------------------------------------- 1 | newtype ReaderT r m a = ReaderT 2 | { runReaderT :: r -> m a } 3 | 4 | instance Functor m => Functor (ReaderT r m) where 5 | fmap f (ReaderT x) = ReaderT $ (fmap . fmap) f x 6 | 7 | instance Applicative m => Applicative (ReaderT r m) where 8 | pure x = ReaderT $ (pure (pure x)) 9 | ReaderT f <*> ReaderT x = ReaderT $ (<*>) <$> f <*> x 10 | 11 | instance Monad m => Monad (ReaderT r m) where 12 | return = pure 13 | ReaderT m >>= f = ReaderT $ \r -> do 14 | x <- m r 15 | runReaderT (f x) r 16 | -------------------------------------------------------------------------------- /26/26.05-state-t.hs: -------------------------------------------------------------------------------- 1 | newtype StateT s m a = StateT 2 | { runStateT :: s -> m (a, s) } 3 | 4 | ----------------------------------------------------------------------------- 5 | -- 1. 6 | instance Functor m => Functor (StateT s m) where 7 | fmap f (StateT m) = StateT $ \s -> fmap (\(x, s') -> (f x, s')) (m s) 8 | 9 | ----------------------------------------------------------------------------- 10 | -- 2. 11 | instance Monad m => Applicative (StateT s m) where 12 | pure x = StateT $ \s -> pure (x, s) 13 | StateT mf <*> StateT mx = StateT $ \s -> do 14 | (f, s') <- mf s 15 | (x, s'') <- mx s' 16 | return (f x, s'') 17 | 18 | ----------------------------------------------------------------------------- 19 | -- 3. 20 | instance Monad m => Monad (StateT s m) where 21 | return = pure 22 | StateT m >>= f = StateT $ \s -> do 23 | (x, s') <- m s 24 | runStateT (f x) s' 25 | 26 | -------------------------------------------------------------------------------- /26/26.08-outer-inner.hs: -------------------------------------------------------------------------------- 1 | module OuterInner where 2 | 3 | import Control.Monad.Trans.Except 4 | import Control.Monad.Trans.Maybe 5 | import Control.Monad.Trans.Reader 6 | 7 | embedded :: MaybeT (ExceptT String (ReaderT () IO)) Int 8 | embedded = return 1 9 | 10 | maybeUnwrap :: ExceptT String (ReaderT () IO) (Maybe Int) 11 | maybeUnwrap = runMaybeT embedded 12 | 13 | eitherUnwrap :: ReaderT () IO (Either String (Maybe Int)) 14 | eitherUnwrap = runExceptT maybeUnwrap 15 | 16 | readerUnwrap :: () -> IO (Either String (Maybe Int)) 17 | readerUnwrap = runReaderT eitherUnwrap 18 | -------------------------------------------------------------------------------- /26/26.08-wrap-it-up.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Trans.Except 2 | import Control.Monad.Trans.Maybe 3 | import Control.Monad.Trans.Reader 4 | 5 | embedded :: MaybeT (ExceptT String (ReaderT () IO)) Int 6 | embedded = return 1 7 | 8 | maybeUnwrap :: ExceptT String (ReaderT () IO) (Maybe Int) 9 | maybeUnwrap = runMaybeT embedded 10 | 11 | eitherUnwrap :: ReaderT () IO (Either String (Maybe Int)) 12 | eitherUnwrap = runExceptT maybeUnwrap 13 | 14 | readerUnwrap :: () -> IO (Either String (Maybe Int)) 15 | readerUnwrap = runReaderT eitherUnwrap 16 | 17 | embedded' :: MaybeT (ExceptT String (ReaderT () IO)) Int 18 | embedded' = MaybeT $ ExceptT $ ReaderT $ return . const (Right (Just 1)) 19 | -------------------------------------------------------------------------------- /26/26.09-lift-more.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Trans.Class 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 1. 5 | newtype EitherT e m a = EitherT 6 | { runEitherT :: m (Either e a) } 7 | 8 | instance MonadTrans (EitherT e) where 9 | lift = EitherT . fmap Right 10 | 11 | ----------------------------------------------------------------------------- 12 | -- 2. 13 | newtype StateT s m a = StateT 14 | { runStateT :: s -> m (a, s) } 15 | 16 | instance MonadTrans (StateT s) where 17 | lift m = StateT $ \s -> do 18 | a <- m 19 | return (a, s) 20 | -------------------------------------------------------------------------------- /26/26.09-scotty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Scotty where 4 | 5 | import Control.Monad.Trans.Class 6 | import Control.Monad.Trans.Except 7 | import Control.Monad.Trans.Reader 8 | import Control.Monad.Trans.State.Lazy hiding (get) 9 | import Data.Monoid (mconcat) 10 | import Web.Scotty 11 | import Web.Scotty.Internal.Types (ActionT (..)) 12 | 13 | main = scotty 3000 $ do 14 | get "/:word" $ do 15 | beam <- param "word" 16 | (ActionT 17 | . (ExceptT . fmap Right) 18 | . ReaderT . const 19 | . \m -> StateT (\s -> do 20 | a <- m 21 | return (a, s))) (putStrLn "hello") 22 | html $ mconcat [ "

Scotty, " 23 | , beam 24 | , " me up!

" 25 | ] 26 | -------------------------------------------------------------------------------- /26/26.11-except-t.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 $ rescue 14 | (Right <$> param k) 15 | (const (return (Left $ "The key: " ++ show k ++ " was missing!"))) 16 | 17 | type Reco = (Integer, Integer, Integer, Integer) 18 | 19 | tshow :: Reco -> Text 20 | tshow = TL.pack . show 21 | 22 | main :: IO () 23 | main = scotty 3000 $ do 24 | get "/" $ do 25 | reco <- runExceptT $ do 26 | a <- param' "1" 27 | liftIO $ print a 28 | b <- param' "2" 29 | c <- param' "3" 30 | d <- param' "4" 31 | (lift . lift) $ print b 32 | return ((a, b, c, d) :: Reco) 33 | case reco of 34 | Left e -> text (TL.pack e) 35 | Right r -> html $ mconcat [ "

Success! Reco was: " 36 | , tshow r 37 | , "

" 38 | ] 39 | -------------------------------------------------------------------------------- /26/26.14-fix-the-code.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Control.Monad.Trans.Maybe 3 | 4 | isValid :: String -> Bool 5 | isValid v = '!' `elem` v 6 | 7 | maybeExcite :: MaybeT IO String 8 | maybeExcite = MaybeT $ do 9 | v <- getLine 10 | case isValid v of 11 | True -> return $ Just v 12 | False -> return $ Nothing 13 | 14 | doExcite :: IO () 15 | doExcite = do 16 | putStrLn "say something excite!" 17 | excite <- runMaybeT maybeExcite 18 | case excite of 19 | Nothing -> putStrLn "MOAR EXCITE" 20 | Just e -> putStrLn ("Good, was very excite: " ++ e) 21 | -------------------------------------------------------------------------------- /26/26.14-hit-counter.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.Reader 8 | import Data.IORef 9 | import qualified Data.Map as M 10 | import Data.Maybe (fromMaybe) 11 | import Data.Text.Lazy (Text) 12 | import qualified Data.Text.Lazy as TL 13 | import System.Environment (getArgs) 14 | import Web.Scotty.Trans 15 | 16 | data Config = Config 17 | { counts :: IORef (M.Map Text Integer) 18 | , prefix :: Text 19 | } 20 | 21 | type Scotty = ScottyT Text (ReaderT Config IO) 22 | type Handler = ActionT Text (ReaderT Config IO) 23 | 24 | bumpBoomp :: Text -> M.Map Text Integer -> (M.Map Text Integer, Integer) 25 | bumpBoomp k m = (M.insert k incInt m, incInt) 26 | where 27 | incInt = fromMaybe 0 (M.lookup k m) + 1 28 | 29 | app :: Scotty () 30 | app = get "/:key" $ do 31 | unprefixed <- param "key" 32 | config <- lift $ ReaderT return 33 | let key' = mappend (prefix config) unprefixed 34 | n <- liftIO $ do 35 | m <- readIORef (counts config) 36 | let (m', n) = bumpBoomp key' m 37 | writeIORef (counts config) m' 38 | return n 39 | html $ mconcat [ "

Success! Count was: " 40 | , TL.pack $ show n 41 | , "

" 42 | ] 43 | 44 | main :: IO () 45 | main = do 46 | [prefixArg] <- getArgs 47 | counter <- newIORef M.empty 48 | let config = Config counter (TL.pack prefixArg) 49 | runR r = runReaderT r config 50 | scottyT 3000 runR app 51 | -------------------------------------------------------------------------------- /26/26.14-write-the-code.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Trans.Reader 2 | import Control.Monad.Trans.State 3 | import Data.Functor.Identity 4 | 5 | ----------------------------------------------------------------------------- 6 | -- 1. 7 | rDec :: Num a => Reader a a 8 | rDec = ReaderT $ return . \x -> x - 1 9 | 10 | ----------------------------------------------------------------------------- 11 | -- 2. 12 | rDec' :: Num a => Reader a a 13 | rDec' = ReaderT $ return . ((+) (-1)) 14 | 15 | ----------------------------------------------------------------------------- 16 | -- 3 & 4. 17 | rShow :: Show a => ReaderT a Identity String 18 | rShow = ReaderT $ return . show 19 | 20 | ----------------------------------------------------------------------------- 21 | -- 5. 22 | rPrintAndInc :: (Num a, Show a) => ReaderT a IO a 23 | rPrintAndInc = ReaderT $ \r -> do 24 | putStrLn ("Hi: " ++ show r) 25 | return $ r + 1 26 | 27 | ----------------------------------------------------------------------------- 28 | -- 6. 29 | sPrintIncAccum :: (Num a, Show a) => StateT a IO String 30 | sPrintIncAccum = StateT $ \s -> do 31 | putStrLn ("Hi: " ++ show s) 32 | return (show s, s + 1) 33 | -------------------------------------------------------------------------------- /27/27.09-debug.trace.hs: -------------------------------------------------------------------------------- 1 | import Debug.Trace (trace) 2 | 3 | inc :: Integer -> Integer 4 | inc = (+1) 5 | 6 | twice :: Integer -> Integer 7 | twice = inc . inc 8 | 9 | howManyTimes :: Integer 10 | howManyTimes = inc (trace "I got eval'd" (1 + 1)) 11 | + twice 12 | (trace "I got eval'd" (1 + 1)) 13 | 14 | howManyTimes' :: Integer 15 | howManyTimes' = let onePlusOne = trace "I got eval'd" (1 + 1) 16 | in inc onePlusOne + twice onePlusOne 17 | -------------------------------------------------------------------------------- /27/27.14-strict-list.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Strict #-} 2 | 3 | module StrictList where 4 | 5 | data List a = Nil 6 | | Cons a (List a) 7 | deriving Show 8 | 9 | take' n _ | n <= 0 = Nil 10 | take' _ Nil = Nil 11 | take' n (Cons x xs) = (Cons x (take' (n - 1) xs)) 12 | 13 | map' _ Nil = Nil 14 | map' f (Cons x xs) = (Cons (f x) (map' f xs)) 15 | 16 | repeat' x = xs where xs = (Cons x xs) 17 | 18 | main = do 19 | print $ take' 10 $ map' (+1) (repeat' 1) 20 | -------------------------------------------------------------------------------- /28/28.02-benchmarking-with-criterion/.gitignore: -------------------------------------------------------------------------------- 1 | 28.02-bench 2 | -------------------------------------------------------------------------------- /28/28.02-benchmarking-with-criterion/28.02-bench.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | 5 | infixl 9 !? 6 | {-# INLINABLE (!?) #-} 7 | (!?) :: [a] -> Int -> Maybe a 8 | xs !? n 9 | | n < 0 = Nothing 10 | | otherwise = foldr (\x r k -> 11 | case k of 12 | 0 -> Just x 13 | _ -> r (k - 1)) 14 | (const Nothing) xs n 15 | 16 | 17 | myList :: [Int] 18 | myList = [1..9999] 19 | 20 | main :: IO () 21 | main = defaultMain 22 | [ bench "index list 9999" $ whnf (myList !!) 9998 23 | , bench "index list maybe index 9999" $ whnf (myList !?) 9998 24 | ] 25 | -------------------------------------------------------------------------------- /28/28.04-constant-applicative-forms.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | incdInts :: [Integer] -> [Integer] 4 | incdInts = map (+1) 5 | 6 | main :: IO () 7 | main = do 8 | print (incdInts [1..] !! 1000) 9 | -------------------------------------------------------------------------------- /28/28.05-map.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import qualified Data.Map as M 5 | 6 | genList :: Int -> [(String, Int)] 7 | genList n = go n [] 8 | where 9 | go 0 xs = ("0", 0) : xs 10 | go n' xs = go (n' - 1) ((show n', n') : xs) 11 | 12 | pairList :: [(String, Int)] 13 | pairList = genList 9001 14 | 15 | testMap :: M.Map String Int 16 | testMap = M.fromList pairList 17 | 18 | 19 | main :: IO () 20 | main = defaultMain 21 | [ bench "lookup one thing, list" $ 22 | whnf (lookup "doesntExist") pairList 23 | , bench "lookup one thing, map" $ 24 | whnf (M.lookup "doesntExist") testMap 25 | ] 26 | -------------------------------------------------------------------------------- /28/28.06-benchmark-practice.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | import qualified Data.Map as M 3 | import qualified Data.Set as S 4 | 5 | bumpIt (i, v) = (i + 1, v + 1) 6 | 7 | m :: M.Map Int Int 8 | m = M.fromList $ take 10000 stream 9 | where 10 | stream = iterate bumpIt (0, 0) 11 | 12 | s :: S.Set Int 13 | s = S.fromList $ take 10000 stream 14 | where 15 | stream = iterate (+1) 0 16 | 17 | lookupMap :: Int -> Maybe Int 18 | lookupMap i = M.lookup i m 19 | 20 | lookupSet :: Int -> Maybe Int 21 | lookupSet i = S.lookupIndex i s 22 | 23 | main :: IO () 24 | main = defaultMain 25 | [ bench "lookup map" $ 26 | whnf lookupMap 9999 27 | , bench "lookup set" $ 28 | whnf lookupSet 9999 29 | ] 30 | -------------------------------------------------------------------------------- /28/28.06-set.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import qualified Data.Map as M 5 | import qualified Data.Set as S 6 | 7 | bumpIt (i, v) = (i + 1, v + 1) 8 | 9 | m :: M.Map Int Int 10 | m = M.fromList $ take 10000 stream 11 | where 12 | stream = iterate bumpIt (0, 0) 13 | 14 | s :: S.Set Int 15 | s = S.fromList $ take 10000 stream 16 | where 17 | stream = iterate (+1) 0 18 | 19 | membersMap :: Int -> Bool 20 | membersMap i = M.member i m 21 | 22 | membersSet :: Int -> Bool 23 | membersSet i = S.member i s 24 | 25 | main :: IO () 26 | main = defaultMain 27 | [ bench "member check map" $ 28 | whnf membersMap 9999 29 | , bench "member check set" $ 30 | whnf membersSet 9999 31 | ] 32 | -------------------------------------------------------------------------------- /28/28.07-sequence.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import qualified Data.Sequence as S 5 | 6 | lists :: [[Int]] 7 | lists = replicate 10 [1..100000] 8 | 9 | lists' :: [Int] 10 | lists' = [1..100000] 11 | 12 | seqs :: [S.Seq Int] 13 | seqs = replicate 10 (S.fromList [1..100000]) 14 | 15 | seqs' :: S.Seq Int 16 | seqs' = S.fromList [1..100000] 17 | 18 | main :: IO () 19 | main = defaultMain 20 | [ bench "concatenate lists" $ 21 | nf mconcat lists 22 | , bench "concatenate sequences" $ 23 | nf mconcat seqs 24 | ] 25 | 26 | main' :: IO () 27 | main' = defaultMain 28 | [ bench "indexing list" $ 29 | whnf (\xs -> xs !! 9001) lists' 30 | , bench "indexing sequence" $ 31 | whnf (flip S.index 9001) seqs' 32 | ] 33 | -------------------------------------------------------------------------------- /28/28.08-vector.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import qualified Data.Vector as V 5 | import qualified Data.Vector.Unboxed as U 6 | 7 | v :: V.Vector Int 8 | v = V.fromList [1..1000] 9 | 10 | u :: U.Vector Int 11 | u = U.fromList [1..1000] 12 | 13 | main :: IO () 14 | main = defaultMain 15 | [ bench "slicing boxed" $ 16 | whnf (V.head . V.slice 100 900) v 17 | , bench "slicing unboxed" $ 18 | whnf (U.head . U.slice 100 900) u 19 | ] 20 | -------------------------------------------------------------------------------- /28/28.09-text.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import qualified Data.Text as T 5 | import qualified Data.Text.IO as TIO 6 | import qualified Data.Text.Lazy as TL 7 | import qualified Data.Text.Lazy.IO as TLIO 8 | import qualified System.IO as SIO 9 | 10 | dictWords :: IO String 11 | dictWords = SIO.readFile "/usr/share/dict/words" 12 | 13 | dictWordsT :: IO T.Text 14 | dictWordsT = TIO.readFile "/usr/share/dict/words" 15 | 16 | dictWordsTL :: IO TL.Text 17 | dictWordsTL = TLIO.readFile "/usr/share/dict/words" 18 | 19 | main :: IO () 20 | main = do 21 | replicateM_ 1000 (dictWords >>= print) 22 | replicateM_ 1000 (dictWordsT >>= TIO.putStrLn) 23 | replicateM_ 1000 (dictWordsTL >>= TLIO.putStrLn) 24 | -------------------------------------------------------------------------------- /28/28.10-a-simple-queue.hs: -------------------------------------------------------------------------------- 1 | data Queue a = Queue 2 | { enqueue :: [a] 3 | , dequeue :: [a] 4 | } deriving (Eq, Show) 5 | 6 | push :: a -> Queue a -> Queue a 7 | push x q = case enqueue q of 8 | [] -> Queue [] $ [x] 9 | xs -> Queue [x] $ xs 10 | 11 | pop :: Queue a -> Maybe (a, Queue a) 12 | pop q = case dequeue q of 13 | [] -> Nothing 14 | (x:xs) -> Just (x, Queue [] $ xs) 15 | -------------------------------------------------------------------------------- /28/28.10-difference-list.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | 3 | newtype DList a = DL { unDL :: [a] -> [a] } 4 | 5 | ----------------------------------------------------------------------------- 6 | -- 1. 7 | empty :: DList a 8 | empty = DL $ \_ -> [] 9 | {-# INLINE empty #-} 10 | 11 | ----------------------------------------------------------------------------- 12 | -- 2. 13 | singleton :: a -> DList a 14 | singleton x = DL $ \_ -> [x] 15 | {-# INLINE singleton #-} 16 | 17 | ----------------------------------------------------------------------------- 18 | -- 3. 19 | toList :: DList a -> [a] 20 | toList d = (unDL d) [] 21 | {-# INLINE toList #-} 22 | 23 | ----------------------------------------------------------------------------- 24 | -- 4. 25 | infixr `cons` 26 | cons :: a -> DList a -> DList a 27 | cons x xs = DL ((x:) . unDL xs) 28 | {-# INLINE cons #-} 29 | 30 | ----------------------------------------------------------------------------- 31 | -- 5. 32 | infixl `snoc` 33 | snoc :: DList a -> a -> DList a 34 | snoc xs x = DL ((++ [x]) . unDL xs) 35 | {-# INLINE snoc #-} 36 | 37 | ----------------------------------------------------------------------------- 38 | -- 6. 39 | append :: DList a -> DList a -> DList a 40 | append xs ys = DL (unDL xs . unDL ys) 41 | {-# INLINE append #-} 42 | 43 | schlemiel :: Int -> [Int] 44 | schlemiel i = go i [] 45 | where 46 | go 0 xs = xs 47 | go n xs = go (n-1) ([n] ++ xs) 48 | 49 | constructDlist :: Int -> [Int] 50 | constructDlist i = toList $ go i empty 51 | where 52 | go 0 xs = xs 53 | go n xs = go (n-1) (singleton n `append` xs) 54 | 55 | main :: IO () 56 | main = defaultMain 57 | [ bench "concat list" $ 58 | whnf schlemiel 123456 59 | , bench "concat dlist" $ 60 | whnf constructDlist 123456 61 | ] 62 | -------------------------------------------------------------------------------- /29/29.04-what-happens.hs: -------------------------------------------------------------------------------- 1 | module WhatHappens where 2 | 3 | import Control.Concurrent 4 | 5 | myData :: IO (MVar Int) 6 | myData = newEmptyMVar 7 | 8 | main :: IO () 9 | main = do 10 | mv <- myData 11 | putMVar mv 0 12 | -- mv' <- myData 13 | zero <- takeMVar mv 14 | print zero 15 | -------------------------------------------------------------------------------- /29/29.09-config-directories/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | -------------------------------------------------------------------------------- /29/29.09-config-directories/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Evan Turner (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Turner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /29/29.09-config-directories/README.md: -------------------------------------------------------------------------------- 1 | ``` 2 | _ \ _) 3 | | | _` | __| __| | __ \ _` | 4 | ___/ ( | | \__ \ | | | ( | 5 | _|___|\__,_| _| ____/_||_)| _| \__, | | _) 6 | | _ \ __ \ | | _` |__|/ | __| _` | __| | _ \ __ \ 7 | | ( | | | __| | ( | | | | ( | | | ( | | | 8 | \____| \___/ _| _| _| _| \__, | \__,_| _| \__,_| \__| _| \___/ _| _| 9 | ____| _) | |___/ 10 | | | | _ \ __| 11 | __| | | __/ \__ \ 12 | _| _| _| \___| ____/ 13 | 14 | ``` 15 | -------------------------------------------------------------------------------- /29/29.09-config-directories/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /29/29.09-config-directories/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Parser 4 | import Run 5 | 6 | main :: IO () 7 | main = do 8 | ls 9 | -------------------------------------------------------------------------------- /29/29.09-config-directories/ini-parser.cabal: -------------------------------------------------------------------------------- 1 | name: ini-parser 2 | version: 0.1.0.0 3 | description: Configurations, am I right? 4 | homepage: https://github.com/evturn/haskellbook 5 | bug-reports: https://github.com/evturn/haskellbook 6 | author: Evan Turner 7 | maintainer: ev@evturn.com 8 | copyright: Copyright (c) 2018 Evan Turner 9 | license: BSD3 10 | license-file: LICENSE 11 | build-type: Simple 12 | cabal-version: >= 1.10 13 | extra-source-files: README.md 14 | 15 | library 16 | hs-source-dirs: src 17 | build-depends: base >=4.7 && <5 18 | , bytestring 19 | , containers 20 | , directory 21 | , raw-strings-qq 22 | , text 23 | , trifecta 24 | exposed-modules: Parser 25 | , Run 26 | other-modules: Paths_ini_parser 27 | default-language: Haskell2010 28 | 29 | executable ini-parser 30 | main-is: Main.hs 31 | hs-source-dirs: app 32 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 33 | build-depends: base >=4.7 && <5 34 | , ini-parser 35 | other-modules: Paths_ini_parser 36 | default-language: Haskell2010 37 | 38 | source-repository head 39 | type: git 40 | location: https://github.com/evturn/haskellbook 41 | 42 | -------------------------------------------------------------------------------- /29/29.09-config-directories/package.yaml: -------------------------------------------------------------------------------- 1 | name: ini-parser 2 | version: 0.1.0.0 3 | github: "evturn/haskellbook" 4 | license: BSD3 5 | author: "Evan Turner" 6 | maintainer: "ev@evturn.com" 7 | copyright: "Copyright (c) 2018 Evan Turner" 8 | 9 | extra-source-files: 10 | - README.md 11 | 12 | # Metadata used when publishing your package 13 | # synopsis: Short description of your package 14 | # category: Very Cool 15 | 16 | # To avoid duplicated efforts in documentation and dealing with the 17 | # complications of embedding Haddock markup inside cabal files, it is 18 | # common to point users to the README.md file. 19 | description: Configurations, am I right? 20 | 21 | dependencies: 22 | - base >= 4.7 && < 5 23 | 24 | library: 25 | source-dirs: src 26 | build-depends: base >=4.7 && <5 27 | , bytestring 28 | , containers 29 | , hspec 30 | , raw-strings-qq 31 | , text 32 | , trifecta 33 | exposed-modules: Parser 34 | 35 | executables: 36 | ini-parser-exe: 37 | main: Main.hs 38 | source-dirs: app 39 | ghc-options: 40 | - -threaded 41 | - -rtsopts 42 | - -with-rtsopts=-N 43 | dependencies: 44 | - ini-parser 45 | -------------------------------------------------------------------------------- /29/29.09-config-directories/src/Run.hs: -------------------------------------------------------------------------------- 1 | module Run where 2 | 3 | import Data.List (isSuffixOf) 4 | import qualified Data.Map as M 5 | import Parser 6 | import System.Directory 7 | import System.Environment 8 | 9 | type Entry = M.Map FilePath String 10 | 11 | selectConfigs :: [String] -> [String] 12 | selectConfigs = filter (isSuffixOf ".ini") 13 | 14 | readC :: FilePath -> IO Entry -> IO Entry 15 | readC x iomp = do 16 | v <- readFile x 17 | mp <- iomp 18 | return $ M.insert x v mp 19 | 20 | ls :: IO () 21 | ls = do 22 | [x] <- getArgs 23 | paths <- listDirectory x 24 | files <- return $ selectConfigs paths 25 | mp <- foldr readC (return M.empty) files 26 | print mp 27 | 28 | 29 | -------------------------------------------------------------------------------- /29/29.09-config-directories/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.2 2 | packages: 3 | - . 4 | extra-library-dirs: ~/.cabal/packages/hackage.haskell.org/ 5 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for vigenere 2 | 3 | ## Unreleased changes 4 | 5 | ## Secret unreleased changes 6 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Evan Turner (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Turner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/README.md: -------------------------------------------------------------------------------- 1 | ``` 2 | d8, 3 | `8P 4 | 5 | ?88 d8P 88b d888b8b d8888b 88bd88b d8888b 88bd88b d8888b 6 | d88 d8P' 88Pd8P' ?88 d8b_,dP 88P' ?8bd8b_,dP 88P' `d8b_,dP 7 | ?8b ,88' d88 88b ,88b 88b d88 88P88b d88 88b 8 | `?888P' d88' `?88P'`88b`?888P'd88' 88b`?888P'd88' `?888P' 9 | )88 Since 1995 10 | ,88P 11 | `?8888P 12 | ``` 13 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Vigenere 4 | 5 | main :: IO () 6 | main = run 7 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/package.yaml: -------------------------------------------------------------------------------- 1 | name: vigenere 2 | version: 0.1.0.0 3 | github: "evturn/haskellbook" 4 | license: BSD3 5 | author: "Evan Turner" 6 | maintainer: "ev@evturn.com" 7 | copyright: "Copyright (c) 2018 Evan Turner" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Very Cool 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on Github at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | vigenere-exe: 30 | main: Main.hs 31 | source-dirs: app 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - vigenere 38 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/src/Cipher.hs: -------------------------------------------------------------------------------- 1 | module Cipher 2 | ( caesar 3 | , uncaesar 4 | ) where 5 | 6 | import Data.Char 7 | 8 | charCodes :: [Int] 9 | charCodes = fmap ord ['a'..'z'] 10 | 11 | wrapLeft :: Int -> Int 12 | wrapLeft n 13 | | n > (last charCodes) = n - (last charCodes) + (head charCodes - 1) 14 | | otherwise = n 15 | 16 | wrapRight :: Int -> Int 17 | wrapRight n 18 | | n < (head charCodes) = n + (last charCodes) - (head charCodes - 1) 19 | | otherwise = n 20 | 21 | shiftChar :: Int -> Char -> Char 22 | shiftChar n ch = chr $ wrapLeft (n + ord ch) 23 | 24 | unshiftChar :: Int -> Char -> Char 25 | unshiftChar n co = chr $ wrapRight (ord co - n) 26 | 27 | caesar :: Int -> String -> String 28 | caesar _ [] = [] 29 | caesar n xs = fmap (shiftChar n) xs 30 | 31 | uncaesar :: Int -> String -> String 32 | uncaesar _ [] = [] 33 | uncaesar n xs = fmap (unshiftChar n) xs 34 | 35 | table :: [(Char, Int)] 36 | table = zip ['a'..'z'] [0..] 37 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/src/Vigenere.hs: -------------------------------------------------------------------------------- 1 | module Vigenere where 2 | 3 | import Cipher 4 | import System.Environment (getArgs) 5 | import System.Exit 6 | import System.IO (hGetLine, hPutStr, hWaitForInput, stderr, 7 | stdin, stdout) 8 | 9 | readIn :: String -> Int 10 | readIn x = read x 11 | 12 | parseArgs :: Int -> String -> String -> String 13 | parseArgs k "-d" xs = uncaesar k xs 14 | parseArgs k _ xs = caesar k xs 15 | 16 | finishWithError :: IO a 17 | finishWithError = do 18 | hPutStr stderr "Timed out" 19 | exitWith (ExitFailure 1) 20 | 21 | run :: IO () 22 | run = do 23 | (k:m:[]) <- getArgs 24 | putStrLn "Start typing." 25 | success <- hWaitForInput stdin (5000) 26 | input <- case success of 27 | False -> finishWithError 28 | True -> hGetLine stdin 29 | putStrLn $ parseArgs (readIn k) m input 30 | 31 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.2 2 | packages: 3 | - . 4 | -------------------------------------------------------------------------------- /29/29.09-file-io-with-vigenere/vigenere.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.20.0. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: 64318baff6f68e7a0421d79b829d65faca12c8289a2da5640de8038c30294485 6 | 7 | name: vigenere 8 | version: 0.1.0.0 9 | description: Ok, so like I know what this looks like. 10 | homepage: https://github.com/evturn/haskellbook 11 | bug-reports: https://github.com/evturn/haskellbook 12 | author: Evan Turner 13 | maintainer: ev@evturn.com 14 | copyright: Copyright (c) 2018 Evan Turner 15 | license: BSD3 16 | license-file: LICENSE 17 | build-type: Simple 18 | cabal-version: >= 1.10 19 | 20 | extra-source-files: 21 | ChangeLog.md 22 | README.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/evturn/haskellbook 27 | 28 | library 29 | hs-source-dirs: 30 | src 31 | build-depends: 32 | base >=4.7 && <5 33 | exposed-modules: 34 | Vigenere 35 | , Cipher 36 | other-modules: 37 | Paths_vigenere 38 | default-language: Haskell2010 39 | 40 | executable vigenere 41 | main-is: Main.hs 42 | hs-source-dirs: 43 | app 44 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 45 | build-depends: 46 | base >=4.7 && <5 47 | , vigenere 48 | other-modules: 49 | Paths_vigenere 50 | default-language: Haskell2010 51 | -------------------------------------------------------------------------------- /30/30.02-why-some-exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | module WhySomeException where 5 | 6 | import Control.Exception (ArithException (..), AsyncException (..)) 7 | import Data.Typeable 8 | 9 | data MyException = forall e . (Show e, Typeable e) => MyException e 10 | 11 | instance Show MyException where 12 | showsPrec p (MyException e) = showsPrec p e 13 | 14 | multiError :: Int -> Either MyException Int 15 | multiError n = case n of 16 | 0 -> Left (MyException DivideByZero) 17 | 1 -> Left (MyException StackOverflow) 18 | _ -> Right n 19 | 20 | data SomeError = Arith ArithException 21 | | Async AsyncException 22 | | SomethingElse 23 | deriving Show 24 | 25 | discriminateError :: MyException -> SomeError 26 | discriminateError (MyException e) = 27 | case cast e of 28 | Just arith -> Arith arith 29 | Nothing -> 30 | case cast e of 31 | Just async -> Async async 32 | Nothing -> SomethingElse 33 | 34 | runDisc :: Int -> SomeError 35 | runDisc n = either discriminateError (const SomethingElse) (multiError n) 36 | 37 | 38 | -------------------------------------------------------------------------------- /30/30.03-write-pls.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Exception 4 | import Data.Typeable 5 | 6 | handler :: SomeException -> IO () 7 | handler (SomeException e) = do 8 | putStrLn ("Running main caused an error! It was " ++ show e) 9 | writeFile "bbb" "hi" 10 | 11 | main :: IO () 12 | main = do 13 | writeFile "zzz" "hi" `catch` handler 14 | -------------------------------------------------------------------------------- /30/30.04-try-except.hs: -------------------------------------------------------------------------------- 1 | module TryExcept where 2 | 3 | import Control.Exception 4 | import System.Environment (getArgs) 5 | 6 | willIFail :: Integer -> IO (Either ArithException ()) 7 | willIFail denom = try $ print $ div 5 denom 8 | 9 | onlyReportError :: Show e => IO (Either e a) -> IO () 10 | onlyReportError action = do 11 | result <- action 12 | case result of 13 | Left e -> print e 14 | Right _ -> return () 15 | 16 | testDiv :: String -> IO () 17 | testDiv d = onlyReportError $ willIFail (read d) 18 | 19 | main :: IO () 20 | main = do 21 | args <- getArgs 22 | mapM_ testDiv args 23 | -------------------------------------------------------------------------------- /30/30.05-stopping-the-party.hs: -------------------------------------------------------------------------------- 1 | module StoppingTheParty where 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Exception 5 | import Control.Monad (forever) 6 | import System.Random (randomRIO) 7 | 8 | randomException :: IO () 9 | randomException = do 10 | i <- randomRIO (1, 10 :: Int) 11 | if i `elem` [1..9] 12 | then throwIO DivideByZero 13 | else throwIO StackOverflow 14 | 15 | main :: IO () 16 | main = forever $ do 17 | let tryS :: IO () -> IO (Either SomeException ()) 18 | tryS = try 19 | _ <- tryS randomException 20 | putStrLn "Live to loop another day!" 21 | threadDelay (1 * 1000000) 22 | -------------------------------------------------------------------------------- /30/30.07-our-exceptions.hs: -------------------------------------------------------------------------------- 1 | module OurExceptions where 2 | 3 | import Control.Exception 4 | 5 | data EATD = NotEven Int 6 | | NotDivThree Int 7 | deriving (Eq, Show) 8 | 9 | instance Exception EATD 10 | 11 | evenAndThreeDiv :: Int -> IO Int 12 | evenAndThreeDiv i 13 | | rem i 3 /= 0 = throwIO (NotDivThree i) 14 | | even i = throwIO (NotEven i) 15 | | otherwise = return i 16 | 17 | -- catchNotDivThree :: IO Int -> (NotDivThree -> IO Int) -> IO Int 18 | -- catchNotDivThree = catch 19 | 20 | -- catchNotEven :: IO Int -> (NotEven -> IO Int) -> IO Int 21 | -- catchNotEven = catch 22 | 23 | catchBoth :: IO Int -> IO Int 24 | catchBoth ioInt = catches ioInt 25 | [ Handler (\(NotEven _) -> return maxBound) 26 | , Handler (\(NotDivThree _) -> return minBound) 27 | ] 28 | -------------------------------------------------------------------------------- /31/31.03-fingerd/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Evan Turner (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Turner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /31/31.03-fingerd/README.md: -------------------------------------------------------------------------------- 1 | ``` 2 | _| _) | 3 | | | __ \ _` | _ \ __| _` | 4 | __| | | | ( | __/ | ( | 5 | _| _| _| _| \__, | \___| _| \__,_| 6 | |___/ 7 | ``` 8 | -------------------------------------------------------------------------------- /31/31.03-fingerd/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /31/31.03-fingerd/finger.db: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/evturn/haskellbook/3d310d0ddd4221ffc5b9fd7ec6476b2a0731274a/31/31.03-fingerd/finger.db -------------------------------------------------------------------------------- /31/31.03-fingerd/fingerd.cabal: -------------------------------------------------------------------------------- 1 | name: fingerd 2 | version: 0.1.0.0 3 | synopsis: Yes, it's true. 4 | description: An audio version of the dictionary from cover to cover. 5 | homepage: https://github.com/evturn/haskellbook 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Evan Turner 9 | maintainer: ev@evturn.com 10 | copyright: Copyright (c) 2018 Evan Turner 11 | category: Very Cool 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable debug 17 | ghc-options: -Wall 18 | hs-source-dirs: src 19 | main-is: Debug.hs 20 | default-language: Haskell2010 21 | build-depends: base >= 4.7 && < 5 22 | , network 23 | 24 | executable fingerd 25 | ghc-options: -Wall 26 | hs-source-dirs: src 27 | main-is: Main.hs 28 | default-language: Haskell2010 29 | build-depends: base >= 4.7 && < 5 30 | , bytestring 31 | , network 32 | , raw-strings-qq 33 | , sqlite-simple 34 | , text 35 | -------------------------------------------------------------------------------- /31/31.03-fingerd/src/Debug.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (forever) 4 | import Network.Socket hiding (recv) 5 | import Network.Socket.ByteString (recv, sendAll) 6 | 7 | logAndEcho :: Socket -> IO () 8 | logAndEcho sock = forever $ do 9 | (soc, _) <- accept sock 10 | printAndKickback soc 11 | close soc 12 | where 13 | printAndKickback conn = do 14 | msg <- recv conn 1024 15 | print msg 16 | sendAll conn msg 17 | 18 | main :: IO () 19 | main = withSocketsDo $ do 20 | addrinfos <- getAddrInfo 21 | (Just (defaultHints { addrFlags = [AI_PASSIVE] })) 22 | Nothing (Just "79") 23 | let serveraddr = head addrinfos 24 | sock <- socket (addrFamily serveraddr) Stream defaultProtocol 25 | bind sock (addrAddress serveraddr) 26 | listen sock 1 27 | logAndEcho sock 28 | close sock 29 | -------------------------------------------------------------------------------- /31/31.03-fingerd/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.3 2 | packages: 3 | - . 4 | -------------------------------------------------------------------------------- /31/31.05-chapter-exercises.hs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/evturn/haskellbook/3d310d0ddd4221ffc5b9fd7ec6476b2a0731274a/31/31.05-chapter-exercises.hs --------------------------------------------------------------------------------