Allow for evaluation of modules in places where expressions (but not …

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)

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.

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

Graphics/Implicit/ExtOpenScad/Eval/Module.hs

@@ -0,0 +1,150 @@
+-- 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 (
+                                                  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."
+