{- ORMOLU_DISABLE -}
-- 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 use string literals for Text
{-# LANGUAGE OverloadedStrings #-}

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, sourceDir),
                                                  varUnion, runImplicitCadM
                                                 )

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 Control.Monad.State (gets, liftIO)

import Data.Foldable (traverse_, for_)

import Data.Traversable (for)

import Data.Text.Lazy (unpack, pack)

import System.Directory (doesFileExist)

import System.FilePath (takeDirectory)
import Control.Monad.Reader.Class (MonadReader(ask))

-- | Run statements out of the OpenScad file.
runStatementI :: StatementI -> StateC ()
runStatementI :: StatementI -> StateC ()
runStatementI (StatementI SourcePosition
sourcePos (Pattern
pat := Expr
expr)) = do
    -- Interpret variable assignment
    OVal
val <- SourcePosition -> Expr -> StateC OVal
evalExpr SourcePosition
sourcePos Expr
expr
    let posMatch :: Maybe VarLookup
posMatch = Pattern -> OVal -> Maybe VarLookup
matchPat Pattern
pat OVal
val
    case (OVal -> Maybe Text
getErrors OVal
val, Maybe VarLookup
posMatch) of
        (Just Text
err,  Maybe VarLookup
_ ) -> SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos Text
err
        (Maybe Text
_, Just (VarLookup Map Symbol OVal
match)) ->
          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
toList Map Symbol OVal
match) forall a b. (a -> b) -> a -> b
$ \(Symbol Text
varName, OVal
_) -> do
            Maybe OVal
maybeVar <- Symbol -> StateC (Maybe OVal)
lookupVar (Text -> Symbol
Symbol Text
varName)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe OVal
maybeVar)
              (SourcePosition -> Text -> StateC ()
warnC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"redefining already defined object: " forall a. Semigroup a => a -> a -> a
<> Text
varName)
            (VarLookup -> VarLookup) -> StateC ()
modifyVarLookup forall a b. (a -> b) -> a -> b
$ VarLookup -> VarLookup -> VarLookup
varUnion (Map Symbol OVal -> VarLookup
VarLookup Map Symbol OVal
match)
        (Maybe Text
_,   Maybe VarLookup
Nothing ) -> SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos Text
"pattern match failed in assignment"

runStatementI (StatementI SourcePosition
sourcePos (If Expr
expr [StatementI]
a [StatementI]
b)) = do
    -- Interpret an if conditional statement.
    OVal
val <- SourcePosition -> Expr -> StateC OVal
evalExpr SourcePosition
sourcePos Expr
expr
    case (OVal -> Maybe Text
getErrors OVal
val, OVal
val) of
        (Just Text
err,  OVal
_  )  -> SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos (Text
"In conditional expression of if statement: " forall a. Semigroup a => a -> a -> a
<> Text
err)
        (Maybe Text
_, OBool Bool
True )  -> [StatementI] -> StateC ()
runSuite [StatementI]
a
        (Maybe Text
_, OBool Bool
False)  -> [StatementI] -> StateC ()
runSuite [StatementI]
b
        (Maybe Text, OVal)
_                 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runStatementI (StatementI SourcePosition
sourcePos (NewModule Symbol
name [(Symbol, Maybe Expr)]
argTemplate [StatementI]
suite)) = do
    -- Interpret a module declaration.
    [(Symbol, Maybe OVal)]
argTemplate' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Symbol, Maybe Expr)]
argTemplate forall a b. (a -> b) -> a -> b
$ \(Symbol
argName, Maybe Expr
defexpr) -> do
        Maybe OVal
defval <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourcePosition -> Expr -> StateC OVal
evalExpr SourcePosition
sourcePos) Maybe Expr
defexpr
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbol
argName, Maybe OVal
defval)
    [(Symbol, Bool)]
argNames <-  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Symbol, Maybe Expr)]
argTemplate forall a b. (a -> b) -> a -> b
$ \(Symbol
argName, Maybe Expr
defexpr) -> do
      Maybe OVal
