Skip to content

Commit ac1d05c

Browse files
julialongtinjulialongtin
committed
add missing file.
1 parent 5873333 commit ac1d05c

1 file changed

Lines changed: 150 additions & 0 deletions

File tree

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

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

0 commit comments

Comments
 (0)