Evaluate formulas in arbitrarily large context

1 files changed, 29 insertions, 9 deletions

diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
index 0d99fc0..9000c58 100644
--- a/src/Sequence/Formula.hs
+++ b/src/Sequence/Formula.hs
@@ -1,13 +1,14 @@
-{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies #-}
+{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies, GADTs, TypeOperators, ExistentialQuantification, FlexibleContexts #-}
 
 module Sequence.Formula
   ( FormulaM, Formula, quot'
+  , (:<:)(..), Context(..)
   , evalFormula
   , val
   , d, z
   ) where
 
-import Control.Lens
+import Control.Lens hiding (Context(..))
 import Data.Data.Lens
 
 import Control.Monad
@@ -30,8 +31,27 @@ import Data.Either
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+class (:<:) small large where
+  ctx' :: Traversal' large small
 
-type FormulaM input a = StateT (Set String) (ReaderT input (ExceptT (Question input) EventM)) a
+instance a :<: a where
+  ctx' = simple
+
+instance a :<: (a, a) where
+  ctx' = both
+
+instance a :<: (a, b) where
+  ctx' = _1
+
+instance a :<: (b, a) where
+  ctx' = _2
+
+data Context small = forall large. (small :<: large) => Context large
+
+ctx :: Traversal' (Context input) input
+ctx modifySmall (Context large) = Context <$> ctx' modifySmall large
+
+type FormulaM input a = StateT (Set String) (ReaderT (Context input) (ExceptT (Question input) EventM)) a
 
 type Formula input = FormulaM input Int
 
@@ -66,22 +86,22 @@ instance Integral a => Num (FormulaM input a) where
 quot' :: Integral a => FormulaM input a -> FormulaM input a -> FormulaM input a
 quot' = liftM2 quot
 
-askQuestion :: MonadIO m => input -> (Question input) -> m input
-askQuestion input q@(Question{..}) = flip (set answer) input . maybe (throwError q) return <$> askQ prompt (join . fmap readMaybe)
+askQuestion :: (MonadIO m, sInput :<: lInput) => lInput -> Question sInput -> m lInput
+askQuestion input q@(Question{..}) = flip (set $ ctx' . answer) input . maybe (throwError q) return <$> askQ prompt (join . fmap readMaybe)
 
-evalFormula :: (MonadIO m, Ord a, Show a) => input -> FormulaM input a -> m (input, a)
+evalFormula :: (MonadIO m, sInput :<: lInput) => lInput -> FormulaM sInput a -> m (lInput, a)
 evalFormula = evalFormula' []
   where
     evalFormula' finalChanges input formula = do
-      result <- liftIO . enact . runExceptT . (runReaderT ?? input) . (evalStateT ?? Set.empty) $ formula
+      result <- liftIO . enact . runExceptT . (runReaderT ?? (Context 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
+        Left q@(Question{..}) -> askQuestion input q >>= flip (evalFormula' $ bool (pure . set (ctx' . 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 = do
   gets (Set.member prompt) >>= bool (modify $ Set.insert prompt) (modify (Set.delete prompt) >> throwError Question{..})
-  preview answer >>= maybe (throwError Question{..}) id
+  preview (ctx . answer) >>= maybe (throwError Question{..}) id
 
 d, z :: Integral a => Int -> FormulaM input a
 d n = liftBase . fmap fromIntegral $ D.d n