defval <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourcePosition -> Expr -> StateC OVal
evalExpr SourcePosition
sourcePos) Maybe Expr
defexpr
      let
        hasDefault :: Bool
hasDefault = forall a. Maybe a -> Bool
isJust Maybe OVal
defval
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbol
argName, Bool
hasDefault)
    StatementI -> StateC ()
runStatementI forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePosition -> Statement StatementI -> StatementI
StatementI SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ (Symbol -> Pattern
Name Symbol
name forall st. Pattern -> Expr -> Statement st
:=) forall a b. (a -> b) -> a -> b
$ OVal -> Expr
LitE forall a b. (a -> b) -> a -> b
$ Symbol
-> Maybe [(Symbol, Bool)]
-> (VarLookup -> ArgParser (StateC [OVal]))
-> OVal
OUModule Symbol
name (forall a. a -> Maybe a
Just [(Symbol, Bool)]
argNames) forall a b. (a -> b) -> a -> b
$ \(VarLookup Map Symbol OVal
varlookup) -> do
        [(Symbol, OVal)]
newNameVals <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Symbol, Maybe OVal)]
argTemplate' forall a b. (a -> b) -> a -> b
$ \(Symbol
argName, Maybe OVal
maybeDef) -> do
            OVal
val <- case Maybe OVal
maybeDef of
                Just OVal
def -> forall desiredType.
OTypeMirror desiredType =>
Symbol -> ArgParser desiredType
argument Symbol
argName forall a. OTypeMirror a => ArgParser a -> a -> ArgParser a
`defaultTo` OVal
def
                Maybe OVal
Nothing  -> forall desiredType.
OTypeMirror desiredType =>
Symbol -> ArgParser desiredType
argument Symbol
argName
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbol
argName, OVal
val)
        let
            varlookup' :: Map Symbol OVal
varlookup' = forall k a. Ord k => Map k a -> Map k a -> Map k a
union (forall k a. Ord k => [(k, a)] -> Map k a
fromList [(Symbol, OVal)]
newNameVals) Map Symbol OVal
varlookup
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ VarLookup -> [StatementI] -> StateC [OVal]
runSuiteCapture (Map Symbol OVal -> VarLookup
VarLookup Map Symbol OVal
varlookup') [StatementI]
suite

runStatementI (StatementI SourcePosition
sourcePos (ModuleCall (Symbol Text
name) [(Maybe Symbol, Expr)]
argsExpr [StatementI]
suite)) = do
        -- Interpret a call to a module.
        Maybe OVal
maybeMod <- Symbol -> StateC (Maybe OVal)
lookupVar (Text -> Symbol
Symbol Text
name)
        VarLookup
varlookup <- StateC VarLookup
getVarLookup
        [OVal]
newVals  <- case Maybe OVal
maybeMod of
            Just (OUModule Symbol
_ Maybe [(Symbol, Bool)]
args VarLookup -> ArgParser (StateC [OVal])
mod') -> do
              Bool
optionsMatch <- Maybe [(Symbol, Bool)] -> Bool -> StateC Bool
checkOptions Maybe [(Symbol, Bool)]
args Bool
True
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
optionsMatch (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Options check failed when executing user-defined module " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
".")
              [(Maybe Symbol, OVal)]
evaluatedArgs <- [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]
evalArgs [(Maybe Symbol, Expr)]
argsExpr
              VarLookup
varLookup <- StateC VarLookup
getVarLookup
              -- Evaluate the suite.
              --suiteResults <- runSuiteCapture varlookup suite
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([StatementI]
suite forall a. Eq a => a -> a -> Bool
/= []) (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Suite provided, but module " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" does not accept one. Perhaps a missing semicolon?")
              -- Run the module.
              let
                argsMapped :: (Maybe (StateC [OVal]), [String])
argsMapped = forall a.
[(Maybe Symbol, OVal)] -> ArgParser a -> (Maybe a, [String])
argMap [(Maybe Symbol, OVal)]
evaluatedArgs forall a b. (a -> b) -> a -> b
$ VarLookup -> ArgParser (StateC [OVal])
mod' VarLookup
varLookup
              forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> b
snd (Maybe (StateC [OVal]), [String])
argsMapped) forall a b. (a -> b) -> a -> b
$ SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos
              forall a. a -> Maybe a -> a
fromMaybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (forall a b. (a, b) -> a
fst (Maybe (StateC [OVal]), [String])
argsMapped)
            Just (ONModule Symbol
_ SourcePosition -> [OVal] -> ArgParser (StateC [OVal])
implementation [([(Symbol, Bool)], Maybe Bool)]
forms) -> do
              [([(Symbol, Bool)], Maybe Bool)]
possibleInstances <- [([(Symbol, Bool)], Maybe Bool)]
-> StateC [([(Symbol, Bool)], Maybe Bool)]
selectInstances [([(Symbol, Bool)], Maybe Bool)]
forms
              let
                suiteInfo :: Maybe Bool
suiteInfo = case [([(Symbol, Bool)], Maybe Bool)]
possibleInstances of
                  [([(Symbol, Bool)]
_, Maybe Bool
suiteInfoFound)]   -> Maybe Bool
suiteInfoFound
                  []                      -> forall a. Maybe a
Nothing
                  (([(Symbol, Bool)]
_, Maybe Bool
suiteInfoFound):[([(Symbol, Bool)], Maybe Bool)]
_) -> Maybe Bool
suiteInfoFound
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([(Symbol, Bool)], Maybe Bool)]
possibleInstances) (do
                                                SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"no instance of " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" found to match given parameters.\nInstances available:\n" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show (Symbol
-> (SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))
-> [([(Symbol, Bool)], Maybe Bool)]
-> OVal
ONModule (Text -> Symbol
Symbol Text
name) SourcePosition -> [OVal] -> ArgParser (StateC [OVal])
implementation [([(Symbol, Bool)], Maybe Bool)]
forms))
                                                forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Maybe [(Symbol, Bool)] -> Bool -> StateC Bool
