diff --git a/CHANGELOG.md b/CHANGELOG.md index 6e343250..2a564f4e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,7 @@ * Added `projection(cut=true)` support [#448](https://github.com/Haskell-Things/ImplicitCAD/pull/448) * Added `polyhedron()` support [#497](https://github.com/Haskell-Things/ImplicitCAD/pull/497) * Added `import()` support [#505](https://github.com/Haskell-Things/ImplicitCAD/pull/505) + * Improved syntax for module calling: now allows module calls in place of expressions []() * Haskell interface changes * `extrude` arguments are now swapped, instead of `extrude obj height` we now have `extrude height obj` [#473](https://github.com/Haskell-Things/ImplicitCAD/issues/473) diff --git a/Graphics/Implicit/ExtOpenScad/Default.hs b/Graphics/Implicit/ExtOpenScad/Default.hs index a48ca2b2..b1654b15 100644 --- a/Graphics/Implicit/ExtOpenScad/Default.hs +++ b/Graphics/Implicit/ExtOpenScad/Default.hs @@ -1,5 +1,5 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) --- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) +-- Copyright (C) 2016-2026, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE -- Allow us to use string literals to represent Text. diff --git a/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs b/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs index e6fd57b6..91ebc299 100644 --- a/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs +++ b/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs @@ -5,13 +5,13 @@ -- Allow us to use string literals for Text {-# LANGUAGE OverloadedStrings #-} -module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, rawRunExpr, matchPat, StateE, ExprState(ExprState), addMessage) where +module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalArgs, evalExpr, rawRunExpr, matchPat, StateE, ExprState(ExprState), addMessage) where -import Prelude (String, Maybe(Just, Nothing), Bool (True), ($), elem, pure, zip, (&&), const, (<>), foldr, foldMap, (.), (<$>), traverse) +import Prelude (String, Monoid, Maybe(Just, Nothing), Bool (False, True), ($), elem, mempty, pure, show, zip, (&&), const, (<>), foldr, foldMap, (.), (<$>), traverse) import Graphics.Implicit.ExtOpenScad.Definitions ( Pattern(Name, ListP, Wild), - OVal(OList, OError, OFunc, OUndefined), + OVal(OList, OError, OFunc, OUndefined, OUModule, ONModule, ONModuleWithSuite, OVargsModule), Expr(LitE, ListE, LamE, Var, (:$)), Symbol(Symbol), VarLookup(VarLookup), @@ -21,12 +21,16 @@ import Graphics.Implicit.ExtOpenScad.Definitions ( StateC, ImplicitCadM, runImplicitCadM ) +import Graphics.Implicit.ExtOpenScad.Util.ArgParser (argMap) + import Graphics.Implicit.ExtOpenScad.Util.OVal (oTypeStr, getErrors) -import Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup) +import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC, getVarLookup) import qualified Graphics.Implicit.ExtOpenScad.Util.StateC as GIEUS (addMessage) +import Graphics.Implicit.ExtOpenScad.Eval.Module (checkOptions, runModule) + import Data.Maybe (fromMaybe, isNothing) import Data.Map (fromList, lookup) @@ -35,9 +39,9 @@ import Data.Foldable (fold, traverse_) import Data.Traversable (for) -import Control.Monad (zipWithM) +import Control.Monad (unless, zipWithM) -import Data.Text.Lazy (Text, unpack) +import Data.Text.Lazy (Text, pack, unpack) import Data.Eq (Eq, (==)) import Text.Show (Show) @@ -57,8 +61,8 @@ newtype ExprState = ExprState -- so we can put them into a reader, so they can never -- accidentally be written to. data Input = Input - { varLookup :: VarLookup - , sourcePos :: SourcePosition + { _varLookup :: VarLookup + , _sourcePos :: SourcePosition } deriving (Eq, Show) -- Check Graphics.Implicit.ExtOpenScad.Definitions for an explanation @@ -96,9 +100,82 @@ patMatch _ _ = Nothing matchPat :: Pattern -> OVal -> Maybe VarLookup matchPat pat val = VarLookup . fromList . zip (Symbol <$> patVars pat) <$> patMatch pat val --- | The entry point from StateC. evaluates an expression, pureing the result, and moving any error messages generated into the calling StateC. +-- | Evaluate the arguments, turning them from expressions into values. +evalArgs :: [(Maybe Symbol, Expr)] -> SourcePosition -> StateC [(Maybe Symbol, OVal)] +evalArgs args sourcePos = for args $ \(posName, expr) -> do + val <- evalExpr sourcePos expr + pure (posName, val) + +-- | The entry point from StateC. Evaluates either an expression or an eligible module call. evalExpr :: SourcePosition -> Expr -> StateC OVal -evalExpr pos expr = do +evalExpr sourcePos expr = case expr of + (maybeMod :$ argExprs) -> do + -- Yes, we're recursing, after dropping argument expressions, for the OVal + rVal <- evalExpr sourcePos maybeMod + if isModule rVal + then do + -- Perform a module call. + res <- runExprModule sourcePos rVal argExprs + pure $ canonicalizeRes $ OList res + else + -- Evaluate expression. + evalExprStateC sourcePos expr + _ -> evalExprStateC sourcePos expr + where + isModule (OUModule _ _ _) = True + isModule (ONModule _ _ _) = True + isModule (ONModuleWithSuite _ _ _) = True + isModule (OVargsModule _ _) = True + isModule _ = False + -- FIXME: We may need a better result cannonicalizer here. + canonicalizeRes (OList [oneItem]) = oneItem + canonicalizeRes other = other + +-- | Execute a module call, in place of an expression. +runExprModule :: SourcePosition -> OVal -> [Expr] -> StateC [OVal] +runExprModule sourcePos mod argExprsRaw = do + let + -- Mark all of our arguments as unnamed. There are no named arguments in expressions. + argExprs = (\a -> (Nothing, a)) <$> argExprsRaw + -- Common error messages. + noSuiteError,notModError :: (Monoid a) => StateC a + noSuiteError = do + errorC sourcePos $ "tried to use a " <> oTypeStr mod <> " that uses suites on the right hand side of assignment." + pure mempty + notModError = do + errorC sourcePos $ "tried to run something that is not a module:" <> pack (show mod) + pure mempty + + -- Fully evaluate arguments. Since we're in Expr context, we can only handle unnamed arguments. + evaluatedArgs <- evalArgs argExprs sourcePos + + -- We can't handle any suites, either. + _ <- case mod of + (OUModule _ _ _) -> pure mempty :: StateC () + (ONModule _ _ _) -> pure mempty + (ONModuleWithSuite _ _ _) -> noSuiteError + (OVargsModule _ _) -> noSuiteError + _ -> notModError + + -- Perform any per-module-type specific housework, and call the module. + case mod of + (OUModule (Symbol name) args implementation) -> do + -- User modules can only have one instance, so we only have to check one set of options here. + optionsMatch <- checkOptions args argExprs True sourcePos + unless optionsMatch (errorC sourcePos $ "Options check failed when executing user-defined module " <> name <> ".") + varLookup <- getVarLookup + -- Run the module. + runModule sourcePos $ argMap evaluatedArgs $ implementation varLookup + (ONModule _ implementation _) -> do + -- Run the module. + runModule sourcePos $ argMap evaluatedArgs $ implementation sourcePos + (ONModuleWithSuite _ _ _) -> noSuiteError + (OVargsModule _ _) -> noSuiteError + _ -> notModError + +-- | The inner monadic entry point. Evaluates an expression, pureing the result, and moving any error messages generated into the calling StateC. +evalExprStateC :: SourcePosition -> Expr -> StateC OVal +evalExprStateC pos expr = do vars <- getVarLookup let input = Input vars pos diff --git a/Graphics/Implicit/ExtOpenScad/Eval/Module.hs b/Graphics/Implicit/ExtOpenScad/Eval/Module.hs new file mode 100644 index 00000000..cc5d8f8c --- /dev/null +++ b/Graphics/Implicit/ExtOpenScad/Eval/Module.hs @@ -0,0 +1,151 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) +-- Released under the GNU AGPLV3+, see LICENSE + +-- Allow us to use string literals for Text +{-# LANGUAGE OverloadedStrings #-} + +-- Utility functions for handling module calling. +module Graphics.Implicit.ExtOpenScad.Eval.Module ( + checkInstances, + checkOptions, + ensureNoSuite, + nameOfModule, + runModule, + ) where + +import Prelude(Maybe(Just, Nothing), Bool(False), (.), ($), elem, error, filter, fmap, fst, init, last, length, not, notElem, null, show, snd, pure, zip, (<>), (&&), (==), (/=), String, (<$>)) + +import Graphics.Implicit.ExtOpenScad.Definitions ( + Expr(), + OVal(OUModule, ONModule, ONModuleWithSuite, OVargsModule), + SourcePosition, + StateC, + StatementI, + Symbol(Symbol) + ) + +import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC) + +import qualified Data.List as DL (intercalate) + +import Data.Maybe (isJust, fromMaybe, mapMaybe, catMaybes) + +import Control.Monad (when) + +import Data.Foldable (for_) + +import Data.Traversable (for) + +import Data.Text.Lazy as DTL (concat, intercalate) + +import Data.Text.Lazy (pack, Text) + +-- | Ensure that argsExpr fits into args. +checkOptions :: Maybe [(Symbol, Bool)] -> [(Maybe Symbol, Expr)] -> Bool -> SourcePosition -> StateC Bool +checkOptions args argsExpr makeWarnings sourcePos = do + let + -- Find what arguments are satisfied by a default value, were given in a named parameter, or were given.. and count them. + valDefaulted ,valNotDefaulted, valNamed, mappedDefaulted, mappedNotDefaulted, notMappedNotDefaultable :: [Symbol] + -- function definition has a default value. + valDefaulted = fmap fst $ filter snd $ fromMaybe [] args + -- function definition has no default value. + valNotDefaulted = fmap fst $ filter (not.snd) $ fromMaybe [] args + -- function call has a named expression bound to this symbol. + valNamed = namedParameters argsExpr + -- function call has a named expression, function definition has an argument with this name, AND there is a default value for this argument. + mappedDefaulted = filter (`elem` valNamed) valDefaulted + -- function call has a named expression, function definition has an argument with this name, AND there is NOT a default value for this argument. + mappedNotDefaulted = filter (`elem` valNamed) valNotDefaulted + -- arguments we need to find a mapping for, from the unnamed expressions. + notMappedNotDefaultable = filter (`notElem` mappedNotDefaulted) valNotDefaulted + -- expressions without a name. + valUnnamed :: [Expr] + valUnnamed = unnamedParameters argsExpr + mapFromUnnamed :: [(Symbol, Expr)] + mapFromUnnamed = zip notMappedNotDefaultable valUnnamed + missingNotDefaultable = filter (`notElem` (mappedDefaulted <> mappedNotDefaulted <> fmap fst mapFromUnnamed)) valNotDefaulted + extraUnnamed = filter (`notElem` (valDefaulted <> valNotDefaulted)) $ namedParameters argsExpr + namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol] + namedParameters = mapMaybe fst + unnamedParameters :: [(Maybe Symbol, Expr)] -> [Expr] + unnamedParameters = mapMaybe ( + \(argName, expr) -> + case argName of + Just _ -> Nothing + Nothing -> Just expr + ) + parameterReport = "Passed " <> + (if null valNamed && null valUnnamed then "no parameters" else "" ) <> + (if not (null valNamed) then show (length valNamed) <> (if length valNamed == 1 then " named parameter" else " named parameters") else "" ) <> + (if not (null valNamed) && not (null valUnnamed) then ", and " else "") <> + (if not (null valUnnamed) then show (length valUnnamed) <> (if length valUnnamed == 1 then " un-named parameter." else " un-named parameters.") else ".") <> + (if not (null missingNotDefaultable) then + (if length missingNotDefaultable == 1 + then " Couldn't match one parameter: " <> showSymbol (last missingNotDefaultable) + else " Couldn't match " <> show (length missingNotDefaultable) <> " parameters: " <> DL.intercalate ", " (showSymbol <$> init missingNotDefaultable) <> " and " <> showSymbol (last missingNotDefaultable) <> "." + ) else "") <> + (if not (null extraUnnamed) + then + (if length extraUnnamed == 1 + then " Had one extra parameter: " <> showSymbol (last extraUnnamed) + else " Had " <> show (length extraUnnamed) <> " extra parameters. They are:" <> DL.intercalate ", " (showSymbol <$> init extraUnnamed) <> " and " <> showSymbol (last extraUnnamed) <> "." + ) + else "") + showSymbol :: Symbol -> String + showSymbol (Symbol sym) = show sym + when (not (null missingNotDefaultable) && makeWarnings) + (errorC sourcePos $ "Insufficient parameters. " <> pack parameterReport) + when (not (null extraUnnamed) && isJust args && makeWarnings) + (errorC sourcePos $ "Too many parameters: " <> pack (show $ length extraUnnamed) <> " extra. " <> pack parameterReport) + pure $ null missingNotDefaultable && null extraUnnamed + +-- | Do not evaluate the suite, if there is one. Throw an error instead. +ensureNoSuite :: SourcePosition -> OVal -> [StatementI] -> StateC [OVal] +ensureNoSuite sourcePos mod suite = do + when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> nameOfModule mod <> " does not accept one. Perhaps a missing semicolon?") + pure [] + +-- | Check the instances, make sure we can only resolve one instance, or throw a warning. +checkInstances :: SourcePosition -> OVal -> [(Maybe Symbol, Expr)] -> [[(Symbol, Bool)]] -> StateC () +checkInstances sourcePos mod argsExpr forms = do + possibleInstances <- selectInstances forms argsExpr sourcePos + when (null possibleInstances) (errorC sourcePos $ "No instance of " <> nameOfModule mod <> " found to match given parameters.\narguments given:\n" <> pack (show argsExpr) <> "\nForms available:" <> pack (show forms) <> "\n") +-- FIXME: make this a warning that can be turned on and off, and is off by default. +{- + when (length possibleInstances > 1) (warnC sourcePos $ "Multiple instances of " <> nameOfModule mod <> " found matching given parameters.\nInstances found:\n" <> (DTL.concat $ showInstance mod <$> possibleInstances) <> "Parameters given: " <> nameOfModule mod <> "(" <> (DTL.intercalate ", " $ showParameter <$> argsExpr) <> ");") + where + showParameter :: (Maybe Symbol, Expr) -> Text + showParameter (Just (Symbol s), v) = s <> "=" <> pack (show v) + showParameter (Nothing, LitE v) = pack (show v) + showParameter (Nothing, v) = pack (show v) + showInstance :: OVal -> [(Symbol, Bool)] -> Text + showInstance myMod args = nameOfModule myMod <> "(" <> (DTL.intercalate "," $ showArg <$> args) <> ");\n" + showArg :: (Symbol, Bool) -> Text + showArg (Symbol argName, optional) = argName <> "=...(" <> (if optional then "optional)" else "required)") +-} + +-- Run a module. +runModule :: SourcePosition -> (Maybe (StateC [OVal]), [String]) -> StateC [OVal] +runModule sourcePos argsMapped = do + for_ (pack <$> snd argsMapped) $ errorC sourcePos + fromMaybe (pure []) (fst argsMapped) + +selectInstances :: [[(Symbol, Bool)]] -> [(Maybe Symbol, Expr)] -> SourcePosition -> StateC [[(Symbol, Bool)]] +selectInstances instances argsExpr sourcePos = do + validInstances <- for instances + ( \args -> do + res <- checkOptions (Just args) argsExpr False sourcePos + pure $ if res then Just args else Nothing + ) + pure $ catMaybes validInstances + +-- Find the name of a module. +nameOfModule :: OVal -> Text +nameOfModule mod = case mod of + (OUModule (Symbol modName) _ _) -> modName + (ONModule (Symbol modName) _ _) -> modName + (ONModuleWithSuite (Symbol modName) _ _) -> modName + (OVargsModule (Symbol modName) _) -> modName + _ -> error "Tried to get the name of a non-module." + diff --git a/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs b/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs index fc3fc644..8177229c 100644 --- a/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs +++ b/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs @@ -7,7 +7,7 @@ module Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI) where -import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left, Right), (>), (.), ($), error, show, pure, (<>), reverse, fst, snd, readFile, filter, length, (&&), (==), (/=), fmap, notElem, elem, not, zip, init, last, null, String, (*>), (<$>), traverse, (<$)) +import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left, Right), (.), ($), show, pure, (<>), reverse, readFile, not, null, (*>), traverse, (<$)) import Graphics.Implicit.ExtOpenScad.Definitions ( SourcePosition, @@ -28,14 +28,13 @@ import Graphics.Implicit.ExtOpenScad.Definitions ( import Graphics.Implicit.ExtOpenScad.Util.OVal (getErrors) import Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, defaultTo, argMap) import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC, warnC, modifyVarLookup, scadOptions, lookupVar, pushVals, getRelPath, withPathShiftedBy, getVals, putVals, addMessage, getVarLookup) -import Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat) +import Graphics.Implicit.ExtOpenScad.Eval.Expr (evalArgs, evalExpr, matchPat) +import Graphics.Implicit.ExtOpenScad.Eval.Module (checkInstances, checkOptions, ensureNoSuite, runModule) import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) -import Data.List (intercalate) - import Data.Map (union, fromList, toList) -import Data.Maybe (isJust, fromMaybe, mapMaybe, catMaybes) +import Data.Maybe (isJust) import Control.Monad (when, unless) @@ -45,7 +44,7 @@ import Data.Foldable (traverse_, for_) import Data.Traversable (for) -import Data.Text.Lazy (unpack, pack, Text) +import Data.Text.Lazy (unpack, pack) import System.Directory (doesFileExist) @@ -177,9 +176,18 @@ runStatementI (StatementI sourcePos (Include name injectVals)) = do runStatementI (StatementI _ DoNothing) = pure () +-- Execute a set of OpenSCAD statements, without returning results. runSuite :: [StatementI] -> StateC () runSuite = traverse_ runStatementI +-- | Evaluate the suite of an OpenSCAD module. +evalSuite :: VarLookup -> SourcePosition -> [StatementI] -> StateC [OVal] +evalSuite varlookup sourcePos suite = do + vals <- runSuiteCapture varlookup suite + when (null vals) (errorC sourcePos "Suite required, but none provided.") + runSuiteCapture varlookup suite + +-- | Execute the suite of an OpenSCAD module. runSuiteCapture :: VarLookup -> [StatementI] -> StateC [OVal] runSuiteCapture varlookup suite = do opts <- ask @@ -191,112 +199,3 @@ runSuiteCapture varlookup suite = do mkSubState s = CompState varlookup [] (sourceDir s) moveMessage (Message mtype mpos text) = addMessage mtype mpos text -selectInstances :: [[(Symbol, Bool)]] -> [(Maybe Symbol, Expr)] -> SourcePosition -> StateC [[(Symbol, Bool)]] -selectInstances instances argsExpr sourcePos = do - validInstances <- for instances - ( \args -> do - res <- checkOptions (Just args) argsExpr False sourcePos - pure $ if res then Just args else Nothing - ) - pure $ catMaybes validInstances - -checkOptions :: Maybe [(Symbol, Bool)] -> [(Maybe Symbol, Expr)] -> Bool -> SourcePosition -> StateC Bool -checkOptions args argsExpr makeWarnings sourcePos = do - let - -- Find what arguments are satisfied by a default value, were given in a named parameter, or were given.. and count them. - valDefaulted ,valNotDefaulted, valNamed, mappedDefaulted, mappedNotDefaulted, notMappedNotDefaultable :: [Symbol] - -- function definition has a default value. - valDefaulted = fmap fst $ filter snd $ fromMaybe [] args - -- function definition has no default value. - valNotDefaulted = fmap fst $ filter (not.snd) $ fromMaybe [] args - -- function call has a named expression bound to this symbol. - valNamed = namedParameters argsExpr - -- function call has a named expression, function definition has an argument with this name, AND there is a default value for this argument. - mappedDefaulted = filter (`elem` valNamed) valDefaulted - -- function call has a named expression, function definition has an argument with this name, AND there is NOT a default value for this argument. - mappedNotDefaulted = filter (`elem` valNamed) valNotDefaulted - -- arguments we need to find a mapping for, from the unnamed expressions. - notMappedNotDefaultable = filter (`notElem` mappedNotDefaulted) valNotDefaulted - -- expressions without a name. - valUnnamed :: [Expr] - valUnnamed = unnamedParameters argsExpr - mapFromUnnamed :: [(Symbol, Expr)] - mapFromUnnamed = zip notMappedNotDefaultable valUnnamed - missingNotDefaultable = filter (`notElem` (mappedDefaulted <> mappedNotDefaulted <> fmap fst mapFromUnnamed)) valNotDefaulted - extraUnnamed = filter (`notElem` (valDefaulted <> valNotDefaulted)) $ namedParameters argsExpr - namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol] - namedParameters = mapMaybe fst - unnamedParameters :: [(Maybe Symbol, Expr)] -> [Expr] - unnamedParameters = mapMaybe ( - \(argName, expr) -> - case argName of - Just _ -> Nothing - Nothing -> Just expr - ) - parameterReport = "Passed " <> - (if null valNamed && null valUnnamed then "no parameters" else "" ) <> - (if not (null valNamed) then show (length valNamed) <> (if length valNamed == 1 then " named parameter" else " named parameters") else "" ) <> - (if not (null valNamed) && not (null valUnnamed) then ", and " else "") <> - (if not (null valUnnamed) then show (length valUnnamed) <> (if length valUnnamed == 1 then " un-named parameter." else " un-named parameters.") else ".") <> - (if not (null missingNotDefaultable) then - (if length missingNotDefaultable == 1 - then " Couldn't match one parameter: " <> showSymbol (last missingNotDefaultable) - else " Couldn't match " <> show (length missingNotDefaultable) <> " parameters: " <> intercalate ", " (showSymbol <$> init missingNotDefaultable) <> " and " <> showSymbol (last missingNotDefaultable) <> "." - ) else "") <> - (if not (null extraUnnamed) - then - (if length extraUnnamed == 1 - then " Had one extra parameter: " <> showSymbol (last extraUnnamed) - else " Had " <> show (length extraUnnamed) <> " extra parameters. They are:" <> intercalate ", " (showSymbol <$> init extraUnnamed) <> " and " <> showSymbol (last extraUnnamed) <> "." - ) - else "") - showSymbol :: Symbol -> String - showSymbol (Symbol sym) = show sym - when (not (null missingNotDefaultable) && makeWarnings) - (errorC sourcePos $ "Insufficient parameters. " <> pack parameterReport) - when (not (null extraUnnamed) && isJust args && makeWarnings) - (errorC sourcePos $ "Too many parameters: " <> pack (show $ length extraUnnamed) <> " extra. " <> pack parameterReport) - pure $ null missingNotDefaultable && null extraUnnamed - --- Evaluate the arguments, turning them from expressions into values. -evalArgs :: [(Maybe Symbol, Expr)] -> SourcePosition -> StateC [(Maybe Symbol, OVal)] -evalArgs args sourcePos = for args $ \(posName, expr) -> do - val <- evalExpr sourcePos expr - pure (posName, val) - --- Do not evaluate the suite. throw an error instead. -ensureNoSuite :: SourcePosition -> OVal -> [StatementI] -> StateC [OVal] -ensureNoSuite sourcePos mod suite = do - when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> nameOfModule mod <> " does not accept one. Perhaps a missing semicolon?") - pure [] - --- | Evaluate the suite. -evalSuite :: VarLookup -> SourcePosition -> [StatementI] -> StateC [OVal] -evalSuite varlookup sourcePos suite = do - vals <- runSuiteCapture varlookup suite - when (null vals) (errorC sourcePos "Suite required, but none provided.") - runSuiteCapture varlookup suite - --- check the instances, make sure we can only resolve one instance. -checkInstances :: SourcePosition -> OVal -> [(Maybe Symbol, Expr)] -> [[(Symbol, Bool)]] -> StateC () -checkInstances sourcePos mod argsExpr forms = do - possibleInstances <- selectInstances forms argsExpr sourcePos - when (null possibleInstances) (do - errorC sourcePos $ "no instance of " <> nameOfModule mod <> " found to match given parameters.\nInstances available:\n" <> pack (show mod) - traverse_ (\a -> checkOptions (Just a) argsExpr True sourcePos) forms) - when (length possibleInstances > 1) (do - errorC sourcePos $ "too many instances of " <> nameOfModule mod <> " have been found that match given parameters." - traverse_ (\a -> checkOptions (Just a) argsExpr True sourcePos) possibleInstances) - --- Find the name of a module. -nameOfModule :: OVal -> Text -nameOfModule mod = case mod of - (ONModule (Symbol modName) _ _) -> modName - (ONModuleWithSuite (Symbol modName) _ _) -> modName - _ -> error "Tried to get the name of a non-module." - --- Run a module. -runModule :: SourcePosition -> (Maybe (StateC [OVal]), [String]) -> StateC [OVal] -runModule sourcePos argsMapped = do - for_ (pack <$> snd argsMapped) $ errorC sourcePos - fromMaybe (pure []) (fst argsMapped) diff --git a/Graphics/Implicit/ExtOpenScad/Util/OVal.hs b/Graphics/Implicit/ExtOpenScad/Util/OVal.hs index 2f42dadb..822b1a48 100644 --- a/Graphics/Implicit/ExtOpenScad/Util/OVal.hs +++ b/Graphics/Implicit/ExtOpenScad/Util/OVal.hs @@ -80,9 +80,24 @@ instance (OTypeMirror a) => OTypeMirror [a] where instance OTypeMirror Text where fromOObj (OString str) = Just str fromOObj _ = Nothing + {-# INLINABLE fromOObj #-} toOObj :: Text -> OVal toOObj = OString +instance OTypeMirror SymbolicObj2 where + fromOObj (OObj2 obj) = Just obj + fromOObj _ = Nothing + {-# INLINABLE fromOObj #-} + toOObj :: SymbolicObj2 -> OVal + toOObj = OObj2 + +instance OTypeMirror SymbolicObj3 where + fromOObj (OObj3 obj) = Just obj + fromOObj _ = Nothing + {-# INLINABLE fromOObj #-} + toOObj :: SymbolicObj3 -> OVal + toOObj = OObj3 + instance (OTypeMirror a) => OTypeMirror (Maybe a) where fromOObj a = Just $ fromOObj a {-# INLINABLE fromOObj #-} diff --git a/implicit.cabal b/implicit.cabal index 3659d8c1..12daa9fd 100644 --- a/implicit.cabal +++ b/implicit.cabal @@ -166,6 +166,7 @@ Library Graphics.Implicit.ExtOpenScad.Parser.Util Graphics.Implicit.ExtOpenScad.Eval.Statement Graphics.Implicit.ExtOpenScad.Eval.Expr + Graphics.Implicit.ExtOpenScad.Eval.Module Graphics.Implicit.ExtOpenScad.Util.OVal Graphics.Implicit.ExtOpenScad.Util.StateC Graphics.Implicit.Export.RayTrace