Add remaining haskell book exercises

Haskell-book/15/semigroup/.gitignore

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

Haskell-book/15/semigroup/Setup.hs

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

Haskell-book/15/semigroup/app/Main.hs

@@ -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

Haskell-book/15/semigroup/package.yaml

@@ -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

Haskell-book/15/semigroup/src/Bool.hs

@@ -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

Haskell-book/15/semigroup/src/Combine.hs

@@ -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"

Haskell-book/15/semigroup/src/Comp.hs

@@ -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"

Haskell-book/15/semigroup/src/Identity.hs

@@ -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

Haskell-book/15/semigroup/src/Mem.hs

@@ -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)

Haskell-book/15/semigroup/src/Or.hs

@@ -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) ]

Haskell-book/15/semigroup/src/Trivial.hs

@@ -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 = (<>)

Haskell-book/15/semigroup/src/Two.hs

@@ -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

Haskell-book/15/semigroup/src/Validation.hs

@@ -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) ]

Haskell-book/15/semigroup/stack.yaml

@@ -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

Haskell-book/15/semigroup/test/Main.hs

@@ -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)