`checkOptions` Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([(Symbol, Bool)], Maybe Bool)]
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.
              [(Maybe Symbol, OVal)]
evaluatedArgs <- [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]
evalArgs [(Maybe Symbol, Expr)]
argsExpr
              -- Evaluate the suite.
              [OVal]
vals <- VarLookup -> [StatementI] -> StateC [OVal]
runSuiteCapture VarLookup
varlookup [StatementI]
suite
              [OVal]
suiteResults <- case Maybe Bool
suiteInfo of
                              Just Bool
True -> do
                                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OVal]
vals) (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos Text
"Suite required, but none provided.")
                                forall (f :: * -> *) a. Applicative f => a -> f a
pure [OVal]
vals
                              Just Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [OVal]
vals
                              Maybe Bool
_ -> do
                                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([StatementI]
suite forall a. Eq a => a -> a -> Bool
/= []) (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Suite provided, but module " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" does not accept one. Perhaps a missing semicolon?")
                                forall (f :: * -> *) a. Applicative f => a -> f a
pure []
              -- Run the module.
              let
                argsMapped :: (Maybe (StateC [OVal]), [String])
argsMapped = forall a.
[(Maybe Symbol, OVal)] -> ArgParser a -> (Maybe a, [String])
argMap [(Maybe Symbol, OVal)]
evaluatedArgs forall a b. (a -> b) -> a -> b
$ SourcePosition -> [OVal] -> ArgParser (StateC [OVal])
implementation SourcePosition
sourcePos [OVal]
suiteResults
              forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> b
snd (Maybe (StateC [OVal]), [String])
argsMapped) forall a b. (a -> b) -> a -> b
$ SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos
              forall a. a -> Maybe a -> a
fromMaybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (forall a b. (a, b) -> a
fst (Maybe (StateC [OVal]), [String])
argsMapped)
            Just (OVargsModule Symbol
modname Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
mod') -> do
              -- Evaluate all of the arguments.
              [(Maybe Symbol, OVal)]
evaluatedArgs <- [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]
evalArgs [(Maybe Symbol, Expr)]
argsExpr
              -- Run the module, which evaluates it's own suite.
              ()
_ <- Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
mod' Symbol
modname SourcePosition
sourcePos [(Maybe Symbol, OVal)]
evaluatedArgs [StatementI]
suite [StatementI] -> StateC ()
runSuite -- no values are pureed
              forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            Just OVal
foo -> do
                    case OVal -> Maybe Text
getErrors OVal
foo of
                        Just Text
err -> SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos Text
err
                        Maybe Text
Nothing  -> SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Object " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" is not a module!"
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            Maybe OVal
_ -> do
                SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" not in scope."
                forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        [OVal] -> StateC ()
pushVals [OVal]
newVals
          where
            selectInstances :: [([(Symbol, Bool)], Maybe Bool)] -> StateC [([(Symbol, Bool)], Maybe Bool)]
            selectInstances :: [([(Symbol, Bool)], Maybe Bool)]
-> StateC [([(Symbol, Bool)], Maybe Bool)]
selectInstances [([(Symbol, Bool)], Maybe Bool)]
instances = do
              [Maybe ([(Symbol, Bool)], Maybe Bool)]
validInstances <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [([(Symbol, Bool)], Maybe Bool)]
instances
                    ( \([(Symbol, Bool)]
args, Maybe Bool
suiteInfo) -> do
                        Bool
res <- Maybe [(Symbol, Bool)] -> Bool -> StateC Bool
checkOptions (forall a. a -> Maybe a
Just [(Symbol, Bool)]
args) Bool
False
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
res then forall a. a -> Maybe a
Just ([(Symbol, Bool)]
args, Maybe Bool
suiteInfo) else forall a. Maybe a
Nothing
                    )
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe ([(Symbol, Bool)], Maybe Bool)]
validInstances
            checkOptions :: Maybe [(Symbol, Bool)] -> Bool -> StateC Bool
            checkOptions :: Maybe [(Symbol, Bool)] -> Bool -> StateC Bool
checkOptions Maybe [(Symbol, Bool)]
args Bool
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 :: [Symbol]
valDefaulted  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] Maybe [(Symbol, Bool)]
args
                -- function definition has no default value.
                valNotDefaulted :: [Symbol]
valNotDefaulted = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] Maybe [(Symbol, Bool)]
args
                -- function call has a named expression bound to this symbol.
                valNamed :: [Symbol]
valNamed = [(Maybe Symbol, Expr)] -> [Symbol]
namedParameters [(Maybe Symbol, Expr)]
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 :: [Symbol]
mappedDefaulted = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Symbol]
valNamed) [Symbol]
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 :: [Symbol]
mappedNotDefaulted = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Symbol]
valNamed) [Symbol]
valNotDefaulted
                -- arguments we need to find a mapping for, from the unnamed expressions.
                notMappedNotDefaultable :: [Symbol]
notMappedNotDefaultable = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Symbol]
mappedNotDefaulted) [Symbol]
valNotDefaulted
                -- expressions without a name.
                valUnnamed :: [Expr]
                valUnnamed :: [Expr]
valUnnamed = [(Maybe Symbol, Expr)] -> [Expr]
unnamedParameters [(Maybe Symbol, Expr)]
argsExpr
                mapFromUnnamed :: [(Symbol, Expr)]
                mapFromUnnamed :: [(Symbol, Expr)]
mapFromUnnamed = forall a b. [a] -> [b] -> [(a, b)]
zip [Symbol]
notMappedNotDefaultable [Expr]
valUnnamed
                missingNotDefaultable :: [Symbol]
missingNotDefaultable = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Symbol]
mappedDefaulted forall a. Semigroup a => a -> a -> a
<> [Symbol]
mappedNotDefaulted forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(Symbol, Expr)]
mapFromUnnamed)) [Symbol]
valNotDefaulted
                extraUnnamed :: [Symbol]
