From cfb7be14aebffd68ca357d7c6ef15e1c0974a156 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 3 Jun 2016 22:09:01 +0200 Subject: cleanup & stumped on variadic val --- src/Sequence/Formula.hs | 59 +++++++++++++++++++++++++++++++++++------------ src/Sequence/Utils.hs | 17 ++------------ src/Sequence/Utils/Ask.hs | 27 ++++++++++++++++++++++ 3 files changed, 73 insertions(+), 30 deletions(-) create mode 100644 src/Sequence/Utils/Ask.hs (limited to 'src/Sequence') 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