├── chapter19 └── urlshortener │ ├── README.md │ ├── Setup.hs │ ├── test │ └── Spec.hs │ ├── .gitignore │ ├── urlshortener.cabal │ ├── LICENSE │ ├── stack.yaml │ └── app │ └── Main.hs ├── chapter14 ├── morse │ ├── Setup.hs │ ├── .gitignore │ ├── tests │ │ └── tests.hs │ ├── morse.cabal │ ├── src │ │ ├── Morse.hs │ │ └── Main.hs │ └── LICENSE ├── addition │ ├── Setup.hs │ ├── .gitignore │ ├── addition.cabal │ ├── LICENSE │ └── src │ │ ├── Exercises.hs │ │ └── Addition.hs └── wordnumber │ ├── Setup.hs │ ├── .gitignore │ ├── tests │ ├── cipherspecs.hs │ └── tests.hs │ ├── src │ ├── WordNumber.hs │ └── VigenereCipher.hs │ ├── LICENSE │ └── wordnumber.cabal ├── chapter13 ├── call-em-up │ ├── Setup.hs │ ├── src │ │ └── Main.hs │ ├── .gitignore │ ├── call-em-up.cabal │ └── LICENSE ├── hangman │ ├── Setup.hs │ ├── .gitignore │ ├── hangman.cabal │ ├── src │ │ └── Main.hs │ └── LICENSE ├── hello-haskell │ ├── Setup.hs │ ├── src │ │ ├── Hello.hs │ │ └── Main.hs │ ├── .gitignore │ ├── hello-haskell.cabal │ └── LICENSE ├── palindrome.hs └── persongame.hs ├── chapter15 ├── orphan-instance │ ├── Listy.hs │ └── ListyInstances.hs ├── intermission.hs ├── madlib.hs ├── MonoidLaws.hs └── exercises.hs ├── test.hs ├── chapter6 ├── exercises.hs ├── typeclasses.hs └── intermission.hs ├── README.md ├── chapter3 ├── global.hs ├── reverse.hs ├── print3.hs └── exercises.hs ├── chapter4 ├── intermission.hs └── exercises.hs ├── chapter5 ├── arith3broken.hs ├── sing.hs ├── types.hs ├── exercises.hs └── type-kwon-do.hs ├── chapter9 ├── lists.hs ├── cipher.hs ├── exercises.hs ├── poemLines.hs └── intermission.hs ├── chapter10 ├── scans.hs ├── exercises.hs └── intermission.hs ├── chapter7 ├── greetIfCool.hs ├── arith4.hs ├── matchingTuples.hs ├── registeredUser.hs ├── intermission.hs ├── exercises.hs └── arith2.hs ├── chapter17 ├── Combinations.hs ├── ZipListMonoid.hs ├── ApplicativeLaws.hs ├── listap.hs ├── applicatives.hs ├── intermission.hs └── exercises.hs ├── chapter2 ├── exercises.hs └── intermission.hs ├── chapter16 ├── FlipFunctor.hs ├── NaturalTransformation.hs ├── FunctorLaws.hs ├── functors.hs ├── ReplaceExperiment.hs ├── intermission.hs └── exercises.hs ├── chapter11 ├── huttonsrazor.hs ├── exercises.hs ├── jammin.hs ├── vigenere-cipher.hs ├── intermission.hs ├── adts.hs ├── phone.hs └── binarytree.hs ├── chapter12 ├── ' ├── binarytree.hs ├── natural.hs ├── eitherlib.hs ├── signaling.hs ├── maybelib.hs └── exercises.hs ├── chapter18 ├── kleisli.hs ├── dosyntax.hs ├── intermission.hs ├── BadMonad.hs ├── EitherMonad.hs ├── monads.hs └── exercises.hs ├── chapter23 ├── exercises.hs ├── fizzbuzz.hs ├── intermission.hs ├── state.hs ├── RandomExample.hs └── RandomStateExample.hs ├── chapter20 ├── foldable.hs ├── exercises.hs └── intermission.hs ├── chapter22 ├── intro.hs ├── intermission.hs ├── ReaderPractice.hs └── reader.hs ├── chapter8 ├── recursion.hs ├── wordNumbers.hs └── exercises.hs └── chapter21 └── exercises.hs /chapter19/urlshortener/README.md: -------------------------------------------------------------------------------- 1 | # urlshortener 2 | -------------------------------------------------------------------------------- /chapter14/morse/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter13/call-em-up/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter13/hangman/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter14/addition/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter14/wordnumber/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter13/hello-haskell/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter19/urlshortener/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter19/urlshortener/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /chapter15/orphan-instance/Listy.hs: -------------------------------------------------------------------------------- 1 | module Listy where 2 | 3 | newtype Listy a = Listy [a] deriving (Eq, Show) 4 | -------------------------------------------------------------------------------- /chapter13/call-em-up/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Hello 4 | 5 | main :: IO () 6 | main = sayHello "GoatScreams McGee" 7 | -------------------------------------------------------------------------------- /test.hs: -------------------------------------------------------------------------------- 1 | sayHello :: String -> IO () 2 | sayHello x = putStrLn ("Hello " ++ x ++ "!") 3 | 4 | triple :: Int -> Int 5 | triple x = x * 3 6 | -------------------------------------------------------------------------------- /chapter13/hello-haskell/src/Hello.hs: -------------------------------------------------------------------------------- 1 | module Hello where 2 | 3 | sayHello :: String -> IO () 4 | sayHello name = putStrLn ("Hi " ++ name ++ "!") 5 | -------------------------------------------------------------------------------- /chapter6/exercises.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 x y = f y 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | haskell-book-exercises 2 | ====================== 3 | 4 | My way of solving the exercises of the excellent book [Haskell Programming from first principles](http://haskellbook.com/). 5 | -------------------------------------------------------------------------------- /chapter3/global.hs: -------------------------------------------------------------------------------- 1 | module GlobalLocal where 2 | 3 | topLevelFunction :: Integer -> Integer 4 | topLevelFunction x = x + woot + topLevelValue 5 | where woot = 10 6 | 7 | topLevelValue = 5 8 | -------------------------------------------------------------------------------- /chapter3/reverse.hs: -------------------------------------------------------------------------------- 1 | module Reverse where 2 | 3 | rvrs :: String -> String 4 | rvrs x = (drop 9 x) ++ take 4 (drop 5 x) ++ (take 5 x) 5 | 6 | main :: IO() 7 | main = print $ rvrs "curry is awesome" 8 | -------------------------------------------------------------------------------- /chapter4/intermission.hs: -------------------------------------------------------------------------------- 1 | data Mood = Blah | Woot deriving (Eq, Show) 2 | 3 | changeMood :: Mood -> Mood 4 | changeMood Woot = Blah 5 | changeMood Blah = Woot 6 | --changeMood x = if (x == Blah) then Woot else Blah 7 | -------------------------------------------------------------------------------- /chapter5/arith3broken.hs: -------------------------------------------------------------------------------- 1 | module Arith3Broken where 2 | 3 | main :: IO () 4 | main = do 5 | print (1 + 2) 6 | putStrLn "10" 7 | print (negate (-1)) 8 | print ((+) 0 blah) 9 | where blah = negate 1 10 | -------------------------------------------------------------------------------- /chapter9/lists.hs: -------------------------------------------------------------------------------- 1 | safeTail :: [a] -> Maybe [a] 2 | safeTail [] = Nothing 3 | safeTail (x:[]) = Nothing 4 | safeTail (_:xs) = Just xs 5 | 6 | safeHead :: [a] -> Maybe a 7 | safeHead [] = Nothing 8 | safeHead (x:_) = Just x 9 | -------------------------------------------------------------------------------- /chapter15/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 | -------------------------------------------------------------------------------- /chapter10/scans.hs: -------------------------------------------------------------------------------- 1 | fibs = 1 : scanl (+) 1 fibs 2 | fibsNth n = fibs !! n 3 | 4 | fibs20 = take 20 fibs 5 | 6 | fibsLessThan100 = takeWhile (<100) fibs 7 | 8 | fact :: Integer -> Integer 9 | fact 0 = 1 10 | fact n = foldl (*) n [1..(n-1)] 11 | -------------------------------------------------------------------------------- /chapter13/hello-haskell/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.IO 4 | import Hello 5 | 6 | main :: IO () 7 | main = do 8 | hSetBuffering stdout NoBuffering 9 | putStr "Please enter your name: " 10 | name <- getLine 11 | sayHello name 12 | -------------------------------------------------------------------------------- /chapter7/greetIfCool.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 cool = coolness == "downright frosty yo" 8 | -------------------------------------------------------------------------------- /chapter9/cipher.hs: -------------------------------------------------------------------------------- 1 | module Cipher where 2 | 3 | import Data.Char 4 | 5 | type Shift = Int 6 | 7 | encode :: Shift -> String -> [Int] 8 | encode s = fmap (\x -> (ord x) + s) 9 | 10 | decode :: Shift -> [Int] -> String 11 | decode s= fmap (\x -> chr (x - s)) 12 | -------------------------------------------------------------------------------- /chapter17/Combinations.hs: -------------------------------------------------------------------------------- 1 | module Combinations where 2 | 3 | import Control.Applicative (liftA3) 4 | 5 | stops, vowels :: String 6 | stops = "pbtdkg" 7 | vowels = "aeiou" 8 | 9 | combos :: [a] -> [b] -> [c] -> [(a, b, c)] 10 | combos a b c = liftA3 (,,) a b c 11 | -------------------------------------------------------------------------------- /chapter13/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 | cabal.project.local 20 | .HTF/ 21 | -------------------------------------------------------------------------------- /chapter14/morse/.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 | cabal.project.local 20 | .HTF/ 21 | -------------------------------------------------------------------------------- /chapter13/call-em-up/.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 | cabal.project.local 20 | .HTF/ 21 | -------------------------------------------------------------------------------- /chapter14/addition/.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 | cabal.project.local 20 | .HTF/ 21 | -------------------------------------------------------------------------------- /chapter14/wordnumber/.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 | cabal.project.local 20 | .HTF/ 21 | -------------------------------------------------------------------------------- /chapter19/urlshortener/.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 | cabal.project.local 20 | .HTF/ 21 | -------------------------------------------------------------------------------- /chapter2/exercises.hs: -------------------------------------------------------------------------------- 1 | module Exercises where 2 | 3 | waxOn :: Num a => a -> a 4 | waxOn x = x * 5 5 | where z = 7 6 | y = z + 8 7 | x = y * y -- same as y ^ 2 8 | 9 | triple :: Num a => a -> a 10 | triple x = x * 3 11 | 12 | waxOff :: Num a => a -> a 13 | waxOff x = triple x 14 | -------------------------------------------------------------------------------- /chapter13/hello-haskell/.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 | cabal.project.local 20 | .HTF/ 21 | -------------------------------------------------------------------------------- /chapter5/sing.hs: -------------------------------------------------------------------------------- 1 | module Sing where 2 | 3 | fstString :: [Char] -> [Char] 4 | fstString x = x ++ " in the rain" 5 | 6 | sndString :: [Char] -> [Char] 7 | sndString x = x ++ " over the rainbow" 8 | 9 | sing = if (x > y) then fstString x else sndString y 10 | where x = "Singin" 11 | y = "Somewhere" 12 | -------------------------------------------------------------------------------- /chapter16/FlipFunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module FlipFunctor where 4 | 5 | data Tuple a b = Tuple a b deriving (Eq, Show) 6 | 7 | newtype Flip f a b = Flip (f b a) deriving (Eq, Show) 8 | 9 | instance Functor (Flip Tuple a) where 10 | fmap f (Flip (Tuple a b)) = Flip $ Tuple (f a) b 11 | -------------------------------------------------------------------------------- /chapter7/arith4.hs: -------------------------------------------------------------------------------- 1 | module Arith4 where 2 | 3 | -- id :: a -> a 4 | -- id x = x 5 | 6 | roundTrip :: (Show a, Read a) => a -> a 7 | roundTrip = read . show 8 | 9 | roundTripAlt :: (Show a, Read b) => a -> b 10 | roundTripAlt = read . show 11 | 12 | main = do 13 | print (roundTripAlt 4 :: Integer) -- roundTrip 4 14 | print (id 4) 15 | -------------------------------------------------------------------------------- /chapter16/NaturalTransformation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module NaturalTransformation where 4 | 5 | type Nat f g = forall a. f a -> g a 6 | 7 | maybeToList :: Nat Maybe [] 8 | maybeToList Nothing = [] 9 | maybeToList (Just x) = [x] 10 | 11 | headOption :: Nat [] Maybe 12 | headOption [] = Nothing 13 | headOption (x:xs) = Just x 14 | -------------------------------------------------------------------------------- /chapter3/print3.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] 17 | -------------------------------------------------------------------------------- /chapter14/wordnumber/tests/cipherspecs.hs: -------------------------------------------------------------------------------- 1 | module CipherSpecs where 2 | 3 | import Test.QuickCheck 4 | import VigenereCipher (encode, decode) 5 | 6 | -- TODO: It does not work for "a\NAK" find out why 7 | vigenereSpec :: String -> Bool 8 | vigenereSpec x = x == (decode (encode x)) 9 | 10 | cipherSpec :: IO () 11 | cipherSpec = do 12 | quickCheck vigenereSpec 13 | -------------------------------------------------------------------------------- /chapter11/huttonsrazor.hs: -------------------------------------------------------------------------------- 1 | data Expr = Lit Integer | Add Expr Expr deriving (Show) 2 | 3 | eval :: Expr -> Integer 4 | eval (Lit x) = x 5 | eval (Add x y) = eval x + eval y 6 | 7 | printExpr :: Expr -> String 8 | printExpr (Lit x) = show x 9 | printExpr (Add x y) = (printExpr x) ++ " + " ++ (printExpr y) 10 | 11 | a1 = Add (Lit 9001) (Lit 1) 12 | a2 = Add a1 (Lit 20001) 13 | a3 = Add (Lit 1) a2 14 | -------------------------------------------------------------------------------- /chapter12/': -------------------------------------------------------------------------------- 1 | data BinaryTree a = Leaf | Node (BinaryTree a) a (BinaryTree a) deriving (Eq, Ord, Show) 2 | 3 | unfold :: (a -> Maybe (a,b,a)) -> a -> BinaryTree b 4 | unfold f x = case f x of 5 | Nothing -> Leaf 6 | Just (x, y, z) -> Node (unfold f x) y (unfold f z) 7 | 8 | treeBuild :: Integer -> BinaryTree Integer 9 | treeBuild n = unfold f 0 10 | where f x 11 | | x == n = Nothing 12 | | otherwise = Just (x + 1, x, x + 1) 13 | -------------------------------------------------------------------------------- /chapter18/kleisli.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad ((>=>)) 2 | 3 | -- Monad function composition examples 4 | 5 | sayHi :: String -> IO String 6 | sayHi greeting = do 7 | putStrLn greeting 8 | getLine 9 | 10 | readM :: Read a => String -> IO a 11 | readM = return . read 12 | 13 | getAge :: String -> IO Int 14 | getAge = sayHi >=> readM -- >=> is the kleisli composition operator 15 | 16 | askForAge :: IO Int 17 | askForAge = getAge "Hello! How old are you? " 18 | -------------------------------------------------------------------------------- /chapter23/exercises.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Control.Monad.Trans.State hiding (get, put, modify) 3 | 4 | get :: State s s 5 | get = state $ \f -> (f, f) 6 | 7 | put :: s -> State s () 8 | put s = state $ \f -> ((), s) 9 | 10 | exec :: State s a -> s -> s 11 | exec sa s = snd $ runState sa s 12 | 13 | eval :: State s a -> s -> a 14 | eval sa s = fst $ runState sa s 15 | 16 | modify :: (s -> s) -> State s () 17 | modify f = state $ \s -> ((), f s) 18 | -------------------------------------------------------------------------------- /chapter12/binarytree.hs: -------------------------------------------------------------------------------- 1 | data BinaryTree a = Leaf | Node (BinaryTree a) a (BinaryTree a) deriving (Eq, Ord, Show) 2 | 3 | unfold :: (a -> Maybe (a,b,a)) -> a -> BinaryTree b 4 | unfold f x = case f x of 5 | Nothing -> Leaf 6 | Just (x, y, z) -> Node (unfold f x) y (unfold f z) 7 | 8 | treeBuild :: Integer -> BinaryTree Integer 9 | treeBuild n = unfold f 0 10 | where f x 11 | | x == n = Nothing 12 | | otherwise = Just (x + 1, x, x + 1) 13 | -------------------------------------------------------------------------------- /chapter7/matchingTuples.hs: -------------------------------------------------------------------------------- 1 | module TupleFunctions where 2 | 3 | -- These have to be the same type because 4 | -- (+) is a -> a -> a 5 | addEmUp2 :: Num a => (a, a) -> a 6 | addEmUp2 (x, y) = x + y 7 | 8 | -- addEmUp2 could also be written like so (not pattern matching) 9 | addEmUp2Alt :: Num a => (a, a) -> a 10 | addEmUp2Alt tup = (fst tup) + (snd tup) 11 | 12 | fst3 :: (a, b, c) -> a 13 | fst3 (x, _, _) = x 14 | 15 | third3 :: (a, b, c) -> c 16 | third3 (_, _, x) = x 17 | -------------------------------------------------------------------------------- /chapter20/foldable.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | data Identity a = Identity a 4 | 5 | instance Foldable Identity where 6 | foldr f z (Identity x) = f x z 7 | foldl f z (Identity x) = f z x 8 | foldMap f (Identity x) = f x 9 | 10 | data Optional a = Yep a | Nada 11 | 12 | instance Foldable Optional where 13 | foldr _ z Nada = z 14 | foldr f z (Yep x) = f x z 15 | foldl _ z Nada = z 16 | foldl f z (Yep x) = f z x 17 | foldMap _ Nada = mempty 18 | foldMap f (Yep a) = f a 19 | -------------------------------------------------------------------------------- /chapter3/exercises.hs: -------------------------------------------------------------------------------- 1 | module Chapter3 where 2 | 3 | oneA :: [Char] -> [Char] 4 | oneA x = x ++ "!" 5 | 6 | oneB :: String -> String 7 | oneB x = [x !! 4] --[head (drop 4 x)] 8 | 9 | oneC :: String -> String 10 | oneC x = drop 9 x 11 | 12 | thirdLetter :: String -> Char 13 | thirdLetter x = x !! 3 14 | 15 | currying = "Curry is awesome" 16 | 17 | letterIndex :: Int -> Char 18 | letterIndex x = currying !! x 19 | 20 | rvrs :: String 21 | rvrs = (drop 9 currying) ++ take 4 (drop 5 currying) ++ (take 5 currying) 22 | -------------------------------------------------------------------------------- /chapter18/dosyntax.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 | binding :: IO () 19 | binding = do 20 | name <- getLine 21 | putStrLn name 22 | 23 | binding' :: IO () 24 | binding' = 25 | getLine >>= putStrLn 26 | -------------------------------------------------------------------------------- /chapter5/types.hs: -------------------------------------------------------------------------------- 1 | nonsense :: Bool -> Integer 2 | nonsense True = 805 3 | nonsense False = 31337 4 | 5 | typicalCurriedFunction :: Integer -> Bool -> Integer 6 | typicalCurriedFunction i b = i + (nonsense b) 7 | 8 | uncurriedFunction :: (Integer, Bool) -> Integer 9 | uncurriedFunction (i, b) = i + (nonsense b) 10 | 11 | anonymous :: Integer -> Bool -> Integer 12 | anonymous = \i b -> i + (nonsense b) 13 | 14 | anonymousAndManuallyNested :: Integer -> Bool -> Integer 15 | anonymousAndManuallyNested = \i -> \b -> i + (nonsense b) 16 | -------------------------------------------------------------------------------- /chapter2/intermission.hs: -------------------------------------------------------------------------------- 1 | piProduct :: Float -> Float 2 | piProduct x = 3.14 * x 3 | 4 | --Rewrite the following let expressions into declarations with where clauses: 5 | -- let x = 3; y = 1000 in x * 3 + y 6 | a = x * 3 + y 7 | where x = 3 8 | y = 1000 9 | 10 | -- let y = 10; x = 10 * 5 + y in x * 5 11 | b = x * 5 12 | where y = 10 13 | x = 10 * 5 + y 14 | 15 | -- let x = 7; y = negate x; z = y * 10 in z / x + y 16 | c = z / x + y 17 | where x = 7 18 | y = negate x 19 | z = y * 10 20 | -------------------------------------------------------------------------------- /chapter22/intro.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | 3 | hurr = (*2) 4 | durr = (+10) 5 | 6 | m :: Integer -> Integer 7 | m = hurr . durr 8 | 9 | m' :: Integer -> Integer 10 | m' = fmap hurr durr 11 | 12 | -- parallel computation using the Applicative 13 | m2 :: Integer -> Integer 14 | m2 = (+) <$> hurr <*> durr 15 | 16 | m3 :: Integer -> Integer 17 | m3 = liftA2 (+) hurr durr 18 | 19 | -- sequential (monadic) computation 20 | hurrDurr :: Integer -> Integer 21 | hurrDurr = do 22 | a <- hurr 23 | b <- durr 24 | return (a + b) 25 | -------------------------------------------------------------------------------- /chapter7/registeredUser.hs: -------------------------------------------------------------------------------- 1 | module RegisteredUser where 2 | 3 | newtype Username = Username String 4 | newtype AccountNumber = AccountNumber Integer 5 | 6 | data User = UnregisteredUser | RegisteredUser Username AccountNumber 7 | 8 | printUser :: User -> IO () 9 | printUser UnregisteredUser = putStrLn "UnregisteredUser" 10 | printUser (RegisteredUser (Username name) 11 | (AccountNumber acctNum)) 12 | = putStrLn $ name ++ " " ++ show acctNum 13 | 14 | -- printUser $ RegisteredUser (Username "gvolpe") (AccountNumber 123) 15 | -------------------------------------------------------------------------------- /chapter8/recursion.hs: -------------------------------------------------------------------------------- 1 | factorial :: Integer -> Integer 2 | factorial 0 = 1 3 | factorial n = n * factorial (n - 1) 4 | 5 | incTimes :: (Eq a, Num a) => a -> a -> a 6 | incTimes 0 n = n 7 | incTimes times n = 1 + (incTimes (times - 1) n) 8 | 9 | fibonacci :: Integral a => a -> a 10 | fibonacci 0 = 1 11 | fibonacci 1 = 1 12 | fibonacci x = fibonacci (x - 1) + fibonacci (x - 2) 13 | 14 | dividedBy :: Integral a => a -> a -> (a, a) 15 | dividedBy num denom = loop num denom 0 16 | where loop n d acc 17 | | n < d = (acc, n) 18 | | otherwise = loop (n - d) d (acc + 1) 19 | -------------------------------------------------------------------------------- /chapter16/FunctorLaws.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | module FunctorLaws where 4 | 5 | import Test.QuickCheck 6 | import Test.QuickCheck.Function 7 | 8 | functorIdentity :: (Functor f, Eq (f a)) => f a -> Bool 9 | functorIdentity f = fmap id f == f 10 | 11 | functorCompose :: (Eq (f c), Functor f) => (a -> b) -> (b -> c) -> f a -> Bool 12 | functorCompose f g x = (fmap g (fmap f x)) == (fmap (g . f) x) 13 | 14 | functorCompose' :: (Eq (f c), Functor f) => f a -> Fun a b -> Fun b c -> Bool 15 | functorCompose' x (Fun _ f) (Fun _ g) = (fmap (g . f) x) == (fmap g . fmap f $ x) 16 | -------------------------------------------------------------------------------- /chapter13/palindrome.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad (forever) 2 | import Data.Char 3 | import System.Exit (exitSuccess) 4 | 5 | isPalindrome :: String -> Bool 6 | isPalindrome x = w == reverse w 7 | where f = filter (\x -> x /= '\'' && x /= ',') 8 | w = f $ concat $ words $ map toLower x 9 | 10 | palindrome :: IO () 11 | palindrome = forever $ do 12 | line1 <- getLine 13 | case (line1 == reverse line1) of 14 | True -> do 15 | putStrLn "It's a palindrome!" 16 | return () 17 | False -> do 18 | putStrLn "Nope!" 19 | exitSuccess 20 | 21 | main :: IO () 22 | main = palindrome 23 | -------------------------------------------------------------------------------- /chapter18/intermission.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- Implement the Either Monad. 4 | data Sum a b = First a | Second b deriving (Eq, Show) 5 | 6 | instance Functor (Sum a) where 7 | fmap f (First x) = First x 8 | fmap f (Second x) = Second (f x) 9 | 10 | instance Applicative (Sum a) where 11 | pure = Second 12 | (First f) <*> _ = First f 13 | _ <*> (First x) = First x 14 | (Second f) <*> (Second x) = Second (f x) 15 | 16 | instance Monad (Sum a) where 17 | return = pure 18 | (Second x) >>= f = f x 19 | (First x) >>= _ = First x 20 | -------------------------------------------------------------------------------- /chapter7/intermission.hs: -------------------------------------------------------------------------------- 1 | --- Lamda expressions 2 | addOneIfOdd n = case odd n of 3 | True -> f n 4 | False -> n 5 | where f = \n -> n + 1 6 | 7 | addFive = \x -> \y -> (if x > y then y else x) + 5 8 | 9 | mflip f x y = f y x 10 | 11 | -- Pattern matching 12 | f :: (a, b, c) -> (d, e, f) -> ((a, d), (c, f)) 13 | f (a, _, c) (d, _, f) = ((a, d), (c, f)) 14 | 15 | -- Case Expressions 16 | functionC x y = case x > y of 17 | True -> x 18 | False -> y 19 | 20 | ifEvenAdd2 n = case even n of 21 | True -> (n+2) 22 | False -> n 23 | 24 | nums x = case compare x 0 of 25 | LT -> -1 26 | GT -> 1 27 | EQ -> 0 28 | -------------------------------------------------------------------------------- /chapter14/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 = 21 | forAll charGen 22 | (\c -> ((charToMorse c) >>= morseToChar) == Just c) 23 | 24 | main :: IO () 25 | main = quickCheck prop_thereAndBackAgain 26 | -------------------------------------------------------------------------------- /chapter7/exercises.hs: -------------------------------------------------------------------------------- 1 | tensDigit :: Integral a => a -> a 2 | tensDigit x = snd (divMod x 10) 3 | -- where xLast = div x 10 4 | -- d = mod xLast 10 5 | 6 | hunsDigit :: Integral a => a -> a 7 | hunsDigit x = g x 8 | where f = flip divMod 9 | g = snd . f 100 10 | 11 | foldBool :: a -> a -> Bool -> a 12 | foldBool = error "Error: Need to implement foldBool!" 13 | 14 | foldBool2 :: a -> a -> Bool -> a 15 | foldBool2 x y z 16 | | z == True = x 17 | | z == False = y 18 | 19 | foldBool3 :: a -> a -> Bool -> a 20 | foldBool3 x y True = x 21 | foldBool3 x y False = y 22 | 23 | g :: (a -> b) -> (a, c) -> (b, c) 24 | g f (x, y) = (f x, y) 25 | -------------------------------------------------------------------------------- /chapter7/arith2.hs: -------------------------------------------------------------------------------- 1 | module Arith2 where 2 | 3 | add :: Int -> Int -> Int 4 | add x y = x + y 5 | 6 | addPF :: Int -> Int -> Int 7 | addPF = (+) 8 | 9 | addOne :: Int -> Int 10 | addOne = \x -> x + 1 11 | 12 | addOnePF :: Int -> Int 13 | addOnePF = (+1) 14 | 15 | main :: IO () 16 | main = do 17 | print (0 :: Int) 18 | print (add 1 0) 19 | print (addOne 0) 20 | print (addOnePF 0) 21 | print ((addOne . addOne) 0) 22 | print ((addOnePF . addOne) 0) 23 | print ((addOne . addOnePF) 0) 24 | print ((addOnePF . addOnePF) 0) 25 | print (negate (addOne 0)) 26 | print ((negate . addOne) 0) 27 | print ((addOne . addOne . addOne . negate . addOne) 0) 28 | -------------------------------------------------------------------------------- /chapter8/wordNumbers.hs: -------------------------------------------------------------------------------- 1 | module WordNumber where 2 | 3 | import Data.List (intersperse) 4 | 5 | digitToWord :: Int -> String 6 | digitToWord n 7 | | n == 0 = "zero" 8 | | n == 1 = "one" 9 | | n == 2 = "two" 10 | | n == 3 = "three" 11 | | n == 4 = "four" 12 | | n == 5 = "five" 13 | | n == 6 = "six" 14 | | n == 7 = "seven" 15 | | n == 8 = "eight" 16 | | n == 9 = "nine" 17 | | otherwise = "not a digit" 18 | 19 | digits :: Int -> [Int] 20 | digits n = loop n [] 21 | where loop x acc 22 | | x < 10 = x : acc 23 | | otherwise = loop (div x 10) ((mod x 10) : acc) 24 | 25 | wordNumber :: Int -> String 26 | wordNumber n = concat $ intersperse "-" (map digitToWord $ digits n) 27 | -------------------------------------------------------------------------------- /chapter4/exercises.hs: -------------------------------------------------------------------------------- 1 | awesome = ["Papuchon", "curry", ":)"] 2 | alsoAwesome = ["Quake", "The Simons"] 3 | allAwesome = [awesome, alsoAwesome] 4 | 5 | one :: [a] -> Int 6 | one x = length x 7 | 8 | four :: Int -> [a] -> Int 9 | four x y = div x (length y) 10 | 11 | isPalindrome :: (Eq a) => [a] -> Bool 12 | isPalindrome x = reverse x == x 13 | 14 | myAbs :: Integer -> Integer 15 | myAbs x = if x < 0 then negate x else x 16 | 17 | f :: (a, b) -> (c, d) -> ((b, d), (a, c)) 18 | f x y = ((snd x, snd y), (fst x, fst y)) 19 | 20 | -- Reading Syntax exercises 21 | 22 | plusOne = (+ 1) 23 | 24 | lenPlusOne x = plusOne w where w = length x 25 | 26 | myId x = x 27 | 28 | myHead (x:xs) = x 29 | 30 | myFirst (x,y) = x 31 | -------------------------------------------------------------------------------- /chapter14/wordnumber/src/WordNumber.hs: -------------------------------------------------------------------------------- 1 | module WordNumber where 2 | 3 | import Data.List (intersperse) 4 | 5 | digitToWord :: Int -> String 6 | digitToWord n 7 | | n == 0 = "zero" 8 | | n == 1 = "one" 9 | | n == 2 = "two" 10 | | n == 3 = "three" 11 | | n == 4 = "four" 12 | | n == 5 = "five" 13 | | n == 6 = "six" 14 | | n == 7 = "seven" 15 | | n == 8 = "eight" 16 | | n == 9 = "nine" 17 | | otherwise = "not a digit" 18 | 19 | digits :: Int -> [Int] 20 | digits n = loop n [] 21 | where loop x acc 22 | | x < 10 = x : acc 23 | | otherwise = loop (div x 10) ((mod x 10) : acc) 24 | 25 | wordNumber :: Int -> String 26 | wordNumber n = concat $ intersperse "-" (map digitToWord $ digits n) 27 | -------------------------------------------------------------------------------- /chapter6/typeclasses.hs: -------------------------------------------------------------------------------- 1 | data DayOfWeek = Mon | Tue | Weds | Thu | Fri | Sat | Sun 2 | 3 | -- day of week and numerical day of month 4 | data Date = Date DayOfWeek Int 5 | 6 | instance Eq DayOfWeek where 7 | (==) Mon Mon = True 8 | (==) Tue Tue = True 9 | (==) Weds Weds = True 10 | (==) Thu Thu = True 11 | (==) Fri Fri = True 12 | (==) Sat Sat = True 13 | (==) Sun Sun = True 14 | (==) _ _ = False 15 | 16 | instance Eq Date where 17 | (==) (Date weekday dayOfMonth) 18 | (Date weekday' dayOfMonth') = 19 | weekday == weekday' && dayOfMonth == dayOfMonth' 20 | 21 | data Identity a = Identity a 22 | 23 | instance Eq a => Eq (Identity a) where 24 | (==) (Identity v) (Identity v') = v == v' 25 | -------------------------------------------------------------------------------- /chapter5/exercises.hs: -------------------------------------------------------------------------------- 1 | -- Write a type signature 2 | functionH :: [a] -> a 3 | functionH (x:_) = x 4 | 5 | functionC :: Ord a => a -> a -> Bool 6 | functionC x y = if (x > y) then True else False 7 | 8 | functionS :: (a, b) -> b 9 | functionS (x, y) = y 10 | 11 | -- Given a type, write the function 12 | i :: a -> a 13 | i x = x 14 | 15 | c :: a -> b -> a 16 | c x y = x 17 | 18 | -- Yes, c & c'' are the same 19 | c'' :: b -> a -> b 20 | c'' x y = x 21 | 22 | c' :: a -> b -> b 23 | c' x y = y 24 | 25 | -- r could be named tail 26 | r :: [a] -> [a] 27 | r (x:xs) = xs 28 | r [] = [] 29 | 30 | -- composition 31 | co :: (b -> c) -> (a -> b) -> (a -> c) 32 | co f g = f . g 33 | 34 | a :: (a -> c) -> a -> a 35 | a f x = x 36 | 37 | a' :: (a -> b) -> a -> b 38 | a' = f x 39 | -------------------------------------------------------------------------------- /chapter23/fizzbuzz.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Control.Monad.Trans.State 3 | 4 | fizzBuzz :: Integer -> String 5 | fizzBuzz n | n `mod` 15 == 0 = "FizzBuzz" 6 | | n `mod` 5 == 0 = "Fizz" 7 | | n `mod` 3 == 0 = "Buzz" 8 | | otherwise = show n 9 | 10 | fizzbuzzList :: [Integer] -> [String] 11 | fizzbuzzList list = execState (mapM_ addResult list) [] 12 | 13 | addResult :: Integer -> State [String] () 14 | addResult n = do 15 | xs <- get 16 | let result = fizzBuzz n 17 | put (result : xs) 18 | 19 | -- exercise (I was lazy here XD) 20 | fizzbuzzFromTo :: Integer -> Integer -> [String] 21 | fizzbuzzFromTo from to = fizzbuzzList [from..to] 22 | 23 | main :: IO () 24 | main = mapM_ putStrLn $ reverse $ fizzbuzzFromTo 1 100 25 | -------------------------------------------------------------------------------- /chapter23/intermission.hs: -------------------------------------------------------------------------------- 1 | import RandomExample 2 | import System.Random 3 | 4 | rollsToGetN :: Int -> StdGen -> Int 5 | rollsToGetN n = go 0 0 6 | where go :: Int -> Int -> StdGen -> Int 7 | go sum count gen 8 | | sum >= n = count 9 | | otherwise = 10 | let (die, nextGen) = randomR (1, 6) gen 11 | in go (sum + die) (count + 1) nextGen 12 | 13 | rollsCountLogged :: Int -> StdGen -> (Int, [Die]) 14 | rollsCountLogged n = go 0 0 [] 15 | where go :: Int -> Int -> [Die] -> StdGen -> (Int, [Die]) 16 | go sum count log gen 17 | | sum >= n = (count, log) 18 | | otherwise = 19 | let (die, nextGen) = randomR (1, 6) gen 20 | in go (sum + die) (count + 1) (intToDie die : log) nextGen 21 | -------------------------------------------------------------------------------- /chapter12/natural.hs: -------------------------------------------------------------------------------- 1 | module Naturals where 2 | 3 | data Nat = Zero | Succ Nat deriving (Eq, Show) 4 | 5 | -- >>> natToInteger Zero 6 | -- 0 7 | -- >>> natToInteger (Succ Zero) 8 | -- 1 9 | -- >>> natToInteger (Succ (Succ Zero)) 10 | -- 2 11 | natToInteger :: Nat -> Integer 12 | natToInteger Zero = 0 13 | natToInteger (Succ x) = 1 + (natToInteger x) 14 | 15 | -- >>> integerToNat 0 16 | -- Just Zero 17 | -- >>> integerToNat 1 18 | -- Just (Succ Zero) 19 | -- >>> integerToNat 2 20 | -- Just (Succ (Succ Zero)) 21 | -- >>> integerToNat (-1) 22 | -- Nothing 23 | validIntToNat :: Integer -> Nat 24 | validIntToNat 0 = Zero 25 | validIntToNat x = Succ $ validIntToNat (x - 1) 26 | 27 | integerToNat :: Integer -> Maybe Nat 28 | integerToNat x = case x >= 0 of 29 | True -> Just (validIntToNat x) 30 | False -> Nothing 31 | -------------------------------------------------------------------------------- /chapter17/ZipListMonoid.hs: -------------------------------------------------------------------------------- 1 | module ZipListMonoid 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 | -- unfortunate orphan instances. Try to avoid these 10 | -- in code you're going to keep or release. 11 | -- this isn't going to work properly 12 | instance Monoid a => Monoid (ZipList a) where 13 | mempty = pure mempty -- ZipList [] 14 | mappend = liftA2 mappend 15 | 16 | instance Arbitrary a => Arbitrary (ZipList a) where 17 | arbitrary = ZipList <$> arbitrary 18 | 19 | instance Arbitrary a => Arbitrary (Sum a) where 20 | arbitrary = Sum <$> arbitrary 21 | 22 | instance Eq a => EqProp (ZipList a) where (=-=) = eq 23 | 24 | main :: IO () 25 | main = do 26 | quickBatch $ monoid (ZipList [1 :: Sum Int]) 27 | -------------------------------------------------------------------------------- /chapter23/state.hs: -------------------------------------------------------------------------------- 1 | {-# Language InstanceSigs #-} 2 | 3 | import Text.Show.Functions 4 | 5 | newtype Moi s a = 6 | Moi { runMoi :: s -> (a, s) } deriving (Show) 7 | 8 | instance Functor (Moi s) where 9 | fmap :: (a -> b) -> Moi s a -> Moi s b 10 | fmap f (Moi g) = Moi $ \h -> 11 | let a = fst $ g h 12 | in (f a, h) 13 | 14 | instance Applicative (Moi s) where 15 | pure :: a -> Moi s a 16 | pure a = Moi $ \s -> (a, s) 17 | (<*>) :: Moi s (a -> b) -> Moi s a -> Moi s b 18 | (Moi f) <*> (Moi g) = Moi $ \h -> 19 | let ab = fst $ f h 20 | a = fst $ g h 21 | in (ab a, h) 22 | 23 | instance Monad (Moi s) where 24 | return = pure 25 | (>>=) :: Moi s a -> (a -> Moi s b) -> Moi s b 26 | (Moi f) >>= g = Moi $ \h -> 27 | let a = fst $ f h 28 | b = fst $ runMoi (g a) h 29 | in (b, h) 30 | -------------------------------------------------------------------------------- /chapter20/exercises.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | data Constant a b = Constant a deriving Show 4 | 5 | instance Foldable (Constant b) where 6 | foldMap _ _ = mempty 7 | 8 | data Two a b = Two a b deriving Show 9 | 10 | instance Foldable (Two a) where 11 | foldMap f (Two a b) = f b 12 | 13 | data Three a b c = Three a b c 14 | 15 | instance Foldable (Three a b) where 16 | foldMap f (Three a b c) = f c 17 | 18 | data Three' a b = Three' a b b 19 | 20 | instance Foldable (Three' a) where 21 | foldMap f (Three' a b c) = (f b) <> (f c) 22 | 23 | data Four' a b = Four' a b b b 24 | 25 | instance Foldable (Four' a) where 26 | foldMap f (Four' a b c d) = (f b) <> (f c) <> (f d) 27 | 28 | filterF :: (Applicative f, Foldable f, Monoid (f a)) => (a -> Bool) -> f a -> f a 29 | filterF f = foldMap (\x -> if f x then mempty else pure x) 30 | -------------------------------------------------------------------------------- /chapter5/type-kwon-do.hs: -------------------------------------------------------------------------------- 1 | module TypeKwonDo where 2 | 3 | data Woot 4 | data Blah 5 | 6 | f :: Woot -> Blah 7 | f x = undefined 8 | 9 | g :: (Blah, Woot) -> (Blah, Blah) 10 | g (x, y) = (x, x) 11 | 12 | -- one 13 | f1 :: Int -> String 14 | f1 x = show x 15 | 16 | g1 :: String -> Char 17 | g1 (x:xs) = x 18 | 19 | h1 :: Int -> Char 20 | h1 x = head $ show x 21 | 22 | -- two 23 | data A 24 | data B 25 | data C 26 | 27 | q :: A -> B 28 | q x = undefined 29 | 30 | w :: B -> C 31 | w x = undefined 32 | 33 | e :: A -> C 34 | e x = w $ q x 35 | 36 | -- three 37 | data X 38 | data Y 39 | data Z 40 | 41 | xz :: X -> Z 42 | xz = undefined 43 | 44 | yz :: Y -> Z 45 | yz = undefined 46 | 47 | xform :: (X, Y) -> (Z, Z) 48 | xform (x, y) = (xz x, yz y) 49 | 50 | -- four 51 | munge :: (x -> y) -> (y -> (w, z)) -> x -> w 52 | munge f g x = fst $ g $ f x 53 | -------------------------------------------------------------------------------- /chapter13/call-em-up/call-em-up.cabal: -------------------------------------------------------------------------------- 1 | -- Initial call-em-up.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: call-em-up 5 | version: 0.1.0.0 6 | synopsis: Call the sayHello function 7 | -- description: 8 | license: Apache-2.0 9 | license-file: LICENSE 10 | author: Gabi Volpe 11 | maintainer: gvolpe@github.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable call-em-up 19 | main-is: Main.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.8 && <4.9, hello 23 | hs-source-dirs: src 24 | default-language: Haskell2010 25 | -------------------------------------------------------------------------------- /chapter16/functors.hs: -------------------------------------------------------------------------------- 1 | data FixMePls a = FixMe | Pls a deriving (Eq, Show) 2 | 3 | instance Functor FixMePls where 4 | fmap _ FixMe = FixMe 5 | fmap f (Pls a) = Pls (f a) 6 | 7 | data Two a b = Two a b deriving (Eq, Show) 8 | data Or a b = First a | Second b deriving (Eq, Show) 9 | 10 | instance Functor (Two a) where 11 | fmap f (Two x y) = Two x (f y) 12 | 13 | instance Functor (Or a) where 14 | fmap _ (First x) = First x 15 | fmap f (Second x) = Second (f x) 16 | 17 | -- ``lifted'' because they've been lifted over 18 | -- some structure f 19 | liftedInc :: (Functor f, Num b) => f b -> f b 20 | liftedInc = fmap (+1) 21 | 22 | liftedShow :: (Functor f, Show a) => f a -> f String 23 | liftedShow = fmap show 24 | 25 | -- more functors 26 | data Wrap f a = Wrap (f a) deriving (Eq, Show) 27 | 28 | instance Functor f => Functor (Wrap f) where 29 | fmap f (Wrap fa) = Wrap (fmap f fa) 30 | -------------------------------------------------------------------------------- /chapter22/intermission.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 | -- Two simple functions with the same type, taking the same type of input. We could compose them, using (.) or fmap : 10 | composed :: [Char] -> [Char] 11 | composed = cap . rev 12 | 13 | fmapped :: [Char] -> [Char] 14 | fmapped = fmap cap rev 15 | 16 | -- We will want to use an applicative here. The type will look like this: 17 | tupled :: [Char] -> ([Char], [Char]) 18 | tupled = (,) <$> cap <*> rev 19 | 20 | tupled' :: [Char] -> ([Char], [Char]) 21 | tupled' = (,) <$> rev <*> cap 22 | 23 | -- Monadic implementation 24 | tupledM :: [Char] -> ([Char], [Char]) 25 | tupledM = do 26 | a <- cap 27 | b <- rev 28 | return (a, b) 29 | 30 | tupledM' :: [Char] -> ([Char], [Char]) 31 | tupledM' = cap >>= \a -> rev >>= \b -> return (a, b) 32 | -------------------------------------------------------------------------------- /chapter11/exercises.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Data.List 3 | 4 | isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool 5 | isSubsequenceOf a@(x:_) b@(y:_) = and $ foldr (\x acc -> elem x b : acc) [True] a 6 | 7 | f a@(x:xs) = (a, toUpper x : xs) 8 | 9 | capitalizeWords :: String -> [(String, String)] 10 | capitalizeWords = map f . words 11 | 12 | capitalizeWord :: String -> String 13 | capitalizeWord [] = [] 14 | capitalizeWord (x:xs) 15 | | x == ' ' = capitalizeWord xs 16 | | otherwise = toUpper x : xs 17 | 18 | -- generic function from module PoemLines 19 | splitOn :: Char -> String -> [String] 20 | splitOn c [] = [] 21 | splitOn c xs = (takeWhile (/=c) xs) : splitOn c (drop 1 $ dropWhile (/=c) xs) 22 | 23 | capitalizeParagraph :: String -> String 24 | capitalizeParagraph x = (concat $ intersperse ". " capitals) ++ "." 25 | where capitals = map capitalizeWord separated 26 | separated = splitOn '.' x 27 | -------------------------------------------------------------------------------- /chapter14/addition/addition.cabal: -------------------------------------------------------------------------------- 1 | -- Initial addition.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: addition 5 | version: 0.1.0.0 6 | synopsis: Addition and testing 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Gabi Volpe 11 | maintainer: gvolpe@github.com 12 | -- copyright: 13 | category: Testing 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Exercises 20 | ghc-options: -Wall -fwarn-tabs 21 | build-depends: base >=4.8 && <4.9 22 | , hspec 23 | , containers 24 | , QuickCheck 25 | hs-source-dirs: src 26 | default-language: Haskell2010 27 | -------------------------------------------------------------------------------- /chapter18/BadMonad.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 deriving (Eq, Show) 8 | 9 | instance Functor CountMe where 10 | fmap f (CountMe i a) = CountMe (i+1) (f a) 11 | 12 | instance Applicative CountMe where 13 | pure = CountMe 0 14 | CountMe n f <*> CountMe n' a = CountMe (n + n') (f a) 15 | 16 | instance Monad CountMe where 17 | return = pure 18 | CountMe n a >>= f = 19 | let CountMe _ b = f a 20 | in CountMe (n+1) b 21 | 22 | instance Arbitrary a => Arbitrary (CountMe a) where 23 | arbitrary = CountMe <$> arbitrary <*> arbitrary 24 | 25 | instance Eq a => EqProp (CountMe a) where (=-=) = eq 26 | 27 | main = do 28 | let trigger = undefined :: CountMe (Int, String, Int) 29 | quickBatch $ functor trigger 30 | quickBatch $ applicative trigger 31 | quickBatch $ monad trigger 32 | -------------------------------------------------------------------------------- /chapter11/jammin.hs: -------------------------------------------------------------------------------- 1 | module Jammin where 2 | 3 | import Data.List (sortBy, groupBy) 4 | 5 | data Fruit = Peach | Plum | Apple | Blackberry deriving (Eq, Ord, Show) 6 | 7 | data JamJars = Jam { fruit :: Fruit, count :: Int } deriving (Eq, Ord, Show) 8 | 9 | row1 = Jam Peach 5 10 | row2 = Jam Plum 7 11 | row3 = Jam Apple 3 12 | row4 = Jam Blackberry 9 13 | row5 = Jam Peach 2 14 | row6 = Jam Plum 1 15 | allJam = [row1, row2, row3, row4, row5, row6] 16 | 17 | jamCount :: [JamJars] -> [Int] 18 | jamCount = fmap count 19 | 20 | jamSum :: [JamJars] -> Int 21 | jamSum = foldr ((+) . count) 0 22 | 23 | mostRow :: [JamJars] -> JamJars 24 | mostRow = maximum 25 | 26 | compareKind :: JamJars -> JamJars -> Ordering 27 | compareKind (Jam k _) (Jam k' _) = compare k k' 28 | 29 | sortJam :: [JamJars] -> [JamJars] 30 | sortJam = sortBy compareKind 31 | 32 | groupJam :: [JamJars] -> [[JamJars]] 33 | groupJam = groupBy (\ a b -> compareKind a b == EQ) 34 | -------------------------------------------------------------------------------- /chapter23/RandomExample.hs: -------------------------------------------------------------------------------- 1 | module RandomExample where 2 | 3 | import System.Random 4 | 5 | -- Six-sided die 6 | data Die = 7 | DieOne 8 | | DieTwo 9 | | DieThree 10 | | DieFour 11 | | DieFive 12 | | DieSix 13 | deriving (Eq, Show) 14 | 15 | intToDie :: Int -> Die 16 | intToDie n = 17 | case n of 18 | 1 -> DieOne 19 | 2 -> DieTwo 20 | 3 -> DieThree 21 | 4 -> DieFour 22 | 5 -> DieFive 23 | 6 -> DieSix 24 | -- Use this tactic _extremely_ sparingly. 25 | x -> error $ "intToDie got non 1-6 integer: " ++ show x 26 | 27 | rollDieThreeTimes :: (Die, Die, Die) 28 | rollDieThreeTimes = do 29 | -- this will produce the same results every 30 | -- time because it is free of effects. 31 | -- This is fine for this demonstration. 32 | let s = mkStdGen 1 33 | (d1, s1) = randomR (1, 6) s 34 | (d2, s2) = randomR (1, 6) s1 35 | (d3, _) = randomR (1, 6) s2 36 | (intToDie d1, intToDie d2, intToDie d3) 37 | -------------------------------------------------------------------------------- /chapter13/hangman/hangman.cabal: -------------------------------------------------------------------------------- 1 | -- Initial hangman.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hangman 5 | version: 0.1.0.0 6 | synopsis: Hangman Game 7 | -- description: 8 | homepage: http://github.com/gvolpe 9 | license: Apache-2.0 10 | license-file: LICENSE 11 | author: Gabi Volpe 12 | maintainer: gvolpe@github.com 13 | -- copyright: 14 | category: Game 15 | build-type: Simple 16 | -- extra-source-files: 17 | cabal-version: >=1.10 18 | 19 | executable hangman 20 | main-is: Main.hs 21 | -- other-modules: 22 | -- other-extensions: 23 | build-depends: base >=4.8 && <4.9 24 | , random == 1.1 25 | , split == 0.2.2 26 | hs-source-dirs: src 27 | default-language: Haskell2010 28 | -------------------------------------------------------------------------------- /chapter12/eitherlib.hs: -------------------------------------------------------------------------------- 1 | module EitherSmallLib where 2 | 3 | getLeft :: Either a b -> [a] 4 | getLeft (Left x) = [x] 5 | getLeft _ = [] 6 | 7 | getRight :: Either a b -> [b] 8 | getRight (Right x) = [x] 9 | getRight _ = [] 10 | 11 | lefts' :: [Either a b] -> [a] 12 | lefts' = foldr (\x acc -> (getLeft x) ++ acc) [] 13 | 14 | rights' :: [Either a b] -> [b] 15 | rights' = foldr (\x acc -> (getRight x) ++ acc) [] 16 | 17 | partitionEithers' :: [Either a b] -> ([a], [b]) 18 | partitionEithers' xs = (lefts' xs, rights' xs) 19 | 20 | eitherMaybe' :: (b -> c) -> Either a b -> Maybe c 21 | eitherMaybe' f (Right x) = Just (f x) 22 | eitherMaybe' _ _ = Nothing 23 | 24 | either' :: (a -> c) -> (b -> c) -> Either a b -> c 25 | either' f g (Right x) = g x 26 | either' f g (Left x) = f x 27 | 28 | -- There's no info about (a -> c) here to define it in terms of either', don't know how to do it... 29 | eitherMaybe'' :: (b -> c) -> Either a b -> Maybe c 30 | eitherMaybe'' = undefined 31 | -------------------------------------------------------------------------------- /chapter17/ApplicativeLaws.hs: -------------------------------------------------------------------------------- 1 | module ApplicativeLaws where 2 | 3 | -- 1) Identity: pure id <*> [1..5] == [1..5] 4 | -- 2) Composition: pure (.) <*> [(+1)] <*> [(*2)] <*> [1, 2, 3] == [(+1)] <*> ([(*2)] <*> [1, 2, 3]) 5 | -- 3) Homomorphism: pure (+1) <*> pure 1 == pure ((+1) 1) 6 | -- 4) Interchange: Just (+3) <*> pure 1 == pure ($ 1) <*> Just (+3) 7 | 8 | import Data.Monoid 9 | import Test.QuickCheck 10 | import Test.QuickCheck.Checkers 11 | import Test.QuickCheck.Classes 12 | 13 | data Bull = Fools | Twoo deriving (Eq, Show) 14 | 15 | instance Arbitrary Bull where 16 | arbitrary = 17 | frequency [ (1, return Fools) 18 | , (1, return Twoo) ] 19 | 20 | instance Monoid Bull where 21 | mempty = Fools 22 | mappend _ _ = Fools 23 | 24 | instance EqProp Bull where (=-=) = eq 25 | 26 | x = [("b", "w", 1)] :: [(String, String, Int)] 27 | 28 | main :: IO () 29 | main = do 30 | --quickBatch $ monoid Twoo -- Bad Monoid rules breaker 31 | quickBatch $ applicative x 32 | -------------------------------------------------------------------------------- /chapter8/exercises.hs: -------------------------------------------------------------------------------- 1 | sumsAll :: (Eq a, Num a) => a -> a 2 | sumsAll 0 = 0 3 | sumsAll n = n + sumsAll (n - 1) 4 | 5 | multiplyR :: (Integral a) => a -> a -> a 6 | multiplyR x 0 = 0 7 | multiplyR x y = x + multiplyR x (y - 1) 8 | 9 | data DividedResult = Result Integer | DividedByZero deriving Show 10 | 11 | --dividedBy :: Integral a => a -> a -> DividedResult 12 | dividedBy :: Integer -> Integer -> DividedResult 13 | dividedBy _ 0 = DividedByZero 14 | dividedBy num denom = Result value 15 | where value 16 | | num < 0 && denom < 0 = result 17 | | num < 0 || denom < 0 = negate result 18 | | otherwise = result 19 | result = simpleDiv num denom 20 | 21 | simpleDiv :: Integral a => a -> a -> a 22 | simpleDiv num denom = loop (abs num) (abs denom) 0 23 | where loop n d acc 24 | | n < d = acc 25 | | otherwise = loop (n - d) d (acc + 1) 26 | 27 | mc91 :: Integral a => a -> a 28 | mc91 x 29 | | x > 100 = x - 10 30 | | otherwise = 91 31 | -------------------------------------------------------------------------------- /chapter11/vigenere-cipher.hs: -------------------------------------------------------------------------------- 1 | module VigenereCipher where 2 | 3 | import Data.Char 4 | 5 | type Shift = Int 6 | 7 | keyword = "ALLY" 8 | 9 | magicZip :: String -> String -> [(Char, Char)] 10 | magicZip [] _ = [] 11 | magicZip _ [] = [] 12 | magicZip (x:xs) (y:ys) 13 | | x == ' ' = (x,x) : magicZip xs (y : ys) 14 | | otherwise = (x,y) : magicZip xs ys 15 | 16 | shift :: Char -> Shift 17 | shift x 18 | | x == head keyword || x == ' ' = 0 19 | | otherwise = ord x - ord (head keyword) 20 | 21 | shiftings :: (Char -> Shift) -> String -> [Shift] 22 | shiftings f x = map (f . snd) $ magicZip x keywordStream 23 | where keywordStream = concat $ repeat keyword 24 | 25 | codec :: ((Char, Shift) -> Char) -> String -> String 26 | codec f x = map f valueWithShifts 27 | where valueWithShifts = zip x $ shiftings shift x 28 | 29 | encode :: String -> String 30 | encode = codec (\(x,y) -> chr $ (ord x) + y) 31 | 32 | decode :: String -> String 33 | decode = codec (\(x,y) -> chr $ (ord x) - y) 34 | -------------------------------------------------------------------------------- /chapter14/wordnumber/src/VigenereCipher.hs: -------------------------------------------------------------------------------- 1 | module VigenereCipher (encode, decode) where 2 | 3 | import Data.Char 4 | 5 | type Shift = Int 6 | 7 | keyword = "ALLY" 8 | 9 | magicZip :: String -> String -> [(Char, Char)] 10 | magicZip [] _ = [] 11 | magicZip _ [] = [] 12 | magicZip (x:xs) (y:ys) 13 | | x == ' ' = (x,x) : magicZip xs (y : ys) 14 | | otherwise = (x,y) : magicZip xs ys 15 | 16 | shift :: Char -> Shift 17 | shift x 18 | | x == head keyword || x == ' ' = 0 19 | | otherwise = ord x - ord (head keyword) 20 | 21 | shiftings :: (Char -> Shift) -> String -> [Shift] 22 | shiftings f x = map (f . snd) $ magicZip x keywordStream 23 | where keywordStream = concat $ repeat keyword 24 | 25 | codec :: ((Char, Shift) -> Char) -> String -> String 26 | codec f x = map f valueWithShifts 27 | where valueWithShifts = zip x $ shiftings shift x 28 | 29 | encode :: String -> String 30 | encode = codec (\(x,y) -> chr $ (ord x) + y) 31 | 32 | decode :: String -> String 33 | decode = codec (\(x,y) -> chr $ (ord x) - y) 34 | -------------------------------------------------------------------------------- /chapter17/listap.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | data List a = Nil | Cons a (List a) deriving (Eq, Show) 4 | 5 | instance Monoid (List a) where 6 | mempty = Nil 7 | mappend Nil x = x 8 | mappend x Nil = x 9 | mappend (Cons x xs) ys = Cons x $ xs <> ys 10 | 11 | instance Functor List where 12 | fmap _ Nil = Nil 13 | fmap f (Cons x y) = Cons (f x) (fmap f y) 14 | 15 | instance Applicative List where 16 | pure x = Cons x Nil 17 | Nil <*> _ = Nil 18 | _ <*> Nil = Nil 19 | Cons f x <*> y = (f <$> y) <> (x <*> y) 20 | 21 | append :: List a -> List a -> List a 22 | append Nil ys = ys 23 | append (Cons x xs) ys = Cons x $ xs `append` ys 24 | 25 | fold :: (a -> b -> b) -> b -> List a -> b 26 | fold _ b Nil = b 27 | fold f b (Cons h t) = f h (fold f b t) 28 | 29 | concat' :: List (List a) -> List a 30 | concat' = fold append Nil 31 | 32 | -- write this one in terms of concat' and fmap 33 | flatMap :: (a -> List b) -> List a -> List b 34 | flatMap f xs = concat' $ fmap f xs 35 | -------------------------------------------------------------------------------- /chapter23/RandomStateExample.hs: -------------------------------------------------------------------------------- 1 | module RandomStateExample where 2 | 3 | import Control.Applicative (liftA3) 4 | import Control.Monad (replicateM) 5 | import Control.Monad.Trans.State 6 | import RandomExample (Die, intToDie) 7 | import System.Random 8 | 9 | rollDie :: State StdGen Die 10 | rollDie = state $ do 11 | (n, s) <- randomR (1, 6) 12 | return (intToDie n, s) 13 | 14 | rollDie' :: State StdGen Die 15 | rollDie' = intToDie <$> state (randomR (1, 6)) 16 | 17 | rollDieThreeTimes' :: State StdGen (Die, Die, Die) 18 | rollDieThreeTimes' = 19 | liftA3 (,,) rollDie rollDie rollDie 20 | 21 | infiniteDie :: State StdGen [Die] 22 | infiniteDie = repeat <$> rollDie 23 | 24 | nDie :: Int -> State StdGen [Die] 25 | nDie n = replicateM n rollDie 26 | 27 | rollsToGetTwenty :: StdGen -> Int 28 | rollsToGetTwenty g = go 0 0 g 29 | where go :: Int -> Int -> StdGen -> Int 30 | go sum count gen 31 | | sum >= 20 = count 32 | | otherwise = 33 | let (die, nextGen) = randomR (1, 6) gen 34 | in go (sum + die) (count + 1) nextGen 35 | -------------------------------------------------------------------------------- /chapter15/intermission.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | import MonoidLaws 3 | import Test.QuickCheck 4 | 5 | data Optional a = Nada | Only a deriving (Eq, Show) 6 | 7 | instance Monoid a => Monoid (Optional a) where 8 | mempty = Nada 9 | mappend Nada Nada = Nada 10 | mappend (Only x) (Only y) = Only (x <> y) 11 | mappend (Only x) Nada = Only x 12 | mappend Nada (Only y) = Only y 13 | 14 | newtype First' a = First' { getFirst' :: Optional a } deriving (Eq, Show) 15 | 16 | instance Monoid (First' a) where 17 | mempty = First' Nada 18 | mappend (First' Nada) (First' y) = First' y 19 | mappend (First' (Only x)) _ = First' (Only x) 20 | 21 | firstMappend :: First' a -> First' a -> First' a 22 | firstMappend = mappend 23 | 24 | type FirstMappend = First' String -> First' String -> First' String -> Bool 25 | 26 | --exercise :: IO () 27 | --exercise = do 28 | -- quickCheck (monoidAssoc :: FirstMappend) 29 | -- quickCheck (monoidLeftIdentity :: First' String -> Bool) 30 | --quickCheck (monoidRightIdentity :: First' String -> Bool) 31 | -------------------------------------------------------------------------------- /chapter13/persongame.hs: -------------------------------------------------------------------------------- 1 | module PersonGame where 2 | 3 | import System.IO 4 | 5 | type Name = String 6 | type Age = Integer 7 | 8 | data Person = Person Name Age deriving Show 9 | data PersonInvalid = NameEmpty | AgeTooLow | PersonInvalidUnknown String deriving (Eq, Show) 10 | 11 | mkPerson :: Name -> Age -> Either PersonInvalid Person 12 | mkPerson name age 13 | | name /= "" && age > 0 = Right $ Person name age 14 | | name == "" = Left NameEmpty 15 | | not (age > 0) = Left AgeTooLow 16 | | otherwise = Left $ PersonInvalidUnknown $ 17 | "Name was: " ++ show name ++ 18 | " Age was: " ++ show age 19 | 20 | gimmePerson :: IO () 21 | gimmePerson = do 22 | hSetBuffering stdout NoBuffering 23 | putStr "Please enter a name: " 24 | name <- getLine 25 | putStr "Please enter an age: " 26 | age <- getLine 27 | case (mkPerson name (read age :: Integer)) of 28 | (Left e) -> do 29 | print e 30 | return () 31 | (Right p) -> do 32 | print p 33 | return () 34 | 35 | main :: IO () 36 | main = gimmePerson 37 | -------------------------------------------------------------------------------- /chapter17/applicatives.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Test.QuickCheck 3 | 4 | f x = lookup x [(3, "hello"), (4, "julie"), (5, "kbai")] 5 | g y = lookup y [(7, "sup?"), (8, "chris"), (9, "aloha")] 6 | 7 | h z = lookup z [(2, 3), (5, 6), (7, 8)] 8 | m x = lookup x [(4, 10), (8, 13), (1, 9001)] 9 | 10 | a = (++) <$> f 3 <*> g 7 11 | a' = liftA2 (++) (f 3) (g 7) 12 | 13 | main :: IO () 14 | main = do 15 | quickCheck (a == a') 16 | 17 | -- Maybe Applicative 18 | validateLength :: Int -> String -> Maybe String 19 | validateLength maxLen s = 20 | if (length s) > maxLen 21 | then Nothing 22 | else Just s 23 | 24 | newtype Name = Name String deriving (Eq, Show) 25 | newtype Address = Address String deriving (Eq, Show) 26 | 27 | mkName :: String -> Maybe Name 28 | mkName s = fmap Name $ validateLength 25 s 29 | 30 | mkAddress :: String -> Maybe Address 31 | mkAddress a = fmap Address $ validateLength 100 a 32 | 33 | data Person = Person Name Address deriving (Eq, Show) 34 | 35 | mkPerson :: String -> String -> Maybe Person 36 | mkPerson n a = Person <$> mkName n <*> mkAddress a 37 | -------------------------------------------------------------------------------- /chapter15/madlib.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 10 | -> Adverb 11 | -> Noun 12 | -> Adjective 13 | -> String 14 | madlibbin' e adv noun adj = 15 | e <> "! he said " <> 16 | adv <> " as he jumped into his car " <> 17 | noun <> " and drove off with this " <> 18 | adj <> " wife." 19 | 20 | madlibbinBetter' :: Exclamation 21 | -> Adverb 22 | -> Noun 23 | -> Adjective 24 | -> String 25 | madlibbinBetter' e adv noun adj = mconcat [e 26 | ,"! he said " 27 | , adv 28 | , " as he jumped into his car " 29 | , noun 30 | , " and drove off with this " 31 | , adj 32 | , " wife."] 33 | -------------------------------------------------------------------------------- /chapter10/exercises.hs: -------------------------------------------------------------------------------- 1 | stops = "pbtdkg" 2 | vowels = "aeiou" 3 | 4 | one = [(x,y,z) | x <- stops, y <- vowels, z <- stops] 5 | two = [(x,y,z) | x <- stops, y <- vowels, z <- stops, x == 'p'] 6 | 7 | -- avg 8 | seekritFunc x = div (sum (map length (words x))) (length (words x)) 9 | avg x = sumLen / len 10 | where len = fromIntegral $ length (words x) 11 | sumLen = fromIntegral $ sum $ map length (words x) 12 | 13 | -- using folds 14 | myOr :: [Bool] -> Bool 15 | myOr = foldr (||) False 16 | 17 | myAny :: (a -> Bool) -> [a] -> Bool 18 | myAny f = foldr (\ a b -> f a || b) False 19 | 20 | myElem :: Eq a => a -> [a] -> Bool 21 | myElem x = foldr (\ a b -> x == a || b) False 22 | 23 | myElem' :: Eq a => a -> [a] -> Bool 24 | myElem' _ [] = False 25 | myElem' x xs = any (==x) xs 26 | 27 | myReverse :: [a] -> [a] 28 | myReverse = foldl (flip (:)) [] 29 | 30 | myMap :: (a -> b) -> [a] -> [b] 31 | myMap f = foldr (\ a b -> f a : b) [] 32 | 33 | myFilter :: (a -> Bool) -> [a] -> [a] 34 | myFilter f = foldr (\ a b -> if f a then a : b else b) [] 35 | 36 | squish :: [[a]] -> [a] 37 | squish = foldr (++) [] 38 | 39 | squishMap :: (a -> [b]) -> [a] -> [b] 40 | squishMap f = foldr ((++) . f) [] 41 | 42 | -------------------------------------------------------------------------------- /chapter18/EitherMonad.hs: -------------------------------------------------------------------------------- 1 | module EitherMonad where 2 | 3 | -- years ago 4 | type Founded = Int 5 | 6 | -- number of programmers 7 | type Coders = Int 8 | data SoftwareShop = 9 | Shop { 10 | founded :: Founded 11 | , programmers :: Coders 12 | } 13 | deriving (Eq, Show) 14 | 15 | data FoundedError = 16 | NegativeYears Founded 17 | | TooManyYears Founded 18 | | NegativeCoders Coders 19 | | TooManyCoders Coders 20 | | TooManyCodersForYears Founded Coders 21 | deriving (Eq, Show) 22 | 23 | validateFounded :: Int -> Either FoundedError Founded 24 | validateFounded n 25 | | n < 0 = Left $ NegativeYears n 26 | | n > 500 = Left $ TooManyYears n 27 | | otherwise = Right $ n 28 | 29 | validateCoders :: Int -> Either FoundedError Coders 30 | validateCoders n 31 | | n < 0 = Left $ NegativeCoders n 32 | | n > 5000 = Left $ TooManyCoders n 33 | | otherwise = Right n 34 | 35 | mkSoftware :: Int -> Int -> Either FoundedError SoftwareShop 36 | mkSoftware years coders = do 37 | founded <- validateFounded years 38 | programmers <- validateCoders coders 39 | if programmers > div founded 10 40 | then Left $ TooManyCodersForYears founded programmers 41 | else Right $ Shop founded programmers 42 | -------------------------------------------------------------------------------- /chapter6/intermission.hs: -------------------------------------------------------------------------------- 1 | data TisAnInteger = TisAn Integer 2 | 3 | instance Eq TisAnInteger where 4 | (==) (TisAn v) (TisAn v') = v == v' 5 | 6 | data TwoIntegers = Two Integer Integer 7 | 8 | instance Eq TwoIntegers where 9 | (==) (Two a b) (Two a' b') = a == a' && b == b' 10 | 11 | data StringOrInt = TisAnInt Int | TisAString String 12 | 13 | instance Eq StringOrInt where 14 | (==) (TisAnInt v) (TisAnInt v') = v == v' 15 | (==) (TisAString v) (TisAString v') = v == v' 16 | (==) (_) (_) = False 17 | 18 | data Pair a = Pair a a 19 | 20 | instance Eq a => Eq (Pair a) where 21 | (==) (Pair x y) (Pair x' y') = x == x' && y == y' 22 | 23 | data Tuple a b = Tuple a b 24 | 25 | instance (Eq a, Eq b) => Eq (Tuple a b) where 26 | (==) (Tuple x y) (Tuple x' y') = x == x' && y == y' 27 | 28 | data Which a = ThisOne a | ThatOne a 29 | 30 | instance Eq a => Eq (Which a) where 31 | (==) (ThisOne x) (ThisOne x') = x == x' 32 | (==) (ThatOne x) (ThatOne x') = x == x' 33 | (==) (_) (_) = False 34 | 35 | data EitherOr a b = Hello a | Goodbye b 36 | 37 | instance (Eq a, Eq b) => Eq (EitherOr a b) where 38 | (==) (Hello x) (Hello x') = x == x' 39 | (==) (Goodbye x) (Goodbye x') = x == x' 40 | (==) (_) (_) = False 41 | -------------------------------------------------------------------------------- /chapter15/MonoidLaws.hs: -------------------------------------------------------------------------------- 1 | module MonoidLaws (monoidAssoc, monoidLeftIdentity, monoidRightIdentity) where 2 | 3 | import Control.Monad 4 | import Data.Monoid 5 | import Test.QuickCheck 6 | 7 | monoidAssoc :: (Eq m, Monoid m) => m -> m -> m -> Bool 8 | monoidAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c) 9 | 10 | monoidLeftIdentity :: (Eq m, Monoid m) => m -> Bool 11 | monoidLeftIdentity a = (mempty <> a) == a 12 | 13 | monoidRightIdentity :: (Eq m, Monoid m) => m -> Bool 14 | monoidRightIdentity a = (a <> mempty) == a 15 | 16 | type S = String 17 | type B = Bool 18 | 19 | data Bull = Fools | Twoo deriving (Eq, Show) 20 | 21 | instance Arbitrary Bull where 22 | arbitrary = frequency [ (1, return Fools) 23 | , (1, return Twoo) ] 24 | 25 | instance Monoid Bull where 26 | mempty = Fools 27 | mappend _ _ = Fools 28 | 29 | type BullMappend = Bull -> Bull -> Bull -> Bool 30 | 31 | main :: IO () 32 | main = do 33 | quickCheck (monoidAssoc :: S -> S -> S -> B) 34 | quickCheck (monoidLeftIdentity :: S -> B) 35 | quickCheck (monoidRightIdentity :: S -> B) 36 | 37 | notabiding :: IO () 38 | notabiding = do 39 | quickCheck (monoidAssoc :: BullMappend) 40 | quickCheck (monoidLeftIdentity :: Bull -> Bool) 41 | quickCheck (monoidRightIdentity :: Bull -> Bool) 42 | 43 | -------------------------------------------------------------------------------- /chapter9/exercises.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | filterUppercase :: String -> String 4 | filterUppercase xs = filter isUpper xs 5 | 6 | capitalize :: String -> String 7 | capitalize [] = [] 8 | capitalize (x:xs) = toUpper x : xs 9 | 10 | toUppercase :: String -> String 11 | toUppercase [] = [] 12 | toUppercase (x:xs) = toUpper x : toUppercase xs 13 | 14 | capitalizeHead :: String -> Maybe Char 15 | capitalizeHead [] = Nothing 16 | capitalizeHead (x:xs) = Just (toUpper x) 17 | 18 | capitalizeHead' :: String -> Char 19 | capitalizeHead' = toUpper . head 20 | 21 | -- more 22 | 23 | myOr :: [Bool] -> Bool 24 | myOr [] = False 25 | myOr (x:xs) = if x == True then True else myOr xs 26 | 27 | myAny :: (a -> Bool) -> [a] -> Bool 28 | myAny _ [] = False 29 | myAny f (x:xs) = if f x then True else myAny f xs 30 | 31 | myElem :: Eq a => a -> [a] -> Bool 32 | myElem _ [] = False 33 | myElem x (y:ys) = if x == y then True else myElem x ys 34 | 35 | myElem' :: Eq a => a -> [a] -> Bool 36 | myElem' _ [] = False 37 | myElem' x xs = any (==x) xs 38 | 39 | myReverse :: [a] -> [a] 40 | myReverse [] = [] 41 | myReverse (x:xs) = myReverse xs ++ x : [] 42 | 43 | squish :: [[a]] -> [a] 44 | squish [] = [] 45 | squish (x:xs) = x ++ squish xs 46 | 47 | squishMap :: (a -> [b]) -> [a] -> [b] 48 | squishMap _ [] = [] 49 | squishMap f xs = squish $ map f xs 50 | 51 | -------------------------------------------------------------------------------- /chapter12/signaling.hs: -------------------------------------------------------------------------------- 1 | type Name = String 2 | type Age = Integer 3 | 4 | data Person = Person Name Age deriving Show 5 | 6 | mkPersonM :: Name -> Age -> Maybe Person 7 | mkPersonM name age 8 | | name /= "" && age >= 0 = Just $ Person name age 9 | | otherwise = Nothing 10 | 11 | data PersonInvalid = NameEmpty | AgeTooLow deriving (Eq, Show) 12 | 13 | mkPersonE :: Name -> Age -> Either PersonInvalid Person 14 | mkPersonE name age 15 | | age < 0 = Left AgeTooLow 16 | | name == "" = Left NameEmpty 17 | | otherwise = Right $ Person name age 18 | 19 | type ValidatePerson a = Either [PersonInvalid] a 20 | 21 | ageOkay :: Age -> Either [PersonInvalid] Age 22 | ageOkay age = case age >=0 of 23 | True -> Right age 24 | False -> Left [AgeTooLow] 25 | 26 | nameOkay :: Name -> Either [PersonInvalid] Name 27 | nameOkay name = case name /= "" of 28 | True -> Right name 29 | False -> Left [NameEmpty] 30 | 31 | mkPerson :: Name -> Age -> ValidatePerson Person 32 | mkPerson name age = mkPerson' (nameOkay name) (ageOkay age) 33 | 34 | mkPerson' :: ValidatePerson Name -> ValidatePerson Age -> ValidatePerson Person 35 | mkPerson' (Right nameOk) (Right ageOk) = Right (Person nameOk ageOk) 36 | mkPerson' (Left badName) (Left badAge) = Left (badName ++ badAge) 37 | mkPerson' (Left badName) _ = Left badName 38 | mkPerson' _ (Left badAge) = Left badAge 39 | -------------------------------------------------------------------------------- /chapter9/poemLines.hs: -------------------------------------------------------------------------------- 1 | module PoemLines where 2 | 3 | -- generic function for both myWords and myLines 4 | splitOn :: Char -> String -> [String] 5 | splitOn c [] = [] 6 | splitOn c xs = (takeWhile (/=c) xs) : splitOn c (drop 1 $ dropWhile (/=c) xs) 7 | 8 | -- takeWhile & dropWhile first exercise 9 | myWords :: String -> [String] 10 | myWords xs = splitOn ' ' xs 11 | 12 | -- poem sentences 13 | firstSen = "Tyger Tyger, burning bright\n" 14 | secondSen = "In the forests of the night\n" 15 | thirdSen = "What immortal hand or eye\n" 16 | fourthSen = "Could frame thy fearful symmetry?" 17 | sentences = firstSen ++ secondSen ++ thirdSen ++ fourthSen 18 | 19 | -- putStrLn sentences -- should print 20 | -- Tyger Tyger, burning bright 21 | -- In the forests of the night 22 | -- What immortal hand or eye 23 | -- Could frame thy fearful symmetry? 24 | -- Implement this 25 | myLines :: String -> [String] 26 | myLines xs = splitOn '\n' xs 27 | 28 | -- What we want 'myLines sentences' to equal 29 | shouldEqual = 30 | [ "Tyger Tyger, burning bright" 31 | , "In the forests of the night" 32 | , "What immortal hand or eye" 33 | , "Could frame thy fearful symmetry?" 34 | ] 35 | 36 | -- The main function here is a small test 37 | -- to ensure you've written your function 38 | -- correctly. 39 | main :: IO () 40 | main = print $ "Are they equal? " ++ show (myLines sentences == shouldEqual) 41 | -------------------------------------------------------------------------------- /chapter9/intermission.hs: -------------------------------------------------------------------------------- 1 | myEnumFromTo :: (Ord a, Enum a) => a-> a -> [a] 2 | myEnumFromTo x y 3 | | x < y = x : myEnumFromTo (succ x) y 4 | | otherwise = [] 5 | 6 | -- I don't get the requirement for these 4 functions... I can only think about class constraint to make it work. 7 | eftBool :: Bool -> Bool -> [Bool] 8 | eftBool x y = x : y : [] 9 | 10 | eftOrd :: Ordering -> Ordering -> [Ordering] 11 | eftOrd = undefined 12 | 13 | eftInt :: Int -> Int -> [Int] 14 | eftInt = undefined 15 | 16 | eftChar :: Char -> Char -> [Char] 17 | eftChar = undefined 18 | 19 | -- list comprehensions 20 | mySqr = [x^2 | x <- [1..5]] 21 | myCube = [y^3 | y <- [1..5]] 22 | 23 | one = [(x,y) | x <- mySqr, y <- myCube] 24 | two = [(x,y) | x <- mySqr, y <- myCube, x < 50, y < 50] 25 | three = (length one) - (length two) 26 | 27 | -- filter 28 | fOne xs = filter (\x -> rem x 3 == 0) xs 29 | fTwo = length . fOne 30 | 31 | myFilter xs = filter (\x -> x/="the" && x/="an" && x/="a") $ words xs 32 | 33 | -- zip 34 | myZip :: [a] -> [b] -> [(a,b)] 35 | myZip [] _ = [] 36 | myZip _ [] = [] 37 | myZip (x:xs) (y:ys) = (x,y) : myZip xs ys 38 | 39 | myZipWith :: (a -> b -> c) -> [a] -> [b] -> [c] 40 | myZipWith _ [] _ = [] 41 | myZipWith _ _ [] = [] 42 | myZipWith f (x:xs) (y:ys) = f x y : myZipWith f xs ys 43 | 44 | myZip' :: [a] -> [b] -> [(a,b)] 45 | myZip' = myZipWith (,) 46 | -------------------------------------------------------------------------------- /chapter11/intermission.hs: -------------------------------------------------------------------------------- 1 | data Price = Price Integer deriving (Eq, Show) 2 | 3 | data Manufacturer = Mini | Mazda | Tata deriving (Eq, Show) 4 | 5 | data Airline = PapuAir | CatapultsR'Us | TakeYourChancesUnited deriving (Eq, Show) 6 | 7 | data Vehicle = Car Manufacturer Price | Plane Airline deriving (Eq, Show) 8 | 9 | myCar = Car Mini (Price 14000) 10 | urCar = Car Mazda (Price 20000) 11 | clownCar = Car Tata (Price 7000) 12 | doge = Plane PapuAir 13 | 14 | isCar :: Vehicle -> Bool 15 | isCar (Car _ _) = True 16 | isCar _ = False 17 | 18 | isPlane :: Vehicle -> Bool 19 | isPlane (Plane _) = True 20 | isPlane _ = False 21 | 22 | areCars :: [Vehicle] -> [Bool] 23 | areCars = fmap isCar 24 | 25 | getManu :: Vehicle -> Maybe Manufacturer 26 | getManu (Car m _) = Just m 27 | getManu _ = Nothing 28 | 29 | data OperatingSystem = GnuPlusLinux | OpenBSD | Mac | Windows deriving (Eq, Show) 30 | data ProgrammingLanguage = Haskell | Agda | Idris | PureScript deriving (Eq, Show) 31 | data Programmer = Programmer { os :: OperatingSystem, lang :: ProgrammingLanguage } deriving (Eq, Show) 32 | 33 | allOperatingSystems :: [OperatingSystem] 34 | allOperatingSystems = [GnuPlusLinux, OpenBSD, Mac, Windows] 35 | 36 | allLanguages :: [ProgrammingLanguage] 37 | allLanguages = [Haskell, Agda, Idris, PureScript] 38 | 39 | allProgrammers :: [Programmer] 40 | allProgrammers = [Programmer {os = x, lang = y} | x <- allOperatingSystems, y <- allLanguages] 41 | 42 | -------------------------------------------------------------------------------- /chapter10/intermission.hs: -------------------------------------------------------------------------------- 1 | import Data.Time 2 | 3 | data DatabaseItem = DbString String 4 | | DbNumber Integer 5 | | DbDate UTCTime 6 | deriving (Eq, Ord, Show) 7 | 8 | theDatabase :: [DatabaseItem] 9 | theDatabase = 10 | [ DbDate (UTCTime 11 | (fromGregorian 1911 5 1) 12 | (secondsToDiffTime 34123)) 13 | , DbNumber 9001 14 | , DbString "Hello, world!" 15 | , DbDate (UTCTime 16 | (fromGregorian 1921 5 1) 17 | (secondsToDiffTime 34123)) 18 | ] 19 | 20 | -- Generic for filter db 21 | filterDb :: (DatabaseItem -> [a]) -> [DatabaseItem] -> [a] 22 | filterDb _ [] = [] 23 | filterDb f xs = foldr (\ x y -> f x ++ y) [] xs 24 | --filterDb f xs = concat $ map f xs -- SAME RESULT 25 | 26 | filterDbDate :: [DatabaseItem] -> [UTCTime] 27 | filterDbDate = filterDb onlyTime 28 | 29 | onlyTime :: DatabaseItem -> [UTCTime] 30 | onlyTime x = case x of 31 | DbDate time -> time : [] 32 | _ -> [] 33 | 34 | filterDbNumber :: [DatabaseItem] -> [Integer] 35 | filterDbNumber = filterDb onlyNumber 36 | 37 | onlyNumber :: DatabaseItem -> [Integer] 38 | onlyNumber x = case x of 39 | DbNumber number -> number : [] 40 | _ -> [] 41 | 42 | mostRecent :: [DatabaseItem] -> UTCTime 43 | mostRecent = maximum . filterDbDate 44 | 45 | sumDb :: [DatabaseItem] -> Integer 46 | sumDb = sum . filterDbNumber 47 | 48 | avgDb :: [DatabaseItem] -> Double 49 | avgDb xs = avg $ map fromInteger $ filterDbNumber xs 50 | 51 | avg :: Fractional a => [a] -> a 52 | avg xs = (sum xs) / fromIntegral (length xs) 53 | -------------------------------------------------------------------------------- /chapter14/morse/morse.cabal: -------------------------------------------------------------------------------- 1 | -- Initial morse.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: morse 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Gabi Volpe 11 | maintainer: gvolpe@github.com 12 | -- copyright: 13 | category: Testing 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Morse 20 | ghc-options: -Wall -fwarn-tabs 21 | build-depends: base >=4.8 && <4.9 22 | , containers 23 | , QuickCheck 24 | hs-source-dirs: src 25 | default-language: Haskell2010 26 | 27 | executable morse 28 | main-is: Main.hs 29 | ghc-options: -Wall -fwarn-tabs 30 | build-depends: base >=4.8 && <4.9 31 | , containers 32 | , morse 33 | , QuickCheck 34 | hs-source-dirs: src 35 | default-language: Haskell2010 36 | 37 | test-suite tests 38 | ghc-options: -Wall -fwarn-tabs 39 | type: exitcode-stdio-1.0 40 | main-is: tests.hs 41 | hs-source-dirs: tests 42 | build-depends: base >=4.8 && <4.9 43 | , containers 44 | , morse 45 | , QuickCheck 46 | default-language: Haskell2010 47 | -------------------------------------------------------------------------------- /chapter19/urlshortener/urlshortener.cabal: -------------------------------------------------------------------------------- 1 | name: urlshortener 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/gvolpe/haskell-book-exercises/tree/master/chapter19/urlshortener 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Gabriel Volpe 9 | maintainer: gvolpe@github.com 10 | copyright: Copyright: (c) 2017 Gabriel Volpe 11 | category: Demo 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | executable urlshortener-exe 17 | hs-source-dirs: app 18 | main-is: Main.hs 19 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 20 | build-depends: base 21 | , bytestring 22 | , hedis 23 | , mtl 24 | , network-uri 25 | , random 26 | , scotty 27 | , semigroups 28 | , text 29 | , transformers 30 | default-language: Haskell2010 31 | 32 | test-suite urlshortener-test 33 | type: exitcode-stdio-1.0 34 | hs-source-dirs: test 35 | main-is: Spec.hs 36 | build-depends: base 37 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 38 | default-language: Haskell2010 39 | 40 | source-repository head 41 | type: git 42 | location: https://github.com/gvolpe/haskell-book-exercises/tree/master/chapter19/urlshortener 43 | -------------------------------------------------------------------------------- /chapter11/adts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | -- newtype keyword 5 | -- it has no runtime overhead, as it reuses the representation of the type it contains 6 | -- type == newtype for the compiler but it helps readability for human beings :) 7 | newtype Goats = Goats Int deriving (Eq, Show) 8 | newtype Cows = Cows Int deriving (Eq, Show) 9 | 10 | tooManyGoats :: Goats -> Bool 11 | tooManyGoats (Goats n) = n > 42 12 | 13 | class TooMany a where 14 | tooMany :: a -> Bool 15 | 16 | instance TooMany Int where 17 | tooMany n = n > 42 18 | 19 | newtype Horses = Horses Int deriving (Eq, Show, TooMany) 20 | 21 | -- Don't needed if we derive it using the generalized pragma at the top 22 | --instance TooMany Goats where 23 | -- tooMany (Goats n) = tooMany n 24 | 25 | -- intermission exercises 26 | instance TooMany (Int, String) where 27 | tooMany (x, y) = tooMany x 28 | 29 | instance TooMany (Int, Int) where 30 | tooMany (x, y) = tooMany (x + y) 31 | 32 | --instance TooMany (Num a, TooMany a) where 33 | -- tooMany (x, y) = tooMany (x + y) 34 | 35 | data GuessWhat = Chickenbutt deriving (Eq, Show) 36 | data Id a = MkId a deriving (Eq, Show) 37 | data Product a b = Product a b deriving (Eq, Show) 38 | data Sum a b = First a | Second b deriving (Eq, Show) 39 | data RecordProduct a b = RecordProduct { pfirst :: a, psecond :: b }deriving (Eq, Show) 40 | 41 | newtype NumCow = NumCow Int deriving (Eq, Show) 42 | newtype NumPig = NumPig Int deriving (Eq, Show) 43 | 44 | data Farmhouse = Farmhouse NumCow NumPig deriving (Eq, Show) 45 | type Farmhouse' = Product NumCow NumPig 46 | -------------------------------------------------------------------------------- /chapter14/morse/src/Morse.hs: -------------------------------------------------------------------------------- 1 | module Morse 2 | ( Morse 3 | , charToMorse 4 | , morseToChar 5 | , stringToMorse 6 | , letterToMorse 7 | , morseToLetter 8 | ) where 9 | 10 | import qualified Data.Map as M 11 | 12 | type Morse = String 13 | 14 | letterToMorse :: (M.Map Char Morse) 15 | letterToMorse = M.fromList [ 16 | ('a', ".-") 17 | , ('b', "-...") 18 | , ('c', "-.-.") 19 | , ('d', "-..") 20 | , ('e', ".") 21 | , ('f', "..-.") 22 | , ('g', "--.") 23 | , ('h', "....") 24 | , ('i', "..") 25 | , ('j', ".---") 26 | , ('k', "-.-") 27 | , ('l', ".-..") 28 | , ('m', "--") 29 | , ('n', "-.") 30 | , ('o', "---") 31 | , ('p', ".--.") 32 | , ('q', "--.-") 33 | , ('r', ".-.") 34 | , ('s', "...") 35 | , ('t', "-") 36 | , ('u', "..-") 37 | , ('v', "...-") 38 | , ('w', ".--") 39 | , ('x', "-..-") 40 | , ('y', "-.--") 41 | , ('z', "--..") 42 | , ('1', ".----") 43 | , ('2', "..---") 44 | , ('3', "...--") 45 | , ('4', "....-") 46 | , ('5', ".....") 47 | , ('6', "-....") 48 | , ('7', "--...") 49 | , ('8', "---..") 50 | , ('9', "----.") 51 | , ('0', "-----") 52 | ] 53 | 54 | morseToLetter :: M.Map Morse Char 55 | morseToLetter = M.foldWithKey (flip M.insert) M.empty letterToMorse 56 | 57 | charToMorse :: Char -> Maybe Morse 58 | charToMorse c = M.lookup c letterToMorse 59 | 60 | stringToMorse :: String -> Maybe [Morse] 61 | stringToMorse s = sequence $ fmap charToMorse s 62 | 63 | morseToChar :: Morse -> Maybe Char 64 | morseToChar m = M.lookup m morseToLetter 65 | -------------------------------------------------------------------------------- /chapter12/maybelib.hs: -------------------------------------------------------------------------------- 1 | module MaybeSmallLib where 2 | 3 | -- >>> isJust (Just 1) 4 | -- True 5 | -- >>> isJust Nothing 6 | -- False 7 | isJust :: Maybe a -> Bool 8 | isJust (Just x) = True 9 | isJust _ = False 10 | 11 | -- >>> isNothing (Just 1) 12 | -- False 13 | -- >>> isNothing Nothing 14 | -- True 15 | isNothing :: Maybe a -> Bool 16 | isNothing = not . isJust 17 | 18 | -- >>> mayybee 0 (+1) Nothing 19 | -- 0 20 | -- >>> mayybee 0 (+1) (Just 1) 21 | -- 2 22 | mayybee :: b -> (a -> b) -> Maybe a -> b 23 | mayybee x f Nothing = x 24 | mayybee x f (Just v) = f v 25 | 26 | -- >>> fromMaybe 0 Nothing 27 | -- 0 28 | -- >>> fromMaybe 0 (Just 1) 29 | -- 1 30 | fromMaybe :: a -> Maybe a -> a 31 | fromMaybe x Nothing = x 32 | fromMaybe x (Just v) = v 33 | 34 | -- >>> listToMaybe [1, 2, 3] 35 | -- Just 1 36 | -- >>> listToMaybe [] 37 | -- Nothing 38 | listToMaybe :: [a] -> Maybe a 39 | listToMaybe [] = Nothing 40 | listToMaybe (x:_) = Just x 41 | 42 | -- >>> maybeToList (Just 1) 43 | -- [1] 44 | -- >>> maybeToList Nothing 45 | -- [] 46 | maybeToList :: Maybe a -> [a] 47 | maybeToList Nothing = [] 48 | maybeToList (Just x) = [x] 49 | 50 | -- >>> catMaybes [Just 1, Nothing, Just 2] 51 | -- [1, 2] 52 | -- >>> catMaybes [Nothing, Nothing, Nothing] 53 | -- [] 54 | catMaybes :: [Maybe a] -> [a] 55 | catMaybes = foldr (\x acc -> if isJust x then (maybeToList x) ++ acc else acc) [] 56 | 57 | -- >>> flipMaybe [Just 1, Just 2, Just 3] 58 | -- Just [1, 2, 3] 59 | -- >>> flipMaybe [Just 1, Nothing, Just 3] 60 | -- Nothing 61 | flipMaybe :: [Maybe a] -> Maybe [a] 62 | flipMaybe xs = if or $ map isNothing xs then Nothing else Just (catMaybes xs) 63 | -------------------------------------------------------------------------------- /chapter14/morse/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Gabi Volpe 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 Gabi Volpe 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 | -------------------------------------------------------------------------------- /chapter18/monads.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | bind :: Monad m => (a -> m b) -> m a -> m b 4 | bind f x = join $ fmap f x 5 | -- Try this out: 6 | -- bind (\x -> [x+1]) [1,2,3] 7 | 8 | twiceWhenEven :: [Integer] -> [Integer] 9 | twiceWhenEven xs = do 10 | x <- xs 11 | if even x 12 | then [x*x, x*x] 13 | else [x*x] 14 | 15 | data Cow = Cow { 16 | name :: String 17 | , age :: Int 18 | , weight :: Int 19 | } deriving (Eq, Show) 20 | 21 | noEmpty :: String -> Maybe String 22 | noEmpty "" = Nothing 23 | noEmpty str = Just str 24 | 25 | noNegative :: Int -> Maybe Int 26 | noNegative n | n >= 0 = Just n 27 | | otherwise = Nothing 28 | 29 | -- if Cow's name is Bess, must be under 500 30 | weightCheck :: Cow -> Maybe Cow 31 | weightCheck c = 32 | let w = weight c 33 | n = name c 34 | in if n == "Bess" && w > 499 35 | then Nothing 36 | else Just c 37 | 38 | -- Ugly nested structures 39 | mkSphericalCow :: String -> Int -> Int -> Maybe Cow 40 | mkSphericalCow name' age' weight' = 41 | case noEmpty name' of 42 | Nothing -> Nothing 43 | Just nammy -> 44 | case noNegative age' of 45 | Nothing -> Nothing 46 | Just agey -> 47 | case noNegative weight' of 48 | Nothing -> Nothing 49 | Just weighty -> 50 | weightCheck (Cow nammy agey weighty) 51 | 52 | -- A bit better using do notation 53 | mkSphericalCow' :: String -> Int -> Int -> Maybe Cow 54 | mkSphericalCow' name' age' weight' = do 55 | nammy <- noEmpty name' 56 | agey <- noNegative age' 57 | weighty <- noNegative weight' 58 | weightCheck (Cow nammy agey weighty) 59 | -------------------------------------------------------------------------------- /chapter14/addition/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Gabi Volpe 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 Gabi Volpe 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 | -------------------------------------------------------------------------------- /chapter14/wordnumber/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Gabi Volpe 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 Gabi Volpe 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 | -------------------------------------------------------------------------------- /chapter19/urlshortener/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Gabriel Volpe (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 Gabriel Volpe 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. -------------------------------------------------------------------------------- /chapter14/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 (stringToMorse, morseToChar) 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 | -- otherwise, proceed. 16 | line <- hGetLine stdin 17 | convertLine line 18 | where 19 | convertLine line = do 20 | let morse = stringToMorse line 21 | case morse of 22 | (Just str) -> putStrLn $ intercalate " " str 23 | Nothing -> do 24 | putStrLn $ "ERROR: " ++ line 25 | exitFailure 26 | 27 | convertFromMorse :: IO () 28 | convertFromMorse = forever $ do 29 | weAreDone <- hIsEOF stdin 30 | when weAreDone exitSuccess 31 | -- otherwise, proceed. 32 | line <- hGetLine stdin 33 | convertLine line 34 | where 35 | convertLine line = do 36 | let decoded :: Maybe String 37 | decoded = traverse morseToChar (words line) 38 | case decoded of 39 | (Just s) -> putStrLn s 40 | Nothing -> do 41 | putStrLn $ "ERROR: " ++ line 42 | exitFailure 43 | 44 | main :: IO () 45 | main = do 46 | mode <- getArgs 47 | case mode of 48 | [arg] -> 49 | case arg of 50 | "from" -> convertFromMorse 51 | "to" -> convertToMorse 52 | _ -> argError 53 | _ -> argError 54 | where argError = do 55 | putStrLn "Please specify the first argument \ 56 | \as being 'from' or 'to' morse,\ 57 | \ such as: morse to" 58 | exitFailure 59 | -------------------------------------------------------------------------------- /chapter20/intermission.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | import Data.Foldable 3 | 4 | -- for definition of xMinimum 5 | newtype Min a = Min {getMin :: Maybe a} 6 | 7 | instance Ord a => Monoid (Min a) where 8 | mempty = Min Nothing 9 | m `mappend` Min Nothing = m 10 | Min Nothing `mappend` n = n 11 | (Min m@(Just x)) `mappend` (Min n@(Just y)) 12 | | x <= y = Min m 13 | | otherwise = Min n 14 | 15 | -- for definition of xMaximum 16 | newtype Max a = Max {getMax :: Maybe a} 17 | 18 | instance Ord a => Monoid (Max a) where 19 | mempty = Max Nothing 20 | m `mappend` Max Nothing = m 21 | Max Nothing `mappend` n = n 22 | (Max m@(Just x)) `mappend` (Max n@(Just y)) 23 | | x >= y = Max m 24 | | otherwise = Max n 25 | 26 | -- functions 27 | xSum :: (Foldable t, Num a) => t a -> a 28 | xSum = getSum . foldMap Sum 29 | 30 | xProduct :: (Foldable t, Num a) => t a -> a 31 | xProduct = getProduct . foldMap Product 32 | 33 | xElem :: (Foldable t, Eq a) => a -> t a -> Bool 34 | xElem x xs = getAny $ foldMap (\e -> Any $ x == e) xs -- any . (==) 35 | 36 | xMinimum :: (Foldable t, Ord a) => t a -> Maybe a 37 | xMinimum xs = getMin $ foldMap (\e -> Min {getMin = Just e}) xs 38 | 39 | xMaximum :: (Foldable t, Ord a) => t a -> Maybe a 40 | xMaximum xs = getMax $ foldMap (\e -> Max {getMax = Just e}) xs 41 | 42 | xNull :: (Foldable t) => t a -> Bool 43 | xNull = foldr (\_ _ -> False) True 44 | 45 | xLength :: (Foldable t) => t a -> Int 46 | xLength = foldr (\x acc -> acc + 1) 0 47 | 48 | xToList :: (Foldable t) => t a -> [a] 49 | xToList = foldr (:) [] 50 | 51 | xFold :: (Foldable t, Monoid m) => t m -> m 52 | xFold = foldr (\x acc -> x <> acc) mempty -- foldMap id 53 | 54 | xFoldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m 55 | xFoldMap f = foldr (mappend . f) mempty 56 | -------------------------------------------------------------------------------- /chapter17/intermission.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Data.List (elemIndex) 3 | 4 | -- Short exercises 5 | added :: Maybe Integer 6 | added = (+3) <$> (lookup 3 $ zip [1, 2, 3] [4, 5, 6]) 7 | 8 | w :: Maybe Integer 9 | w = lookup 3 $ zip [1, 2, 3] [4, 5, 6] 10 | 11 | z :: Maybe Integer 12 | z = lookup 2 $ zip [1, 2, 3] [4, 5, 6] 13 | 14 | tupled :: Maybe (Integer, Integer) 15 | tupled = (,) <$> w <*> z 16 | 17 | x :: Maybe Int 18 | x = elemIndex 3 [1, 2, 3, 4, 5] 19 | 20 | y :: Maybe Int 21 | y = elemIndex 4 [1, 2, 3, 4, 5] 22 | 23 | max' :: Int -> Int -> Int 24 | max' = max 25 | 26 | maxed :: Maybe Int 27 | maxed = liftA2 max' x y 28 | 29 | xs = [1, 2, 3] 30 | ys = [4, 5, 6] 31 | 32 | x1 :: Maybe Integer 33 | x1 = lookup 3 $ zip xs ys 34 | 35 | y1 :: Maybe Integer 36 | y1 = lookup 2 $ zip xs ys 37 | 38 | -- I don't get this one... 39 | summed :: Maybe Integer 40 | summed = fst $ sum <$> (,) x1 y1 41 | 42 | -- Write an Applicative instance for Identity. 43 | newtype Identity a = Identity a deriving (Eq, Ord, Show) 44 | 45 | instance Functor Identity where 46 | fmap f (Identity x) = Identity (f x) 47 | 48 | instance Applicative Identity where 49 | pure = Identity 50 | Identity f <*> Identity x = Identity (f x) 51 | 52 | --Write an Applicative instance for Constant. 53 | newtype Constant a b = Constant { getConstant :: a } deriving (Eq, Ord, Show) 54 | 55 | instance Functor (Constant a) where 56 | fmap _ (Constant x) = Constant x 57 | 58 | instance Monoid a => Applicative (Constant a) where 59 | pure _ = Constant mempty 60 | Constant f <*> Constant x = Constant $ mappend f x 61 | 62 | -- More exercises 63 | a = const <$> Just "Hello" <*> pure "World" 64 | b = (,,,) <$> Just 90 <*> Just 10 <*> Just "Tierness" <*> pure [1, 2, 3] 65 | -------------------------------------------------------------------------------- /chapter14/wordnumber/wordnumber.cabal: -------------------------------------------------------------------------------- 1 | -- Initial wordnumber.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: wordnumber 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Gabi Volpe 11 | maintainer: gvolpe@github.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: WordNumber 20 | , VigenereCipher 21 | ghc-options: -Wall -fwarn-tabs 22 | build-depends: base >=4.8 && <4.9 23 | , containers 24 | , hspec 25 | , QuickCheck 26 | hs-source-dirs: src 27 | default-language: Haskell2010 28 | 29 | test-suite tests 30 | ghc-options: -Wall -fwarn-tabs 31 | type: exitcode-stdio-1.0 32 | main-is: tests.hs 33 | hs-source-dirs: tests 34 | build-depends: base >=4.8 && <4.9 35 | , containers 36 | , wordnumber 37 | , hspec 38 | , QuickCheck 39 | default-language: Haskell2010 40 | 41 | test-suite cipherspecs 42 | ghc-options: -Wall -fwarn-tabs 43 | type: exitcode-stdio-1.0 44 | main-is: cipherspecs.hs 45 | hs-source-dirs: tests 46 | build-depends: base >=4.8 && <4.9 47 | , containers 48 | , wordnumber 49 | , hspec 50 | , QuickCheck 51 | default-language: Haskell2010 52 | 53 | -------------------------------------------------------------------------------- /chapter12/exercises.hs: -------------------------------------------------------------------------------- 1 | -- >>> notThe "the" 2 | -- Nothing 3 | -- >>> notThe "blahtheblah" 4 | -- Just "blahtheblah" 5 | -- >>> notThe "woot" 6 | -- Just "woot" 7 | notThe :: String -> Maybe String 8 | notThe x = case x == "the" of 9 | True -> Nothing 10 | False -> Just x 11 | 12 | maybeToString :: Maybe String -> String 13 | maybeToString (Just x) = x ++ " " 14 | maybeToString Nothing = "a " 15 | 16 | dropRight :: Int -> [a] -> [a] 17 | dropRight x = reverse . drop x . reverse 18 | 19 | -- >>> replaceThe "the cow loves us" 20 | -- "a cow loves us" 21 | replaceThe :: String -> String 22 | replaceThe x = dropRight 1 $ concat $ map maybeToString f 23 | where f = map notThe $ words x 24 | 25 | wordAfterThe :: [String] -> String 26 | wordAfterThe (x:xs) = case x == "the" of 27 | True -> head xs 28 | False -> wordAfterThe xs 29 | 30 | vowels = "aeiou" 31 | 32 | startsWithVowel :: String -> Bool 33 | startsWithVowel [] = False 34 | startsWithVowel (x:_) = elem x vowels 35 | 36 | countTheBeforeVowel :: String -> Bool 37 | countTheBeforeVowel = startsWithVowel . wordAfterThe . words 38 | 39 | countVowels :: String -> Integer 40 | countVowels "" = 0 41 | countVowels (x:xs) = if elem x vowels then 1 + (countVowels xs) else countVowels xs 42 | 43 | newtype Word' = Word' String deriving (Eq, Show) 44 | 45 | mkWord :: String -> Maybe Word' 46 | mkWord x = if condition then Nothing else Just (Word' x) 47 | where condition = vowels > (fromIntegral $ length x) - vowels 48 | vowels = countVowels x 49 | 50 | -- iterate, unfoldr 51 | 52 | myIterate :: (a -> a) -> a -> [a] 53 | myIterate f x = [x] ++ myIterate f (f x) 54 | 55 | as' :: Maybe (a, b) -> [a] 56 | as' (Just (x, _)) = [x] 57 | as' Nothing = [] 58 | 59 | bs' :: Maybe (a, b) -> [b] 60 | bs' (Just (_, y)) = [y] 61 | bs' Nothing = [] 62 | 63 | myUnfoldr :: (b -> Maybe (a, b)) -> b -> [a] 64 | myUnfoldr f x = (as' $ f x) ++ myUnfoldr f (head $ bs' $ f x) 65 | 66 | betterIterate :: (a -> a) -> a -> [a] 67 | betterIterate f x = myUnfoldr (\a -> Just (a, f a)) x 68 | -------------------------------------------------------------------------------- /chapter16/ReplaceExperiment.hs: -------------------------------------------------------------------------------- 1 | module ReplaceExperiment where 2 | 3 | replaceWithP :: b -> Char 4 | replaceWithP = const 'p' 5 | 6 | lms :: [Maybe [Char]] 7 | lms = [Just "Ave", Nothing, Just "woohoo"] 8 | 9 | -- Just making the argument more specific 10 | replaceWithP' :: [Maybe [Char]] -> Char 11 | replaceWithP' = replaceWithP 12 | 13 | -- Prelude> :t fmap replaceWithP 14 | -- fmap replaceWithP :: Functor f => f a -> f Char 15 | liftedReplace :: Functor f => f a -> f Char 16 | liftedReplace = fmap replaceWithP 17 | 18 | liftedReplace' :: [Maybe [Char]] -> [Char] 19 | liftedReplace' = liftedReplace 20 | 21 | -- Prelude> :t (fmap . fmap) replaceWithP 22 | -- (fmap . fmap) replaceWithP 23 | -- :: (Functor f1, Functor f) => f (f1 a) -> f (f1 Char) 24 | twiceLifted :: (Functor f1, Functor f) => f (f1 a) -> f (f1 Char) 25 | twiceLifted = (fmap . fmap) replaceWithP 26 | 27 | -- Making it more specific 28 | twiceLifted' :: [Maybe [Char]] -> [Maybe Char] 29 | twiceLifted' = twiceLifted 30 | -- f ~ [] 31 | -- f1 ~ Maybe 32 | 33 | -- Prelude> :t (fmap . fmap . fmap) replaceWithP 34 | -- (fmap . fmap . fmap) replaceWithP 35 | -- :: (Functor f2, Functor f1, Functor f) => 36 | -- f (f1 (f2 a)) -> f (f1 (f2 Char)) 37 | thriceLifted :: (Functor f2, Functor f1, Functor f) => f (f1 (f2 a)) -> f (f1 (f2 Char)) 38 | thriceLifted = (fmap . fmap . fmap) replaceWithP 39 | 40 | -- More specific or "concrete" 41 | thriceLifted' :: [Maybe [Char]] -> [Maybe [Char]] 42 | thriceLifted' = thriceLifted 43 | -- f ~ [] 44 | -- f1 ~ Maybe 45 | -- f2 ~ [] 46 | 47 | main :: IO () 48 | main = do 49 | putStr "replaceWithP' lms: " 50 | print (replaceWithP' lms) 51 | 52 | putStr "liftedReplace lms: " 53 | print (liftedReplace lms) 54 | 55 | putStr "liftedReplace' lms: " 56 | print (liftedReplace' lms) 57 | 58 | putStr "twiceLifted lms: " 59 | print (twiceLifted lms) 60 | 61 | putStr "twiceLifted' lms: " 62 | print (twiceLifted' lms) 63 | 64 | putStr "thriceLifted lms: " 65 | print (thriceLifted lms) 66 | 67 | putStr "thriceLifted' lms: " 68 | print (thriceLifted' lms) 69 | -------------------------------------------------------------------------------- /chapter22/ReaderPractice.hs: -------------------------------------------------------------------------------- 1 | module ReaderPractice where 2 | 3 | import Control.Applicative 4 | import Data.Maybe 5 | import Prelude hiding (lookup, uncurry) 6 | 7 | x = [1, 2, 3] 8 | y = [4, 5, 6] 9 | z = [7, 8, 9] 10 | 11 | lookup :: Eq a => a -> [(a, b)] -> Maybe b 12 | lookup _ [] = Nothing 13 | lookup a (h:t) = 14 | if fst h == a 15 | then Just $ snd h 16 | else lookup a t 17 | 18 | -- zip x and y using 3 as the lookup key 19 | xs :: Maybe Integer 20 | xs = lookup 3 $ zip x y 21 | 22 | -- zip y and z using 6 as the lookup key 23 | ys :: Maybe Integer 24 | ys = lookup 6 $ zip y z 25 | 26 | -- it's also nice to have one that will return Nothing, like this one 27 | -- zip x and y using 4 as the lookup key 28 | zs :: Maybe Integer 29 | zs = lookup 4 $ zip x y 30 | 31 | -- now zip x and z using a variable lookup key 32 | z' :: Integer -> Maybe Integer 33 | z' n = lookup n $ zip x z 34 | 35 | x1 :: Maybe (Integer, Integer) 36 | x1 = (,) <$> xs <*> ys 37 | 38 | x2 :: Maybe (Integer, Integer) 39 | x2 = (,) <$> ys <*> zs 40 | 41 | x3 :: Integer -> (Maybe Integer, Maybe Integer) 42 | x3 n = (z' n, z' n) 43 | 44 | uncurry :: (a -> b -> c) -> (a, b) -> c 45 | uncurry f = f <$> fst <*> snd 46 | -- that first argument is a function 47 | -- in this case, we want it to be addition 48 | -- summed is just uncurry with addition as 49 | -- the first argument 50 | 51 | summed :: Num c => (c, c) -> c 52 | summed = (+) <$> fst <*> snd 53 | 54 | bolt :: Integer -> Bool 55 | bolt = (&&) <$> (>3) <*> (<8) 56 | 57 | sequA :: Integral a => a -> [Bool] 58 | sequA = sequenceA [(>3), (<8), even] 59 | 60 | s' :: Maybe Integer 61 | s' = summed <$> ((,) <$> xs <*> ys) 62 | 63 | -- main 64 | main :: IO () 65 | main = do 66 | print $ sequenceA [Just 3, Just 2, Just 1] 67 | print $ sequenceA [x, y] 68 | print $ sequenceA [xs, ys] 69 | print $ summed <$> ((,) <$> xs <*> ys) 70 | print $ fmap summed ((,) <$> xs <*> zs) 71 | print $ bolt 7 72 | print $ fmap bolt z 73 | print $ sequenceA [(>3), (<8), even] 7 74 | print $ sequA $ fromMaybe 1 s' 75 | print $ bolt $ fromMaybe 1 ys 76 | print $ bolt $ fromMaybe 0 $ z' 1 -- exercise not clear 77 | -------------------------------------------------------------------------------- /chapter11/phone.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Data.Function (on) 3 | import Data.List (elemIndex, groupBy, sortBy) 4 | import Data.Ord (comparing) 5 | import Data.Tuple (swap) 6 | 7 | type Digit = Char 8 | type PhoneValues = String 9 | 10 | data DaPhone = DaPhone [(Digit, PhoneValues)] deriving (Eq, Show) 11 | 12 | daphone = DaPhone 13 | [('1', "1"), 14 | ('2', "abc"), 15 | ('3', "def"), 16 | ('4', "ghi"), 17 | ('5', "jkl"), 18 | ('6', "mno"), 19 | ('7', "pqrs"), 20 | ('8', "tuv"), 21 | ('9', "wxyz"), 22 | ('*', "*^"), 23 | ('0', " +_"), 24 | ('#', "#.,")] 25 | 26 | convo :: [String] 27 | convo = 28 | ["Wanna play 20 questions", 29 | "Ya", 30 | "U 1st haha", 31 | "Lol ok. Have u ever tasted alcohol lol", 32 | "Lol ya", 33 | "Wow ur cool haha. Ur turn", 34 | "Ok. Do u think I am pretty Lol", 35 | "Lol ya", 36 | "Haha thanks just making sure rofl ur turn"] 37 | 38 | -- Valid presses: 1 and up 39 | type Presses = Int 40 | 41 | indexOf :: Eq a => a -> [a] -> Int 42 | indexOf x xs = case index of 43 | Just v -> v + 1 44 | Nothing -> 0 45 | where index = elemIndex x xs 46 | 47 | reverseTaps :: DaPhone -> Char -> [(Digit, Presses)] 48 | reverseTaps (DaPhone x) v = foldr f [] y 49 | where y = map swap x 50 | g = (\(c,d) acc -> if isUpper v && elem (toLower v) c then ('*', 1) : (d, indexOf (toLower v) c) : acc else acc) 51 | f = (\(c,d) acc -> if elem v c then (d, indexOf v c) : acc else g (c,d) acc) 52 | -- assuming the default phone definition 53 | -- 'a' -> ('2', 1) 54 | -- 'A' -> [('*', 1), ('2', 1)] 55 | 56 | cellPhonesDead :: DaPhone -> String -> [(Digit, Presses)] 57 | cellPhonesDead p x = concat $ map (reverseTaps p) x 58 | 59 | groupByIdentity :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])] 60 | groupByIdentity = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst) . sortBy (comparing fst) 61 | 62 | fingerTaps :: [(Digit, Presses)] -> Presses 63 | fingerTaps = sum . map (\(a,b) -> sum b) . groupByIdentity 64 | 65 | --mostPopularLetter :: String -> Char 66 | 67 | mostPressedDigit :: [(Digit, Presses)] -> (Digit, Presses) 68 | mostPressedDigit = swap . maximum . map swap . map (\(a,b) -> (a, sum b)) . groupByIdentity 69 | -------------------------------------------------------------------------------- /chapter16/intermission.hs: -------------------------------------------------------------------------------- 1 | import FunctorLaws 2 | import Test.QuickCheck 3 | import Test.QuickCheck.Function 4 | 5 | -- Lifting exercises 6 | a = fmap (+1) $ read "[1]" :: [Int] 7 | 8 | b = (fmap . fmap) (++ "lol") (Just ["Hi,", "Hello"]) 9 | 10 | c = fmap (*2) (\x -> x - 2) 11 | 12 | d = fmap ((return '1' ++) . show) (\x -> [x, 1..3]) 13 | 14 | e :: IO Integer 15 | e = let ioi = readIO "1" :: IO Integer 16 | changed = fmap ("123"++) $ fmap show ioi 17 | in fmap (*3) $ fmap (\x -> read x :: Integer) changed 18 | 19 | -- Intermission exercises 20 | newtype Identity a = Identity a deriving (Eq, Show) 21 | data Pair a = Pair a a deriving (Eq, Show) 22 | data Two a b = Two a b deriving (Eq, Show) 23 | data Three a b c = Three a b c deriving (Eq, Show) 24 | data Three' a b = Three' a b b deriving (Eq, Show) 25 | data Four a b c d = Four a b c d deriving (Eq, Show) 26 | data Four' a b = Four' a a a b deriving (Eq, Show) 27 | 28 | instance Functor Identity where 29 | fmap f (Identity x) = Identity (f x) 30 | 31 | instance Functor Pair where 32 | fmap f (Pair x y) = Pair (f x) (f y) 33 | 34 | instance Functor (Two x) where 35 | fmap f (Two x y) = Two x (f y) 36 | 37 | instance Functor (Three x y) where 38 | fmap f (Three x y z) = Three x y (f z) 39 | 40 | instance Functor (Three' x) where 41 | fmap f (Three' x y z) = Three' x (f y) (f z) 42 | 43 | instance Functor (Four x y z) where 44 | fmap f (Four w x y z) = Four w x y (f z) 45 | 46 | instance Functor (Four' x) where 47 | fmap f (Four' w x y z) = Four' w x y (f z) 48 | 49 | -- Short exercise (Types similar to Maybe and Either respectively) 50 | data Possibly a = LolNope | Yeppers a deriving (Eq, Show) 51 | 52 | instance Functor Possibly where 53 | fmap _ LolNope = LolNope 54 | fmap f (Yeppers x) = Yeppers (f x) 55 | 56 | data Sum a b = First a | Second b deriving (Eq, Show) 57 | 58 | instance Functor (Sum a) where 59 | fmap _ (First x) = First x 60 | fmap f (Second x) = Second (f x) 61 | 62 | -- Verifying law abiding 63 | type IntToInt = Fun Int Int 64 | type IntFC = [Int] -> IntToInt -> IntToInt -> Bool 65 | 66 | main :: IO () 67 | main = do 68 | quickCheck $ \x -> functorIdentity (x :: [Int]) 69 | quickCheck (functorIdentity :: [Int] -> Bool) 70 | quickCheck (functorCompose' :: IntFC) 71 | -------------------------------------------------------------------------------- /chapter14/addition/src/Exercises.hs: -------------------------------------------------------------------------------- 1 | module Exercises where 2 | 3 | import Data.List (sort) 4 | 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | 8 | half x = x / 2 9 | halfIdentity = (*2) . half 10 | 11 | listOrdered :: (Ord a) => [a] -> Bool 12 | listOrdered xs = snd $ foldr go (Nothing, True) xs 13 | where go _ status@(_, False) = status 14 | go y (Nothing, t) = (Just y, t) 15 | go y (Just x, t) = (Just y, x >= y) 16 | 17 | plusAssociative :: Integer -> Integer -> Integer -> Bool 18 | plusAssociative x y z = x + (y + z) == (x + y) + z 19 | 20 | plusCommutative :: Integer -> Integer -> Bool 21 | plusCommutative x y = x + y == y + x 22 | 23 | productAssociative :: Integer -> Integer -> Integer -> Bool 24 | productAssociative x y z = x * (y * z) == (x * y) * z 25 | 26 | productCommutative :: Integer -> Integer -> Bool 27 | productCommutative x y = x * y == y * x 28 | 29 | -- TODO: quickCheck will divide by zero every time, maybe we should use a custom Generator 30 | prop_quotrem :: Integer -> Integer -> Bool 31 | prop_quotrem x y = (quot x y) * y + (rem x y) == x 32 | 33 | prop_divmod :: Integer -> Integer -> Bool 34 | prop_divmod x y = (div x y)*y + (mod x y) == x 35 | 36 | prop_half :: Double -> Bool 37 | prop_half x = half x == half (halfIdentity x) 38 | 39 | prop_listOrdered :: (Ord a) => [a] -> Bool 40 | prop_listOrdered xs = listOrdered (sort xs) == True 41 | 42 | prop_reverse :: (Eq a) => [a] -> Bool 43 | prop_reverse xs = reverse (reverse xs) == id xs 44 | 45 | prop_moneysymbol :: (Eq b) => (a -> b) -> a -> Bool 46 | prop_moneysymbol f x = (f $ x) == f x 47 | 48 | prop_composition :: (Eq c) => (b -> c) -> (a -> b) -> a -> Bool 49 | prop_composition f g x = ((f . g) x) == (f (g x)) 50 | 51 | --prop_lentake :: a -> [b] -> Bool 52 | --prop_lentake n xs = length (take n xs) == n 53 | 54 | runExerciseSpecs :: IO () 55 | runExerciseSpecs = do 56 | quickCheck prop_half 57 | quickCheck (prop_listOrdered :: [Int] -> Bool) 58 | quickCheck plusAssociative 59 | quickCheck plusCommutative 60 | quickCheck productAssociative 61 | quickCheck productCommutative 62 | -- quickCheck prop_quotrem 63 | -- quickCheck prop_divmod 64 | quickCheck (prop_reverse :: String -> Bool) 65 | quickCheck (prop_moneysymbol (+1) :: Int -> Bool ) 66 | quickCheck (prop_composition (+1) (+2) :: Int -> Bool) 67 | -- quickCheck (prop_lentake :: Integer -> String -> Bool) 68 | -------------------------------------------------------------------------------- /chapter21/exercises.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} -- This is needed for all the constrains (Functor, Foldable). The compiler will tell you need FlexibleContexts instead. 2 | 3 | import Data.Monoid 4 | 5 | newtype Identity a = Identity a deriving (Eq, Ord, Show) 6 | 7 | instance (Functor Identity, Foldable Identity) => Traversable Identity where 8 | traverse f (Identity x) = Identity <$> f x 9 | 10 | newtype Constant a b = Constant { getConstant :: a } deriving (Eq, Ord, Show) 11 | 12 | instance (Functor (Constant a), Foldable (Constant a)) => Traversable (Constant a) where 13 | traverse f (Constant x) = pure $ Constant x 14 | 15 | data Optional a = Nada | Yep a deriving (Eq, Ord, Show) 16 | 17 | instance (Functor Optional, Foldable Optional) => Traversable Optional where 18 | traverse _ Nada = pure $ Nada 19 | traverse f (Yep x) = Yep <$> f x 20 | 21 | data List a = Nil | Cons a (List a) deriving (Eq, Ord, Show) 22 | 23 | instance (Functor List, Foldable List) => Traversable List where 24 | traverse _ Nil = pure $ Nil 25 | traverse f (Cons x xs) = Cons <$> f x <*> traverse f xs 26 | 27 | data Three a b c = Three a b c deriving (Eq, Ord, Show) 28 | 29 | instance (Functor (Three a b), Foldable (Three a b)) => Traversable (Three a b) where 30 | traverse f (Three a b c) = Three a b <$> f c 31 | 32 | data Three' a b = Three' a b b deriving (Eq, Ord, Show) 33 | 34 | instance (Functor (Three' a), Foldable (Three' a)) => Traversable (Three' a) where 35 | traverse f (Three' a b c) = Three' a <$> f b <*> f c 36 | 37 | data S n a = S (n a) a deriving (Eq, Ord, Show) 38 | 39 | instance (Functor (S n), Foldable (S n), Traversable n) => Traversable (S n) where 40 | traverse f (S x y) = S <$> traverse f x <*> f y 41 | 42 | data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) deriving (Eq, Ord, Show) 43 | 44 | instance Functor Tree where 45 | fmap _ Empty = Empty 46 | fmap f (Leaf x) = Leaf (f x) 47 | fmap f (Node l x r) = Node (fmap f l) (f x) (fmap f r) 48 | 49 | instance Foldable Tree where 50 | foldMap _ Empty = mempty 51 | foldMap f (Leaf x) = f x 52 | foldMap f (Node l x r) = (foldMap f l) <> (f x) <> (foldMap f r) 53 | 54 | instance Traversable Tree where 55 | traverse _ Empty = pure $ Empty 56 | traverse f (Leaf x) = Leaf <$> f x 57 | traverse f (Node l x r) = Node <$> traverse f l <*> f x <*> traverse f r 58 | 59 | -------------------------------------------------------------------------------- /chapter14/wordnumber/tests/tests.hs: -------------------------------------------------------------------------------- 1 | module WordNumberTest where 2 | 3 | import Data.Char (toUpper) 4 | import Data.List (sort) 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | import WordNumber (digitToWord, digits, wordNumber) 8 | 9 | capitalize :: String -> String 10 | capitalize [] = [] 11 | capitalize (x:xs) = (toUpper x) : xs 12 | 13 | main :: IO () 14 | main = hspec $ do 15 | describe "digitToWord does what we want" $ do 16 | it "returns zero for 0" $ do 17 | digitToWord 0 `shouldBe` "zero" 18 | it "returns one for 1" $ do 19 | digitToWord 1 `shouldBe` "one" 20 | describe "digits does what we want" $ do 21 | it "returns [1] for 1" $ do 22 | digits 1 `shouldBe` [1] 23 | it "returns [1, 0, 0] for 100" $ do 24 | digits 100 `shouldBe` [1, 0, 0] 25 | describe "wordNumber does what we want" $ do 26 | it "returns one-zero-zero for 100" $ do 27 | wordNumber 100 `shouldBe` "one-zero-zero" 28 | it "returns nine-zero-zero-one for 9001" $ do 29 | wordNumber 9001 `shouldBe` "nine-zero-zero-one" 30 | 31 | capitalizeSpec :: IO () 32 | capitalizeSpec = hspec $ do 33 | describe "Capitalize Word does what we expect" $ do 34 | it "returns an empty string for an empty string" $ do 35 | capitalize "" `shouldBe` "" 36 | it "capitalize the only letter for a string of one letter" $ do 37 | capitalize "h" `shouldBe` "H" 38 | it "returns Gabi for gabi" $ do 39 | capitalize "gabi" `shouldBe` "Gabi" 40 | 41 | twice :: (a -> a) -> a -> a 42 | twice f = f . f 43 | 44 | fourTimes :: (a -> a) -> a -> a 45 | fourTimes = twice . twice 46 | 47 | idempotenceTwice :: String -> Bool 48 | idempotenceTwice x = (capitalize x) == (twice capitalize) x 49 | 50 | idempotenceFourTimes :: String -> Bool 51 | idempotenceFourTimes w = (capitalize w) == (fourTimes capitalize) w 52 | 53 | idempotenceSort :: (Ord a, Eq a) => [a] -> Bool 54 | idempotenceSort x = (sort x) == (twice sort) x && (sort x) == (fourTimes sort) x 55 | 56 | idempotenceSpec :: IO () 57 | idempotenceSpec = do 58 | quickCheck idempotenceTwice 59 | quickCheck idempotenceFourTimes 60 | quickCheck (idempotenceSort :: String -> Bool) 61 | 62 | -- Make your own Generators for the following type: 63 | 64 | data Fool = Fulse | Frue deriving (Eq, Show) 65 | 66 | genFool :: Gen Fool 67 | genFool = elements [Fulse, Frue] 68 | 69 | genFool' :: Gen Fool 70 | genFool' = frequency [ (2, return Fulse) 71 | , (1, return Frue) ] 72 | -------------------------------------------------------------------------------- /chapter19/urlshortener/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.13 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /chapter22/reader.hs: -------------------------------------------------------------------------------- 1 | {-# Language InstanceSigs #-} 2 | 3 | import Control.Applicative (liftA2) 4 | import Text.Show.Functions 5 | 6 | newtype Reader r a = Reader { runReader :: r -> a } deriving (Show) 7 | 8 | instance Functor (Reader r) where 9 | fmap :: (a -> b) -> Reader r a -> Reader r b 10 | fmap f (Reader ra) = Reader $ \r -> f (ra r) 11 | 12 | instance Applicative (Reader r) where 13 | pure :: a -> Reader r a 14 | pure a = Reader $ \r -> a 15 | (<*>) :: Reader r (a -> b) -> Reader r a -> Reader r b 16 | (Reader rab) <*> (Reader ra) = Reader $ \r -> rab r $ ra r 17 | 18 | instance Monad (Reader r) where 19 | return = pure 20 | (>>=) :: Reader r a -> (a -> Reader r b) -> Reader r b 21 | (Reader ra) >>= aRb = Reader $ \r -> runReader (aRb (ra r)) r 22 | 23 | -- exercise 1 24 | ask :: Reader a a 25 | ask = Reader $ id 26 | 27 | newtype HumanName = HumanName String deriving (Eq, Show) 28 | newtype DogName = DogName String deriving (Eq, Show) 29 | newtype Address = Address String deriving (Eq, Show) 30 | 31 | data Person = 32 | Person { 33 | humanName :: HumanName 34 | , dogName :: DogName 35 | , address :: Address 36 | } deriving (Eq, Show) 37 | 38 | data Dog = 39 | Dog { 40 | dogsName :: DogName 41 | , dogsAddress :: Address 42 | } deriving (Eq, Show) 43 | 44 | pers :: Person 45 | pers = Person (HumanName "Big Bird") (DogName "Barkley") (Address "Sesame Street") 46 | 47 | chris :: Person 48 | chris = Person (HumanName "Chris Allen") (DogName "Papu") (Address "Austin") 49 | 50 | -- without Reader 51 | getDog :: Person -> Dog 52 | getDog p = Dog (dogName p) (address p) 53 | 54 | -- with Reader 55 | getDogR :: Person -> Dog 56 | getDogR = Dog <$> dogName <*> address 57 | 58 | -- with Reader, alternate 59 | getDogR' :: Person -> Dog 60 | getDogR' = liftA2 Dog dogName address 61 | 62 | -- exercise 2 63 | myLiftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c 64 | myLiftA2 f x y = f <$> x <*> y 65 | 66 | -- exercise 3 67 | asks :: (r -> a) -> Reader r a 68 | asks f = Reader $ \x -> f x 69 | 70 | -- exercise 4 71 | getDogR'' :: Reader Person Dog 72 | getDogR'' = Reader $ \p -> Dog (dogName p) (address p) 73 | 74 | -- exercise Monadic impl 75 | getDogRM :: Person -> Dog 76 | getDogRM = do 77 | name <- dogName 78 | addy <- address 79 | return $ Dog name addy 80 | 81 | getDogRM' :: Reader Person Dog 82 | getDogRM' = do 83 | name <- Reader $ \p -> dogName p 84 | addy <- Reader $ \p -> address p 85 | return $ Dog (name) (addy) 86 | -------------------------------------------------------------------------------- /chapter13/hello-haskell/hello-haskell.cabal: -------------------------------------------------------------------------------- 1 | -- Initial hello-haskell.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | -- The name of the package. 5 | name: hello 6 | 7 | -- The package version. See the Haskell package versioning policy (PVP) 8 | -- for standards guiding when and how versions should be incremented. 9 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy 10 | -- PVP summary: +-+------- breaking API changes 11 | -- | | +----- non-breaking API additions 12 | -- | | | +--- code changes with no API change 13 | version: 0.1.0.0 14 | 15 | -- A short (one-line) description of the package. 16 | synopsis: Say hello 17 | 18 | -- A longer description of the package. 19 | description: Say hello 20 | 21 | -- The license under which the package is released. 22 | license: Apache-2.0 23 | 24 | -- The file containing the license text. 25 | license-file: LICENSE 26 | 27 | -- The package author(s). 28 | author: Gabi Volpe 29 | 30 | -- An email address to which users can send suggestions, bug reports, and 31 | -- patches. 32 | maintainer: gvolpe@github.com 33 | 34 | -- A copyright notice. 35 | -- copyright: 36 | 37 | -- category: 38 | 39 | build-type: Simple 40 | 41 | -- Extra files to be distributed with the package, such as examples or a 42 | -- README. 43 | -- extra-source-files: 44 | 45 | -- Constraint on the version of Cabal needed to build this package. 46 | cabal-version: >=1.10 47 | 48 | library 49 | exposed-modules: Hello 50 | ghc-options: -Wall 51 | hs-source-dirs: src 52 | build-depends: base >=4.8 && <4.9 53 | default-language: Haskell2010 54 | 55 | executable hello-haskell 56 | -- .hs or .lhs file containing the Main module. 57 | main-is: Main.hs 58 | 59 | -- Modules included in this executable, other than Main. 60 | -- other-modules: 61 | 62 | -- LANGUAGE extensions used by modules in this package. 63 | -- other-extensions: 64 | 65 | -- Other library packages from which modules are imported. 66 | build-depends: base >=4.8 && <4.9, hello 67 | 68 | -- Directories containing source files. 69 | hs-source-dirs: src 70 | 71 | -- Base language which the package is written in. 72 | default-language: Haskell2010 73 | 74 | Ghc-Options: -Wall -fwarn-tabs 75 | 76 | -------------------------------------------------------------------------------- /chapter11/binarytree.hs: -------------------------------------------------------------------------------- 1 | -- binary trees 2 | data BinaryTree a = Leaf | Node (BinaryTree a) a (BinaryTree a) deriving (Eq, Ord, Show) 3 | 4 | insert' :: Ord a => a -> BinaryTree a -> BinaryTree a 5 | insert' b Leaf = Node Leaf b Leaf 6 | insert' b (Node left a right) 7 | | b == a = Node left a right 8 | | b < a = Node (insert' b left) a right 9 | | b > a = Node left a (insert' b right) 10 | 11 | mapTree :: (a -> b) -> BinaryTree a -> BinaryTree b 12 | mapTree _ Leaf = Leaf 13 | mapTree f (Node l x r) = Node (mapTree f l) (f x) (mapTree f r) 14 | 15 | t1 = insert' 0 Leaf 16 | t2 = insert' 3 t1 17 | t3 = insert' 5 t2 18 | t4 = mapTree (+1) t3 19 | 20 | testTree' :: BinaryTree Integer 21 | testTree' = Node (Node Leaf 3 Leaf) 1 (Node Leaf 4 Leaf) 22 | mapExpected = Node (Node Leaf 4 Leaf) 2 (Node Leaf 5 Leaf) 23 | 24 | -- acceptance test for mapTree 25 | mapOkay = 26 | if mapTree (+1) testTree' == mapExpected 27 | then print "yup okay!" 28 | else error "test failed!" 29 | 30 | -- convert bt into list 31 | preorder :: BinaryTree a -> [a] 32 | preorder Leaf = [] 33 | preorder (Node l x r) = x : (preorder l) ++ (preorder r) 34 | 35 | inorder :: BinaryTree a -> [a] 36 | inorder Leaf = [] 37 | inorder (Node l x r) = (inorder l) ++ [x] ++ (inorder r) 38 | 39 | postorder :: BinaryTree a -> [a] 40 | postorder Leaf = [] 41 | postorder (Node l x r) = (postorder l) ++ (postorder r) ++ [x] 42 | 43 | testTree :: BinaryTree Integer 44 | testTree = Node (Node Leaf 1 Leaf) 2 (Node Leaf 3 Leaf) 45 | 46 | testPreorder :: IO () 47 | testPreorder = 48 | if preorder testTree == [2, 1, 3] 49 | then putStrLn "Preorder fine!" 50 | else putStrLn "Bad news bears." 51 | 52 | testInorder :: IO () 53 | testInorder = 54 | if inorder testTree == [1, 2, 3] 55 | then putStrLn "Inorder fine!" 56 | else putStrLn "Bad news bears." 57 | 58 | testPostorder :: IO () 59 | testPostorder = 60 | if postorder testTree == [1, 3, 2] 61 | then putStrLn "Postorder fine!" 62 | else putStrLn "postorder failed check" 63 | 64 | main :: IO () 65 | main = do 66 | testPreorder 67 | testInorder 68 | testPostorder 69 | 70 | -- foldr + map rewritten using fold 71 | foldTree :: (a -> b -> b) -> b -> BinaryTree a -> b 72 | foldTree _ acc Leaf = acc 73 | foldTree f acc (Node l x r) = foldTree f z r 74 | where y = f x acc 75 | z = foldTree f y l 76 | 77 | -- FIXME (I gave up on this one but it seems the exercise it's wrong and this is not possible?) 78 | mapTree' :: (a -> b) -> BinaryTree a -> BinaryTree b 79 | mapTree' f bt = foldTree (\ a b -> Node Leaf (f a) Leaf) Leaf bt 80 | -------------------------------------------------------------------------------- /chapter16/exercises.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | -- Fic Functor instances 4 | data Sum a b = First a | Second b deriving (Eq, Show) 5 | 6 | instance Functor (Sum e) where 7 | fmap _ (First a) = First a 8 | fmap f (Second b) = Second (f b) 9 | 10 | data Company a b c = DeepBlue a c | Something b deriving (Eq, Show) 11 | 12 | instance Functor (Company e e') where 13 | fmap _ (Something b) = Something b 14 | fmap f (DeepBlue a c) = DeepBlue a (f c) 15 | 16 | data More a b = L a b a | R b a b deriving (Eq, Show) 17 | 18 | instance Functor (More x) where 19 | fmap f (L a b a') = L a (f b) a 20 | fmap f (R b a b') = R (f b) a (f b) 21 | 22 | newtype Flip f a b = Flip (f b a) deriving (Eq, Show) 23 | 24 | instance Functor (Flip More x) where 25 | fmap f (Flip (L a b a')) = Flip $ L (f a) b (f a') 26 | fmap f (Flip (R b a b')) = Flip $ R b (f a) b' 27 | 28 | -- Write Functor instances 29 | data Quant a b = Finance | Desk a | Bloor b deriving (Eq, Show) 30 | 31 | instance Functor (Quant x) where 32 | fmap _ Finance = Finance 33 | fmap _ (Desk x) = Desk x 34 | fmap f (Bloor x) = Bloor (f x) 35 | 36 | newtype K a b = K a 37 | 38 | instance Functor (Flip K a) where 39 | fmap f (Flip (K a)) = Flip $ K (f a) 40 | 41 | data EvilGoateeConst a b = GoatyConst b deriving (Eq, Show) 42 | 43 | instance Functor (EvilGoateeConst x) where 44 | fmap f (GoatyConst x) = GoatyConst (f x) 45 | 46 | data LiftItOut f a = LiftItOut (f a) 47 | 48 | instance Functor f => Functor (LiftItOut f) where 49 | fmap g (LiftItOut x) = LiftItOut $ fmap g x 50 | 51 | data Parappa f g a = DaWrappa (f a) (g a) 52 | 53 | instance (Functor f, Functor g) => Functor (Parappa f g) where 54 | fmap h (DaWrappa x y) = DaWrappa (fmap h x) (fmap h y) 55 | 56 | data IgnoreOne f g a b = IgnoringSomething (f a) (g b) 57 | 58 | instance Functor g => Functor (IgnoreOne f g a) where 59 | fmap h (IgnoringSomething x y) = IgnoringSomething x $ fmap h y 60 | 61 | data Notorious g o a t = Notorious (g o) (g a) (g t) 62 | 63 | instance Functor g => Functor (Notorious g o a) where 64 | fmap f (Notorious x y z) = Notorious x y $ fmap f z 65 | 66 | data MyList a = Nil | Cons a (MyList a) deriving (Eq, Show) 67 | 68 | instance Functor MyList where 69 | fmap _ Nil = Nil 70 | fmap f (Cons x y) = Cons (f x) (fmap f y) 71 | 72 | data GoatLord a = NoGoat | OneGoat a | MoreGoats (GoatLord a) (GoatLord a) (GoatLord a) 73 | 74 | instance Functor GoatLord where 75 | fmap _ NoGoat = NoGoat 76 | fmap f (OneGoat x) = OneGoat (f x) 77 | fmap f (MoreGoats x y z) = MoreGoats (fmap f x) (fmap f y) (fmap f z) 78 | 79 | data TalkToMe a = Halt | Print String a | Read (String -> a) 80 | 81 | instance Functor TalkToMe where 82 | fmap _ Halt = Halt 83 | fmap f (Print x y) = Print x (f y) 84 | fmap f (Read g) = Read $ fmap f g 85 | -------------------------------------------------------------------------------- /chapter14/addition/src/Addition.hs: -------------------------------------------------------------------------------- 1 | module Addition where 2 | 3 | import Test.Hspec 4 | import Test.QuickCheck 5 | 6 | dividedBy :: Integral a => a -> a -> (a, a) 7 | dividedBy num denom = go num denom 0 8 | where go n d count 9 | | n < d = (count, n) 10 | | otherwise = go (n - d) d (count + 1) 11 | 12 | myProduct :: (Eq a, Num a) => a -> a -> a 13 | myProduct x 0 = x 14 | myProduct x y = x + myProduct x (y - 1) 15 | 16 | myProductSpec :: IO () 17 | myProductSpec = hspec $ do 18 | describe "Product in terms of addition" $ do 19 | it "2 * 3 :: Integer is equal to 8" $ do 20 | (myProduct 2 3 :: Integer) `shouldBe` 8 21 | it "2 * 3 :: Double is equal to 8.0" $ do 22 | (myProduct 2 3 :: Double) `shouldBe` (8.0) 23 | 24 | dividedBySpec :: IO () 25 | dividedBySpec = hspec $ do 26 | describe "Division in terms of substraction" $ do 27 | it "15 divided by 3 is 5" $ do 28 | dividedBy 15 3 `shouldBe` (5, 0) 29 | it "22 divided by 5 is 4 remainder 2" $ do 30 | dividedBy 22 5 `shouldBe` (4, 2) 31 | 32 | main :: IO () 33 | main = hspec $ do 34 | describe "Addition" $ do 35 | it "1 + 1 is greater than 1" $ do 36 | (1 + 1) > 1 `shouldBe` True 37 | it "2 + 2 is equal to 4" $ do 38 | 2 + 2 `shouldBe` 4 39 | it "x + 1 is always greater than x" $ do 40 | property $ \x -> x + 1 > (x :: Int) 41 | 42 | sayHello :: IO () 43 | sayHello = putStrLn "Hello" 44 | 45 | -- Generators for property testing 46 | oneToThree :: Gen Int 47 | oneToThree = elements [1, 2, 3] 48 | 49 | genBool :: Gen Bool 50 | genBool = choose (False, True) 51 | 52 | genBool' :: Gen Bool 53 | genBool' = elements [False, True] 54 | 55 | genOrdering :: Gen Ordering 56 | genOrdering = elements [LT, EQ, GT] 57 | 58 | genChar :: Gen Char 59 | genChar = elements ['a'..'z'] 60 | 61 | genTuple :: (Arbitrary a, Arbitrary b) => Gen (a, b) 62 | genTuple = do 63 | a <- arbitrary 64 | b <- arbitrary 65 | return (a, b) 66 | 67 | genThreeple :: (Arbitrary a, Arbitrary b, Arbitrary c) => Gen (a, b, c) 68 | genThreeple = do 69 | a <- arbitrary 70 | b <- arbitrary 71 | c <- arbitrary 72 | return (a, b, c) 73 | 74 | genEither :: (Arbitrary a, Arbitrary b) => Gen (Either a b) 75 | genEither = do 76 | a <- arbitrary 77 | b <- arbitrary 78 | elements [Left a, Right b] 79 | 80 | -- equal probability 81 | genMaybe :: Arbitrary a => Gen (Maybe a) 82 | genMaybe = do 83 | a <- arbitrary 84 | elements [Nothing, Just a] 85 | 86 | -- What QuickCheck actually does 87 | -- so you get more Just values 88 | genMaybe' :: Arbitrary a => Gen (Maybe a) 89 | genMaybe' = do 90 | a <- arbitrary 91 | frequency [ (1, return Nothing) 92 | , (3, return (Just a))] 93 | 94 | -- Using QuickCheck without Hspec 95 | prop_additionGreater :: Int -> Bool 96 | prop_additionGreater x = x + 1 > x 97 | 98 | runQc :: IO () 99 | runQc = quickCheck prop_additionGreater 100 | -------------------------------------------------------------------------------- /chapter13/hangman/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (forever) 4 | import Data.Char (toLower) 5 | import Data.Maybe (isJust) 6 | import Data.List (intersperse) 7 | import System.Exit (exitSuccess) 8 | import System.Random (randomRIO) 9 | 10 | newtype WordList = WordList [String] deriving (Eq, Show) 11 | 12 | allWords :: IO WordList 13 | allWords = do 14 | dict <- readFile "data/dict.txt" 15 | return $ WordList (lines dict) 16 | 17 | minWordLength :: Int 18 | minWordLength = 5 19 | 20 | maxWordLength :: Int 21 | maxWordLength = 9 22 | 23 | gameWords :: IO WordList 24 | gameWords = do 25 | (WordList aw) <- allWords 26 | return $ WordList (filter gameLength aw) 27 | where gameLength w = 28 | let l = length (w :: String) 29 | in l > minWordLength && l < maxWordLength 30 | 31 | randomWord :: WordList -> IO String 32 | randomWord (WordList wl) = do 33 | randomIndex <- randomRIO (0, (length wl) - 1) 34 | return $ wl !! randomIndex 35 | 36 | randomWord' :: IO String 37 | randomWord' = gameWords >>= randomWord 38 | 39 | data Puzzle = Puzzle String [Maybe Char] [Char] 40 | 41 | instance Show Puzzle where 42 | show (Puzzle _ discovered guessed) = 43 | (intersperse ' ' $ fmap renderPuzzleChar discovered) 44 | ++ " Guessed so far: " ++ guessed 45 | 46 | freshPuzzle :: String -> Puzzle 47 | freshPuzzle x = Puzzle x (map (const Nothing) x) [] 48 | 49 | charInWord :: Puzzle -> Char -> Bool 50 | charInWord (Puzzle x _ _) y = elem y x 51 | 52 | alreadyGuessed :: Puzzle -> Char -> Bool 53 | alreadyGuessed (Puzzle _ _ x) y = elem y x 54 | 55 | renderPuzzleChar :: Maybe Char -> Char 56 | renderPuzzleChar Nothing = '_' 57 | renderPuzzleChar (Just x) = x 58 | 59 | fillInCharacter :: Puzzle -> Char -> Puzzle 60 | fillInCharacter (Puzzle word filledInSoFar s) c = 61 | Puzzle word newFilledInSoFar (c : s) 62 | where zipper guessed wordChar guessChar = 63 | if wordChar == guessed 64 | then Just wordChar 65 | else guessChar 66 | newFilledInSoFar = zipWith (zipper c) word filledInSoFar 67 | 68 | handleGuess :: Puzzle -> Char -> IO Puzzle 69 | handleGuess puzzle guess = do 70 | putStrLn $ "Your guess was: " ++ [guess] 71 | case (charInWord puzzle guess 72 | , alreadyGuessed puzzle guess) of 73 | (_, True) -> do 74 | putStrLn "You already guessed that character, pick something else!" 75 | return puzzle 76 | (True, _) -> do 77 | putStrLn "This character was in the word, filling in the word accordingly" 78 | return (fillInCharacter puzzle guess) 79 | (False, _) -> do 80 | putStrLn "This character wasn't in the word, try again." 81 | return (fillInCharacter puzzle guess) 82 | 83 | gameOver :: Puzzle -> IO () 84 | gameOver (Puzzle wordToGuess _ guessed) = 85 | if (length guessed) > 7 then 86 | do putStrLn "You lose!" 87 | putStrLn $ "The word was: " ++ wordToGuess 88 | exitSuccess 89 | else return () 90 | 91 | gameWin :: Puzzle -> IO () 92 | gameWin (Puzzle _ filledInSoFar _) = 93 | if all isJust filledInSoFar then 94 | do putStrLn "You win!" 95 | exitSuccess 96 | else return () 97 | 98 | runGame :: Puzzle -> IO () 99 | runGame puzzle = forever $ do 100 | gameOver puzzle 101 | gameWin puzzle 102 | putStrLn $ "Current puzzle is: " ++ show puzzle 103 | putStr "Guess a letter: " 104 | guess <- getLine 105 | case guess of 106 | [c] -> handleGuess puzzle c >>= runGame 107 | _ -> putStrLn "Your guess must be a single character" 108 | 109 | main :: IO () 110 | main = do 111 | word <- randomWord' 112 | let puzzle = freshPuzzle (fmap toLower word) 113 | runGame puzzle 114 | -------------------------------------------------------------------------------- /chapter19/urlshortener/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad (replicateM) 6 | import Control.Monad.IO.Class (liftIO) 7 | import qualified Data.ByteString.Char8 as BC 8 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 9 | import qualified Data.Text.Lazy as TL 10 | import qualified Database.Redis as R 11 | import Network.URI (URI, parseURI) 12 | import qualified System.Random as SR 13 | import Web.Scotty 14 | 15 | alphaNum :: String 16 | alphaNum = ['A'..'Z'] ++ ['0'..'9'] 17 | 18 | randomElement :: String -> IO Char 19 | randomElement xs = do 20 | let maxIndex :: Int 21 | maxIndex = length xs - 1 22 | randomDigit <- SR.randomRIO (0, maxIndex) :: IO Int 23 | return (xs !! randomDigit) 24 | 25 | shortyGen :: IO [Char] 26 | shortyGen = replicateM 7 $ randomElement alphaNum 27 | 28 | -- Persist URI to Redis 29 | saveURI :: R.Connection 30 | -> BC.ByteString 31 | -> BC.ByteString 32 | -> IO (Either R.Reply R.Status) 33 | saveURI conn shortURI uri = 34 | R.runRedis conn $ R.set shortURI uri 35 | 36 | -- Maybe get the shorten url 37 | getURI :: R.Connection 38 | -> BC.ByteString 39 | -> IO (Either R.Reply (Maybe BC.ByteString)) 40 | getURI conn shortURI = R.runRedis conn $ R.get shortURI 41 | 42 | -- Web functions 43 | linkShorty :: String -> String 44 | linkShorty shorty = 45 | concat [ "Copy and paste your short URL" 48 | ] 49 | 50 | shortyCreated :: Show a => a -> String -> TL.Text 51 | shortyCreated resp shawty = 52 | TL.concat [ TL.pack $ show resp 53 | , " shorty is: ", TL.pack $ linkShorty shawty 54 | ] 55 | 56 | shortyAintUri :: TL.Text -> TL.Text 57 | shortyAintUri uri = 58 | TL.concat [ uri 59 | , " wasn't a url, did you forget http://?" 60 | ] 61 | 62 | shortyFound :: TL.Text -> TL.Text 63 | shortyFound tbs = 64 | TL.concat ["", tbs, ""] 65 | 66 | shortyDuplicated :: TL.Text -> TL.Text 67 | shortyDuplicated shorty = 68 | TL.concat [ "Shorty " 69 | , shorty 70 | , " is duplicated! Please try again." 71 | ] 72 | 73 | utf8 :: BC.ByteString -> TL.Text 74 | utf8 = TL.fromStrict . decodeUtf8 75 | 76 | -- Web app 77 | app :: R.Connection -> ScottyM () 78 | app rConn = do 79 | get "/" $ do 80 | uri <- param "uri" 81 | case parseURI (TL.unpack uri) of 82 | Just _ -> do 83 | shawty <- liftIO shortyGen 84 | let shorty = BC.pack shawty 85 | exists <- liftIO $ getURI rConn shorty -- Verifying existence of the shorty generated 86 | case exists of 87 | Left reply -> text $ TL.pack $ show reply 88 | Right dupl -> case dupl of 89 | Just bs -> 90 | text $ shortyDuplicated $ utf8 shorty 91 | Nothing -> do 92 | let uri' = encodeUtf8 $ TL.toStrict uri 93 | persist <- liftIO $ saveURI rConn shorty uri' 94 | case persist of 95 | Left err -> text $ TL.pack $ show err 96 | Right resp -> html $ shortyCreated resp shawty 97 | Nothing -> text $ shortyAintUri uri 98 | get "/:short" $ do 99 | short <- param "short" 100 | uri <- liftIO $ getURI rConn short 101 | case uri of 102 | Left reply -> text $ TL.pack $ show reply 103 | Right mbBS -> case mbBS of 104 | Nothing -> text "uri not found" 105 | Just bs -> html $ shortyFound $ utf8 bs 106 | 107 | -- Main function 108 | main :: IO () 109 | main = do 110 | rConn <- R.connect R.defaultConnectInfo 111 | scotty 3000 $ app rConn 112 | -------------------------------------------------------------------------------- /chapter18/exercises.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Control.Monad 3 | import Data.Monoid 4 | import Test.QuickCheck 5 | import Test.QuickCheck.Checkers 6 | import Test.QuickCheck.Classes 7 | 8 | -- Doesn't make sense (?) 9 | data Nope a = NopeDotJpg deriving (Eq, Show) 10 | 11 | instance Functor Nope where 12 | fmap _ _ = NopeDotJpg 13 | 14 | instance Applicative Nope where 15 | pure x = NopeDotJpg 16 | _ <*> _ = NopeDotJpg 17 | 18 | instance Monad Nope where 19 | return = pure 20 | _ >>= _ = NopeDotJpg 21 | 22 | instance Arbitrary a => Arbitrary (Nope a) where 23 | arbitrary = return NopeDotJpg 24 | 25 | instance Eq a => EqProp (Nope a) where (=-=) = eq 26 | 27 | -- Flipped Either 28 | data PhhhbbtttEither b a = PLeft a | PRight b deriving (Eq, Show) 29 | 30 | instance Functor (PhhhbbtttEither b) where 31 | fmap f (PLeft x) = PLeft (f x) 32 | fmap f (PRight x) = PRight x 33 | 34 | instance Applicative (PhhhbbtttEither b) where 35 | pure = PLeft 36 | (PRight f) <*> _ = PRight f 37 | _ <*> (PRight x) = PRight x 38 | (PLeft f) <*> (PLeft x) = PLeft (f x) 39 | 40 | instance Monad (PhhhbbtttEither b) where 41 | return = pure 42 | (PLeft x) >>= f = f x 43 | (PRight x) >>= _ = PRight x 44 | 45 | instance (Arbitrary a, Arbitrary b) => Arbitrary (PhhhbbtttEither a b) where 46 | arbitrary = do 47 | a <- arbitrary 48 | b <- arbitrary 49 | elements [PLeft b, PRight a] 50 | 51 | instance (Eq a, Eq b) => EqProp (PhhhbbtttEither a b) where (=-=) = eq 52 | 53 | -- Identity 54 | newtype Identity a = Identity a deriving (Eq, Ord, Show) 55 | 56 | instance Monoid (List a) where 57 | mempty = Nil 58 | mappend Nil x = x 59 | mappend x Nil = x 60 | mappend (Cons x xs) ys = Cons x $ xs <> ys 61 | 62 | instance Functor Identity where 63 | fmap f (Identity x) = Identity (f x) 64 | 65 | instance Applicative Identity where 66 | pure = Identity 67 | (Identity f) <*> (Identity x) = Identity (f x) 68 | 69 | instance Monad Identity where 70 | return = pure 71 | (Identity x) >>= f = f x 72 | 73 | instance Arbitrary a => Arbitrary (Identity a) where 74 | arbitrary = do 75 | a <- arbitrary 76 | return (Identity a) 77 | 78 | instance Eq a => EqProp (Identity a) where (=-=) = eq 79 | 80 | -- List 81 | data List a = Nil | Cons a (List a) deriving (Eq, Show) 82 | 83 | take' :: Int -> List a -> List a 84 | take' n Nil = Nil 85 | take' 1 (Cons x _) = Cons x Nil 86 | take' n (Cons x xs) = Cons x $ take' (n - 1) xs 87 | 88 | instance Functor List where 89 | fmap _ Nil = Nil 90 | fmap f (Cons x xs) = Cons (f x) (fmap f xs) 91 | 92 | instance Applicative List where 93 | pure x = Cons x Nil 94 | _ <*> Nil = Nil 95 | Nil <*> _ = Nil 96 | Cons f x <*> y = (f <$> y) <> (x <*> y) 97 | 98 | instance Monad List where 99 | return = pure 100 | Nil >>= _ = Nil 101 | (Cons x xs) >>= f = f x <> (xs >>= f) 102 | 103 | instance Arbitrary a => Arbitrary (List a) where 104 | arbitrary = do 105 | x <- arbitrary 106 | y <- arbitrary 107 | frequency [(1, return Nil), 108 | (10, return (Cons x y))] 109 | 110 | instance Eq a => EqProp (List a) where 111 | xs =-= ys = xs' `eq` ys' 112 | where xs' = take' 3000 xs 113 | ys' = take' 3000 ys 114 | 115 | -- More functions 116 | j :: Monad m => m (m a) -> m a -- join 117 | j m = m >>= id 118 | 119 | l1 :: Monad m => (a -> b) -> m a -> m b -- liftM 120 | l1 f m = m >>= (\x -> return $ f x) 121 | 122 | -- There probably is a better way to implement this using composition... 123 | l2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c -- liftM2 124 | l2 f m n = (m >>= (\x -> return $ f x)) >>= (\g -> n >>= (\y -> return $ g y)) 125 | 126 | a :: Monad m => m a -> m (a -> b) -> m b -- flip ap 127 | a m n = m >>= (\x -> n >>= (\f -> return $ f x)) 128 | 129 | -- Another way is by using recursion 130 | meh :: Monad m => [a] -> (a -> m b) -> m [b] 131 | meh xs fm = sequence $ xs >>= (\x -> return $ fm x) 132 | 133 | flipType :: (Monad m) => [m a] -> m [a] -- sequence: [Just 1, Just 2] would be Just [1, 2] 134 | flipType xs = meh xs $ join . pure 135 | 136 | -- All the tests! 137 | main = do 138 | let t1 = undefined :: Nope (Int, String, Int) 139 | let t2 = undefined :: PhhhbbtttEither String (Int, String, Int) 140 | let t3 = undefined :: Identity (Int, String, Int) 141 | let t4 = undefined :: List (Int, String, Int) 142 | quickBatch $ functor t1 143 | quickBatch $ applicative t1 144 | quickBatch $ monad t1 145 | quickBatch $ functor t2 146 | quickBatch $ applicative t2 147 | quickBatch $ monad t2 148 | quickBatch $ functor t3 149 | quickBatch $ applicative t3 150 | quickBatch $ monad t3 151 | quickBatch $ functor t4 152 | quickBatch $ applicative t4 153 | quickBatch $ monad t4 154 | 155 | -------------------------------------------------------------------------------- /chapter17/exercises.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Data.Monoid 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Checkers 5 | import Test.QuickCheck.Classes 6 | 7 | data List a = Nil | Cons a (List a) deriving (Eq, Show) 8 | 9 | take' :: Int -> List a -> List a 10 | take' n Nil = Nil 11 | take' 1 (Cons x _) = Cons x Nil 12 | take' n (Cons x xs) = Cons x $ take' (n - 1) xs 13 | 14 | instance Monoid (List a) where 15 | mempty = Nil 16 | mappend Nil x = x 17 | mappend x Nil = x 18 | mappend (Cons x xs) ys = Cons x $ xs <> ys 19 | 20 | instance Functor List where 21 | fmap _ Nil = Nil 22 | fmap f (Cons x xs) = Cons (f x) (fmap f xs) 23 | 24 | instance Applicative List where 25 | pure x = Cons x Nil 26 | _ <*> Nil = Nil 27 | Nil <*> _ = Nil 28 | Cons f x <*> y = (f <$> y) <> (x <*> y) 29 | 30 | -- ZipList Applicative 31 | newtype ZipList' a = ZipList' (List a) deriving (Eq, Show) 32 | 33 | instance Eq a => EqProp (ZipList' a) where 34 | xs =-= ys = xs' `eq` ys' 35 | where xs' = let (ZipList' l) = xs 36 | in take' 3000 l 37 | ys' = let (ZipList' l) = ys 38 | in take' 3000 l 39 | 40 | instance Functor ZipList' where 41 | fmap f (ZipList' xs) = ZipList' $ fmap f xs 42 | 43 | repeat' :: a -> (List a) 44 | repeat' x = xs 45 | where xs = Cons x xs 46 | 47 | zipWith' :: (a -> b -> c) -> (List a) -> (List b) -> (List c) 48 | zipWith' _ Nil _ = Nil 49 | zipWith' _ _ Nil = Nil 50 | zipWith' f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith' f xs ys) 51 | 52 | instance Applicative ZipList' where 53 | pure x = ZipList' $ repeat' x 54 | _ <*> (ZipList' Nil) = ZipList' Nil 55 | (ZipList' Nil) <*> _ = ZipList' Nil 56 | (ZipList' xs) <*> (ZipList' ys) = ZipList' (zipWith' id xs ys) 57 | 58 | instance Arbitrary a => Arbitrary (List a) where 59 | arbitrary = Cons <$> arbitrary <*> arbitrary 60 | 61 | instance Arbitrary a => Arbitrary (ZipList' a) where 62 | arbitrary = ZipList' <$> arbitrary 63 | 64 | -- Validation Applicative 65 | data MySum a b = MyFirst a | MySecond b deriving (Eq, Show) 66 | 67 | data MyValidation e a = MyError e | MySuccess a deriving (Eq, Show) 68 | 69 | instance Functor (MySum a) where 70 | fmap _ (MyFirst x) = MyFirst x 71 | fmap f (MySecond x) = MySecond (f x) 72 | 73 | instance Applicative (MySum a) where 74 | pure = MySecond 75 | (MyFirst x) <*> _ = MyFirst x 76 | _ <*> (MyFirst y) = MyFirst y 77 | (MySecond f) <*> (MySecond x) = MySecond (f x) 78 | 79 | -- same as Sum/Either 80 | instance Functor (MyValidation e) where 81 | fmap _ (MyError e) = MyError e 82 | fmap f (MySuccess x) = MySuccess (f x) 83 | 84 | -- This is different 85 | instance Monoid e => Applicative (MyValidation e) where 86 | pure = MySuccess 87 | (MyError e) <*> (MyError e') = MyError (e <> e') 88 | (MyError e) <*> _ = MyError e 89 | _ <*> (MyError e) = MyError e 90 | (MySuccess f) <*> (MySuccess x) = MySuccess (f x) 91 | 92 | instance (Eq a, Eq b) => EqProp (MySum a b) where (=-=) = eq 93 | 94 | instance (Eq a, Eq b) => EqProp (MyValidation a b) where (=-=) = eq 95 | 96 | instance (Arbitrary a, Arbitrary b) => Arbitrary (MySum a b) where 97 | arbitrary = do 98 | a <- arbitrary 99 | b <- arbitrary 100 | elements [MyFirst a, MySecond b] 101 | 102 | instance (Arbitrary a, Arbitrary b) => Arbitrary (MyValidation a b) where 103 | arbitrary = do 104 | a <- arbitrary 105 | b <- arbitrary 106 | elements [MyError a, MySuccess b] 107 | 108 | -- More exercises: Write Applicative instances 109 | newtype Identity a = Identity a deriving (Eq, Show) 110 | 111 | instance Functor Identity where 112 | fmap f (Identity x) = Identity (f x) 113 | 114 | instance Applicative Identity where 115 | pure = Identity 116 | (Identity f) <*> (Identity x) = Identity (f x) 117 | 118 | instance Arbitrary a => Arbitrary (Identity a) where 119 | arbitrary = do 120 | a <- arbitrary 121 | return (Identity a) 122 | 123 | instance Eq a => EqProp (Identity a) where (=-=) = eq 124 | 125 | -- not going to write Arbitrary and Eq instances for the rest... boring... 126 | data Pair a = Pair a a deriving (Eq, Show) 127 | 128 | instance Functor Pair where 129 | fmap f (Pair x y) = Pair (f x) (f y) 130 | 131 | instance Applicative Pair where 132 | pure x = Pair x x 133 | (Pair f g) <*> (Pair x y) = Pair (f x) (g y) 134 | 135 | data Two a b = Two a b deriving (Eq, Show) 136 | 137 | instance Functor (Two a) where 138 | fmap f (Two x y) = Two x (f y) 139 | 140 | instance Monoid a => Applicative (Two a) where 141 | pure x = Two mempty x 142 | (Two x f) <*> (Two x' y) = Two (x <> x') (f y) 143 | 144 | data Three a b c = Three a b c deriving (Eq, Show) 145 | 146 | instance Functor (Three a b) where 147 | fmap f (Three x y z) = Three x y (f z) 148 | 149 | instance (Monoid a, Monoid b) => Applicative (Three a b) where 150 | pure x = Three mempty mempty x 151 | (Three x y f) <*> (Three x' y' z) = Three (x <> x') (y <> y') (f z) 152 | 153 | data Three' a b = Three' a b b deriving (Eq, Show) 154 | 155 | instance Functor (Three' a) where 156 | fmap f (Three' x y z) = Three' x (f y) (f z) 157 | 158 | instance Monoid a => Applicative (Three' a) where 159 | pure x = Three' mempty x x 160 | (Three' x f f') <*> (Three' x' y z) = Three' (x <> x') (f y) (f z) 161 | 162 | data Four a b c d = Four a b c d deriving (Eq, Show) 163 | 164 | instance Functor (Four a b c) where 165 | fmap f (Four x w y z) = Four x w y (f z) 166 | 167 | instance (Monoid a, Monoid b, Monoid c) => Applicative (Four a b c) where 168 | pure x = Four mempty mempty mempty x 169 | (Four x w y f) <*> (Four x' w' y' z) = Four (x <> x') (w <> w') (y <> y') (f z) 170 | 171 | data Four' a b = Four' a a a b deriving (Eq, Show) 172 | 173 | instance Functor (Four' a) where 174 | fmap f (Four' x w y z) = Four' x w y (f z) 175 | 176 | instance Monoid a => Applicative (Four' a) where 177 | pure x = Four' mempty mempty mempty x 178 | (Four' x w y f) <*> (Four' x' w' y' z) = Four' (x <> x') (w <> w') (y <> y') (f z) 179 | 180 | -- Tests 181 | main :: IO () 182 | main = do 183 | --quickBatch $ applicative (Identity ("a", "b", 1 :: Int)) 184 | quickBatch $ applicative (ZipList' (Cons ("a", "b", 1 :: Int) Nil)) 185 | --quickBatch $ applicative (MySecond ("a", "b", 1 :: Int)) 186 | --quickBatch $ applicative (MySuccess ("a", "b", 1 :: Int)) 187 | -------------------------------------------------------------------------------- /chapter15/exercises.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid (Sum, Monoid) 2 | import Data.Semigroup 3 | import MonoidLaws (monoidLeftIdentity, monoidRightIdentity) 4 | import Test.QuickCheck 5 | 6 | data Trivial = Trivial deriving (Eq, Show) 7 | 8 | instance Semigroup Trivial where 9 | _ <> _ = Trivial 10 | 11 | instance Monoid Trivial where 12 | mempty = Trivial 13 | mappend = (<>) 14 | 15 | instance Arbitrary Trivial where 16 | arbitrary = return Trivial 17 | 18 | semigroupAssoc :: (Eq m, Semigroup m) => m -> m -> m -> Bool 19 | semigroupAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c) 20 | 21 | type TrivialAssoc = Trivial -> Trivial -> Trivial -> Bool 22 | 23 | -- Identity 24 | newtype Identity a = Identity a deriving (Eq, Show) 25 | 26 | instance Semigroup a => Semigroup (Identity a) where 27 | (Identity x) <> (Identity y) = Identity (x <> y) 28 | 29 | instance (Semigroup a, Monoid a) => Monoid (Identity a) where 30 | mempty = Identity mempty 31 | mappend = (<>) 32 | 33 | instance Arbitrary a => Arbitrary (Identity a) where 34 | arbitrary = do 35 | a <- arbitrary 36 | return (Identity a) 37 | 38 | type IdentityAssoc = Identity String -> Identity String -> Identity String -> Bool 39 | 40 | -- Two 41 | data Two a b = Two a b deriving (Eq, Show) 42 | 43 | instance (Semigroup a, Semigroup b) => Semigroup (Two a b) where 44 | (Two x y) <> (Two w z) = Two (x <> w) (y <> z) 45 | 46 | instance (Semigroup a, Semigroup b, Monoid a, Monoid b) => Monoid (Two a b) where 47 | mempty = Two mempty mempty 48 | mappend = (<>) 49 | 50 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where 51 | arbitrary = do 52 | a <- arbitrary 53 | b <- arbitrary 54 | return (Two a b) 55 | 56 | type TwoAssoc = Two String [Int] -> Two String [Int] -> Two String [Int] -> Bool 57 | 58 | -- Three 59 | data Three a b c = Three a b c 60 | 61 | -- Four 62 | data Four a b c d = Four a b c d 63 | 64 | -- BoolConj 65 | newtype BoolConj = BoolConj Bool deriving (Eq, Show) 66 | 67 | instance Semigroup BoolConj where 68 | (BoolConj True) <> (BoolConj True) = BoolConj True 69 | _ <> _ = BoolConj False 70 | 71 | instance Monoid BoolConj where 72 | mempty = BoolConj True 73 | mappend = (<>) 74 | 75 | type BoolConjAssoc = BoolConj -> BoolConj -> BoolConj -> Bool 76 | 77 | instance Arbitrary BoolConj where 78 | arbitrary = do 79 | a <- arbitrary 80 | elements [(BoolConj a), (BoolConj a)] 81 | 82 | -- BoolDisj 83 | newtype BoolDisj = BoolDisj Bool deriving (Eq, Show) 84 | 85 | instance Semigroup BoolDisj where 86 | (BoolDisj True) <> _ = BoolDisj True 87 | _ <> (BoolDisj True) = BoolDisj True 88 | _ <> _ = BoolDisj False 89 | 90 | instance Monoid BoolDisj where 91 | mempty = BoolDisj False 92 | mappend = (<>) 93 | 94 | type BoolDisjAssoc = BoolDisj -> BoolDisj -> BoolDisj -> Bool 95 | 96 | instance Arbitrary BoolDisj where 97 | arbitrary = do 98 | a <- arbitrary 99 | elements [(BoolDisj a), (BoolDisj a)] 100 | 101 | -- Or 102 | data Or a b = Fst a | Snd b deriving (Eq, Show) 103 | 104 | instance Semigroup (Or a b) where 105 | (Fst x) <> (Fst y) = Fst y 106 | (Fst x) <> (Snd y) = Snd y 107 | (Snd x) <> _ = Snd x 108 | 109 | type OrAssoc = Or Int Int -> Or Int Int -> Or Int Int -> Bool 110 | 111 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Or a b) where 112 | arbitrary = do 113 | a <- arbitrary 114 | b <- arbitrary 115 | elements [(Fst a), (Snd b)] 116 | 117 | -- Combine (I don't get the point) 118 | newtype Combine a b = Combine { unCombine :: (a -> b) } 119 | 120 | -- Validation 121 | data MyValidation a b = MyFailure a | MySuccess b deriving (Eq, Show) 122 | 123 | instance Semigroup a => Semigroup (MyValidation a b) where 124 | (MySuccess x) <> (MySuccess y) = MySuccess y 125 | (MyFailure x) <> (MyFailure y) = MyFailure (x <> y) 126 | _ <> (MyFailure y) = MyFailure y 127 | (MyFailure x) <> _ = MyFailure x 128 | 129 | type MyValidationAssoc = MyValidation String Int -> MyValidation String Int -> MyValidation String Int -> Bool 130 | 131 | instance (Arbitrary a, Arbitrary b) => Arbitrary (MyValidation a b) where 132 | arbitrary = do 133 | a <- arbitrary 134 | b <- arbitrary 135 | elements [(MyFailure a), (MySuccess b)] 136 | 137 | -- Validation AccumulateRight 138 | newtype AccumulateRight a b = AccumulateRight (MyValidation a b) deriving (Eq, Show) 139 | 140 | instance Semigroup b => Semigroup (AccumulateRight a b) where 141 | (AccumulateRight (MySuccess x)) <> (AccumulateRight (MySuccess y)) = AccumulateRight (MySuccess (x <> y)) 142 | (AccumulateRight (MySuccess x)) <> (AccumulateRight (MyFailure y)) = AccumulateRight (MyFailure y) 143 | (AccumulateRight (MyFailure x)) <> _ = AccumulateRight (MyFailure x) 144 | 145 | type AccumulateRightAssoc = AccumulateRight String Trivial -> AccumulateRight String Trivial -> AccumulateRight String Trivial -> Bool 146 | 147 | instance (Arbitrary a, Arbitrary b) => Arbitrary (AccumulateRight a b) where 148 | arbitrary = do 149 | a <- arbitrary 150 | b <- arbitrary 151 | elements [(AccumulateRight (MyFailure a)), (AccumulateRight (MySuccess b))] 152 | 153 | -- Validation AccumulateBoth 154 | newtype AccumulateBoth a b = AccumulateBoth (MyValidation a b) deriving (Eq, Show) 155 | 156 | instance (Semigroup a, Semigroup b) => Semigroup (AccumulateBoth a b) where 157 | (AccumulateBoth (MySuccess x)) <> (AccumulateBoth (MySuccess y)) = AccumulateBoth (MySuccess (x <> y)) 158 | (AccumulateBoth (MySuccess x)) <> (AccumulateBoth (MyFailure y)) = AccumulateBoth (MyFailure y) 159 | (AccumulateBoth (MyFailure x)) <> (AccumulateBoth (MySuccess y)) = AccumulateBoth (MyFailure x) 160 | (AccumulateBoth (MyFailure x)) <> (AccumulateBoth (MyFailure y)) = AccumulateBoth (MyFailure (x <> y)) 161 | 162 | type AccumulateBothAssoc = AccumulateBoth String Trivial -> AccumulateBoth String Trivial -> AccumulateBoth String Trivial -> Bool 163 | 164 | instance (Arbitrary a, Arbitrary b) => Arbitrary (AccumulateBoth a b) where 165 | arbitrary = do 166 | a <- arbitrary 167 | b <- arbitrary 168 | elements [(AccumulateBoth (MyFailure a)), (AccumulateBoth (MySuccess b))] 169 | 170 | -- Tests 171 | main :: IO () 172 | main = do 173 | quickCheck (semigroupAssoc :: TrivialAssoc) 174 | quickCheck (semigroupAssoc :: IdentityAssoc) 175 | quickCheck (semigroupAssoc :: BoolConjAssoc) 176 | quickCheck (semigroupAssoc :: BoolDisjAssoc) 177 | quickCheck (semigroupAssoc :: TwoAssoc) 178 | quickCheck (semigroupAssoc :: OrAssoc) 179 | quickCheck (semigroupAssoc :: MyValidationAssoc) 180 | quickCheck (semigroupAssoc :: AccumulateRightAssoc) 181 | quickCheck (semigroupAssoc :: AccumulateBothAssoc) 182 | quickCheck (monoidLeftIdentity :: Trivial -> Bool) 183 | quickCheck (monoidRightIdentity :: Trivial -> Bool) 184 | quickCheck (monoidLeftIdentity :: Identity String -> Bool) 185 | quickCheck (monoidRightIdentity :: Identity String -> Bool) 186 | quickCheck (monoidLeftIdentity :: Two String Trivial -> Bool) 187 | quickCheck (monoidRightIdentity :: Two String Trivial -> Bool) 188 | quickCheck (monoidLeftIdentity :: BoolConj -> Bool) 189 | quickCheck (monoidRightIdentity :: BoolConj -> Bool) 190 | quickCheck (monoidLeftIdentity :: BoolDisj -> Bool) 191 | quickCheck (monoidRightIdentity :: BoolDisj -> Bool) 192 | 193 | -- Mem test: Looks like the State Monad but I don't get it... 194 | newtype Mem s a = Mem { runMem :: s -> (a,s) } 195 | 196 | instance Monoid a => Monoid (Mem s a) where 197 | mempty = Mem (\s -> (mempty, s)) 198 | mappend = undefined 199 | 200 | f' = Mem $ \s -> ("hi", s + 1) 201 | 202 | --memtest = do 203 | -- print $ runMem (f' <> mempty) 0 204 | -- print $ runMem (mempty <> f') 0 205 | -- print $ (runMem mempty 0 :: (String, Int)) 206 | -- print $ runMem (f' <> mempty) 0 == runMem f' 0 207 | -- print $ runMem (mempty <> f') 0 == runMem f' 0 208 | -------------------------------------------------------------------------------- /chapter13/hangman/LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /chapter13/call-em-up/LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /chapter13/hello-haskell/LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | --------------------------------------------------------------------------------