extraUnnamed = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Symbol]
valDefaulted forall a. Semigroup a => a -> a -> a
<> [Symbol]
valNotDefaulted)) forall a b. (a -> b) -> a -> b
$ [(Maybe Symbol, Expr)] -> [Symbol]
namedParameters [(Maybe Symbol, Expr)]
argsExpr
                parameterReport :: String
parameterReport =  String
"Passed " forall a. Semigroup a => a -> a -> a
<>
                  (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
valNamed Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
valUnnamed then String
"no parameters" else String
"" ) forall a. Semigroup a => a -> a -> a
<>
                  (if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
valNamed) then forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
valNamed) forall a. Semigroup a => a -> a -> a
<> (if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
valNamed forall a. Eq a => a -> a -> Bool
== Int
1 then String
" named parameter" else String
" named parameters") else String
"" ) forall a. Semigroup a => a -> a -> a
<>
                  (if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
valNamed) Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
valUnnamed) then String
", and " else String
"") forall a. Semigroup a => a -> a -> a
<>
                  (if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
valUnnamed) then forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
valUnnamed) forall a. Semigroup a => a -> a -> a
<> (if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
valUnnamed forall a. Eq a => a -> a -> Bool
== Int
1 then String
" un-named parameter." else String
" un-named parameters.") else String
".") forall a. Semigroup a => a -> a -> a
<>
                  (if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
missingNotDefaultable) then
                      (if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
missingNotDefaultable forall a. Eq a => a -> a -> Bool
== Int
1
                       then String
" Couldn't match one parameter: " forall a. Semigroup a => a -> a -> a
<> Symbol -> String
showSymbol (forall a. [a] -> a
last [Symbol]
missingNotDefaultable)
                       else String
" Couldn't match " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
missingNotDefaultable) forall a. Semigroup a => a -> a -> a
<> String
" parameters: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Symbol -> String
showSymbol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
init [Symbol]
missingNotDefaultable) forall a. Semigroup a => a -> a -> a
<> String
" and " forall a. Semigroup a => a -> a -> a
<> Symbol -> String
showSymbol (forall a. [a] -> a
last [Symbol]
missingNotDefaultable) forall a. Semigroup a => a -> a -> a
<> String
"."
                      ) else String
"") forall a. Semigroup a => a -> a -> a
<>
                  (if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
extraUnnamed) then
                      (if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
extraUnnamed forall a. Eq a => a -> a -> Bool
== Int
1
                       then String
" Had one extra parameter: " forall a. Semigroup a => a -> a -> a
<> Symbol -> String
showSymbol (forall a. [a] -> a
last [Symbol]
extraUnnamed)
                       else String
" Had " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
extraUnnamed) forall a. Semigroup a => a -> a -> a
<> String
" extra parameters. They are:" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Symbol -> String
showSymbol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
init [Symbol]
extraUnnamed) forall a. Semigroup a => a -> a -> a
<> String
" and " forall a. Semigroup a => a -> a -> a
<> Symbol -> String
showSymbol (forall a. [a] -> a
last [Symbol]
extraUnnamed) forall a. Semigroup a => a -> a -> a
<> String
"."
                      ) else String
"")
                showSymbol :: Symbol -> String
                showSymbol :: Symbol -> String
showSymbol (Symbol Text
sym) = forall a. Show a => a -> String
show Text
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))
                 -}
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
missingNotDefaultable) Bool -> Bool -> Bool
&& Bool
makeWarnings)
                (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Insufficient parameters. " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
parameterReport)
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
extraUnnamed) Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe [(Symbol, Bool)]
args Bool -> Bool -> Bool
&& Bool
makeWarnings)
                (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Too many parameters: " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
extraUnnamed) forall a. Semigroup a => a -> a -> a
<> Text
" extra. " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
parameterReport)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
missingNotDefaultable Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
extraUnnamed
            namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol]
            namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol]
namedParameters = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> a
fst
            unnamedParameters :: [(Maybe Symbol, Expr)] -> [Expr]
            unnamedParameters :: [(Maybe Symbol, Expr)] -> [Expr]
