Prevent infinite recursion (crudely)

3 files changed, 22 insertions, 13 deletions

diff --git a/sequence.cabal b/sequence.cabal
index 47f1532..11e3273 100644
--- a/sequence.cabal
+++ b/sequence.cabal
@@ -35,5 +35,6 @@ executable sequence
                      , game-probability
                      , readline
                      , transformers
+                     , transformers-base
   hs-source-dirs:      src
   default-language:    Haskell2010
\ No newline at end of file
diff --git a/sequence.nix b/sequence.nix
index dfc6cb4..7b46a9d 100644
--- a/sequence.nix
+++ b/sequence.nix
@@ -1,7 +1,7 @@
 { mkDerivation, base, bimap, case-insensitive, containers
-, data-default, directory, either, filepath, game-probability, lens
-, mtl, readline, Shellac, Shellac-haskeline, stdenv, table-layout
-, transformers, xdg-basedir
+, data-default, directory, filepath, game-probability, lens, mtl
+, readline, Shellac, Shellac-haskeline, stdenv, table-layout
+, transformers, transformers-base, xdg-basedir
 }:
 mkDerivation {
   pname = "sequence";
@@ -11,8 +11,9 @@ mkDerivation {
   isExecutable = true;
   executableHaskellDepends = [
     base bimap case-insensitive containers data-default directory
-    either filepath game-probability lens mtl readline Shellac
-    Shellac-haskeline table-layout transformers xdg-basedir
+    filepath game-probability lens mtl readline Shellac
+    Shellac-haskeline table-layout transformers transformers-base
+    xdg-basedir
   ];
   license = stdenv.lib.licenses.mit;
 }
diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
index c3e9e33..7fb4ccb 100644
--- a/src/Sequence/Formula.hs
+++ b/src/Sequence/Formula.hs
@@ -13,6 +13,8 @@ import Data.Data.Lens
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Base
 import Numeric.Probability.Game.Event
 import qualified Numeric.Probability.Game.Dice as D
 
@@ -25,13 +27,17 @@ import Data.List
 import Data.Maybe
 import Data.Either
 
-import Debug.Trace
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 
-type FormulaM input a = ReaderT input (ExceptT (Question input) EventM) a
+type FormulaM input a = StateT (Set String) (ReaderT input (ExceptT (Question input) EventM)) a
 
 type Formula input = FormulaM input Int
 
+instance MonadBase EventM EventM where
+  liftBase = id
+
 data Question input = Question
                       { answer :: Traversal' input (Formula input)
                       , prompt :: String
@@ -66,15 +72,16 @@ askQuestion input q@(Question{..}) = flip (set answer) input . maybe (throwError
 evalFormula :: (MonadIO m, Ord a, Show a) => input -> FormulaM input a -> m (input, a)
 evalFormula = evalFormula' []
   where
-    evalFormula' finalChanges input formula = trace "evalFormula'" $ do
-      result <- liftIO . enact . traceShowId . runExceptT . (runReaderT ?? input) $ formula
-      liftIO . traceIO $ show (isLeft result, isRight result)
+    evalFormula' finalChanges input formula = do
+      result <- liftIO . enact . runExceptT . (runReaderT ?? input) . (evalStateT ?? Set.empty) $ formula
       case result of
         Left q@(Question{..}) -> askQuestion input q >>= flip (evalFormula' $ bool (pure . set answer $ throwError q) mempty keepResult ++ finalChanges) formula
         Right result -> return (foldr ($) input finalChanges, result)
 
 val :: Integral a => Traversal' input (Formula input) -> String -> Bool -> Formula input
-val answer prompt keepResult = preview answer >>= maybe (throwError Question{..}) id . trace "val"
+val answer prompt keepResult = do
+  gets (Set.member prompt) >>= bool (modify $ Set.insert prompt) (throwError Question{..})
+  preview answer >>= maybe (throwError Question{..}) id
 
 -- viewL :: Lens' lInput sInput -> Prism' (FormulaM sInput a) (FormulaM lInput a)
 -- viewL lTrav = iso asL asS
@@ -87,5 +94,5 @@ val answer prompt keepResult = preview answer >>= maybe (throwError Question{..}
 -- val' lTrav sTrav prompt keepResult = preview (lTrav . sTrav . viewL lTrav) >>= maybe (throwError Question{ answer = lTrav . sTrav . viewL lTrav, ..}) id
 
 d, z :: Integral a => Int -> FormulaM input a
-d n = lift . lift . fmap fromIntegral $ D.d n
-z n = lift . lift . fmap fromIntegral $ D.z n
+d n = liftBase . fmap fromIntegral $ D.d n
+z n = liftBase . fmap fromIntegral $ D.z n