implicit-0.3.0.0: Graphics/Implicit/ExtOpenScad/Eval/Statement.hs
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE
-- allow us to specify what package to import what module from.
-- We don't actually care, but when we compile our haskell examples, we do.
{-# LANGUAGE PackageImports #-}
module Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI) where
import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left, Right), (.), ($), show, pure, (<>), reverse, fst, snd, readFile, filter, length, (&&), (==), (/=), fmap, notElem, elem, not, zip, init, last, null, String, (*>), (<$>), traverse, (<$))
import Graphics.Implicit.ExtOpenScad.Definitions (
Statement(Include, (:=), If, NewModule, ModuleCall, DoNothing),
Pattern(Name),
Expr(LitE),
OVal(OBool, OUModule, ONModule, OVargsModule),
VarLookup(VarLookup),
StatementI(StatementI),
Symbol(Symbol),
Message(Message),
ScadOpts(importsAllowed),
StateC,
CompState(CompState, messages, sourceDir, scadOpts),
varUnion
)
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.Parser.Statement (parseProgram)
import Data.List (intercalate)
import Data.Map (union, fromList, toList)
import Data.Maybe (isJust, fromMaybe, mapMaybe, catMaybes)
import Control.Monad (when, unless, (>>=))
import "monads-tf" Control.Monad.State (gets, liftIO, runStateT)
import Data.Foldable (traverse_, for_)
import Data.Traversable (for)
import System.FilePath (takeDirectory)
-- Run statements out of the OpenScad file.
runStatementI :: StatementI -> StateC ()
-- | Interpret variable assignment
runStatementI (StatementI sourcePos (pat := expr)) = do
val <- evalExpr sourcePos expr
let posMatch = matchPat pat val
case (getErrors val, posMatch) of
(Just err, _ ) -> errorC sourcePos err
(_, Just (VarLookup match)) ->
for_ (toList match) $ \(Symbol varName, _) -> do
maybeVar <- lookupVar (Symbol varName)
when (isJust maybeVar)
(warnC sourcePos $ "redefining already defined object: " <> show varName)
modifyVarLookup $ varUnion (VarLookup match)
(_, Nothing ) -> errorC sourcePos "pattern match failed in assignment"
-- | Interpret an if conditional statement.
runStatementI (StatementI sourcePos (If expr a b)) = do
val <- evalExpr sourcePos expr
case (getErrors val, val) of
(Just err, _ ) -> errorC sourcePos ("In conditional expression of if statement: " <> err)
(_, OBool True ) -> runSuite a
(_, OBool False) -> runSuite b
_ -> pure ()
-- | Interpret a module declaration.
runStatementI (StatementI sourcePos (NewModule name argTemplate suite)) = do
argTemplate' <- for argTemplate $ \(argName, defexpr) -> do
defval <- traverse (evalExpr sourcePos) defexpr
pure (argName, defval)
argNames <- for argTemplate $ \(argName, defexpr) -> do
defval <- traverse (evalExpr sourcePos) defexpr
let
hasDefault = isJust defval
pure (argName, hasDefault)
(VarLookup varlookup) <- getVarLookup
-- FIXME: \_? really?
runStatementI . StatementI sourcePos $ (Name name :=) $ LitE $ OUModule name (Just argNames) $ \_ -> do
newNameVals <- for argTemplate' $ \(argName, maybeDef) -> do
val <- case maybeDef of
Just def -> argument argName `defaultTo` def
Nothing -> argument argName
pure (argName, val)
let
varlookup' = union (fromList newNameVals) varlookup
pure $ runSuiteCapture (VarLookup varlookup') suite
-- | Interpret a call to a module.
runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) = do
maybeMod <- lookupVar (Symbol name)
varlookup <- getVarLookup
newVals <- case maybeMod of
Just (OUModule _ args mod') -> do
optionsMatch <- checkOptions args True
unless optionsMatch (errorC sourcePos $ "Options check failed when executing user-defined module " <> name <> ".")
evaluatedArgs <- evalArgs argsExpr
-- Evaluate the suite.
suiteResults <- runSuiteCapture varlookup suite
when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> name <> " does not accept one. Perhaps a missing semicolon?")
-- Run the module.
let
argsMapped = argMap evaluatedArgs $ mod' suiteResults
for_ (snd argsMapped) $ errorC sourcePos
fromMaybe (pure []) (fst argsMapped)
Just (ONModule _ implementation forms) -> do
possibleInstances <- selectInstances forms
let
suiteInfo = case possibleInstances of
[(_, suiteInfoFound)] -> suiteInfoFound
[] -> Nothing
((_, suiteInfoFound):_) -> suiteInfoFound
when (null possibleInstances) (do
errorC sourcePos $ "no instance of " <> name <> " found to match given parameters.\nInstances available:\n" <> show (ONModule (Symbol name) implementation forms)
traverse_ (`checkOptions` True) $ fmap (Just . fst) forms
)
-- Ignore this for now, because all instances we define have the same suite requirements.
{-
when (length possibleInstances > 1) (do
errorC sourcePos $ "too many instances of " <> name <> " have been found that match given parameters."
traverse_ (`checkOptions` True) $ fmap (Just . fst) possibleInstances)
-}
-- Evaluate all of the arguments.
evaluatedArgs <- evalArgs argsExpr
-- Evaluate the suite.
vals <- runSuiteCapture varlookup suite
suiteResults <- case suiteInfo of
Just True -> do
when (null vals) (errorC sourcePos "Suite required, but none provided.")
pure vals
Just False -> pure vals
_ -> do
when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> name <> " does not accept one. Perhaps a missing semicolon?")
pure []
-- Run the module.
let
argsMapped = argMap evaluatedArgs $ implementation sourcePos suiteResults
for_ (snd argsMapped) $ errorC sourcePos
fromMaybe (pure []) (fst argsMapped)
Just (OVargsModule modname mod') -> do
-- Evaluate all of the arguments.
evaluatedArgs <- evalArgs argsExpr
-- Run the module, which evaluates it's own suite.
_ <- mod' modname sourcePos evaluatedArgs suite runSuite -- no values are pureed
pure []
Just foo -> do
case getErrors foo of
Just err -> errorC sourcePos err
Nothing -> errorC sourcePos $ "Object " <> name <> " is not a module!"
pure []
_ -> do
errorC sourcePos $ "Module " <> name <> " not in scope."
pure []
pushVals newVals
where
selectInstances :: [([(Symbol, Bool)], Maybe Bool)] -> StateC [([(Symbol, Bool)], Maybe Bool)]
selectInstances instances = do
validInstances <- for instances
( \(args, suiteInfo) -> do
res <- checkOptions (Just args) False
pure $ if res then Just (args, suiteInfo) else Nothing
)
pure $ catMaybes validInstances
checkOptions :: Maybe [(Symbol, Bool)] -> Bool -> StateC Bool
checkOptions args makeWarnings = 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
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 (makeWarnings)
(errorC sourcePos $ foldMap show argsExpr)
when (makeWarnings)
(errorC sourcePos $ "valNamed: " <> show (length valNamed))
when (makeWarnings)
(errorC sourcePos $ "mappedDefaulted: " <> show (length mappedDefaulted))
when (makeWarnings)
(errorC sourcePos $ "mappedNotDefaulted: " <> show (length mappedNotDefaulted))
when (makeWarnings)
(errorC sourcePos $ "notMappedNotDefaultable: " <> show (length notMappedNotDefaultable))
when (makeWarnings)
(errorC sourcePos $ "mapFromUnnamed: " <> show (length mapFromUnnamed))
when (makeWarnings)
(errorC sourcePos $ "missingNotDefaultable: " <> show (length missingNotDefaultable))
-}
when (not (null missingNotDefaultable) && makeWarnings)
(errorC sourcePos $ "Insufficient parameters. " <> parameterReport)
when (not (null extraUnnamed) && isJust args && makeWarnings)
(errorC sourcePos $ "Too many parameters: " <> show (length extraUnnamed) <> " extra. " <> parameterReport)
pure $ null missingNotDefaultable && null extraUnnamed
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
)
evalArgs :: [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]
evalArgs args = for args $ \(posName, expr) -> do
val <- evalExpr sourcePos expr
pure (posName, val)
-- | Interpret an include or use statement.
runStatementI (StatementI sourcePos (Include name injectVals)) = do
opts <- scadOptions
if importsAllowed opts
then do
name' <- getRelPath name
content <- liftIO $ readFile name'
case parseProgram name' content of
Left e -> errorC sourcePos $ "Error parsing " <> name <> ":" <> show e
Right sts -> withPathShiftedBy (takeDirectory name) $ do
vals <- getVals
putVals []
runSuite sts
if injectVals
then do
vals' <- getVals
putVals $ vals' <> vals
else putVals vals
else warnC sourcePos $ "Not importing " <> name <> ": File import disabled."
runStatementI (StatementI _ DoNothing) = pure ()
runSuite :: [StatementI] -> StateC ()
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)
where
mkSubState s = CompState varlookup [] (sourceDir s) [] (scadOpts s)
moveMessage (Message mtype mpos text) = addMessage mtype mpos text