From cfb7be14aebffd68ca357d7c6ef15e1c0974a156 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 3 Jun 2016 22:09:01 +0200
Subject: cleanup & stumped on variadic val

---
 sequence.cabal            |  2 +-
 sequence.nix              |  4 ++--
 src/Sequence/Formula.hs   | 59 +++++++++++++++++++++++++++++++++++------------
 src/Sequence/Utils.hs     | 17 ++------------
 src/Sequence/Utils/Ask.hs | 27 ++++++++++++++++++++++
 5 files changed, 76 insertions(+), 33 deletions(-)
 create mode 100644 src/Sequence/Utils/Ask.hs

diff --git a/sequence.cabal b/sequence.cabal
index c7c58e4..47f1532 100644
--- a/sequence.cabal
+++ b/sequence.cabal
@@ -34,6 +34,6 @@ executable sequence
                      , table-layout
                      , game-probability
                      , readline
-                     , either
+                     , transformers
   hs-source-dirs:      src
   default-language:    Haskell2010
\ No newline at end of file
diff --git a/sequence.nix b/sequence.nix
index a272486..dfc6cb4 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
-, xdg-basedir
+, transformers, xdg-basedir
 }:
 mkDerivation {
   pname = "sequence";
@@ -12,7 +12,7 @@ mkDerivation {
   executableHaskellDepends = [
     base bimap case-insensitive containers data-default directory
     either filepath game-probability lens mtl readline Shellac
-    Shellac-haskeline table-layout xdg-basedir
+    Shellac-haskeline table-layout transformers xdg-basedir
   ];
   license = stdenv.lib.licenses.mit;
 }
diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
index 7a6e689..2a4541f 100644
--- a/src/Sequence/Formula.hs
+++ b/src/Sequence/Formula.hs
@@ -1,26 +1,37 @@
-{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies #-}
 
 module Sequence.Formula
   ( FormulaM
   , evalFormula
   , val
+  , d, z
   ) where
 
 import Control.Lens
+import Data.Data.Lens
+import Data.Data (Data)
+import Data.Typeable (Typeable)
 
-import Control.Monad.Trans.Either
+import Control.Monad.Except
 import Control.Monad.Reader
 import Numeric.Probability.Game.Event
+import qualified Numeric.Probability.Game.Dice as D
 
-import Sequence.Utils
+import Sequence.Utils.Ask
 
 import Text.Read (readMaybe)
 
-type FormulaM input a = ReaderT input (EitherT (Question input) EventM) a
+import Data.Bool
+import Data.List
+import Data.Maybe
+
+
+type FormulaM input a = ReaderT input (ExceptT (Question input) EventM) a
 
 data Question input = Question
-                      { answer :: Lens' input (Maybe Int)
+                      { answer :: Traversal' input (FormulaM input Int)
                       , prompt :: String
+                      , keepResult :: Bool
                       }
 
 instance Integral a => Num (FormulaM input a) where
@@ -29,18 +40,36 @@ instance Integral a => Num (FormulaM input a) where
   negate = fmap negate
   abs = fmap abs
   signum = fmap signum
-  (*) x y = sum <$> (flip replicateM y =<< fromIntegral <$> x)
+  (*) x y = do n <- x
+               sum <$> replicateM (fromIntegral n) y
   fromInteger = return . fromInteger
 
+
 askQuestion :: MonadIO m => input -> (Question input) -> m input
-askQuestion input q@(Question{..}) = flip (set answer) input <$> askQ prompt (join . fmap readMaybe)
+askQuestion input q@(Question{..}) = flip (set answer) input . maybe (throwError q) return <$> askQ prompt (join . fmap readMaybe)
+
+evalFormula :: MonadIO m => input -> FormulaM input a -> m (input, a)
+evalFormula = evalFormula' []
+  where
+    evalFormula' finalChanges input formula = do
+      result <- liftIO . enact . runExceptT . (runReaderT ?? input) $ 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 (FormulaM input Int) -> String -> Bool -> FormulaM input Int
+val answer prompt keepResult = preview answer >>= maybe (throwError Question{..}) id
+
+-- viewL :: Lens' lInput sInput -> Iso' (FormulaM sInput a) (FormulaM lInput a)
+-- viewL lTrav = iso asL asS
+--   where
+--     asL small = join $ lift . withExceptT (\Question{..} -> Question{ answer = lTrav . answer . viewL lTrav, .. }) . runReaderT small <$> view lTrav
+--     asS :: FormulaM lInput a -> FormulaM sInput a
+--     asS large = undefined
 
-evalFormula :: MonadIO m => input -> FormulaM input a -> m a
-evalFormula input formula = do
-  result <- liftIO . enact . runEitherT . (runReaderT ?? input) $ formula
-  case result of
-    Left q -> askQuestion input q >>= flip evalFormula formula
-    Right result -> return result
+-- val' :: Integral a => Lens' lInput sInput -> Traversal' sInput (FormulaM sInput Int) -> String -> Bool -> FormulaM lInput Int
+-- val' lTrav sTrav prompt keepResult = preview (lTrav . sTrav . viewL lTrav) >>= maybe (throwError Question{ answer = lTrav . sTrav . viewL lTrav, ..}) id
 
-val :: Integral a => Lens' input (Maybe Int) -> String -> FormulaM input Int
-val answer prompt = view answer >>= maybe (lift . left $ Question{..}) return
+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
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
index f0a8849..274a69d 100644
--- a/src/Sequence/Utils.hs
+++ b/src/Sequence/Utils.hs
@@ -2,8 +2,8 @@
 
 module Sequence.Utils
   ( withArg, withFocus
-  , askQ, askBool
   , toName, fromName
+  , module Sequence.Utils.Ask
   ) where
 
 import Sequence.Types
@@ -33,8 +33,7 @@ import System.Console.Shell
 import System.Console.Shell.ShellMonad
 import System.Console.Shell.Backend.Haskeline
 
-import System.Console.Readline (readline)
-
+import Sequence.Utils.Ask
 
 class Argument a st | a -> st where
   arg :: String -> Sh st (Maybe a)
@@ -49,18 +48,6 @@ withFocus f = use gFocus >>= \focus -> case focus of
   Nothing -> shellPutErrLn $ "Currently not focusing any entity"
   Just id -> f id
 
-askBool :: MonadIO m => String -> Bool -> m Bool
-askBool prompt initial = askQ prompt $ fromMaybe initial . join . fmap (eval . CI.mk)
-  where
-    eval "yes" = Just True
-    eval "y" = Just True
-    eval "no" = Just False
-    eval "n" = Just False
-    eval _ = Nothing
-
-askQ :: MonadIO m => String -> (Maybe String -> a) -> m a
-askQ prompt eval = eval <$> liftIO (readline $ prompt ++ " ")
-  
 unaligned = view faction' def
   
 toName :: MonadState GameState m => EntityIdentifier -> m String
diff --git a/src/Sequence/Utils/Ask.hs b/src/Sequence/Utils/Ask.hs
new file mode 100644
index 0000000..8020656
--- /dev/null
+++ b/src/Sequence/Utils/Ask.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Sequence.Utils.Ask
+  ( askQ, askBool
+  ) where
+
+import System.Console.Readline (readline)
+
+import Control.Monad.IO.Class
+import Control.Monad
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Data.Maybe
+
+askBool :: MonadIO m => String -> Bool -> m Bool
+askBool prompt initial = askQ prompt $ fromMaybe initial . join . fmap (eval . CI.mk)
+  where
+    eval "yes" = Just True
+    eval "y" = Just True
+    eval "no" = Just False
+    eval "n" = Just False
+    eval _ = Nothing
+
+askQ :: MonadIO m => String -> (Maybe String -> a) -> m a
+askQ prompt eval = eval <$> liftIO (readline $ prompt ++ " ")
-- 
cgit v1.2.3