Merge pull request #432 from lepsa/splitting-comp-state

Splitting up StateC and CompState

CHANGELOG.md

@@ -46,3 +46,4 @@
   * Rotate now internally uses quaternions [#314](https://github.com/Haskell-Things/ImplicitCAD/pull/314)
   * Fixes to triangle generation [#355](https://github.com/Haskell-Things/ImplicitCAD/pull/355) and [#375](https://github.com/Haskell-Things/ImplicitCAD/pull/375)
   * ExtOpenSCAD vector addition [#408](https://github.com/Haskell-Things/ImplicitCAD/pull/408)
+  * Migrating StateC and StateE to a ReaderT/WriterT/StateT transformer stack [#432](https://github.com/Haskell-Things/ImplicitCAD/pull/432)

Graphics/Implicit/ExtOpenScad.hs

@@ -10,7 +10,7 @@ import Prelude(String, IO, ($), (<$>), pure, either, (.), Applicative, Bool(True
 
 import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3)
 
-import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, ScadOpts, Message(Message), MessageType(SyntaxError), CompState(CompState, scadVars, oVals, messages), StatementI)
+import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, ScadOpts, Message(Message), MessageType(SyntaxError), CompState(CompState, scadVars, oVals), StatementI, runImplicitCadM)
 
 import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)
 
@@ -24,8 +24,6 @@ import Graphics.Implicit.ExtOpenScad.Util.OVal (divideObjs)
 
 import Text.Parsec.Error (errorPos, errorMessages, showErrorMessages, ParseError)
 
-import Control.Monad.State.Lazy (runStateT)
-
 import System.Directory (getCurrentDirectory)
 
 import Data.Foldable (traverse_)
@@ -43,12 +41,15 @@ runOpenscad scadOpts constants source = do
     run sts = rearrange <$> do
       let sts' = traverse_ runStatementI sts
       path <- getCurrentDirectory
-      runStateT sts' $ CompState initialObjects [] path initialMessages scadOpts
+      let initState = CompState initialObjects [] path
+      (_, w, s') <- runImplicitCadM scadOpts initState sts'
+      pure (w, s')
+
   either err run $ parseProgram "" source
   where
-    rearrange :: ((), CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
-    rearrange (_, s) =
+    rearrange :: ([Message], CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
+    rearrange (messages,  s) =
       let (obj2s, obj3s, _) = divideObjs $ oVals s
-      in (scadVars s, obj2s, obj3s, messages s)
+      in (scadVars s, obj2s, obj3s, messages)
     show' = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . errorMessages
     mesg e = Message SyntaxError (sourcePosition $ errorPos e) $ pack $ show' e

Graphics/Implicit/ExtOpenScad/Definitions.hs

@@ -5,8 +5,15 @@
 
 -- Allow us to use string literals for Text
 {-# LANGUAGE OverloadedStrings #-}
-
+-- Tell GHC to use underlying instances for newtypes
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+-- Derive functor automatically
 {-# LANGUAGE DeriveFunctor #-}
+-- Allow constraints to be written like types
+{-# LANGUAGE ConstraintKinds #-}
+-- Allow us to set some context variables to actual types
+-- Useful for working with transformers and MTL
+{-# LANGUAGE FlexibleContexts #-}
 
 module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFail, APExample),
                                                   Symbol(Symbol),
@@ -18,13 +25,17 @@ module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch
                                                   TestInvariant(EulerCharacteristic),
                                                   SourcePosition(SourcePosition),
                                                   StateC,
-                                                  CompState(CompState, scadVars, oVals, sourceDir, messages, scadOpts),
+                                                  CompState(CompState, scadVars, oVals, sourceDir),
+                                                  ImplicitCadM(ImplicitCadM, unImplicitCadM),
                                                   VarLookup(VarLookup),
                                                   Message(Message),
                                                   MessageType(TextOut, Warning, Error, SyntaxError, Compatibility, Unimplemented),
                                                   ScadOpts(ScadOpts, openScadCompatibility, importsAllowed),
                                                   lookupVarIn,
-                                                  varUnion
+                                                  varUnion,
+                                                  runImplicitCadM,
+                                                  CanCompState,
+                                                  CanCompState'
                                                   ) where
 
 import Prelude(Eq, Show, Ord, Maybe(Just), Bool(True, False), IO, FilePath, (==), show, ($), (<>), and, zipWith, Int, (<$>))
@@ -44,18 +55,62 @@ import Data.Maybe (fromMaybe)
 
 import Data.Text.Lazy (Text, unpack, intercalate)
 
-import Control.Monad.State (StateT)
+import Control.Monad.State (StateT (runStateT), MonadState)
+import Control.Monad.Writer (WriterT (runWriterT), MonadWriter)
+import Control.Monad.Reader (ReaderT (runReaderT), MonadReader)
+import Control.Monad.IO.Class ( MonadIO )
 
 -- | The state of computation.
 data CompState = CompState
   { scadVars  :: VarLookup -- ^ A hash of variables and functions.
   , oVals     :: [OVal]    -- ^ The result of geometry generating functions.
   , sourceDir :: FilePath  -- ^ The path we are looking for includes in.
-  , messages  :: [Message] -- ^ Output strings, warnings, and errors generated during execution.
-  , scadOpts  :: ScadOpts  -- ^ Options controlling the execution of scad code.
   } deriving (Show)
 
-type StateC = StateT CompState IO
+-- Similar to StateC, except we are pulling out the bits of state that do not need to be mutable
+-- in the ways they are. scadOpts is only ever read, and messages are only ever written.
+-- This helps enforce that scadOpts is never changed, and messages are only ever appended to.
+--
+-- Transformer stacks are often seen as being "inside out" when first encountered.
+-- For example, `Reader r (Writer w IO) a` runs to a type of `IO (a, w)`
+-- This happens because as you run each layer of the transformer you are exposing the
+-- monad inside of it, usually either IO or Identity at the very bottom.
+-- Running reader gives a Writer Monad, which when run will give an IO monad.
+--
+-- This has been parameterised over all of the transformer types so that we can
+-- also use this to implement StateE using the same stack.
+newtype ImplicitCadM r w s m a = ImplicitCadM {
+  unImplicitCadM :: ReaderT r (WriterT w (StateT s m)) a
+} deriving
+  -- We can have mtl/transformers give us all the instances we care
+  -- about for the newtype, dropping any that won't work when this is
+  -- parameterised at the call site.
+  ( MonadReader r
+  , MonadWriter w
+  , MonadState s
+  , MonadIO -- This only exists if `m` is also MonadIO.
+  , Monad
+  , Applicative
+  , Functor
+  )
+
+-- These are constraint types, and can be used in the same way as `foo :: Monad m => m a -> m ()`
+-- They are useful for when writing code that doesn't care about the exact structure of CompStateM,
+-- but rather what you can do with it. This constraint allows you to `ask`, `get/put`, and `tell`
+-- without having to worry about wrapping, lifting, etc.
+type CanCompState' r w s m = (MonadReader r m, MonadWriter w m, MonadState s m, MonadIO m)
+type CanCompState m = CanCompState' ScadOpts [Message] CompState m
+
+-- Keep the name, so ghc can help us along.
+type StateC a = ImplicitCadM ScadOpts [Message] CompState IO a
+
+-- This is the function you probably want when trying to actually run an ImplicitCadM
+-- It handles running each of the transformers in order and putting the results into a
+-- useful tuple form.
+runImplicitCadM :: Monad m => r -> s -> ImplicitCadM r w s m a -> m (a, w, s)
+runImplicitCadM r s m = do
+  ((a, w), s') <- runStateT (runWriterT $ runReaderT (unImplicitCadM m) r) s
+  pure (a, w, s')
 
 -- | Handles parsing arguments to built-in modules
 data ArgParser a

Graphics/Implicit/ExtOpenScad/Eval/Constant.hs

@@ -19,10 +19,10 @@ import Graphics.Implicit.ExtOpenScad.Definitions (
                                                   MessageType(SyntaxError),
                                                   StateC,
                                                   ScadOpts(ScadOpts),
-                                                  CompState(CompState, scadVars, messages),
+                                                  CompState(CompState, scadVars),
                                                   SourcePosition(SourcePosition),
                                                   OVal(OUndefined),
-                                                  varUnion
+                                                  varUnion, runImplicitCadM
                                                  )
 
 import Graphics.Implicit.ExtOpenScad.Util.StateC (modifyVarLookup, addMessage)
@@ -33,7 +33,7 @@ import Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat, rawRunExpr)
 
 import Graphics.Implicit.ExtOpenScad.Default (defaultObjects)
 
-import Control.Monad.State (liftIO, runStateT, (>>=))
+import Control.Monad.State (liftIO, (>>=))
 
 import System.Directory (getCurrentDirectory)
 
@@ -51,8 +51,10 @@ import Graphics.Implicit.ExtOpenScad.Parser.Lexer (matchTok)
 addConstants :: [String] -> Bool -> IO (VarLookup, [Message])
 addConstants constants withCSG = do
   path <- getCurrentDirectory
-  (_, s) <- liftIO . runStateT (execAssignments constants) $ CompState (defaultObjects withCSG) [] path [] opts
-  pure (scadVars s, messages s)
+  let initState = CompState (defaultObjects withCSG) [] path
+  (_, messages, s) <- liftIO .
+    runImplicitCadM opts initState $ execAssignments constants
+  pure (scadVars s, messages)
   where
     opts = ScadOpts False False
     show' = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . errorMessages
@@ -73,7 +75,7 @@ runExpr :: String -> Bool -> (OVal, [Message])
 runExpr expression withCSG = do
   either oUndefined run $ parse expr0 "raw_expression" expression
     where
-      run expr = rawRunExpr initPos (defaultObjects withCSG) expr
+      run = rawRunExpr initPos (defaultObjects withCSG)
       initPos = SourcePosition 1 1 "raw_expression"
       show' = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . errorMessages
       oUndefined e = (OUndefined, [Message SyntaxError initPos $ pack $ show' e])

Graphics/Implicit/ExtOpenScad/Eval/Expr.hs

@@ -10,9 +10,9 @@
 -- Allow us to use string literals for Text
 {-# LANGUAGE OverloadedStrings #-}
 
-module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, rawRunExpr, matchPat, StateE, ExprState(ExprState), messages, addMessage) where
+module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, rawRunExpr, matchPat, StateE, ExprState(ExprState), addMessage) where
 
-import Prelude (String, Maybe(Just, Nothing), ($), fmap, pure, zip, (!!), const, (<>), foldr, foldMap, (.), (<$>), traverse)
+import Prelude (String, Maybe(Just, Nothing), ($), pure, zip, (!!), const, (<>), foldr, foldMap, (.), (<$>), traverse)
 
 import Graphics.Implicit.ExtOpenScad.Definitions (
                                                   Pattern(Name, ListP, Wild),
@@ -23,7 +23,7 @@ import Graphics.Implicit.ExtOpenScad.Definitions (
                                                   SourcePosition,
                                                   Message(Message),
                                                   MessageType(Error),
-                                                  StateC
+                                                  StateC, ImplicitCadM, runImplicitCadM
                                                  )
 
 import Graphics.Implicit.ExtOpenScad.Util.OVal (oTypeStr, getErrors)
@@ -38,31 +38,47 @@ import Data.Map (fromList, lookup)
 
 import Data.Foldable (fold, traverse_)
 
-import Data.Functor.Identity (Identity)
-
 import Data.Traversable (for)
 
 import Control.Monad (zipWithM)
 
 import Data.Text.Lazy (Text, unpack)
 
-import Control.Monad.State (StateT, get, modify, runState)
-
-data ExprState = ExprState
-  { _scadVars  :: VarLookup
-  , patterns  :: [String]
-  , messages  :: [Message]
-  , _sourcePos :: SourcePosition
-  }
-
-type StateE = StateT ExprState Identity
+import Data.Eq (Eq)
+import Text.Show (Show)
+import Control.Monad.Writer.Class (tell)
+import Control.Monad.State.Lazy (get)
+import Control.Monad.State.Class (modify)
+import Control.Monad.Identity (Identity (runIdentity))
+import Control.Monad.Reader (ask)
+
+-- Patterns is the only thing being modified, so
+-- it is the only on in the state structure.
+newtype ExprState = ExprState
+  { patterns  :: [String]
+  } deriving (Eq, Show)
+
+-- varLookup and sourcePos are only ever read from
+-- so we can put them into a reader, so they can never
+-- accidentally be written to.
+data Input = Input
+  { varLookup :: VarLookup
+  , sourcePos :: SourcePosition
+  } deriving (Eq, Show)
+
+-- Check Graphics.Implicit.ExtOpenScad.Definitions for an explanation
+-- of why we are using a transformer stack.
+type StateE a = ImplicitCadM Input [Message] ExprState Identity a
+
+runStateE :: Input -> ExprState -> StateE a -> (a, [Message], ExprState)
+runStateE r s m = runIdentity $ runImplicitCadM r s m
 
 -- Add a message to our list of messages contained in the StatE monad.
 addMessage :: MessageType -> SourcePosition -> Text -> StateE ()
 addMessage mtype pos text = addMesg $ Message mtype pos text
   where
     addMesg :: Message -> StateE ()
-    addMesg m = modify $ \s -> s { messages = messages s <> pure m }
+    addMesg = tell . pure
 
 -- Log an error condition.
 errorE :: SourcePosition -> Text -> StateE ()
@@ -90,24 +106,29 @@ evalExpr :: SourcePosition -> Expr -> StateC OVal
 evalExpr pos expr = do
     vars <- getVarLookup
     let
-      (valf, s) = runState (evalExpr' expr) $ ExprState vars [] [] pos
+      input = Input vars pos
+      initState = ExprState []
+      (valf, messages, _) = runStateE input initState (evalExpr' expr)
       moveMessage (Message mtype mpos text) = GIEUS.addMessage mtype mpos text
-    traverse_ moveMessage $ messages s
+    traverse_ moveMessage messages
     pure $ valf []
 
 -- A more raw entry point, that does not depend on IO.
 rawRunExpr :: SourcePosition -> VarLookup -> Expr -> (OVal, [Message])
 rawRunExpr pos vars expr = do
   let
-    (valf, s) = runState (evalExpr' expr) $ ExprState vars [] [] pos
-  (valf [], messages s)
+    input = Input vars pos
+    initState = ExprState []
+    (valf, messages, _) = runStateE input initState (evalExpr' expr)
+  (valf [], messages)
 
 -- The expression evaluators.
 evalExpr' :: Expr -> StateE ([OVal] -> OVal)
 
 -- Evaluate a variable lookup.
 evalExpr' (Var (Symbol name)) = do
-  (ExprState (VarLookup varlookup) namestack _ spos) <- get
+  Input (VarLookup varlookup) spos <- ask
+  (ExprState namestack) <- get
   case (lookup (Symbol name) varlookup, elemIndex (unpack name) namestack) of
         (_, Just pos) -> pure (!! pos)
         (Just val, _) -> pure $ const val
@@ -121,13 +142,13 @@ evalExpr' (LitE  val) = pure $ const val
 -- Evaluate a list of expressions.
 evalExpr' (ListE exprs) = do
     valFuncs <- traverse evalExpr' exprs
-    pure $ \s -> OList $ ($s) <$> valFuncs
+    pure $ \s -> OList $ ($ s) <$> valFuncs
 
 -- Evaluate application of a function.
 evalExpr' (fexpr :$ argExprs) = do
     fValFunc <- evalExpr' fexpr
     argValFuncs <- traverse evalExpr' argExprs
-    pure $ \s -> app (fValFunc s) (fmap ($s) argValFuncs)
+    pure $ \s -> app (fValFunc s) (($ s) <$> argValFuncs)
         where
             app f l = case (getErrors f, getErrors $ OList l) of
                 (Nothing, Nothing) -> app' f l
@@ -148,5 +169,4 @@ evalExpr' (LamE pats fexpr) = do
             Just xs -> f (xs <> xss)
             Nothing -> OError "Pattern match failed"
     fval <- evalExpr' fexpr
-    pure $ foldr ($) fval fparts
-
+    pure $ foldr ($) fval fparts

Graphics/Implicit/ExtOpenScad/Eval/Statement.hs

@@ -21,8 +21,8 @@ import Graphics.Implicit.ExtOpenScad.Definitions (
                                                   Message(Message),
                                                   ScadOpts(importsAllowed),
                                                   StateC,
-                                                  CompState(CompState, messages, sourceDir, scadOpts),
-                                                  varUnion
+                                                  CompState(CompState, sourceDir),
+                                                  varUnion, runImplicitCadM
                                                  )
 
 import Graphics.Implicit.ExtOpenScad.Util.OVal (getErrors)
@@ -37,9 +37,9 @@ import Data.Map (union, fromList, toList)
 
 import Data.Maybe (isJust, fromMaybe, mapMaybe, catMaybes)
 
-import Control.Monad (when, unless, (>>=))
+import Control.Monad (when, unless)
 
-import Control.Monad.State (gets, liftIO, runStateT)
+import Control.Monad.State (gets, liftIO)
 
 import Data.Foldable (traverse_, for_)
 
@@ -50,6 +50,7 @@ import Data.Text.Lazy (unpack, pack)
 import System.Directory (doesFileExist)
 
 import System.FilePath (takeDirectory)
+import Control.Monad.Reader.Class (MonadReader(ask))
 
 -- | Run statements out of the OpenScad file.
 runStatementI :: StatementI -> StateC ()
@@ -279,8 +280,11 @@ runSuite = traverse_ runStatementI
 
 runSuiteCapture :: VarLookup -> [StatementI] -> StateC [OVal]
 runSuiteCapture varlookup suite = do
-  (res, s) <- gets mkSubState >>= liftIO . runStateT (runSuite suite *> getVals)
-  reverse res <$ traverse moveMessage (messages s)
+  opts <- ask
+  (res, messages, _) <- do
+    s <- gets mkSubState
+    liftIO . runImplicitCadM opts s $ runSuite suite *> getVals
+  reverse res <$ traverse moveMessage messages
     where
-      mkSubState s = CompState varlookup [] (sourceDir s) [] (scadOpts s)
+      mkSubState s = CompState varlookup [] (sourceDir s)
       moveMessage (Message mtype mpos text) = addMessage mtype mpos text