Overhaul

.gitignore

@@ -0,0 +1 @@
+/dist

Control/Monad/Tardis.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE CPP                        #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+
+{-# LANGUAGE DoRec                      #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FunctionalDependencies     #-}
+
+#ifdef USE_UNDECIDABLE_INSTANCES
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE OverlappingInstances       #-}
+#endif
+
+module Control.Monad.Tardis
+  ( module Control.Monad.Trans.Tardis
+  , module Control.Monad.Tardis.Class
+  ) where
+
+
+#ifdef USE_UNDECIDABLE_INSTANCES
+import Control.Applicative (Applicative)
+import Control.Monad.Trans (MonadTrans, lift)
+#endif
+
+import Control.Monad.Fix
+import Control.Monad.State.Class
+
+import qualified Control.Monad.Trans.Tardis as T
+import Control.Monad.Tardis.Class
+import Control.Monad.Trans.Tardis
+  ( TardisT
+  , runTardisT
+  , evalTardisT
+  , execTardisT
+
+  , Tardis
+  , runTardis
+  , evalTardis
+  , execTardis
+
+  , noState
+  )
+
+instance MonadFix m => MonadTardis bw fw (TardisT bw fw m) where
+  getPast    = T.getPast
+  getFuture  = T.getFuture
+  sendPast   = T.sendPast
+  sendFuture = T.sendFuture
+  tardis     = T.tardis
+
+instance MonadFix m => MonadState fw (TardisT bw fw m) where
+  get = getPast
+  put = sendFuture
+
+
+#ifdef USE_UNDECIDABLE_INSTANCES
+instance ( MonadTrans t
+         , MonadTardis bw fw m
+         , MonadFix (t m)
+         , Applicative (t m)
+         ) => MonadTardis bw fw (t m) where
+  getPast    = lift getPast
+  getFuture  = lift getFuture
+  sendPast   = lift . sendPast
+  sendFuture = lift . sendFuture
+  tardis     = lift . tardis
+#endif
+

Control/Monad/Tardis/Class.hs

@@ -0,0 +1,50 @@
+{-# OPTIONS_GHC -Wall               #-}
+{-# LANGUAGE DoRec                  #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE FunctionalDependencies #-}
+
+module Control.Monad.Tardis.Class
+  ( MonadTardis (..)
+  , modifyForwards
+  , modifyBackwards
+  , getsPast
+  , getsFuture
+  ) where
+
+import Control.Applicative
+import Control.Monad.Fix
+
+class (Applicative m, MonadFix m) => MonadTardis bw fw m | m -> bw, m -> fw where
+  getPast    :: m fw
+  getFuture  :: m bw
+  sendPast   :: bw -> m ()
+  sendFuture :: fw -> m ()
+
+  getPast        = tardis $ \ ~(bw, fw)  -> (fw, (bw, fw))
+  getFuture      = tardis $ \ ~(bw, fw)  -> (bw, (bw, fw))
+  sendPast   bw' = tardis $ \ ~(_bw, fw) -> ((), (bw', fw))
+  sendFuture fw' = tardis $ \ ~(bw, _fw) -> ((), (bw, fw'))
+
+  tardis :: ((bw, fw) -> (a, (bw, fw))) -> m a
+  tardis f = do
+    rec
+      let (a, (future', past')) = f (future, past)
+      sendPast future'
+      past <- getPast
+      future <- getFuture
+      sendFuture past'
+    return a
+
+
+modifyForwards :: MonadTardis bw fw m => (fw -> fw) -> m ()
+modifyForwards f = getPast >>= sendFuture . f
+
+modifyBackwards :: MonadTardis bw fw m => (bw -> bw) -> m ()
+modifyBackwards f = getFuture >>= sendPast . f
+
+getsPast :: MonadTardis bw fw m => (fw -> a) -> m a
+getsPast f = f <$> getPast
+
+getsFuture :: MonadTardis bw fw m => (bw -> a) -> m a
+getsFuture f = f <$> getFuture
+

Control/Monad/Tardis/Example.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE DoRec #-}
+
+module Control.Monad.Tardis.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
+  { 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@(score : _) <- getPast
+    return $ (finalFrameScore + score) : scores
+  go (f : fs) = do
+    rec
+      sendPast $ NextThrows throws'
+      PreviousScores scores@(score : _) <- getPast
+      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])
+
+

