From ab963054c76abf620a2a8708367906a126e0e8eb Mon Sep 17 00:00:00 2001 From: Abhijit Sarkar Date: Sun, 29 Dec 2024 17:37:16 -0800 Subject: [PATCH] Complete StateT --- README.md | 4 +- {share => data}/a.txt | 0 {share => data}/b.txt | 0 {share => data}/c.txt | 0 data/files.txt | 3 + fp-course-haskell.cabal | 6 +- package.yaml | 1 + share/files.txt | 3 - src/FileIO.hs | 12 +- src/State.hs | 9 +- src/StateT.hs | 341 ++++++++++++++++++++++++++++++++++++++++ test/ApplicativeSpec.hs | 110 ++++++------- test/FunctorSpec.hs | 24 +-- test/ListSpec.hs | 38 ++--- test/MonadSpec.hs | 38 ++--- test/OptionalSpec.hs | 22 +-- test/StateSpec.hs | 20 +-- test/StateTSpec.hs | 135 ++++++++++++++++ test/ValidationSpec.hs | 12 +- 19 files changed, 627 insertions(+), 151 deletions(-) rename {share => data}/a.txt (100%) rename {share => data}/b.txt (100%) rename {share => data}/c.txt (100%) create mode 100644 data/files.txt delete mode 100644 share/files.txt create mode 100644 src/StateT.hs create mode 100644 test/StateTSpec.hs diff --git a/README.md b/README.md index 8f308b6..634fa33 100644 --- a/README.md +++ b/README.md @@ -21,7 +21,7 @@ After this, we recommend the following progression of modules: * [Monad](src/Monad.hs) * [FileIO](src/FileIO.hs) * [State](src/State.hs) -* StateT +* [StateT](src/StateT.hs) * Extend * Comonad * Contravariant @@ -59,7 +59,7 @@ To run a _specific test_: To run a file containing a `main` method: ``` -stack runhaskell app/Main.hs +stack runhaskell ``` To run an executable listed in `package.yaml`: diff --git a/share/a.txt b/data/a.txt similarity index 100% rename from share/a.txt rename to data/a.txt diff --git a/share/b.txt b/data/b.txt similarity index 100% rename from share/b.txt rename to data/b.txt diff --git a/share/c.txt b/data/c.txt similarity index 100% rename from share/c.txt rename to data/c.txt diff --git a/data/files.txt b/data/files.txt new file mode 100644 index 0000000..ceb8be7 --- /dev/null +++ b/data/files.txt @@ -0,0 +1,3 @@ +data/a.txt +data/b.txt +data/c.txt \ No newline at end of file diff --git a/fp-course-haskell.cabal b/fp-course-haskell.cabal index e054a0f..9e4bd94 100644 --- a/fp-course-haskell.cabal +++ b/fp-course-haskell.cabal @@ -28,6 +28,7 @@ library Monad Optional State + StateT Validation other-modules: Paths_fp_course_haskell @@ -37,7 +38,7 @@ library TupleSections DerivingStrategies InstanceSigs - ghc-options: -Werror -Weverything -Wno-missing-import-lists -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-safe-haskell-mode -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-unused-top-binds -Wno-missing-export-lists -Wno-missing-role-annotations + ghc-options: -Werror -Weverything -Wno-missing-import-lists -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-safe-haskell-mode -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-unused-top-binds -Wno-missing-export-lists -Wno-missing-role-annotations -Wno-type-defaults build-depends: base >=4.7 && <5 , containers @@ -55,6 +56,7 @@ test-suite fp-course-test Property SpecHook StateSpec + StateTSpec ValidationSpec Paths_fp_course_haskell hs-source-dirs: @@ -63,7 +65,7 @@ test-suite fp-course-test TupleSections DerivingStrategies InstanceSigs - ghc-options: -Werror -Weverything -Wno-missing-import-lists -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-safe-haskell-mode -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-unused-top-binds -Wno-missing-export-lists -Wno-missing-role-annotations + ghc-options: -Werror -Weverything -Wno-missing-import-lists -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-safe-haskell-mode -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-unused-top-binds -Wno-missing-export-lists -Wno-missing-role-annotations -Wno-type-defaults build-depends: QuickCheck , base >=4.7 && <5 diff --git a/package.yaml b/package.yaml index 4778fd5..7563577 100644 --- a/package.yaml +++ b/package.yaml @@ -39,6 +39,7 @@ ghc-options: - -Wno-unused-top-binds - -Wno-missing-export-lists - -Wno-missing-role-annotations +- -Wno-type-defaults library: source-dirs: src diff --git a/share/files.txt b/share/files.txt deleted file mode 100644 index 9e489a2..0000000 --- a/share/files.txt +++ /dev/null @@ -1,3 +0,0 @@ -share/a.txt -share/b.txt -share/c.txt \ No newline at end of file diff --git a/src/FileIO.hs b/src/FileIO.hs index f1673cb..530eeb9 100644 --- a/src/FileIO.hs +++ b/src/FileIO.hs @@ -58,7 +58,7 @@ And c.txt, containing: the contents of c To test this module, load ghci in the root of the project directory, and do - >> :main "share/files.txt" + >> :main "data/files.txt" Example output: @@ -69,14 +69,14 @@ Loading ... [ 1 of 28] Compiling (etc... ... Ok, modules loaded: Course, etc... ->> :main "share/files.txt" -============ share/a.txt +>> :main "data/files.txt" +============ data/a.txt the contents of a -============ share/b.txt +============ data/b.txt the contents of b -============ share/c.txt +============ data/c.txt the contents of c -} @@ -136,7 +136,7 @@ main :: IO () main = L.getArgs >>= \case filename :. Nil -> run filename - _ -> L.putStrLn "usage: stack runhaskell src/FileIO.hs share/files.txt" + _ -> L.putStrLn "usage: stack runhaskell src/FileIO.hs data/files.txt" ---- diff --git a/src/State.hs b/src/State.hs index f1e692f..02bc78e 100644 --- a/src/State.hs +++ b/src/State.hs @@ -151,12 +151,9 @@ firstRepeat xs = eval (findM contains xs) S.empty contains :: (Ord a) => a -> State (Set a) Bool contains x = do seen <- get - if S.member x seen - then - A.pure True - else do - put (S.insert x seen) - A.pure False + let dup = S.member x seen + put $ S.insert x seen + A.pure dup -- | Remove all duplicate elements in a `List`. -- /Tip:/ Use `filtering` and `State` with a @Data.Set#Set@. diff --git a/src/StateT.hs b/src/StateT.hs new file mode 100644 index 0000000..d7afe4f --- /dev/null +++ b/src/StateT.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module StateT where + +import Applicative (Applicative, (>>)) +import qualified Applicative as A +import Core +import Data.Set (Set) +import qualified Data.Set as S +import ExactlyOne (ExactlyOne (..)) +import qualified ExactlyOne as EO +import Functor (Functor) +import qualified Functor as F +import List (Chars, List (..)) +import qualified List as L +import Monad (Monad, (>>=)) +import qualified Monad as M +import Optional (Optional (..)) + +-- $setup +-- >>> import Test.QuickCheck +-- >>> import qualified Prelude as P(fmap) +-- >>> instance Arbitrary a => Arbitrary (List a) where arbitrary = P.fmap listh arbitrary + +-- | A `StateT` is a function from a state value `s` to a functor k of (a produced value `a`, and a resulting state `s`). +newtype StateT s k a + = StateT + ( s -> + k (a, s) + ) + +runStateT :: StateT s k a -> s -> k (a, s) +runStateT (StateT f) = f + +-- | Implement the `Functor` instance for @StateT s k@ given a @Functor k@. +-- +-- >>> runStateT ((+1) <$> (A.pure 2) :: StateT Int List Int) 0 +-- [(3,0)] +instance (Functor k) => Functor (StateT s k) where + (<$>) :: (a -> b) -> StateT s k a -> StateT s k b + (<$>) f ska = StateT g + where + g s = first f F.<$> runStateT ska s + +-- | Implement the `Applicative` instance for @StateT s k@ given a @Monad k@. +-- +-- >>> runStateT (A.pure 2) 0 +-- (2,0) +-- +-- >>> runStateT ((A.pure 2) :: StateT Int List Int) 0 +-- [(2,0)] +-- +-- >>> runStateT (A.pure (+2) A.<*> ((A.pure 2) :: StateT Int List Int)) 0 +-- [(4,0)] +-- +-- >>> runStateT (StateT (\s -> Full ((+2), s ++ (1:.Nil))) A.<*> (StateT (\s -> Full (2, s ++ (2:.Nil))))) (0:.Nil) +-- Full (4,[0,1,2]) +-- +-- >>> runStateT (StateT (\s -> ((+2), s ++ (1:.Nil)) :. ((+3), s ++ (1:.Nil)) :. Nil) A.<*> (StateT (\s -> (2, s ++ (2:.Nil)) :. Nil))) (0:.Nil) +-- [(4,[0,1,2]),(5,[0,1,2])] +instance (Monad k) => Applicative (StateT s k) where + pure :: a -> StateT s k a + pure a = StateT (A.pure . (a,)) + + (<*>) :: StateT s k (a -> b) -> StateT s k a -> StateT s k b + (<*>) skab ska = StateT f + where + f s = do + (g, s') <- runStateT skab s + (a, s'') <- runStateT ska s' + A.pure (g a, s'') + +-- | Implement the `Monad` instance for @StateT s k@ given a @Monad k@. +-- Make sure the state value is passed through in `bind`. +-- +-- >>> runStateT ((const $ putT 2) M.=<< putT 1) 0 +-- ((),2) +-- +-- >>> let modify f = StateT (\s -> A.pure ((), f s)) in runStateT (modify (+1) >>= \() -> modify (*2)) 7 +-- ((),16) +instance (Monad k) => Monad (StateT s k) where + (=<<) :: (a -> StateT s k b) -> StateT s k a -> StateT s k b + (=<<) f ska = StateT g + where + g s = do + (a, s') <- runStateT ska s + runStateT (f a) s' + +-- | A `State'` is `StateT` specialised to the `ExactlyOne` functor. +type State' s a = StateT s ExactlyOne a + +-- | Provide a constructor for `State'` values +-- +-- >>> runStateT (state' $ runState $ put 1) 0 +-- ExactlyOne ((),1) +state' :: (s -> (a, s)) -> State' s a +state' = StateT . (ExactlyOne .) + +-- | Provide an unwrapper for `State'` values. +-- +-- >>> runState' (state' $ runState $ put 1) 0 +-- ((),1) +runState' :: State' s a -> s -> (a, s) +runState' = (EO.runExactlyOne .) . runStateT + +-- | Run the `StateT` seeded with `s` and retrieve the resulting state. +-- +-- >>> execT (StateT $ \s -> Full ((), s + 1)) 2 +-- Full 3 +execT :: (Functor k) => StateT s k a -> s -> k s +execT = ((snd F.<$>) .) . runStateT + +-- | Run the `State'` seeded with `s` and retrieve the resulting state. +-- +-- >>> exec' (state' $ \s -> ((), s + 1)) 2 +-- 3 +exec' :: State' s a -> s -> s +exec' = (snd .) . runState' + +-- | Run the `StateT` seeded with `s` and retrieve the resulting value. +-- +-- >>> evalT (StateT $ \s -> Full (even s, s + 1)) 2 +-- Full True +evalT :: (Functor k) => StateT s k a -> s -> k a +evalT = ((fst F.<$>) .) . runStateT + +-- | Run the `State'` seeded with `s` and retrieve the resulting value. +-- +-- >>> eval' (state' $ \s -> (even s, s + 1)) 5 +-- False +eval' :: State' s a -> s -> a +eval' = (fst .) . runState' + +-- | A `StateT` where the state also distributes into the produced value. +-- +-- >>> (runStateT (getT :: StateT Int List Int) 3) +-- [(3,3)] +getT :: (Applicative k) => StateT s k s +getT = StateT (A.pure . M.join (,)) + +-- | A `StateT` where the resulting state is seeded with the given value. +-- +-- >>> runStateT (putT 2) 0 +-- ((),2) +-- +-- >>> runStateT (putT 2 :: StateT Int List ()) 0 +-- [((),2)] +putT :: (Applicative k) => s -> StateT s k () +putT = StateT . const . A.pure . (,) () + +-- | Remove all duplicate elements in a `List`. +-- +-- /Tip:/ Use `filtering` and `State'` with a @Data.Set#Set@. +-- +-- prop> \xs -> distinct' xs == distinct' (flatMap (\x -> x :. x :. Nil) xs) +distinct' :: (Ord a) => List a -> List a +distinct' xs = EO.runExactlyOne $ evalT (A.filtering notContains xs) S.empty + where + notContains x = state' (S.notMember x &&& S.insert x) + +-- contains :: (Ord a) => a -> StateT (Set a) ExactlyOne Bool +-- contains x = state' (S.notMember x &&& S.insert x) + +-- | Remove all duplicate elements in a `List`. +-- However, if you see a value greater than `100` in the list, +-- abort the computation by producing `Empty`. +-- +-- /Tip:/ Use `filtering` and `StateT` over `Optional` with a @Data.Set#Set@. +-- +-- >>> distinctF $ listh [1,2,3,2,1] +-- Full [1,2,3] +-- +-- >>> distinctF $ listh [1,2,3,2,1,101] +-- Empty +distinctF :: (Ord a, Num a) => List a -> Optional (List a) +distinctF xs = evalT (A.filtering mayAbort xs) S.empty + where + mayAbort :: forall a. (Ord a, Num a) => a -> StateT (Set a) Optional Bool + mayAbort x = + if x > 100 + then + StateT (const Empty) + else do + seen <- getT + let dup = S.notMember x seen + putT $ S.insert x seen + A.pure dup + +-- | An `OptionalT` is a functor of an `Optional` value. +newtype OptionalT k a + = OptionalT + { runOptionalT :: + k (Optional a) + } + +-- | Implement the `Functor` instance for `OptionalT k` given a Functor k. +-- +-- >>> runOptionalT $ (+1) <$> OptionalT (Full 1 :. Empty :. Nil) +-- [Full 2,Empty] +instance (Functor k) => Functor (OptionalT k) where + (<$>) :: (a -> b) -> OptionalT k a -> OptionalT k b + (<$>) f (OptionalT ka) = OptionalT ((f F.<$>) F.<$> ka) + +-- | Implement the `Applicative` instance for `OptionalT k` given a Monad k. +-- +-- /Tip:/ Use `onFull` to help implement (A.<*>). +-- +-- >>> runOptionalT $ OptionalT Nil A.<*> OptionalT (Full 1 :. Full 2 :. Nil) +-- [] +-- +-- >>> runOptionalT $ OptionalT (Full (+1) :. Full (+2) :. Nil) A.<*> OptionalT Nil +-- [] +-- +-- >>> runOptionalT $ OptionalT (Empty :. Nil) A.<*> OptionalT (Empty :. Nil) +-- [Empty] +-- +-- >>> runOptionalT $ OptionalT (Full (+1) :. Empty :. Nil) A.<*> OptionalT (Empty :. Nil) +-- [Empty,Empty] +-- +-- >>> runOptionalT $ OptionalT (Empty :. Nil) A.<*> OptionalT (Full 1 :. Full 2 :. Nil) +-- [Empty] +-- +-- >>> runOptionalT $ OptionalT (Full (+1) :. Empty :. Nil) A.<*> OptionalT (Full 1 :. Full 2 :. Nil) +-- [Full 2,Full 3,Empty] +-- +-- >>> runOptionalT $ OptionalT (Full (+1) :. Full (+2) :. Nil) A.<*> OptionalT (Full 1 :. Empty :. Nil) +-- [Full 2,Empty,Full 3,Empty] +instance (Monad k) => Applicative (OptionalT k) where + pure :: a -> OptionalT k a + pure = OptionalT . A.pure . Full + + (<*>) :: OptionalT k (a -> b) -> OptionalT k a -> OptionalT k b + -- The trick is to call onFull with the optional function, not the optional value. + (<*>) (OptionalT kf) (OptionalT ka) = OptionalT (kf M.>>= onFull g) + where + g f = (f F.<$>) F.<$> ka + +-- | Implement the `Monad` instance for `OptionalT k` given a Monad k. +-- +-- >>> runOptionalT $ (\a -> OptionalT (Full (a+1) :. Full (a+2) :. Nil)) M.=<< OptionalT (Full 1 :. Empty :. Nil) +-- [Full 2,Full 3,Empty] +instance (Monad k) => Monad (OptionalT k) where + (=<<) :: (a -> OptionalT k b) -> OptionalT k a -> OptionalT k b + (=<<) f (OptionalT ka) = OptionalT (onFull (runOptionalT . f) M.=<< ka) + +-- | A `Logger` is a pair of a list of log values (`[l]`) and an arbitrary value (`a`). +data Logger l a + = Logger (List l) a + deriving stock (Eq, Show) + +-- | Implement the `Functor` instance for `Logger +-- +-- >>> (+3) <$> Logger (listh [1,2]) 3 +-- Logger [1,2] 6 +instance Functor (Logger l) where + (<$>) :: (a -> b) -> Logger l a -> Logger l b + (<$>) f (Logger xs a) = Logger xs (f a) + +-- | Implement the `Applicative` instance for `Logger`. +-- +-- >>> A.pure "table" :: Logger Int P.String +-- Logger [] "table" +-- +-- >>> Logger (listh [1,2]) (+7) A.<*> Logger (listh [3,4]) 3 +-- Logger [1,2,3,4] 10 +instance Applicative (Logger l) where + pure :: a -> Logger l a + pure = Logger Nil + + (<*>) :: Logger l (a -> b) -> Logger l a -> Logger l b + (<*>) (Logger xs f) (Logger ys a) = Logger (xs L.++ ys) (f a) + +-- | Implement the `Monad` instance for `Logger`. +-- The `bind` implementation must append log values to maintain associativity. +-- +-- >>> (\a -> Logger (listh [4,5]) (a+3)) M.=<< Logger (listh [1,2]) 3 +-- Logger [1,2,4,5] 6 +instance Monad (Logger l) where + (=<<) :: (a -> Logger l b) -> Logger l a -> Logger l b + (=<<) f (Logger xs a) = Logger (xs L.++ ys) b + where + (Logger ys b) = f a + +-- | A utility function for producing a `Logger` with one log value. +-- +-- >>> log1 1 2 +-- Logger [1] 2 +log1 :: l -> a -> Logger l a +log1 l = Logger (l :. Nil) + +-- | Remove all duplicate integers from a list. Produce a log as you go. +-- If there is an element above 100, then abort the entire computation and produce no result. +-- However, always keep a log. If you abort the computation, produce a log with the value, +-- "aborting > 100: " followed by the value that caused it. +-- If you see an even number, produce a log message, "even number: " followed by the even number. +-- Other numbers produce no log message. +-- +-- /Tip:/ Use `filtering` and `StateT` over (`OptionalT` over `Logger` with a @Data.Set#Set@). +-- +-- >>> distinctG $ listh [1,2,3,2,6] +-- Logger ["even number: 2","even number: 2","even number: 6"] (Full [1,2,3,6]) +-- +-- >>> distinctG $ listh [1,2,3,2,6,106] +-- Logger ["even number: 2","even number: 2","even number: 6","aborting > 100: 106"] Empty + +-- type CharLogger = Logger Chars +-- type OptCharLogger = OptionalT CharLogger +-- type Stack a = StateT (Set a) OptCharLogger Bool + +type Stack a = StateT (Set a) (OptionalT (Logger Chars)) Bool + +distinctG :: (Integral a, Show a) => List a -> Logger Chars (Optional (List a)) +distinctG xs = runOptionalT $ evalT (A.filtering mayAbort xs) S.empty + where + mayAbort :: forall a. (Integral a, Show a) => a -> Stack a + mayAbort x = do + seen <- getT + let logger = + if x > 100 + then + log1 ("aborting > 100: " L.++ L.show' x) Empty + else do + let dup = S.notMember x seen + + let l = + if even x + then log1 ("even number: " L.++ L.show' x) + else A.pure + l (Full (dup, S.insert x seen)) + + StateT (const (OptionalT logger)) + +onFull :: (Applicative k) => (t -> k (Optional a)) -> Optional t -> k (Optional a) +onFull g o = case o of + Empty -> A.pure Empty + Full a -> g a diff --git a/test/ApplicativeSpec.hs b/test/ApplicativeSpec.hs index 623e543..00ca942 100644 --- a/test/ApplicativeSpec.hs +++ b/test/ApplicativeSpec.hs @@ -15,111 +15,111 @@ spec = do prop "pure == ExactlyOne" $ \x -> pure x `shouldBe` ExactlyOne (x :: Integer) it "Applying within ExactlyOne" $ - ExactlyOne (+ 10) A.<*> ExactlyOne 8 `shouldBe` ExactlyOne (18 :: Int) + ExactlyOne (+ 10) A.<*> ExactlyOne 8 `shouldBe` ExactlyOne 18 describe "List instance" $ do prop "pure" $ \x -> pure x `shouldBe` (x :: Integer) :. Nil it "<*>" $ - (+ 1) :. (* 2) :. Nil A.<*> L.listh [1, 2, 3] `shouldBe` L.listh [2 :: Int, 3, 4, 2, 4, 6] + (+ 1) :. (* 2) :. Nil A.<*> L.listh [1, 2, 3] `shouldBe` L.listh [2, 3, 4, 2, 4, 6] describe "lift1" $ do it "ExactlyOne" $ - A.lift1 (+ 1) (ExactlyOne 2) `shouldBe` ExactlyOne (3 :: Integer) + A.lift1 (+ 1) (ExactlyOne 2) `shouldBe` ExactlyOne 3 it "empty List" $ - A.lift1 (+ 1) Nil `shouldBe` (Nil :: List Int) + A.lift1 (+ 1) Nil `shouldBe` Nil it "List" $ - A.lift1 (+ 1) (L.listh [1, 2, 3]) `shouldBe` L.listh [2 :: Int, 3, 4] + A.lift1 (+ 1) (L.listh [1, 2, 3]) `shouldBe` L.listh [2, 3, 4] describe "Optional instance" $ do prop "pure" $ \x -> pure x `shouldBe` Full (x :: Integer) it "Full <*> Full" $ - Full (+ 8) A.<*> Full 7 `shouldBe` Full (15 :: Int) + Full (+ 8) A.<*> Full 7 `shouldBe` Full 15 it "Empty <*> Full" $ Empty A.<*> Full "tilt" `shouldBe` (Empty :: Optional Integer) it "Full <*> Empty" $ - Full (+ 8) A.<*> Empty `shouldBe` (Empty :: Optional Int) + Full (+ 8) A.<*> Empty `shouldBe` Empty describe "Function instance" $ do it "addition" $ - ((+) A.<*> (+ 10)) 3 `shouldBe` (16 :: Int) + ((+) A.<*> (+ 10)) 3 `shouldBe` 16 it "more addition" $ - ((+) A.<*> (+ 5)) 3 `shouldBe` (11 :: Int) + ((+) A.<*> (+ 5)) 3 `shouldBe` 11 it "even more addition" $ - ((+) A.<*> (+ 5)) 1 `shouldBe` (7 :: Int) + ((+) A.<*> (+ 5)) 1 `shouldBe` 7 it "addition and multiplication" $ - ((*) A.<*> (+ 10)) 3 `shouldBe` (39 :: Int) + ((*) A.<*> (+ 10)) 3 `shouldBe` 39 it "more addition and multiplcation" $ - ((*) A.<*> (+ 2)) 3 `shouldBe` (15 :: Int) + ((*) A.<*> (+ 2)) 3 `shouldBe` 15 prop "pure" $ \x y -> pure x (y :: Integer) `shouldBe` (x :: Integer) describe "lift2" $ do it "+ over ExactlyOne" $ - A.lift2 (+) (ExactlyOne 7) (ExactlyOne 8) `shouldBe` ExactlyOne (15 :: Int) + A.lift2 (+) (ExactlyOne 7) (ExactlyOne 8) `shouldBe` ExactlyOne 15 it "+ over List" $ - A.lift2 (+) (L.listh [1, 2, 3]) (L.listh [4, 5]) `shouldBe` L.listh [5 :: Int, 6, 6, 7, 7, 8] + A.lift2 (+) (L.listh [1, 2, 3]) (L.listh [4, 5]) `shouldBe` L.listh [5, 6, 6, 7, 7, 8] it "+ over Optional - all full" $ - A.lift2 (+) (Full 7) (Full 8) `shouldBe` Full (15 :: Int) + A.lift2 (+) (Full 7) (Full 8) `shouldBe` Full 15 it "+ over Optional - first Empty" $ - A.lift2 (+) Empty (Full 8) `shouldBe` (Empty :: Optional Int) + A.lift2 (+) Empty (Full 8) `shouldBe` Empty it "+ over Optional - second Empty" $ - A.lift2 (+) (Full 7) Empty `shouldBe` (Empty :: Optional Int) + A.lift2 (+) (Full 7) Empty `shouldBe` Empty it "+ over functions" $ - A.lift2 (+) L.length L.sum (L.listh [4, 5, 6]) `shouldBe` (18 :: Int) + A.lift2 (+) L.length L.sum (L.listh [4, 5, 6]) `shouldBe` 18 describe "lift3" $ do it "+ over ExactlyOne" $ - A.lift3 (\a b c -> a + b + c) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) `shouldBe` ExactlyOne (24 :: Int) + A.lift3 (\a b c -> a + b + c) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) `shouldBe` ExactlyOne 24 it "+ over List" $ A.lift3 (\a b c -> a + b + c) (L.listh [1, 2, 3]) (L.listh [4, 5]) (L.listh [6, 7, 8]) - `shouldBe` L.listh [11 :: Int, 12, 13, 12, 13, 14, 12, 13, 14, 13, 14, 15, 13, 14, 15, 14, 15, 16] + `shouldBe` L.listh [11, 12, 13, 12, 13, 14, 12, 13, 14, 13, 14, 15, 13, 14, 15, 14, 15, 16] it "+ over Optional" $ - A.lift3 (\a b c -> a + b + c) (Full 7) (Full 8) (Full 9) `shouldBe` Full (24 :: Int) + A.lift3 (\a b c -> a + b + c) (Full 7) (Full 8) (Full 9) `shouldBe` Full 24 it "+ over Optional - third Empty" $ - A.lift3 (\a b c -> a + b + c) (Full 7) (Full 8) Empty `shouldBe` (Empty :: Optional Int) + A.lift3 (\a b c -> a + b + c) (Full 7) (Full 8) Empty `shouldBe` Empty it "+ over Optional - first Empty" $ - A.lift3 (\a b c -> a + b + c) Empty (Full 8) (Full 9) `shouldBe` (Empty :: Optional Int) + A.lift3 (\a b c -> a + b + c) Empty (Full 8) (Full 9) `shouldBe` Empty it "+ over Optional - first and second Empty" $ - A.lift3 (\a b c -> a + b + c) Empty Empty (Full 9) `shouldBe` (Empty :: Optional Int) + A.lift3 (\a b c -> a + b + c) Empty Empty (Full 9) `shouldBe` Empty it "+ over functions" $ - A.lift3 (\a b c -> a + b + c) L.length L.sum L.product (L.listh [4, 5, 6]) `shouldBe` (138 :: Int) + A.lift3 (\a b c -> a + b + c) L.length L.sum L.product (L.listh [4, 5, 6]) `shouldBe` 138 describe "lift4" $ do it "+ over ExactlyOne" $ - A.lift4 (\a b c d -> a + b + c + d) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) (ExactlyOne 10) `shouldBe` ExactlyOne (34 :: Int) + A.lift4 (\a b c d -> a + b + c + d) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) (ExactlyOne 10) `shouldBe` ExactlyOne 34 it "+ over List" $ A.lift4 (\a b c d -> a + b + c + d) (L.listh [1, 2, 3]) (L.listh [4, 5]) (L.listh [6, 7, 8]) (L.listh [9, 10]) - `shouldBe` L.listh [20 :: Int, 21, 21, 22, 22, 23, 21, 22, 22, 23, 23, 24, 21, 22, 22, 23, 23, 24, 22, 23, 23, 24, 24, 25, 22, 23, 23, 24, 24, 25, 23, 24, 24, 25, 25, 26] + `shouldBe` L.listh [20, 21, 21, 22, 22, 23, 21, 22, 22, 23, 23, 24, 21, 22, 22, 23, 23, 24, 22, 23, 23, 24, 24, 25, 22, 23, 23, 24, 24, 25, 23, 24, 24, 25, 25, 26] it "+ over Optional" $ - A.lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) (Full 9) (Full 10) `shouldBe` Full (34 :: Int) + A.lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) (Full 9) (Full 10) `shouldBe` Full 34 it "+ over Optional - third Empty" $ - A.lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) Empty (Full 10) `shouldBe` (Empty :: Optional Int) + A.lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) Empty (Full 10) `shouldBe` Empty it "+ over Optional - first Empty" $ - A.lift4 (\a b c d -> a + b + c + d) Empty (Full 8) (Full 9) (Full 10) `shouldBe` (Empty :: Optional Int) + A.lift4 (\a b c d -> a + b + c + d) Empty (Full 8) (Full 9) (Full 10) `shouldBe` Empty it "+ over Optional - first and second Empty" $ - A.lift4 (\a b c d -> a + b + c + d) Empty Empty (Full 9) (Full 10) `shouldBe` (Empty :: Optional Int) + A.lift4 (\a b c d -> a + b + c + d) Empty Empty (Full 9) (Full 10) `shouldBe` Empty it "+ over functions" $ - A.lift4 (\a b c d -> a + b + c + d) L.length L.sum L.product (L.sum . L.filter even) (L.listh [4, 5, 6]) `shouldBe` (148 :: Int) + A.lift4 (\a b c d -> a + b + c + d) L.length L.sum L.product (L.sum . L.filter even) (L.listh [4, 5, 6]) `shouldBe` 148 describe "lift1" $ do it "+ over ExactlyOne" $ - A.lift1 (+ 1) (ExactlyOne 2) `shouldBe` ExactlyOne (3 :: Int) + A.lift1 (+ 1) (ExactlyOne 2) `shouldBe` ExactlyOne 3 it "+ over empty List" $ - A.lift1 (+ 1) Nil `shouldBe` (Nil :: List Int) + A.lift1 (+ 1) Nil `shouldBe` Nil it "+ over List" $ - A.lift1 (+ 1) (1 :. 2 :. 3 :. Nil) `shouldBe` (2 :: Int) :. 3 :. 4 :. Nil + A.lift1 (+ 1) (1 :. 2 :. 3 :. Nil) `shouldBe` 2 :. 3 :. 4 :. Nil describe "rightApply" $ do it "*> over List" $ - L.listh [1 :: Int, 2, 3] A.*> L.listh [4, 5, 6] `shouldBe` L.listh [4 :: Int, 5, 6, 4, 5, 6, 4, 5, 6] + L.listh [1, 2, 3] A.*> L.listh [4, 5, 6] `shouldBe` L.listh [4, 5, 6, 4, 5, 6, 4, 5, 6] it "*> over List" $ - L.listh [1 :: Int, 2] A.*> L.listh [4, 5, 6] `shouldBe` L.listh [4 :: Int, 5, 6, 4, 5, 6] + L.listh [1, 2] A.*> L.listh [4, 5, 6] `shouldBe` L.listh [4, 5, 6, 4, 5, 6] it "another *> over List" $ - L.listh [1 :: Int, 2, 3] A.*> L.listh [4, 5] `shouldBe` L.listh [4 :: Int, 5, 4, 5, 4, 5] + L.listh [1, 2, 3] A.*> L.listh [4, 5] `shouldBe` L.listh [4, 5, 4, 5, 4, 5] it "*> over Optional" $ - Full (7 :: Int) A.*> Full 8 `shouldBe` Full (8 :: Int) + Full 7 A.*> Full 8 `shouldBe` Full 8 prop "*> over List property" $ \a b c x y z -> let l1 = (L.listh [a, b, c] :: List Integer) @@ -130,13 +130,13 @@ spec = do describe "leftApply" $ do it "<* over List" $ - (1 :. 2 :. 3 :. Nil) A.<* ((4 :: Int) :. 5 :. 6 :. Nil) `shouldBe` L.listh [1 :: Int, 1, 1, 2, 2, 2, 3, 3, 3] + (1 :. 2 :. 3 :. Nil) A.<* (4 :. 5 :. 6 :. Nil) `shouldBe` L.listh [1, 1, 1, 2, 2, 2, 3, 3, 3] it "another <* over List" $ - (1 :. 2 :. Nil) A.<* ((4 :: Int) :. 5 :. 6 :. Nil) `shouldBe` L.listh [1 :: Int, 1, 1, 2, 2, 2] + (1 :. 2 :. Nil) A.<* (4 :. 5 :. 6 :. Nil) `shouldBe` L.listh [1, 1, 1, 2, 2, 2] it "Yet another <* over List" $ - (1 :. 2 :. 3 :. Nil) A.<* ((4 :: Int) :. 5 :. Nil) `shouldBe` L.listh [1 :: Int, 1, 2, 2, 3, 3] + (1 :. 2 :. 3 :. Nil) A.<* (4 :. 5 :. Nil) `shouldBe` L.listh [1, 1, 2, 2, 3, 3] it "<* over Optional" $ - Full 7 A.<* Full (8 :: Int) `shouldBe` Full (7 :: Int) + Full 7 A.<* Full 8 `shouldBe` Full 7 prop "<* over List property" $ \a b c x y z -> let l1 = (x :. y :. z :. Nil) :: List Integer @@ -147,15 +147,15 @@ spec = do describe "sequence" $ do it "ExactlyOne" $ - A.sequence (L.listh [ExactlyOne 7, ExactlyOne 8, ExactlyOne 9]) `shouldBe` ExactlyOne (L.listh [7 :: Int, 8, 9]) + A.sequence (L.listh [ExactlyOne 7, ExactlyOne 8, ExactlyOne 9]) `shouldBe` ExactlyOne (L.listh [7, 8, 9]) it "List" $ - A.sequence ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) `shouldBe` (L.listh F.<$> L.listh [[1 :: Int, 1], [1, 2], [2, 1], [2, 2], [3, 1], [3, 2]]) + A.sequence ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) `shouldBe` (L.listh F.<$> L.listh [[1, 1], [1, 2], [2, 1], [2, 2], [3, 1], [3, 2]]) it "Optional with an empty" $ - A.sequence (Full 7 :. Empty :. Nil) `shouldBe` (Empty :: Optional (List Int)) + A.sequence (Full 7 :. Empty :. Nil) `shouldBe` Empty it "Optional" $ - A.sequence (Full 7 :. Full 8 :. Nil) `shouldBe` Full (L.listh [7 :: Int, 8]) + A.sequence (Full 7 :. Full 8 :. Nil) `shouldBe` Full (L.listh [7, 8]) it "(->)" $ - A.sequence ((* 10) :. (+ 2) :. Nil) 6 `shouldBe` L.listh [60 :: Int, 8] + A.sequence ((* 10) :. (+ 2) :. Nil) 6 `shouldBe` L.listh [60, 8] describe "replicateA" $ do it "ExactlyOne" $ @@ -165,7 +165,7 @@ spec = do it "Optional - Empty" $ A.replicateA 4 Empty `shouldBe` (Empty :: Optional (List Integer)) it "(->)" $ - A.replicateA 4 (* 2) 5 `shouldBe` L.listh [10 :: Int, 10, 10, 10] + A.replicateA 4 (* 2) 5 `shouldBe` L.listh [10, 10, 10, 10] it "List" $ let expected = L.listh @@ -202,15 +202,15 @@ spec = do describe "filtering" $ do it "ExactlyOne" $ - A.filtering (ExactlyOne . even) (4 :. 5 :. 6 :. Nil) `shouldBe` ExactlyOne (L.listh [4 :: Int, 6]) + A.filtering (ExactlyOne . even) (4 :. 5 :. 6 :. Nil) `shouldBe` ExactlyOne (L.listh [4, 6]) it "Optional - all true" $ - A.filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. Nil) `shouldBe` Full (L.listh [4 :: Int, 5, 6]) + A.filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. Nil) `shouldBe` Full (L.listh [4, 5, 6]) it "Optional - some false" $ - A.filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. Nil) `shouldBe` Full (L.listh [4 :: Int, 5, 6, 7]) + A.filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. Nil) `shouldBe` Full (L.listh [4, 5, 6, 7]) it "Optional - some empty" $ - A.filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 13 :. 14 :. Nil) `shouldBe` (Empty :: Optional (List Int)) + A.filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 13 :. 14 :. Nil) `shouldBe` Empty it "(->)" $ - A.filtering (>) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. 10 :. 11 :. 12 :. Nil) 8 `shouldBe` L.listh [9 :: Int, 10, 11, 12] + A.filtering (>) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. 10 :. 11 :. 12 :. Nil) 8 `shouldBe` L.listh [9, 10, 11, 12] it "List" $ - let expected = L.listh F.<$> L.listh [[1 :: Int, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3]] + let expected = L.listh F.<$> L.listh [[1, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3], [1, 2, 3]] in A.filtering (const $ True :. True :. Nil) (1 :. 2 :. 3 :. Nil) `shouldBe` expected diff --git a/test/FunctorSpec.hs b/test/FunctorSpec.hs index bcc351b..d63a0e4 100644 --- a/test/FunctorSpec.hs +++ b/test/FunctorSpec.hs @@ -11,27 +11,27 @@ spec :: Spec spec = do describe "ExactlyOne" $ do it "increment" $ - (+ 1) F.<$> ExactlyOne 2 `shouldBe` ExactlyOne (3 :: Int) + (+ 1) F.<$> ExactlyOne 2 `shouldBe` ExactlyOne 3 describe "List" $ do it "empty list" $ - (+ 1) F.<$> Nil `shouldBe` (Nil :: List Int) + (+ 1) F.<$> Nil `shouldBe` Nil it "increment" $ - (+ 1) F.<$> (1 :. 2 :. 3 :. Nil) `shouldBe` ((2 :: Int) :. 3 :. 4 :. Nil) + (+ 1) F.<$> (1 :. 2 :. 3 :. Nil) `shouldBe` (2 :. 3 :. 4 :. Nil) describe "Optional" $ do it "Empty" $ - (+ 1) F.<$> Empty `shouldBe` (Empty :: Optional Int) + (+ 1) F.<$> Empty `shouldBe` Empty it "Full" $ - (+ 1) F.<$> Full (2 :: Int) `shouldBe` Full 3 + (+ 1) F.<$> Full 2 `shouldBe` Full 3 describe "Function" $ do it "(->)" $ - ((+ 1) F.<$> (* 2)) 8 `shouldBe` (17 :: Int) + ((+ 1) F.<$> (* 2)) 8 `shouldBe` 17 describe "(<$)" $ do it "Map 7" $ - 7 <$ ((1 :: Int) :. 2 :. 3 :. Nil) `shouldBe` ((7 :: Int) :. 7 :. 7 :. Nil) + 7 <$ (1 :. 2 :. 3 :. Nil) `shouldBe` (7 :. 7 :. 7 :. Nil) prop "Always maps a constant value over List" $ \x a b c -> (x :: Integer) <$ ((a :. b :. c :. Nil) :: List Integer) `shouldBe` (x :. x :. x :. Nil) prop "Always maps a constant value over Full (Optional)" $ @@ -39,18 +39,18 @@ spec = do describe "??" $ do it "Map with List" $ - (((* 2) :. (+ 1) :. const 99 :. Nil) F.?? 8) `shouldBe` ((16 :: Int) :. 9 :. 99 :. Nil) + (((* 2) :. (+ 1) :. const 99 :. Nil) F.?? 8) `shouldBe` (16 :. 9 :. 99 :. Nil) it "Map with Optional" $ - (Full (+ 1) F.?? 8) `shouldBe` Full (9 :: Int) + (Full (+ 1) F.?? 8) `shouldBe` Full 9 it "Map with Optional Empty" $ ((Empty :: Optional (Int -> Int)) F.?? 8) `shouldBe` Empty describe "void" $ do it "List" $ - F.void ((1 :: Int) :. 2 :. 3 :. Nil) `shouldBe` () :. () :. () :. Nil + F.void (1 :. 2 :. 3 :. Nil) `shouldBe` () :. () :. () :. Nil it "Full" $ - F.void (Full (7 :: Int)) `shouldBe` Full () + F.void (Full 7) `shouldBe` Full () it "Empty" $ F.void Empty `shouldBe` Empty it "(->)" $ - F.void (+ (10 :: Int)) 5 `shouldBe` () + F.void (+ 10) 5 `shouldBe` () diff --git a/test/ListSpec.hs b/test/ListSpec.hs index cca6393..fa6dec3 100644 --- a/test/ListSpec.hs +++ b/test/ListSpec.hs @@ -13,9 +13,9 @@ spec :: Spec spec = do describe "headOr" $ do it "headOr on non-empty list" $ - L.headOr 3 (1 :. 2 :. Nil) `shouldBe` (1 :: Int) + L.headOr 3 (1 :. 2 :. Nil) `shouldBe` 1 it "headOr on empty list" $ - L.headOr 3 Nil `shouldBe` (3 :: Int) + L.headOr 3 Nil `shouldBe` 3 prop "headOr on infinity always 0" $ \x -> x `L.headOr` L.infinity `shouldBe` 0 prop "headOr on empty list always the default" $ @@ -43,13 +43,13 @@ spec = do it "length of empty list" $ L.length Nil `shouldBe` 0 it "length 1..3" $ - L.length ((1 :: Int) :. 2 :. 3 :. Nil) `shouldBe` 3 + L.length (1 :. 2 :. 3 :. Nil) `shouldBe` 3 prop "summing a list of 1s is equal to its length" $ \xs -> length (L.hlist xs) `shouldBe` L.length (xs :: List Integer) describe "map" $ do it "add 10 on list" $ - L.map (+ 10) ((1 :: Int) :. 2 :. 3 :. Nil) `shouldBe` (11 :. 12 :. 13 :. Nil) + L.map (+ 10) (1 :. 2 :. 3 :. Nil) `shouldBe` (11 :. 12 :. 13 :. Nil) prop "headOr after map" $ \x -> L.headOr (x :: Integer) (L.map (+ 1) L.infinity) `shouldBe` 1 {- HLINT ignore "Redundant map" -} @@ -58,7 +58,7 @@ spec = do describe "filter" $ do it "filter even" $ - L.filter even ((1 :: Int) :. 2 :. 3 :. 4 :. 5 :. Nil) `shouldBe` (2 :. 4 :. Nil) + L.filter even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) `shouldBe` (2 :. 4 :. Nil) prop "filter (const True) is identity (headOr)" $ \x -> L.headOr x (L.filter (const True) L.infinity) `shouldBe` 0 prop "filter (const True) is identity" $ @@ -68,7 +68,7 @@ spec = do describe "++" $ do it "(1..6)" $ - ((1 :: Int) :. 2 :. 3 :. Nil) L.++ (4 :. 5 :. 6 :. Nil) `shouldBe` L.listh [1, 2, 3, 4, 5, 6] + (1 :. 2 :. 3 :. Nil) L.++ (4 :. 5 :. 6 :. Nil) `shouldBe` L.listh [1, 2, 3, 4, 5, 6] prop "append empty to infinite" $ \x -> L.headOr x (Nil L.++ L.infinity) `shouldBe` 0 prop "append anything to infinite" $ @@ -80,7 +80,7 @@ spec = do describe "flatten" $ do it "(1..9)" $ - L.flatten (((1 :: Int) :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. (7 :. 8 :. 9 :. Nil) :. Nil) `shouldBe` L.listh [1, 2, 3, 4, 5, 6, 7, 8, 9] + L.flatten ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. (7 :. 8 :. 9 :. Nil) :. Nil) `shouldBe` L.listh [1, 2, 3, 4, 5, 6, 7, 8, 9] prop "flatten (infinity :. y)" $ \(x, ys) -> L.headOr x (L.flatten (L.infinity :. ys :. Nil)) `shouldBe` 0 prop "flatten (y :. infinity)" $ @@ -90,7 +90,7 @@ spec = do describe "flatMap" $ do it "lists of Integer" $ - L.flatMap (\x -> x :. x + 1 :. x + 2 :. Nil) ((1 :: Int) :. 2 :. 3 :. Nil) `shouldBe` L.listh [1, 2, 3, 2, 3, 4, 3, 4, 5] + L.flatMap (\x -> x :. x + 1 :. x + 2 :. Nil) (1 :. 2 :. 3 :. Nil) `shouldBe` L.listh [1, 2, 3, 2, 3, 4, 3, 4, 5] prop "flatMap id flattens a list of lists" $ \(x, ys) -> L.headOr x (L.flatMap id (L.infinity :. ys :. Nil)) `shouldBe` 0 prop "flatMap id on a list of lists take 2" $ @@ -104,36 +104,36 @@ spec = do describe "seqOptional" $ do it "all Full" $ - L.seqOptional (Full (1 :: Int) :. Full 10 :. Nil) `shouldBe` Full (1 :. 10 :. Nil) + L.seqOptional (Full 1 :. Full 10 :. Nil) `shouldBe` Full (1 :. 10 :. Nil) it "empty list" $ let empty = Nil :: List (Optional Integer) in L.seqOptional empty `shouldBe` Full Nil it "contains Empty" $ - L.seqOptional (Full (1 :: Int) :. Full 10 :. Empty :. Nil) `shouldBe` Empty + L.seqOptional (Full 1 :. Full 10 :. Empty :. Nil) `shouldBe` Empty it "Empty at head of infinity" $ L.seqOptional (Empty :. L.map Full L.infinity) `shouldBe` Empty describe "find" $ do it "find no matches" $ - L.find even ((1 :: Int) :. 3 :. 5 :. Nil) `shouldBe` Empty + L.find even (1 :. 3 :. 5 :. Nil) `shouldBe` Empty it "empty list" $ L.find even (Nil :: List Integer) `shouldBe` Empty it "find only even" $ - L.find even ((1 :: Int) :. 2 :. 3 :. 5 :. Nil) `shouldBe` Full 2 + L.find even (1 :. 2 :. 3 :. 5 :. Nil) `shouldBe` Full 2 it "find first, not second even" $ - L.find even ((1 :: Int) :. 2 :. 3 :. 4 :. 5 :. Nil) `shouldBe` Full 2 + L.find even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) `shouldBe` Full 2 it "find on infinite list" $ L.find (const True) L.infinity `shouldBe` Full 0 describe "lengthGT4" $ do it "list of length 3" $ - L.lengthGT4 ((1 :: Int) :. 3 :. 5 :. Nil) `shouldBe` False + L.lengthGT4 (1 :. 3 :. 5 :. Nil) `shouldBe` False it "list of length 4" $ - L.lengthGT4 ((1 :: Int) :. 2 :. 3 :. 4 :. Nil) `shouldBe` False + L.lengthGT4 (1 :. 2 :. 3 :. 4 :. Nil) `shouldBe` False it "empty list" $ L.lengthGT4 Nil `shouldBe` False it "list of length 5" $ - L.lengthGT4 ((1 :: Int) :. 2 :. 3 :. 4 :. 5 :. Nil) `shouldBe` True + L.lengthGT4 (1 :. 2 :. 3 :. 4 :. 5 :. Nil) `shouldBe` True it "infinite list" $ L.lengthGT4 L.infinity `shouldBe` True @@ -142,7 +142,7 @@ spec = do L.reverse Nil `shouldBe` (Nil :: List Integer) {- HLINT ignore "Avoid reverse" -} it "reverse . reverse on largeList" $ - L.take (1 :: Int) (L.reverse (L.reverse L.largeList)) `shouldBe` (1 :. Nil) + L.take 1 (L.reverse (L.reverse L.largeList)) `shouldBe` (1 :. Nil) prop "reverse then append is same as append then reverse" $ \xs ys -> L.reverse xs L.++ L.reverse ys `shouldBe` (L.reverse (ys L.++ xs) :: List Integer) prop "reverse single element list is the list" $ @@ -151,7 +151,7 @@ spec = do describe "produce" $ do it "increment" $ let (x :. y :. z :. w :. _) = L.produce (+ 1) 0 - in (x :. y :. z :. w :. Nil) `shouldBe` ((0 :: Int) :. 1 :. 2 :. 3 :. Nil) + in (x :. y :. z :. w :. Nil) `shouldBe` (0 :. 1 :. 2 :. 3 :. Nil) it "double" $ let (x :. y :. z :. w :. _) = L.produce (* 2) 1 - in (x :. y :. z :. w :. Nil) `shouldBe` ((1 :: Int) :. 2 :. 4 :. 8 :. Nil) + in (x :. y :. z :. w :. Nil) `shouldBe` (1 :. 2 :. 4 :. 8 :. Nil) diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs index c50cb3c..21fa380 100644 --- a/test/MonadSpec.hs +++ b/test/MonadSpec.hs @@ -10,48 +10,48 @@ spec :: Spec spec = do describe "(=<<)" $ do it "ExactlyOne" $ - ((\x -> ExactlyOne (x + 1)) M.=<< ExactlyOne 2) `shouldBe` ExactlyOne (3 :: Int) + ((\x -> ExactlyOne (x + 1)) M.=<< ExactlyOne 2) `shouldBe` ExactlyOne 3 it "List" $ - ((\n -> n :. n :. Nil) M.=<< (1 :. 2 :. 3 :. Nil)) `shouldBe` ((1 :: Int) :. 1 :. 2 :. 2 :. 3 :. 3 :. Nil) + ((\n -> n :. n :. Nil) M.=<< (1 :. 2 :. 3 :. Nil)) `shouldBe` (1 :. 1 :. 2 :. 2 :. 3 :. 3 :. Nil) it "Optional" $ - ((\n -> Full (n + n)) M.=<< Full 7) `shouldBe` Full (14 :: Int) + ((\n -> Full (n + n)) M.=<< Full 7) `shouldBe` Full 14 it "(->)" $ - ((*) M.=<< (+ 10)) 7 `shouldBe` (119 :: Int) + ((*) M.=<< (+ 10)) 7 `shouldBe` 119 describe "<**>" $ do it "ExactlyOne" $ - ExactlyOne (+ 10) M.<**> ExactlyOne 8 `shouldBe` ExactlyOne (18 :: Int) + ExactlyOne (+ 10) M.<**> ExactlyOne 8 `shouldBe` ExactlyOne 18 it "List" $ - (+ 1) :. (* 2) :. Nil M.<**> 1 :. 2 :. 3 :. Nil `shouldBe` ((2 :: Int) :. 3 :. 4 :. 2 :. 4 :. 6 :. Nil) + (+ 1) :. (* 2) :. Nil M.<**> 1 :. 2 :. 3 :. Nil `shouldBe` (2 :. 3 :. 4 :. 2 :. 4 :. 6 :. Nil) it "Optional" $ - Full (+ 8) M.<**> Full 7 `shouldBe` Full (15 :: Int) + Full (+ 8) M.<**> Full 7 `shouldBe` Full 15 it "Optional - empty function" $ - Empty M.<**> Full (7 :: Int) `shouldBe` (Empty :: Optional Int) + Empty M.<**> Full 7 `shouldBe` (Empty :: Optional Integer) it "Optional - empty value" $ - Full (+ 8) M.<**> Empty `shouldBe` (Empty :: Optional Int) + Full (+ 8) M.<**> Empty `shouldBe` Empty it "(->) 1" $ - ((+) M.<**> (+ 10)) 3 `shouldBe` (16 :: Int) + ((+) M.<**> (+ 10)) 3 `shouldBe` 16 it "(->) 2" $ - ((+) M.<**> (+ 5)) 3 `shouldBe` (11 :: Int) + ((+) M.<**> (+ 5)) 3 `shouldBe` 11 it "(->) 3" $ - ((+) M.<**> (+ 5)) 1 `shouldBe` (7 :: Int) + ((+) M.<**> (+ 5)) 1 `shouldBe` 7 it "(->) 4" $ - ((*) M.<**> (+ 10)) 3 `shouldBe` (39 :: Int) + ((*) M.<**> (+ 10)) 3 `shouldBe` 39 it "(->) 5" $ - ((*) M.<**> (+ 2)) 3 `shouldBe` (15 :: Int) + ((*) M.<**> (+ 2)) 3 `shouldBe` 15 describe "join" $ do it "List" $ - M.join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) `shouldBe` ((1 :: Int) :. 2 :. 3 :. 1 :. 2 :. Nil) + M.join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) `shouldBe` (1 :. 2 :. 3 :. 1 :. 2 :. Nil) it "Optional with Empty" $ M.join (Full Empty) `shouldBe` (Empty :: Optional Integer) it "Optional all Full" $ - M.join (Full (Full 7)) `shouldBe` Full (7 :: Int) + M.join (Full (Full 7)) `shouldBe` Full 7 it "(->)" $ - M.join (+) 7 `shouldBe` (14 :: Int) + M.join (+) 7 `shouldBe` 14 it "(>>=)" $ - ((+ 10) M.>>= (*)) 7 `shouldBe` (119 :: Int) + ((+ 10) M.>>= (*)) 7 `shouldBe` 119 it "kleislyComposition" $ - ((\n -> n :. n :. Nil) M.<=< (\n -> n + 1 :. n + 2 :. Nil)) 1 `shouldBe` ((2 :: Int) :. 2 :. 3 :. 3 :. Nil) + ((\n -> n :. n :. Nil) M.<=< (\n -> n + 1 :. n + 2 :. Nil)) 1 `shouldBe` (2 :. 2 :. 3 :. 3 :. Nil) diff --git a/test/OptionalSpec.hs b/test/OptionalSpec.hs index dd1884b..2b6f6e5 100644 --- a/test/OptionalSpec.hs +++ b/test/OptionalSpec.hs @@ -8,9 +8,9 @@ spec :: Spec spec = do describe "mapOptional" $ do it "Empty" $ - O.mapOptional (+ 1) Empty `shouldBe` (Empty :: Optional Int) + O.mapOptional (+ 1) Empty `shouldBe` Empty it "Full" $ - O.mapOptional (+ 1) (Full 8) `shouldBe` Full (9 :: Int) + O.mapOptional (+ 1) (Full 8) `shouldBe` Full 9 describe "bindOptional" $ do let evenDecOddInc n = if even n then Full (n - 1) else Full (n + 1) @@ -18,28 +18,28 @@ spec = do it "Empty" $ O.bindOptional Full Empty `shouldBe` (Empty :: Optional Integer) it "even dec, odd inc, even input" $ - O.bindOptional evenDecOddInc (Full 8) `shouldBe` (Full 7 :: Optional Int) + O.bindOptional evenDecOddInc (Full 8) `shouldBe` Full 7 it "even dec, odd inc, odd input" $ - O.bindOptional evenDecOddInc (Full 9) `shouldBe` (Full 10 :: Optional Int) + O.bindOptional evenDecOddInc (Full 9) `shouldBe` Full 10 describe "fullOr" $ do it "Full" $ - O.fullOr 99 (Full 8) `shouldBe` (8 :: Int) + O.fullOr 99 (Full 8) `shouldBe` 8 it "Empty" $ - O.fullOr 99 Empty `shouldBe` (99 :: Int) + O.fullOr 99 Empty `shouldBe` 99 describe "<+>" $ do it "first Full" $ - Full 8 O.<+> Empty `shouldBe` Full (8 :: Int) + Full 8 O.<+> Empty `shouldBe` Full 8 it "both Full" $ - Full 8 O.<+> Full 9 `shouldBe` Full (8 :: Int) + Full 8 O.<+> Full 9 `shouldBe` Full 8 it "first Empty" $ - Empty O.<+> Full 9 `shouldBe` Full (9 :: Int) + Empty O.<+> Full 9 `shouldBe` Full 9 it "both empty" $ Empty O.<+> Empty `shouldBe` (Empty :: Optional Integer) describe "optional" $ do it "replaces full data constructor" $ - O.optional (+ 1) 0 (Full 8) `shouldBe` (9 :: Int) + O.optional (+ 1) 0 (Full 8) `shouldBe` 9 it "replaces empty data constructor" $ - O.optional (+ 1) 0 Empty `shouldBe` (0 :: Int) + O.optional (+ 1) 0 Empty `shouldBe` 0 diff --git a/test/StateSpec.hs b/test/StateSpec.hs index 91d1781..179a65c 100644 --- a/test/StateSpec.hs +++ b/test/StateSpec.hs @@ -27,37 +27,37 @@ spec = do S.eval (State f) s `shouldBe` fst (S.runState (State f) s) it "get" $ - S.runState S.get 0 `shouldBe` (0 :: Int, 0) + S.runState S.get 0 `shouldBe` (0, 0) it "put" $ - S.runState (S.put 1) 0 `shouldBe` ((), 1 :: Int) + S.runState (S.put 1) 0 `shouldBe` ((), 1) it "(<$>)" $ - S.runState ((+ 1) F.<$> State (\s -> (9, s * 2))) 3 `shouldBe` ((10, 6) :: (Int, Int)) + S.runState ((+ 1) F.<$> State (\s -> (9, s * 2))) 3 `shouldBe` (10, 6) describe "Applicative" $ do it "pure" $ S.runState (A.pure 2) 0 `shouldBe` ((2, 0) :: (Int, Int)) - it "<*>" $ S.runState (A.pure (+ 1) A.<*> A.pure 0) 0 `shouldBe` ((1, 0) :: (Int, Int)) + it "<*>" $ S.runState (A.pure (+ 1) A.<*> A.pure 0) 0 `shouldBe` (1, 0) it "complicated <*>" $ let state = State (\s -> ((+ 3), s ++ ["apple"])) A.<*> State (\s -> (7, s ++ ["banana"])) - in S.runState state [] `shouldBe` (10 :: Int, ["apple", "banana"]) + in S.runState state [] `shouldBe` (10, ["apple", "banana"]) describe "Monad" $ do it "(=<<)" $ - S.runState (const (S.put 2) M.=<< S.put 1) 0 `shouldBe` ((), 2 :: Int) + S.runState (const (S.put 2) M.=<< S.put 1) 0 `shouldBe` ((), 2) it "correctly produces new state and value" $ - S.runState ((\a -> State (\s -> (a + s, 10 + s))) M.=<< State (\s -> (s * 2, 4 + s))) 2 `shouldBe` ((10, 16) :: (Int, Int)) + S.runState ((\a -> State (\s -> (a + s, 10 + s))) M.=<< State (\s -> (s * 2, 4 + s))) 2 `shouldBe` (10, 16) it "(>>=)" $ let modify f = State (\s -> ((), f s)) - in S.runState (modify (+ 1) M.>>= \() -> modify (* 2)) 7 `shouldBe` ((), 16 :: Int) + in S.runState (modify (+ 1) M.>>= \() -> modify (* 2)) 7 `shouldBe` ((), 16) describe "findM" $ do it "find 'c' in 'a'..'h'" $ let p x = (\s -> const (A.pure (x == 'c')) M.=<< S.put (1 + s)) M.=<< S.get - in S.runState (S.findM p $ L.listh ['a' .. 'h']) 0 `shouldBe` (Full 'c', 3 :: Int) + in S.runState (S.findM p $ L.listh ['a' .. 'h']) 0 `shouldBe` (Full 'c', 3) it "find 'i' in 'a'..'h'" $ let p x = (\s -> const (A.pure (x == 'i')) M.=<< S.put (1 + s)) M.=<< S.get - in S.runState (S.findM p $ L.listh ['a' .. 'h']) 0 `shouldBe` (Empty, 8 :: Int) + in S.runState (S.findM p $ L.listh ['a' .. 'h']) 0 `shouldBe` (Empty, 8) describe "firstRepeat" $ do it "'x' is the only repeat" $ diff --git a/test/StateTSpec.hs b/test/StateTSpec.hs new file mode 100644 index 0000000..42c74a0 --- /dev/null +++ b/test/StateTSpec.hs @@ -0,0 +1,135 @@ +module StateTSpec (spec) where + +import qualified Applicative as A +import ExactlyOne (ExactlyOne (..)) +import qualified Functor as F +import List (List (..)) +import qualified List as L +import qualified Monad as M +import Optional (Optional (..)) +import Property () +import qualified State as S +import StateT (Logger (..), OptionalT (..), StateT (..)) +import qualified StateT as ST +import Test.Hspec +import Test.Hspec.QuickCheck + +spec :: Spec +spec = do + it "<$>" $ + let st = StateT (\s -> (2, s) :. Nil) + in ST.runStateT ((+ 1) F.<$> st) 0 `shouldBe` ((3, 0) :. Nil) + + describe "Applicative" $ do + it "List (pure)" $ ST.runStateT (A.pure 2 :: StateT Int List Int) 0 `shouldBe` ((2, 0) :. Nil) + it "List (<*>)" $ ST.runStateT (A.pure (+ 2) A.<*> (A.pure 2 :: StateT Int List Int)) 0 `shouldBe` ((4, 0) :. Nil) + it "Optional" $ + let st = StateT (\s -> Full ((+ 2), s ++ [1])) A.<*> StateT (\s -> Full (2, s ++ [2])) + in ST.runStateT st [0] `shouldBe` Full (4, [0, 1, 2]) + it "List" $ + let st = + StateT (\s -> ((+ 2), s ++ [1]) :. ((+ 3), s ++ [1]) :. Nil) + A.<*> StateT (\s -> (2, s ++ [2]) :. Nil) + in ST.runStateT st [0] `shouldBe` ((4, [0, 1, 2]) :. (5, [0, 1, 2]) :. Nil) + + describe "Monad" $ do + it "bind const" $ + let s n = StateT $ const (((), n) :. Nil) + in ST.runStateT (const (s 2) M.=<< s 1) 0 `shouldBe` (((), 2) :. Nil) + it "modify" $ + let modify f = StateT (\s -> A.pure ((), f s)) + in ST.runStateT (modify (+ 1) M.>>= \() -> modify (* 2)) 7 `shouldBe` (((), 16) :. Nil) + + it "state'" $ + ST.runStateT (ST.state' . S.runState $ S.put 1) 0 `shouldBe` ExactlyOne ((), 1) + + it "runState'" $ + ST.runState' (ST.state' . S.runState $ S.put 1) 0 `shouldBe` ((), 1) + + it "execTTest" $ + ST.execT (StateT $ \s -> Full ((), s + 1)) 2 `shouldBe` Full 3 + + it "exec'Test" $ + ST.exec' (ST.state' $ \s -> ((), s + 1)) 2 `shouldBe` 3 + + it "evalTTest" $ + ST.evalT (StateT $ \s -> Full (even s, s + 1)) 2 `shouldBe` Full True + + it "eval'Test" $ + ST.eval' (ST.state' $ \s -> (even s, s + 1)) 5 `shouldBe` False + + it "getTTest" $ + ST.runStateT (ST.getT :: StateT Int List Int) 3 `shouldBe` ((3, 3) :. Nil) + + it "putTTest" $ + ST.runStateT (ST.putT 2 :: StateT Int List ()) 0 `shouldBe` (((), 2) :. Nil) + + describe "distinct'" $ do + it "removes duplicate 'c's" $ + ST.distinct' (L.listh "abcdcefcghi") `shouldBe` L.listh ['a' .. 'i'] + prop "distinct'" $ \xs -> + ST.distinct' xs `shouldBe` ST.distinct' (L.flatMap (\x -> (x :: Integer) :. x :. Nil) xs) + + describe "distinctF" $ do + it "Full case" $ ST.distinctF (L.listh [1, 2, 3, 2, 1]) `shouldBe` Full (L.listh [1, 2, 3]) + it "Empty case" $ ST.distinctF (L.listh [1, 2, 3, 2, 1, 101]) `shouldBe` Empty + + it "(<$>) for OptionalT" $ + ST.runOptionalT ((+ 1) F.<$> OptionalT (Full 1 :. Empty :. Nil)) `shouldBe` (Full 2 :. Empty :. Nil) + + it "pure for OptionalT" $ + let ot = A.pure 0 :: OptionalT List Int + in ST.runOptionalT ot `shouldBe` (Full 0 :. Nil :: List (Optional Int)) + + describe "(<*>) for OptionalT" $ do + it "one" $ + let ot = (OptionalT Nil A.<*> OptionalT (Full 1 :. Full 2 :. Nil)) + in ST.runOptionalT ot `shouldBe` (Nil :: List (Optional Int)) + it "two" $ + let ot = OptionalT (Full (+ 1) :. Full (+ 2) :. Nil) A.<*> OptionalT Nil + in ST.runOptionalT ot `shouldBe` (Nil :: List (Optional Int)) + it "three" $ + let ot = OptionalT (Empty :. Nil) A.<*> OptionalT (Empty :. Nil) + in ST.runOptionalT ot `shouldBe` (Empty :. Nil :: List (Optional Int)) + it "four" $ + let ot = OptionalT (Full (+ 1) :. Empty :. Nil) A.<*> OptionalT (Empty :. Nil) + in ST.runOptionalT ot `shouldBe` (Empty :. Empty :. Nil :: List (Optional Int)) + it "five" $ + let ot = OptionalT (Empty :. Nil) A.<*> OptionalT (Full 1 :. Full 2 :. Nil) + in ST.runOptionalT ot `shouldBe` (Empty :. Nil :: List (Optional Int)) + it "six" $ + let ot = OptionalT (Full (+ 1) :. Empty :. Nil) A.<*> OptionalT (Full 1 :. Full 2 :. Nil) + in ST.runOptionalT ot `shouldBe` (Full 2 :. Full 3 :. Empty :. Nil) + it "seven" $ + let ot = OptionalT (Full (+ 1) :. Full (+ 2) :. Nil) A.<*> OptionalT (Full 1 :. Empty :. Nil) + in ST.runOptionalT ot `shouldBe` (Full 2 :. Empty :. Full 3 :. Empty :. Nil) + + it "(=<<) for OptionalT" $ + let ot = (\a -> OptionalT (Full (a + 1) :. Full (a + 2) :. Nil)) M.=<< OptionalT (Full 1 :. Empty :. Nil) + in ST.runOptionalT ot `shouldBe` (Full 2 :. Full 3 :. Empty :. Nil) + + it "(<$>) for Logger" $ + (+ 3) F.<$> Logger (1 :. 2 :. Nil) 3 `shouldBe` Logger (1 :. 2 :. Nil) 6 + + describe "Logger Applicative" $ do + it "pure" $ + (A.pure "table" :: Logger Int String) `shouldBe` Logger Nil "table" + it "<*>" $ + Logger (1 :. 2 :. Nil) (+ 7) A.<*> Logger (3 :. 4 :. Nil) 3 `shouldBe` Logger (1 :. 2 :. 3 :. 4 :. Nil) 10 + + it "(=<<) for Logger" $ + ((\a -> Logger (4 :. 5 :. Nil) (a + 3)) M.=<< Logger (1 :. 2 :. Nil) 3) `shouldBe` Logger (1 :. 2 :. 4 :. 5 :. Nil) 6 + + it "log1" $ + ST.log1 1 2 `shouldBe` Logger (1 :. Nil) 2 + + describe "distinctG" $ do + it "Full case" $ + let expected = + Logger + (L.listh F.<$> ("even number: 2" :. "even number: 2" :. "even number: 6" :. Nil)) + (Full (1 :. 2 :. 3 :. 6 :. Nil)) + in ST.distinctG (1 :. 2 :. 3 :. 2 :. 6 :. Nil) `shouldBe` expected + it "Empty case" $ + let expected = Logger (L.listh F.<$> ("even number: 2" :. "even number: 2" :. "even number: 6" :. "aborting > 100: 106" :. Nil)) Empty + in ST.distinctG (L.listh [1, 2, 3, 2, 6, 106]) `shouldBe` expected diff --git a/test/ValidationSpec.hs b/test/ValidationSpec.hs index cef838c..7c2fa6d 100644 --- a/test/ValidationSpec.hs +++ b/test/ValidationSpec.hs @@ -26,9 +26,9 @@ spec = do describe "mapValidation" $ do it "errors unchanged" $ - V.mapValidation (+ 10) (Error "message") `shouldBe` (Error "message" :: Validation Int) + V.mapValidation (+ 10) (Error "message") `shouldBe` Error "message" it "values changed" $ - V.mapValidation (+ 10) (Value 7) `shouldBe` Value (17 :: Int) + V.mapValidation (+ 10) (Value 7) `shouldBe` Value 17 prop "map with id causes no change" $ \x -> V.mapValidation id x `shouldBe` (x :: Validation Integer) @@ -36,11 +36,11 @@ spec = do let f n = if even n then Value (n + 10) else Error "odd" it "error unchanged" $ - V.bindValidation f (Error "message") `shouldBe` (Error "message" :: Validation Int) + V.bindValidation f (Error "message") `shouldBe` Error "message" it "odd value" $ - V.bindValidation f (Value 7) `shouldBe` (Error "odd" :: Validation Int) + V.bindValidation f (Value 7) `shouldBe` Error "odd" it "even value" $ - V.bindValidation f (Value 8) `shouldBe` Value (18 :: Int) + V.bindValidation f (Value 8) `shouldBe` Value 18 prop "bind with Value causes no change" $ \x -> V.bindValidation Value x `shouldBe` (x :: Validation Integer) @@ -56,6 +56,6 @@ spec = do it "unwraps errors" $ V.errorOr (Error "message") "q" `shouldBe` "message" it "falls through for values" $ - V.errorOr (Value (7 :: Integer)) "q" `shouldBe` "q" + V.errorOr (Value 7) "q" `shouldBe` "q" prop "isError or errorOr falls through" $ \x s -> V.isError (x :: Validation Integer) || V.errorOr x s == s `shouldBe` True