{-# 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))
runStatementI :: StatementI -> StateC ()
runStatementI :: StatementI -> StateC ()
runStatementI (StatementI SourcePosition
sourcePos (Pattern
pat := Expr
expr)) = do
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
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
[(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
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
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?")
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
)
[(Maybe Symbol, OVal)]
evaluatedArgs <- [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]
evalArgs [(Maybe Symbol, Expr)]
argsExpr
[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 []
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
[(Maybe Symbol, OVal)]
evaluatedArgs <- [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]
evalArgs [(Maybe Symbol, Expr)]
argsExpr
()
_ <- Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
mod' Symbol
modname SourcePosition
sourcePos [(Maybe Symbol, OVal)]
evaluatedArgs [StatementI]
suite [StatementI] -> StateC ()
runSuite
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
valDefaulted ,valNotDefaulted, valNamed, mappedDefaulted, mappedNotDefaulted, notMappedNotDefaultable :: [Symbol]
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
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
valNamed :: [Symbol]
valNamed = [(Maybe Symbol, Expr)] -> [Symbol]
namedParameters [(Maybe Symbol, Expr)]
argsExpr
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
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
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
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
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
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