Skip to content

Commit f141075

Browse files
julialongtinjulialongtin
committed
Allow for evaluation of modules in places where expressions (but not sub-expressions) are allowed.
1 parent 5873333 commit f141075

8 files changed

Lines changed: 268 additions & 127 deletions

File tree

‎CHANGELOG.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
* Added `projection(cut=true)` support [#448](https://github.com/Haskell-Things/ImplicitCAD/pull/448)
55
* Added `polyhedron()` support [#497](https://github.com/Haskell-Things/ImplicitCAD/pull/497)
66
* Added `import()` support [#505](https://github.com/Haskell-Things/ImplicitCAD/pull/505)
7+
* Improved syntax for module calling: now allows module calls in place of expressions []()
78

89
* Haskell interface changes
910
* `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‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
2-
-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
2+
-- Copyright (C) 2016-2026, Julia Longtin (julial@turinglace.com)
33
-- Released under the GNU AGPLV3+, see LICENSE
44

55
-- Allow us to use string literals to represent Text.

‎Graphics/Implicit/ExtOpenScad/Eval/Expr.hs‎

Lines changed: 87 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -5,13 +5,13 @@
55
-- Allow us to use string literals for Text
66
{-# LANGUAGE OverloadedStrings #-}
77

8-
module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, rawRunExpr, matchPat, StateE, ExprState(ExprState), addMessage) where
8+
module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalArgs, evalExpr, rawRunExpr, matchPat, StateE, ExprState(ExprState), addMessage) where
99

10-
import Prelude (String, Maybe(Just, Nothing), Bool (True), ($), elem, pure, zip, (&&), const, (<>), foldr, foldMap, (.), (<$>), traverse)
10+
import Prelude (String, Monoid, Maybe(Just, Nothing), Bool (False, True), ($), elem, mempty, pure, show, zip, (&&), const, (<>), foldr, foldMap, (.), (<$>), traverse)
1111

1212
import Graphics.Implicit.ExtOpenScad.Definitions (
1313
Pattern(Name, ListP, Wild),
14-
OVal(OList, OError, OFunc, OUndefined),
14+
OVal(OList, OError, OFunc, OUndefined, OUModule, ONModule, ONModuleWithSuite, OVargsModule),
1515
Expr(LitE, ListE, LamE, Var, (:$)),
1616
Symbol(Symbol),
1717
VarLookup(VarLookup),
@@ -21,12 +21,16 @@ import Graphics.Implicit.ExtOpenScad.Definitions (
2121
StateC, ImplicitCadM, runImplicitCadM
2222
)
2323

24+
import Graphics.Implicit.ExtOpenScad.Util.ArgParser (argMap)
25+
2426
import Graphics.Implicit.ExtOpenScad.Util.OVal (oTypeStr, getErrors)
2527

26-
import Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup)
28+
import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC, getVarLookup)
2729

2830
import qualified Graphics.Implicit.ExtOpenScad.Util.StateC as GIEUS (addMessage)
2931

32+
import Graphics.Implicit.ExtOpenScad.Eval.Module (checkOptions, runModule)
33+
3034
import Data.Maybe (fromMaybe, isNothing)
3135

3236
import Data.Map (fromList, lookup)
@@ -35,9 +39,9 @@ import Data.Foldable (fold, traverse_)
3539

3640
import Data.Traversable (for)
3741

38-
import Control.Monad (zipWithM)
42+
import Control.Monad (unless, zipWithM)
3943

40-
import Data.Text.Lazy (Text, unpack)
44+
import Data.Text.Lazy (Text, pack, unpack)
4145

4246
import Data.Eq (Eq, (==))
4347
import Text.Show (Show)
@@ -57,8 +61,8 @@ newtype ExprState = ExprState
5761
-- so we can put them into a reader, so they can never
5862
-- accidentally be written to.
5963
data Input = Input
60-
{ varLookup :: VarLookup
61-
, sourcePos :: SourcePosition
64+
{ _varLookup :: VarLookup
65+
, _sourcePos :: SourcePosition
6266
} deriving (Eq, Show)
6367

6468
-- Check Graphics.Implicit.ExtOpenScad.Definitions for an explanation
@@ -96,9 +100,82 @@ patMatch _ _ = Nothing
96100
matchPat :: Pattern -> OVal -> Maybe VarLookup
97101
matchPat pat val = VarLookup . fromList . zip (Symbol <$> patVars pat) <$> patMatch pat val
98102

99-
-- | The entry point from StateC. evaluates an expression, pureing the result, and moving any error messages generated into the calling StateC.
103+
-- | Evaluate the arguments, turning them from expressions into values.
104+
evalArgs :: [(Maybe Symbol, Expr)] -> SourcePosition -> StateC [(Maybe Symbol, OVal)]
105+
evalArgs args sourcePos = for args $ \(posName, expr) -> do
106+
val <- evalExpr sourcePos expr
107+
pure (posName, val)
108+
109+
-- | The entry point from StateC. Evaluates either an expression or an eligible module call.
100110
evalExpr :: SourcePosition -> Expr -> StateC OVal
101-
evalExpr pos expr = do
111+
evalExpr sourcePos expr = case expr of
112+
(maybeMod :$ argExprs) -> do
113+
-- Yes, we're recursing, after dropping argument expressions, for the OVal
114+
rVal <- evalExpr sourcePos maybeMod
115+
if isModule rVal
116+
then do
117+
-- Perform a module call.
118+
res <- runExprModule sourcePos rVal argExprs
119+
pure $ canonicalizeRes $ OList res
120+
else
121+
-- Evaluate expression.
122+
evalExprStateC sourcePos expr
123+
_ -> evalExprStateC sourcePos expr
124+
where
125+
isModule (OUModule _ _ _) = True
126+
isModule (ONModule _ _ _) = True
127+
isModule (ONModuleWithSuite _ _ _) = True
128+
isModule (OVargsModule _ _) = True
129+
isModule _ = False
130+
-- FIXME: We may need a better result cannonicalizer here.
131+
canonicalizeRes (OList [oneItem]) = oneItem
132+
canonicalizeRes other = other
133+
134+
-- | Execute a module call, in place of an expression.
135+
runExprModule :: SourcePosition -> OVal -> [Expr] -> StateC [OVal]
136+
runExprModule sourcePos mod argExprsRaw = do
137+
let
138+
-- Mark all of our arguments as unnamed. There are no named arguments in expressions.
139+
argExprs = (\a -> (Nothing, a)) <$> argExprsRaw
140+
-- Common error messages.
141+
noSuiteError,notModError :: (Monoid a) => StateC a
142+
noSuiteError = do
143+
errorC sourcePos $ "tried to use a " <> oTypeStr mod <> " that uses suites on the right hand side of assignment."
144+
pure mempty
145+
notModError = do
146+
errorC sourcePos $ "tried to run something that is not a module:" <> pack (show mod)
147+
pure mempty
148+
149+
-- Fully evaluate arguments. Since we're in Expr context, we can only handle unnamed arguments.
150+
evaluatedArgs <- evalArgs argExprs sourcePos
151+
152+
-- We can't handle any suites, either.
153+
_ <- case mod of
154+
(OUModule _ _ _) -> pure mempty :: StateC ()
155+
(ONModule _ _ _) -> pure mempty
156+
(ONModuleWithSuite _ _ _) -> noSuiteError
157+
(OVargsModule _ _) -> noSuiteError
158+
_ -> notModError
159+
160+
-- Perform any per-module-type specific housework, and call the module.
161+
case mod of
162+
(OUModule (Symbol name) args implementation) -> do
163+
-- User modules can only have one instance, so we only have to check one set of options here.
164+
optionsMatch <- checkOptions args argExprs True sourcePos
165+
unless optionsMatch (errorC sourcePos $ "Options check failed when executing user-defined module " <> name <> ".")
166+
varLookup <- getVarLookup
167+
-- Run the module.
168+
runModule sourcePos $ argMap evaluatedArgs $ implementation varLookup
169+
(ONModule _ implementation _) -> do
170+
-- Run the module.
171+
runModule sourcePos $ argMap evaluatedArgs $ implementation sourcePos
172+
(ONModuleWithSuite _ _ _) -> noSuiteError
173+
(OVargsModule _ _) -> noSuiteError
174+
_ -> notModError
175+
176+
-- | The inner monadic entry point. Evaluates an expression, pureing the result, and moving any error messages generated into the calling StateC.
177+
evalExprStateC :: SourcePosition -> Expr -> StateC OVal
178+
evalExprStateC pos expr = do
102179
vars <- getVarLookup
103180
let
104181
input = Input vars pos

‎Graphics/Implicit/ExtOpenScad/Eval/Module.hs‎

Lines changed: 148 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,148 @@
1+
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
2+
-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
3+
-- Released under the GNU AGPLV3+, see LICENSE
4+
5+
-- Allow us to use string literals for Text
6+
{-# LANGUAGE OverloadedStrings #-}
7+
8+
-- Utility functions for handling module calling.
9+
module Graphics.Implicit.ExtOpenScad.Eval.Module (
10+
checkInstances,
11+
checkOptions,
12+
ensureNoSuite,
13+
nameOfModule,
14+
runModule,
15+
) where
16+
17+
import Prelude(Maybe(Just, Nothing), Bool(False), (>), (.), ($), elem, error, filter, fmap, fst, init, last, length, not, notElem, null, show, snd, pure, zip, (<>), (&&), (==), (/=), String, (<$>))
18+
19+
import Graphics.Implicit.ExtOpenScad.Definitions (
20+
Expr(LitE),
21+
OVal(OUModule, ONModule, ONModuleWithSuite, OVargsModule),
22+
SourcePosition,
23+
StateC,
24+
StatementI,
25+
Symbol(Symbol)
26+
)
27+
28+
import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC, warnC)
29+
30+
import qualified Data.List as DL (intercalate)
31+
32+
import Data.Maybe (isJust, fromMaybe, mapMaybe, catMaybes)
33+
34+
import Control.Monad (when)
35+
36+
import Data.Foldable (for_)
37+
38+
import Data.Traversable (for)
39+
40+
import Data.Text.Lazy as DTL (concat, intercalate)
41+
42+
import Data.Text.Lazy (pack, Text)
43+
44+
-- | Ensure that argsExpr fits into args.
45+
checkOptions :: Maybe [(Symbol, Bool)] -> [(Maybe Symbol, Expr)] -> Bool -> SourcePosition -> StateC Bool
46+
checkOptions args argsExpr makeWarnings sourcePos = do
47+
let
48+
-- Find what arguments are satisfied by a default value, were given in a named parameter, or were given.. and count them.
49+
valDefaulted ,valNotDefaulted, valNamed, mappedDefaulted, mappedNotDefaulted, notMappedNotDefaultable :: [Symbol]
50+
-- function definition has a default value.
51+
valDefaulted = fmap fst $ filter snd $ fromMaybe [] args
52+
-- function definition has no default value.
53+
valNotDefaulted = fmap fst $ filter (not.snd) $ fromMaybe [] args
54+
-- function call has a named expression bound to this symbol.
55+
valNamed = namedParameters argsExpr
56+
-- function call has a named expression, function definition has an argument with this name, AND there is a default value for this argument.
57+
mappedDefaulted = filter (`elem` valNamed) valDefaulted
58+
-- function call has a named expression, function definition has an argument with this name, AND there is NOT a default value for this argument.
59+
mappedNotDefaulted = filter (`elem` valNamed) valNotDefaulted
60+
-- arguments we need to find a mapping for, from the unnamed expressions.
61+
notMappedNotDefaultable = filter (`notElem` mappedNotDefaulted) valNotDefaulted
62+
-- expressions without a name.
63+
valUnnamed :: [Expr]
64+
valUnnamed = unnamedParameters argsExpr
65+
mapFromUnnamed :: [(Symbol, Expr)]
66+
mapFromUnnamed = zip notMappedNotDefaultable valUnnamed
67+
missingNotDefaultable = filter (`notElem` (mappedDefaulted <> mappedNotDefaulted <> fmap fst mapFromUnnamed)) valNotDefaulted
68+
extraUnnamed = filter (`notElem` (valDefaulted <> valNotDefaulted)) $ namedParameters argsExpr
69+
namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol]
70+
namedParameters = mapMaybe fst
71+
unnamedParameters :: [(Maybe Symbol, Expr)] -> [Expr]
72+
unnamedParameters = mapMaybe (
73+
\(argName, expr) ->
74+
case argName of
75+
Just _ -> Nothing
76+
Nothing -> Just expr
77+
)
78+
parameterReport = "Passed " <>
79+
(if null valNamed && null valUnnamed then "no parameters" else "" ) <>
80+
(if not (null valNamed) then show (length valNamed) <> (if length valNamed == 1 then " named parameter" else " named parameters") else "" ) <>
81+
(if not (null valNamed) && not (null valUnnamed) then ", and " else "") <>
82+
(if not (null valUnnamed) then show (length valUnnamed) <> (if length valUnnamed == 1 then " un-named parameter." else " un-named parameters.") else ".") <>
83+
(if not (null missingNotDefaultable) then
84+
(if length missingNotDefaultable == 1
85+
then " Couldn't match one parameter: " <> showSymbol (last missingNotDefaultable)
86+
else " Couldn't match " <> show (length missingNotDefaultable) <> " parameters: " <> DL.intercalate ", " (showSymbol <$> init missingNotDefaultable) <> " and " <> showSymbol (last missingNotDefaultable) <> "."
87+
) else "") <>
88+
(if not (null extraUnnamed)
89+
then
90+
(if length extraUnnamed == 1
91+
then " Had one extra parameter: " <> showSymbol (last extraUnnamed)
92+
else " Had " <> show (length extraUnnamed) <> " extra parameters. They are:" <> DL.intercalate ", " (showSymbol <$> init extraUnnamed) <> " and " <> showSymbol (last extraUnnamed) <> "."
93+
)
94+
else "")
95+
showSymbol :: Symbol -> String
96+
showSymbol (Symbol sym) = show sym
97+
when (not (null missingNotDefaultable) && makeWarnings)
98+
(errorC sourcePos $ "Insufficient parameters. " <> pack parameterReport)
99+
when (not (null extraUnnamed) && isJust args && makeWarnings)
100+
(errorC sourcePos $ "Too many parameters: " <> pack (show $ length extraUnnamed) <> " extra. " <> pack parameterReport)
101+
pure $ null missingNotDefaultable && null extraUnnamed
102+
103+
-- | Do not evaluate the suite, if there is one. Throw an error instead.
104+
ensureNoSuite :: SourcePosition -> OVal -> [StatementI] -> StateC [OVal]
105+
ensureNoSuite sourcePos mod suite = do
106+
when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> nameOfModule mod <> " does not accept one. Perhaps a missing semicolon?")
107+
pure []
108+
109+
-- | Check the instances, make sure we can only resolve one instance, or throw a warning.
110+
checkInstances :: SourcePosition -> OVal -> [(Maybe Symbol, Expr)] -> [[(Symbol, Bool)]] -> StateC ()
111+
checkInstances sourcePos mod argsExpr forms = do
112+
possibleInstances <- selectInstances forms argsExpr sourcePos
113+
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")
114+
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) <> ");")
115+
where
116+
showParameter :: (Maybe Symbol, Expr) -> Text
117+
showParameter (Just (Symbol s), v) = s <> "=" <> pack (show v)
118+
showParameter (Nothing, LitE v) = pack (show v)
119+
showParameter (Nothing, v) = pack (show v)
120+
showInstance :: OVal -> [(Symbol, Bool)] -> Text
121+
showInstance myMod args = nameOfModule myMod <> "(" <> (DTL.intercalate "," $ showArg <$> args) <> ");\n"
122+
showArg :: (Symbol, Bool) -> Text
123+
showArg (Symbol argName, optional) = argName <> "=...(" <> (if optional then "optional)" else "required)")
124+
125+
-- Run a module.
126+
runModule :: SourcePosition -> (Maybe (StateC [OVal]), [String]) -> StateC [OVal]
127+
runModule sourcePos argsMapped = do
128+
for_ (pack <$> snd argsMapped) $ errorC sourcePos
129+
fromMaybe (pure []) (fst argsMapped)
130+
131+
selectInstances :: [[(Symbol, Bool)]] -> [(Maybe Symbol, Expr)] -> SourcePosition -> StateC [[(Symbol, Bool)]]
132+
selectInstances instances argsExpr sourcePos = do
133+
validInstances <- for instances
134+
( \args -> do
135+
res <- checkOptions (Just args) argsExpr False sourcePos
136+
pure $ if res then Just args else Nothing
137+
)
138+
pure $ catMaybes validInstances
139+
140+
-- Find the name of a module.
141+
nameOfModule :: OVal -> Text
142+
nameOfModule mod = case mod of
143+
(OUModule (Symbol modName) _ _) -> modName
144+
(ONModule (Symbol modName) _ _) -> modName
145+
(ONModuleWithSuite (Symbol modName) _ _) -> modName
146+
(OVargsModule (Symbol modName) _) -> modName
147+
_ -> error "Tried to get the name of a non-module."
148+

0 commit comments

Comments
 (0)