From bf7b92a4daff86e3853b1005dcd18c94d14ac362 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 5 Jun 2016 01:35:13 +0200 Subject: Prevent infinite recursion (crudely) --- sequence.cabal | 1 + sequence.nix | 11 ++++++----- src/Sequence/Formula.hs | 23 +++++++++++++++-------- 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 -- cgit v1.2.3