1
0

Add remaining haskell book exercises

This commit is contained in:
2025-12-11 10:28:11 +01:00
parent 3624c712d7
commit 98329e0a3d
221 changed files with 8033 additions and 2 deletions

View File

@@ -0,0 +1,36 @@
module Madness where
import Data.Monoid
type Verb = String
type Adjective = String
type Adverb = String
type Noun = String
type Exclamation = String
madlibbin' :: Exclamation
-> Adverb
-> Noun
-> Adjective
-> String
madlibbin' e adv noun adj =
e <> "! he said " <>
adv <> " as he jumped into his car " <>
noun <> " and drove off with his " <>
adj <> " wife."
madlibbinBetter' :: Exclamation
-> Adverb
-> Noun
-> Adjective
-> String
madlibbinBetter' e adv noun adj =
mconcat [ e
, "! he said "
, adv
, " as he jumped into his car "
, noun
, " and drove off with his "
, adj
, " wife."
]

View File

@@ -0,0 +1,45 @@
name: optional
version: 0.1.0.0
author: Eugen Wissner
maintainer: belka@caraus.de
copyright: 2018 Eugen Wissner
license: BSD3
build-type: Simple
cabal-version: >= 1.10
library
hs-source-dirs:
src
build-depends:
base >=4.7 && <5
exposed-modules:
Optional
other-modules:
Paths_optional
default-language: Haskell2010
test-suite optional-test
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs:
test
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
, hspec
, optional
other-modules:
Paths_optional
default-language: Haskell2010
test-suite first-test
type: exitcode-stdio-1.0
main-is: First.hs
hs-source-dirs:
app
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
, QuickCheck
, optional
default-language: Haskell2010

3
Haskell-book/15/optional/.gitignore vendored Normal file
View File

@@ -0,0 +1,3 @@
.stack-work/
optional.cabal
*~

View File

@@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

View File

