diff --git a/CHANGELOG.md b/CHANGELOG.md index 22f04646..265723cc 100644 --- a/CHANGELOG.md +++ b/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) \ No newline at end of file diff --git a/Graphics/Implicit/ExtOpenScad.hs b/Graphics/Implicit/ExtOpenScad.hs index 5884b4d2..57d829c1 100644 --- a/Graphics/Implicit/ExtOpenScad.hs +++ b/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 diff --git a/Graphics/Implicit/ExtOpenScad/Definitions.hs b/Graphics/Implicit/ExtOpenScad/Definitions.hs index 7bec2f42..14c618a8 100644 --- a/Graphics/Implicit/ExtOpenScad/Definitions.hs +++ b/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 diff --git a/Graphics/Implicit/ExtOpenScad/Eval/Constant.hs b/Graphics/Implicit/ExtOpenScad/Eval/Constant.hs index fa81f69f..4438f90c 100644 --- a/Graphics/Implicit/ExtOpenScad/Eval/Constant.hs +++ b/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]) diff --git a/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs b/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs index a8da9b32..810c9d22 100644 --- a/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs +++ b/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 \ No newline at end of file diff --git a/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs b/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs index dd14607f..58cd08d5 100644 --- a/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs +++ b/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 diff --git a/Graphics/Implicit/ExtOpenScad/Util/StateC.hs b/Graphics/Implicit/ExtOpenScad/Util/StateC.hs index 58f5e8fc..e73b9f68 100644 --- a/Graphics/Implicit/ExtOpenScad/Util/StateC.hs +++ b/Graphics/Implicit/ExtOpenScad/Util/StateC.hs @@ -7,7 +7,7 @@ module Graphics.Implicit.ExtOpenScad.Util.StateC (addMessage, getVarLookup, modi import Prelude(FilePath, Maybe, ($), (<>), pure) -import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal, Symbol, SourcePosition, Message(Message), MessageType(Error, Warning), ScadOpts, StateC, CompState(scadVars, oVals, sourceDir, messages, scadOpts)) +import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal, Symbol, SourcePosition, Message(Message), MessageType(Error, Warning), ScadOpts, StateC, CompState(scadVars, oVals, sourceDir)) import Data.Map (lookup) @@ -16,6 +16,8 @@ import Data.Text.Lazy (Text) import Control.Monad.State (modify, gets) import System.FilePath(()) +import Control.Monad.Writer (tell) +import Control.Monad.Reader.Class (ask) getVarLookup :: StateC VarLookup getVarLookup = gets scadVars @@ -56,8 +58,9 @@ getRelPath relPath = do path <- getPath pure $ path relPath +-- Add a single message to the list of messages being returned addMesg :: Message -> StateC () -addMesg m = modify $ \c -> c { messages = messages c <> pure m } +addMesg m = tell [m] addMessage :: MessageType -> SourcePosition -> Text -> StateC () addMessage mtype pos text = addMesg $ Message mtype pos text @@ -70,6 +73,6 @@ warnC :: SourcePosition -> Text -> StateC () warnC = addMessage Warning {-# INLINABLE warnC #-} +-- Get the ScadOpts from the Reader in ImplicitCadM scadOptions :: StateC ScadOpts -scadOptions = gets scadOpts - +scadOptions = ask \ No newline at end of file