summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDanBurton <>2021-02-23 01:48:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2021-02-23 01:48:00 (GMT)
commit840f11645dcfdbfcf1b407d7fed273509c1d1961 (patch)
tree58a828f83e91e70e40963ecad887098f1a85e86f
parent0259b91be2ff032193fbaa622e005df385b6fed5 (diff)
version 0.4.3.0HEAD0.4.3.0master
-rw-r--r--src/Control/Monad/Tardis.hs (renamed from Control/Monad/Tardis.hs)0
-rw-r--r--src/Control/Monad/Tardis/Class.hs (renamed from Control/Monad/Tardis/Class.hs)6
-rw-r--r--src/Control/Monad/Trans/Tardis.hs (renamed from Control/Monad/Trans/Tardis.hs)7
-rw-r--r--tardis.cabal11
-rw-r--r--test/Example.hs69
-rw-r--r--test/Main.hs10
6 files changed, 93 insertions, 10 deletions
diff --git a/Control/Monad/Tardis.hs b/src/Control/Monad/Tardis.hs
index 96c503b..96c503b 100644
--- a/Control/Monad/Tardis.hs
+++ b/src/Control/Monad/Tardis.hs
diff --git a/Control/Monad/Tardis/Class.hs b/src/Control/Monad/Tardis/Class.hs
index 85817f7..fe1b58f 100644
--- a/Control/Monad/Tardis/Class.hs
+++ b/src/Control/Monad/Tardis/Class.hs
@@ -1,14 +1,12 @@
-{-# OPTIONS_GHC -Wall -fno-warn-warnings-deprecations #-}
-{-# LANGUAGE DoRec #-}
+{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
-
-- | The class definition of a Tardis,
-- as well as a few straightforward combinators
-- based on its primitives.
---
+--
-- See Control.Monad.Tardis for the general explanation
-- of what a Tardis is and how to use it.
module Control.Monad.Tardis.Class
diff --git a/Control/Monad/Trans/Tardis.hs b/src/Control/Monad/Trans/Tardis.hs
index 738fe26..86b8060 100644
--- a/Control/Monad/Trans/Tardis.hs
+++ b/src/Control/Monad/Trans/Tardis.hs
@@ -1,11 +1,9 @@
-{-# OPTIONS_GHC -Wall -fno-warn-warnings-deprecations #-}
-{-# LANGUAGE DoRec #-}
-
+{-# LANGUAGE RecursiveDo #-}
-- | The data definition of a "TardisT"
-- as well as its primitive operations,
-- and straightforward combinators based on the primitives.
---
+--
-- See Control.Monad.Tardis for the general explanation
-- of what a Tardis is and how to use it.
module Control.Monad.Trans.Tardis (
@@ -209,4 +207,3 @@ getsPast f = fmap f getPast
-- | Retrieve a specific view of the backwards-traveling state.
getsFuture :: MonadFix m => (bw -> a) -> TardisT bw fw m a
getsFuture f = fmap f getFuture
-
diff --git a/tardis.cabal b/tardis.cabal
index 4b3d388..e7a55c9 100644
--- a/tardis.cabal
+++ b/tardis.cabal
@@ -1,5 +1,5 @@
name: tardis
-version: 0.4.2.0
+version: 0.4.3.0
synopsis: Bidirectional state monad transformer
homepage: https://github.com/DanBurton/tardis
bug-reports: https://github.com/DanBurton/tardis/issues
@@ -22,6 +22,7 @@ description:
library
default-language: Haskell2010
+ hs-source-dirs: src
exposed-modules: Control.Monad.Tardis
, Control.Monad.Tardis.Class
, Control.Monad.Trans.Tardis
@@ -30,6 +31,14 @@ library
, mtl==2.*
, mmorph==1.*
+test-suite tardis-tests
+ default-language: Haskell2010
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Main.hs
+ build-depends: base >= 4.8 && < 5
+ , tardis
+ other-modules: Example
source-repository head
type: git
diff --git a/test/Example.hs b/test/Example.hs
new file mode 100644
index 0000000..4bc2778
--- /dev/null
+++ b/test/Example.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE RecursiveDo #-}
+
+module Example where
+
+import Control.Monad.Tardis
+
+data BowlingGame = BowlingGame
+ { frames :: ![Frame] -- should be 9, too tedious to type restrict
+ , lastFrame :: LFrame }
+
+data Frame = Strike
+ | Spare { firstThrow :: !Int }
+ | Frame { firstThrow, secondThrow :: !Int }
+
+data LFrame = LStrike { bonus1, bonus2 :: !Int }
+ | LSpare { throw1, bonus1 :: !Int }
+ | LFrame { throw1, throw2 :: !Int }
+
+sampleGame :: BowlingGame
+sampleGame = BowlingGame
+ { frames =
+ [ Strike , Spare 9
+ , Strike , Strike
+ , Strike , Frame 8 1
+ , Spare 7 , Strike
+ , Strike
+ ]
+ , lastFrame = LStrike 10 10
+ }
+
+newtype PreviousScores = PreviousScores [Int]
+newtype NextThrows = NextThrows (Int, Int)
+
+toScores :: BowlingGame -> [Int]
+toScores game = flip evalTardis initState $ go (frames game) where
+ go :: [Frame] -> Tardis NextThrows PreviousScores [Int]
+ go [] = do
+ PreviousScores scores <- getPast
+ let score = head scores
+ return $ (finalFrameScore + score) : scores
+ go (f : fs) = do
+ rec
+ sendPast $ NextThrows throws'
+ PreviousScores scores <- getPast
+ let score = head scores
+ sendFuture $ PreviousScores (score' : scores)
+ NextThrows ~(nextThrow1, nextThrow2) <- getFuture
+ let (score', throws') = case f of
+ Strike -> (score + 10 + nextThrow1 + nextThrow2, (10, nextThrow1))
+ Spare n -> (score + 10 + nextThrow1, (n, 10 - n))
+ Frame n m -> (score + n + m, (n, m))
+ go fs
+
+ finalFrameScore = case lastFrame game of
+ LStrike n m -> 10 + n + m
+ LSpare _n m -> 10 + m
+ LFrame n m -> n + m
+
+ initState = (NextThrows $ case lastFrame game of
+ LStrike n _m -> (10, n)
+ LSpare n _m -> (n, 10 - n)
+ LFrame n m -> (n, m)
+ , PreviousScores [0])
+
+expectedScores :: [Int]
+expectedScores = [236,206,176,146,126,117,98,70,40,20,0]
+
+actualScores :: [Int]
+actualScores = toScores sampleGame
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
index 0000000..955bead
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,10 @@
+import Example
+import System.Exit
+
+main :: IO ()
+main = case actualScores == expectedScores of
+ False -> do
+ putStrLn $ "Expected: " <> show expectedScores
+ putStrLn $ "Actual: " <> show actualScores
+ exitFailure
+ True -> exitSuccess