Add remaining haskell book exercises
This commit is contained in:
36
Haskell-book/15/Madness.hs
Normal file
36
Haskell-book/15/Madness.hs
Normal 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."
|
||||
]
|
||||
45
Haskell-book/15/optional.cabal
Normal file
45
Haskell-book/15/optional.cabal
Normal 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
3
Haskell-book/15/optional/.gitignore
vendored
Normal file
@@ -0,0 +1,3 @@
|
||||
.stack-work/
|
||||
optional.cabal
|
||||
*~
|
||||
2
Haskell-book/15/optional/Setup.hs
Normal file
2
Haskell-book/15/optional/Setup.hs
Normal file
@@ -0,0 +1,2 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
48
Haskell-book/15/optional/app/First.hs
Normal file
48
Haskell-book/15/optional/app/First.hs
Normal 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)
|
||||
35
Haskell-book/15/optional/package.yaml
Normal file
35
Haskell-book/15/optional/package.yaml
Normal 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
|
||||
12
Haskell-book/15/optional/src/Optional.hs
Normal file
12
Haskell-book/15/optional/src/Optional.hs
Normal 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)
|
||||
66
Haskell-book/15/optional/stack.yaml
Normal file
66
Haskell-book/15/optional/stack.yaml
Normal 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
|
||||
21
Haskell-book/15/optional/test/Spec.hs
Normal file
21
Haskell-book/15/optional/test/Spec.hs
Normal 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})
|
||||
10
Haskell-book/15/orphan-instance/Listy.hs
Normal file
10
Haskell-book/15/orphan-instance/Listy.hs
Normal 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'
|
||||
9
Haskell-book/15/orphan-instance/ListyInstances.hs
Normal file
9
Haskell-book/15/orphan-instance/ListyInstances.hs
Normal 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
3
Haskell-book/15/semigroup/.gitignore
vendored
Normal file
@@ -0,0 +1,3 @@
|
||||
.stack-work/
|
||||
semigroup.cabal
|
||||
*~
|
||||
2
Haskell-book/15/semigroup/Setup.hs
Normal file
2
Haskell-book/15/semigroup/Setup.hs
Normal file
@@ -0,0 +1,2 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
18
Haskell-book/15/semigroup/app/Main.hs
Normal file
18
Haskell-book/15/semigroup/app/Main.hs
Normal 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
|
||||
36
Haskell-book/15/semigroup/package.yaml
Normal file
36
Haskell-book/15/semigroup/package.yaml
Normal 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
|
||||
30
Haskell-book/15/semigroup/src/Bool.hs
Normal file
30
Haskell-book/15/semigroup/src/Bool.hs
Normal 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
|
||||
25
Haskell-book/15/semigroup/src/Combine.hs
Normal file
25
Haskell-book/15/semigroup/src/Combine.hs
Normal 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"
|
||||
22
Haskell-book/15/semigroup/src/Comp.hs
Normal file
22
Haskell-book/15/semigroup/src/Comp.hs
Normal 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"
|
||||
16
Haskell-book/15/semigroup/src/Identity.hs
Normal file
16
Haskell-book/15/semigroup/src/Identity.hs
Normal 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
|
||||
11
Haskell-book/15/semigroup/src/Mem.hs
Normal file
11
Haskell-book/15/semigroup/src/Mem.hs
Normal 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)
|
||||
19
Haskell-book/15/semigroup/src/Or.hs
Normal file
19
Haskell-book/15/semigroup/src/Or.hs
Normal 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) ]
|
||||
16
Haskell-book/15/semigroup/src/Trivial.hs
Normal file
16
Haskell-book/15/semigroup/src/Trivial.hs
Normal 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 = (<>)
|
||||
53
Haskell-book/15/semigroup/src/Two.hs
Normal file
53
Haskell-book/15/semigroup/src/Two.hs
Normal 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
|
||||
17
Haskell-book/15/semigroup/src/Validation.hs
Normal file
17
Haskell-book/15/semigroup/src/Validation.hs
Normal 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) ]
|
||||
66
Haskell-book/15/semigroup/stack.yaml
Normal file
66
Haskell-book/15/semigroup/stack.yaml
Normal 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
|
||||
72
Haskell-book/15/semigroup/test/Main.hs
Normal file
72
Haskell-book/15/semigroup/test/Main.hs
Normal 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)
|
||||
Reference in New Issue
Block a user