@@ -0,0 +1,48 @@
module Main where
import Data.Monoid
import Optional
import Test.QuickCheck
newtype First' a =
First' { getFirst' :: Optional a }
deriving (Eq, Show)
instance Monoid (First' a) where
mempty = First' Nada
mappend (First' Nada) x = x
mappend x _ = x
instance Arbitrary a => Arbitrary (First' a) where
arbitrary = frequency [ (1, return $ First' Nada)
, (1, fmap (First' . Only) arbitrary) ]
firstMappend :: First' a
-> First' a
-> First' a
firstMappend = mappend
type FirstMappend =
First' String
-> First' String
-> First' String
-> Bool
type FstId =
First' String -> Bool
monoidAssoc :: (Eq m, Monoid m) => m -> m -> m -> Bool
monoidAssoc a b c =
(a <> (b <> c)) == ((a <> b) <> c)
monoidLeftIdentity :: (Eq m, Monoid m) => m -> Bool
monoidLeftIdentity a = (mempty <> a) == a
monoidRightIdentity :: (Eq m, Monoid m) => m -> Bool
monoidRightIdentity a = (a <> mempty) == a
main :: IO ()
main = do
quickCheck (monoidAssoc :: FirstMappend)
quickCheck (monoidLeftIdentity :: FstId)
quickCheck (monoidRightIdentity :: FstId)

View File

@@ -0,0 +1,35 @@
name: optional
version: 0.1.0.0
license: BSD3
author: "Eugen Wissner"
maintainer: "belka@caraus.de"
copyright: "2018 Eugen Wissner"
dependencies:
- base >= 4.7 && < 5
library:
source-dirs: src
tests:
optional-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- optional
- hspec
first-test:
main: First.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- optional
- QuickCheck

View File

@@ -0,0 +1,12 @@
module Optional where
data Optional a =
Nada
| Only a
deriving (Eq, Show)
instance Monoid a => Monoid (Optional a) where
mempty = Nada
mappend x Nada = x
mappend Nada x = x
mappend (Only x) (Only y) = Only (mappend x y)

View File

@@ -0,0 +1,66 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-10.2
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
# extra-deps: []
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.6"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

View File

@@ -0,0 +1,21 @@
import Data.Monoid
import Optional
import Test.Hspec
main :: IO ()
main = hspec $ do
describe "Sum" $ do
it "1 + 1 is 2" $ do
Only (Sum 1) `mappend` Only (Sum 1) `shouldBe` Only (Sum {getSum = 2})
describe "Product" $ do
it "4 * 2 is 8" $ do
Only (Product 4) `mappend` Only (Product 2) `shouldBe` Only (Product {getProduct = 8})
describe "Sum with Nada" $ do
it "1 + Nada is 1" $ do
Only (Sum 1) `mappend` Nada `shouldBe` Only (Sum {getSum = 1})
describe "List" $ do
it "[1] <> Nada is [1]" $ do
Only [1] `mappend` Nada `shouldBe` Only [1]
describe "Nada with sum" $ do
it "Nada + 1 is 1" $ do
Nada `mappend` Only (Sum 1) `shouldBe` Only (Sum {getSum = 1})

View File

@@ -0,0 +1,10 @@
module Listy where
newtype Listy a =
Listy [a]
deriving (Eq, Show)
instance Monoid (Listy a) where
mempty = Listy []
mappend (Listy l) (Listy l') =
Listy $ mappend l l'

View File

@@ -0,0 +1,9 @@
module ListyInstances where
import Data.Monoid
import Listy
instance Monoid (Listy a) where
mempty = Listy []
mappend (Listy l) (Listy l') =
Listy $ mappend l l'

3
Haskell-book/15/semigroup/.gitignore vendored Normal file
View File

@@ -0,0 +1,3 @@
.stack-work/
semigroup.cabal
*~

View File

@@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

View File

@@ -0,0 +1,18 @@
module Main where
import Data.Monoid
import Mem
f' :: Num a => Mem a String
f' = Mem $ \s -> ("hi", s + 1)
main :: IO ()
main = do
let rmzero = runMem mempty 0
rmleft = runMem (f' <> mempty) 0
rmright = runMem (mempty <> f') 0
print $ (rmleft :: (String, Int))
print $ (rmright :: (String, Int))
print $ (rmzero :: (String, Int))
print $ rmleft == runMem f' 0
print $ rmright == runMem f' 0

View File

@@ -0,0 +1,36 @@
name: semigroup
version: 0.1.0.0
author: "Eugen Wissner"
maintainer: "belka@caraus.de"
copyright: "2018 Eugen Wissner"
dependencies:
- base >= 4.7 && < 5
library:
source-dirs: src
dependencies:
- QuickCheck
executables:
semigroup-exe:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- semigroup
tests:
semigroup-test:
main: Main.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- QuickCheck
- semigroup

View File

@@ -0,0 +1,30 @@
module Bool where
import Data.Semigroup
import Test.QuickCheck
newtype BoolConj = BoolConj Bool deriving (Eq, Show)
instance Semigroup BoolConj where
(BoolConj True) <> (BoolConj True) = BoolConj True
_ <> _ = BoolConj False
instance Monoid BoolConj where
mempty = BoolConj True
mappend = (<>)
instance Arbitrary BoolConj where
arbitrary = fmap BoolConj arbitrary
newtype BoolDisj = BoolDisj Bool deriving (Eq, Show)
instance Semigroup BoolDisj where
(BoolDisj False) <> (BoolDisj False) = BoolDisj False
_ <> _ = BoolDisj True
instance Monoid BoolDisj where
mempty = BoolDisj False
mappend = (<>)
instance Arbitrary BoolDisj where
arbitrary = fmap BoolDisj arbitrary

View File

@@ -0,0 +1,25 @@
{-# LANGUAGE FlexibleInstances #-}
module Combine where
import Data.Semigroup
import Test.QuickCheck
newtype Combine a b =
Combine { unCombine :: (a -> b) }
instance Semigroup b => Semigroup (Combine a b) where
(Combine f1) <> (Combine f2) = Combine f
where f x = (f1 x) <> (f2 x)
instance (Monoid b) => Monoid (Combine a b) where
mempty = Combine $ \_ -> mempty
mappend (Combine f1) (Combine f2) = Combine f
where f x = mappend (f1 x) (f2 x)
instance (Num a, CoArbitrary a, Arbitrary b) => Arbitrary (Combine a b) where
arbitrary = do
f <- arbitrary
return $ Combine (\n -> f n)
instance (Show a, Show b) => Show (Combine a b) where
show _ = "a -> b"

View File

@@ -0,0 +1,22 @@
module Comp where
import Data.Semigroup
import Test.QuickCheck
newtype Comp a =
Comp { unComp :: (a -> a) }
instance Semigroup a => Semigroup (Comp a) where
(Comp f1) <> (Comp f2) = Comp f
where f x = (f1 x) <> (f2 x)
instance Monoid a => Monoid (Comp a) where
mempty = Comp $ \_ -> mempty
mappend (Comp f1) (Comp f2) = Comp f
where f x = mappend (f1 x) (f2 x)
instance (Arbitrary a, CoArbitrary a) => Arbitrary (Comp a) where
arbitrary = fmap Comp arbitrary
instance Show (Comp a) where
show _ = "a -> a"

View File

@@ -0,0 +1,16 @@
module Identity where
import Data.Semigroup
import Test.QuickCheck
newtype Identity a = Identity a deriving (Show, Eq)
instance Semigroup a => Semigroup (Identity a) where
(Identity x) <> (Identity y) = Identity (x <> y)
instance Monoid a => Monoid (Identity a) where
mempty = Identity mempty
mappend (Identity x) (Identity y) = Identity $ mappend x y
instance Arbitrary a => Arbitrary (Identity a) where
arbitrary = fmap Identity arbitrary

View File

@@ -0,0 +1,11 @@
module Mem where
newtype Mem s a =
Mem {
runMem :: s -> (a,s)
}
instance Monoid a => Monoid (Mem s a) where
mempty = Mem $ \x -> (mempty, x)
mappend (Mem f1) (Mem f2) = Mem f
where f x = ((mappend (fst $ f1 x) (fst $ f2 x)), snd $ f2 $ snd $ f1 x)

View File

@@ -0,0 +1,19 @@
module Or where
import Data.Semigroup
import Test.QuickCheck
data Or a b =
Fst a
| Snd b
deriving (Eq, Show)
instance Semigroup (Or a b) where
(Snd x) <> _ = Snd x
_ <> x = x
instance (Arbitrary a, Arbitrary b) => Arbitrary (Or a b) where
arbitrary = do
x <- arbitrary
y <- arbitrary
frequency [ (1, return $ Fst x), (1, return $ Snd y) ]

View File

@@ -0,0 +1,16 @@
module Trivial where
import Data.Semigroup
import Test.QuickCheck
data Trivial = Trivial deriving (Eq, Show)
instance Semigroup Trivial where
_ <> _ = Trivial
instance Arbitrary Trivial where
arbitrary = return Trivial
instance Monoid Trivial where
mempty = undefined
mappend = (<>)

View File

@@ -0,0 +1,53 @@
module Two where
import Data.Semigroup
import Test.QuickCheck
data Two a b = Two a b deriving (Eq, Show)
data Three a b c = Three a b c deriving (Eq, Show)
data Four a b c d = Four a b c d deriving (Eq, Show)
instance (Semigroup a, Semigroup b) => Semigroup (Two a b) where
(Two x1 y1) <> (Two x2 y2) = Two (x1 <> x2) (y1 <> y2)
instance (Monoid a, Monoid b) => Monoid (Two a b) where
mempty = Two mempty mempty
mappend (Two x1 y1) (Two x2 y2) = Two (mappend x1 x2) (mappend y1 y2)
instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where
arbitrary = do
x <- arbitrary
y <- arbitrary
return $ Two x y
instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (Three a b c) where
(Three x1 y1 z1) <> (Three x2 y2 z2) = Three (x1 <> x2) (y1 <> y2) (z1 <> z2)
instance (Monoid a, Monoid b, Monoid c) => Monoid (Three a b c) where
mempty = Three mempty mempty mempty
mappend (Three x1 y1 z1) (Three x2 y2 z2) = Three (mappend x1 x2) (mappend y1 y2) (mappend z1 z2)
instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Three a b c) where
arbitrary = do
x <- arbitrary
y <- arbitrary
z <- arbitrary
return $ Three x y z
instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) => Semigroup (Four a b c d) where
(Four x1 y1 z1 t1) <> (Four x2 y2 z2 t2) = Four (x1 <> x2) (y1 <> y2) (z1 <> z2) (t1 <> t2)
instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (Four a b c d) where
mempty = Four mempty mempty mempty mempty
mappend (Four x1 y1 z1 t1) (Four x2 y2 z2 t2) =
Four (mappend x1 x2) (mappend y1 y2) (mappend z1 z2) (mappend t1 t2)
instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (Four a b c d) where
arbitrary = do
x <- arbitrary
y <- arbitrary
z <- arbitrary
t <- arbitrary
return $ Four x y z t

View File

@@ -0,0 +1,17 @@
module Validation where
import Data.Semigroup
import Test.QuickCheck (arbitrary, Arbitrary(..), frequency)
data Validation a b = Failure a | Success b deriving (Eq, Show)
instance Semigroup a => Semigroup (Validation a b) where
(Success x) <> _ = Success x
_ <> (Success x) = Success x
(Failure x) <> (Failure y) = Failure $ x <> y
instance (Arbitrary a, Arbitrary b) => Arbitrary (Validation a b) where
arbitrary = do
x <- arbitrary
y <- arbitrary
frequency [ (1, return $ Success x), (1, return $ Failure y) ]

View File

@@ -0,0 +1,66 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-10.2
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
# extra-deps: []
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.6"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

View File

@@ -0,0 +1,72 @@
import Trivial
import Identity
import Two
import Test.QuickCheck
import Bool
import Or
import Combine
import Data.Semigroup
import Comp
import Validation
semigroupAssoc :: (Eq m, Semigroup m) => m -> m -> m -> Bool
semigroupAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c)
type TrivAssoc =
Trivial -> Trivial -> Trivial -> Bool
type TwoType = Two Trivial Trivial
type ThreeType = Three Trivial Trivial Trivial
type FourType = Four Trivial Trivial Trivial Trivial
type CombineType = Combine Int (Sum Int)
semigroupCombineAssoc :: CombineType -> CombineType -> CombineType -> Bool
semigroupCombineAssoc a b c =
((unCombine (a <> (b <> c))) 8) == ((unCombine ((a <> b) <> c)) 8)
semigroupCompAssoc :: Comp (Sum Int) -> Comp (Sum Int) -> Comp (Sum Int) -> Bool
semigroupCompAssoc a b c =
((unComp (a <> (b <> c))) (Sum 8)) == ((unComp ((a <> b) <> c)) (Sum 8))
monoidLeftIdentity :: (Eq m, Monoid m)
=> m
-> Bool
monoidLeftIdentity a = (mappend mempty a) == a
monoidRightIdentity :: (Eq m, Monoid m)
=> m
-> Bool
monoidRightIdentity a = (mappend a mempty) == a
main :: IO ()
main = do
quickCheck (semigroupAssoc :: TrivAssoc)
quickCheck (monoidLeftIdentity :: Trivial -> Bool)
quickCheck (monoidRightIdentity :: Trivial -> Bool)
quickCheck (semigroupAssoc :: Identity Trivial -> Identity Trivial -> Identity Trivial -> Bool)
quickCheck (monoidLeftIdentity :: Identity (Sum Int)-> Bool)
quickCheck (monoidRightIdentity :: Identity (Sum Int) -> Bool)
quickCheck (semigroupAssoc :: TwoType -> TwoType -> TwoType -> Bool)
quickCheck (monoidLeftIdentity :: TwoType -> Bool)
quickCheck (monoidRightIdentity :: TwoType -> Bool)
quickCheck (semigroupAssoc :: ThreeType -> ThreeType -> ThreeType -> Bool)
quickCheck (monoidLeftIdentity :: ThreeType -> Bool)
quickCheck (monoidRightIdentity :: ThreeType -> Bool)
quickCheck (semigroupAssoc :: FourType -> FourType -> FourType -> Bool)
quickCheck (monoidLeftIdentity :: FourType -> Bool)
quickCheck (monoidRightIdentity :: FourType -> Bool)
quickCheck (semigroupAssoc :: BoolConj -> BoolConj -> BoolConj -> Bool)
quickCheck (monoidLeftIdentity :: BoolConj -> Bool)
quickCheck (monoidRightIdentity :: BoolConj -> Bool)
quickCheck (semigroupAssoc :: BoolDisj -> BoolDisj -> BoolDisj -> Bool)
quickCheck (monoidLeftIdentity :: BoolDisj -> Bool)
quickCheck (monoidRightIdentity :: BoolDisj -> Bool)
quickCheck (semigroupAssoc :: Or Trivial Trivial -> Or Trivial Trivial -> Or Trivial Trivial -> Bool)
quickCheck semigroupCombineAssoc
quickCheck semigroupCompAssoc
quickCheck (semigroupAssoc :: Validation String Int -> Validation String Int -> Validation String Int -> Bool)