unnamedParameters = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (
              \(Maybe Symbol
argName, Expr
expr) ->
                case Maybe Symbol
argName of
                  Just Symbol
_  -> forall a. Maybe a
Nothing
                  Maybe Symbol
Nothing -> forall a. a -> Maybe a
Just Expr
expr
              )
            evalArgs :: [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]
            evalArgs :: [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]
evalArgs [(Maybe Symbol, Expr)]
args = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Maybe Symbol, Expr)]
args forall a b. (a -> b) -> a -> b
$ \(Maybe Symbol
posName, Expr
expr) -> do
              OVal
val <- SourcePosition -> Expr -> StateC OVal
evalExpr SourcePosition
sourcePos Expr
expr
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Symbol
posName, OVal
val)

runStatementI (StatementI SourcePosition
sourcePos (Include Text
name Bool
injectVals)) = do
    -- Interpret an include or use statement.
    ScadOpts
opts <- StateC ScadOpts
scadOptions
    if ScadOpts -> Bool
importsAllowed ScadOpts
opts
      then do
      String
name' <- String -> StateC String
getRelPath (Text -> String
unpack Text
name)
      Bool
hasFile <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
name'
      if Bool -> Bool
not Bool
hasFile
        then SourcePosition -> Text -> StateC ()
warnC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Not importing " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
": File not found."
        else do
          String
content <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
name'
          case String -> String -> Either ParseError [StatementI]
parseProgram String
name' String
content of
            Left ParseError
e -> SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Error parsing " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show ParseError
e)
            Right [StatementI]
sts -> forall a. String -> StateC a -> StateC a
withPathShiftedBy (String -> String
takeDirectory forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
name) forall a b. (a -> b) -> a -> b
$ do
                [OVal]
vals <- StateC [OVal]
getVals
                [OVal] -> StateC ()
putVals []
                [StatementI] -> StateC ()
runSuite [StatementI]
sts
                if Bool
injectVals
                  then do
                    [OVal]
vals' <- StateC [OVal]
getVals
                    [OVal] -> StateC ()
putVals forall a b. (a -> b) -> a -> b
$ [OVal]
vals' forall a. Semigroup a => a -> a -> a
<> [OVal]
vals
                  else [OVal] -> StateC ()
putVals [OVal]
vals
      else SourcePosition -> Text -> StateC ()
warnC SourcePosition
sourcePos forall a b. (a -> b) -> a -> b
$ Text
"Not importing " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
": File import disabled."

runStatementI (StatementI SourcePosition
_ Statement StatementI
DoNothing) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runSuite :: [StatementI] -> StateC ()
runSuite :: [StatementI] -> StateC ()
runSuite = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ StatementI -> StateC ()
runStatementI

runSuiteCapture :: VarLookup -> [StatementI] -> StateC [OVal]
runSuiteCapture :: VarLookup -> [StatementI] -> StateC [OVal]
runSuiteCapture VarLookup
varlookup [StatementI]
suite = do
  ScadOpts
opts <- forall r (m :: * -> *). MonadReader r m => m r
ask
  ([OVal]
res, [Message]
messages, CompState
_) <- do
    CompState
s <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompState -> CompState
mkSubState
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r s w a.
Monad m =>
r -> s -> ImplicitCadM r w s m a -> m (a, w, s)
runImplicitCadM ScadOpts
opts CompState
s forall a b. (a -> b) -> a -> b
$ [StatementI] -> StateC ()
runSuite [StatementI]
suite forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateC [OVal]
getVals
  forall a. [a] -> [a]
reverse [OVal]
res forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Message -> StateC ()
moveMessage [Message]
messages
    where
      mkSubState :: CompState -> CompState
mkSubState CompState
s = VarLookup -> [OVal] -> String -> CompState
CompState VarLookup
varlookup [] (CompState -> String
sourceDir CompState
s)
      moveMessage :: Message -> StateC ()
moveMessage (Message MessageType
mtype SourcePosition
mpos Text
text) = MessageType -> SourcePosition -> Text -> StateC ()
addMessage MessageType
mtype SourcePosition
mpos Text
text