Control/Monad/Trans/Tardis.hs

@@ -0,0 +1,127 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE DoRec #-}
+
+module Control.Monad.Trans.Tardis (
+    TardisT
+  , runTardisT
+  , evalTardisT
+  , execTardisT
+
+  , Tardis
+  , runTardis
+  , evalTardis
+  , execTardis
+
+  , tardis
+
+  , getPast
+  , getFuture
+  , sendPast
+  , sendFuture
+
+  , modifyForwards
+  , modifyBackwards
+
+  , getsPast
+  , getsFuture
+
+  , noState
+  ) where
+
+import Control.Applicative
+import Control.Monad.Identity
+import Control.Monad.Trans
+
+
+-- Definition
+-------------------------------------------------
+newtype TardisT bw fw m a = TardisT
+  { runTardisT :: (bw, fw) -> m (a, (bw, fw)) }
+type Tardis bw fw = TardisT bw fw Identity
+
+runTardis :: Tardis bw fw a -> (bw, fw) -> (a, (bw, fw))
+runTardis m = runIdentity . runTardisT m
+
+
+-- Helpers
+-------------------------------------------------
+
+evalTardisT :: Monad m => TardisT bw fw m a -> (bw, fw) -> m a
+evalTardisT t s = fst `liftM` runTardisT t s
+
+execTardisT :: Monad m => TardisT bw fw m a -> (bw, fw) -> m (bw, fw)
+execTardisT t s = snd `liftM` runTardisT t s
+
+evalTardis :: Tardis bw fw a -> (bw, fw) -> a
+evalTardis t = runIdentity . evalTardisT t
+
+execTardis :: Tardis bw fw a -> (bw, fw) -> (bw, fw)
+execTardis t = runIdentity . execTardisT t
+
+
+noState :: (a, b)
+noState = (undefined, undefined)
+
+
+-- Instances
+-------------------------------------------------
+
+instance MonadFix m => Monad (TardisT bw fw m) where
+  return x = tardis $ \s -> (x, s)
+  m >>= f  = TardisT $ \ ~(bw, fw) -> do
+    rec (x,  ~(bw'', fw' )) <- runTardisT m (bw', fw)
+        (x', ~(bw' , fw'')) <- runTardisT (f x) (bw, fw')
+    return (x', (bw'', fw''))
+
+instance MonadFix m => Functor (TardisT bw fw m) where
+  fmap = liftM
+
+instance MonadFix m => Applicative (TardisT bw fw m) where
+  pure = return
+  (<*>) = ap
+
+
+instance MonadTrans (TardisT bw fw) where
+  lift m = TardisT $ \s -> do
+    x <- m
+    return (x, s)
+
+instance MonadFix m => MonadFix (TardisT bw fw m) where
+  mfix f = TardisT $ \s -> do
+    rec (x, s') <- runTardisT (f x) s
+    return (x, s')
+
+
+-- Basics
+-------------------------------------------------
+
+tardis :: Monad m => ((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
+tardis f = TardisT $ \s -> return (f s)
+
+
+getPast :: Monad m => TardisT bw fw m fw
+getPast = tardis $ \ ~(bw, fw)  -> (fw, (bw, fw))
+
+getFuture :: Monad m => TardisT bw fw m bw
+getFuture = tardis $ \ ~(bw, fw)  -> (bw, (bw, fw))
+
+sendPast :: Monad m => bw -> TardisT bw fw m ()
+sendPast bw' = tardis $ \ ~(_bw, fw) -> ((), (bw', fw))
+
+sendFuture :: Monad m => fw -> TardisT bw fw m ()
+sendFuture fw' = tardis $ \ ~(bw, _fw) -> ((), (bw, fw'))
+
+
+modifyForwards :: MonadFix m => (fw -> fw) -> TardisT bw fw m ()
+modifyForwards f = getPast >>= sendFuture . f
+
+modifyBackwards :: MonadFix m => (bw -> bw) -> TardisT bw fw m ()
+modifyBackwards f = getFuture >>= sendPast . f
+
+
+getsPast :: MonadFix m => (fw -> a) -> TardisT bw fw m a
+getsPast f = fmap f getPast
+
+getsFuture :: MonadFix m => (bw -> a) -> TardisT bw fw m a
+getsFuture f = fmap f getFuture
+