{-# 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, 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 Control.Monad.State (gets, liftIO, runStateT)
import Data.Foldable (traverse_, for_)
import Data.Traversable (for)
import Data.Text.Lazy (unpack, pack)
import System.Directory (doesFileExist)
import System.FilePath (takeDirectory)
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)) ->
[(Symbol, OVal)] -> ((Symbol, OVal) -> StateC ()) -> StateC ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map Symbol OVal -> [(Symbol, OVal)]
forall k a. Map k a -> [(k, a)]
toList Map Symbol OVal
match) (((Symbol, OVal) -> StateC ()) -> StateC ())
-> ((Symbol, OVal) -> StateC ()) -> StateC ()
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)
Bool -> StateC () -> StateC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe OVal -> Bool
forall a. Maybe a -> Bool
isJust Maybe OVal
maybeVar)
(SourcePosition -> Text -> StateC ()
warnC SourcePosition
sourcePos (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"redefining already defined object: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
varName)
(VarLookup -> VarLookup) -> StateC ()
modifyVarLookup ((VarLookup -> VarLookup) -> StateC ())
-> (VarLookup -> VarLookup) -> StateC ()
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: " Text -> Text -> Text
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)
_ -> () -> StateC ()
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' <- [(Symbol, Maybe Expr)]
-> ((Symbol, Maybe Expr)
-> StateT CompState IO (Symbol, Maybe OVal))
-> StateT CompState IO [(Symbol, Maybe OVal)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Symbol, Maybe Expr)]
argTemplate (((Symbol, Maybe Expr) -> StateT CompState IO (Symbol, Maybe OVal))
-> StateT CompState IO [(Symbol, Maybe OVal)])
-> ((Symbol, Maybe Expr)
-> StateT CompState IO (Symbol, Maybe OVal))
-> StateT CompState IO [(Symbol, Maybe OVal)]
forall a b. (a -> b) -> a -> b
$ \(Symbol
argName, Maybe Expr
defexpr) -> do
Maybe OVal
defval <- (Expr -> StateC OVal) -> Maybe Expr -> StateC (Maybe OVal)
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
(Symbol, Maybe OVal) -> StateT CompState IO (Symbol, Maybe OVal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbol
argName, Maybe OVal
defval)
[(Symbol, Bool)]
argNames <- [(Symbol, Maybe Expr)]
-> ((Symbol, Maybe Expr) -> StateT CompState IO (Symbol, Bool))
-> StateT CompState IO [(Symbol, Bool)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Symbol, Maybe Expr)]
argTemplate (((Symbol, Maybe Expr) -> StateT CompState IO (Symbol, Bool))
-> StateT CompState IO [(Symbol, Bool)])
-> ((Symbol, Maybe Expr) -> StateT CompState IO (Symbol, Bool))
-> StateT CompState IO [(Symbol, Bool)]
forall a b. (a -> b) -> a -> b
$ \(Symbol
argName, Maybe Expr
defexpr) -> do
Maybe OVal
defval <- (Expr -> StateC OVal) -> Maybe Expr -> StateC (Maybe OVal)
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 = Maybe OVal -> Bool
forall a. Maybe a -> Bool
isJust Maybe OVal
defval
(Symbol, Bool) -> StateT CompState IO (Symbol, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbol
argName, Bool
hasDefault)
StatementI -> StateC ()
runStatementI (StatementI -> StateC ())
-> (Statement StatementI -> StatementI)
-> Statement StatementI
-> StateC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePosition -> Statement StatementI -> StatementI
StatementI SourcePosition
sourcePos (Statement StatementI -> StateC ())
-> Statement StatementI -> StateC ()
forall a b. (a -> b) -> a -> b
$ (Symbol -> Pattern
Name Symbol
name Pattern -> Expr -> Statement StatementI
forall st. Pattern -> Expr -> Statement st
:=) (Expr -> Statement StatementI) -> Expr -> Statement StatementI
forall a b. (a -> b) -> a -> b
$ OVal -> Expr
LitE (OVal -> Expr) -> OVal -> Expr
forall a b. (a -> b) -> a -> b
$ Symbol
-> Maybe [(Symbol, Bool)]
-> (VarLookup -> ArgParser (StateC [OVal]))
-> OVal
OUModule Symbol
name ([(Symbol, Bool)] -> Maybe [(Symbol, Bool)]
forall a. a -> Maybe a
Just [(Symbol, Bool)]
argNames) ((VarLookup -> ArgParser (StateC [OVal])) -> OVal)
-> (VarLookup -> ArgParser (StateC [OVal])) -> OVal
forall a b. (a -> b) -> a -> b
$ \(VarLookup Map Symbol OVal
varlookup) -> do
[(Symbol, OVal)]
newNameVals <- [(Symbol, Maybe OVal)]
-> ((Symbol, Maybe OVal) -> ArgParser (Symbol, OVal))
-> ArgParser [(Symbol, OVal)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Symbol, Maybe OVal)]
argTemplate' (((Symbol, Maybe OVal) -> ArgParser (Symbol, OVal))
-> ArgParser [(Symbol, OVal)])
-> ((Symbol, Maybe OVal) -> ArgParser (Symbol, OVal))
-> ArgParser [(Symbol, OVal)]
forall a b. (a -> b) -> a -> b
$ \(Symbol
argName, Maybe OVal
maybeDef) -> do
OVal
val <- case Maybe OVal
maybeDef of
Just OVal
def -> Symbol -> ArgParser OVal
forall desiredType.
OTypeMirror desiredType =>
Symbol -> ArgParser desiredType
argument Symbol
argName ArgParser OVal -> OVal -> ArgParser OVal
forall a. OTypeMirror a => ArgParser a -> a -> ArgParser a
`defaultTo` OVal
def
Maybe OVal
Nothing -> Symbol -> ArgParser OVal
forall desiredType.
OTypeMirror desiredType =>
Symbol -> ArgParser desiredType
argument Symbol
argName
(Symbol, OVal) -> ArgParser (Symbol, OVal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbol
argName, OVal
val)
let
varlookup' :: Map Symbol OVal
varlookup' = Map Symbol OVal -> Map Symbol OVal -> Map Symbol OVal
forall k a. Ord k => Map k a -> Map k a -> Map k a
union ([(Symbol, OVal)] -> Map Symbol OVal
forall k a. Ord k => [(k, a)] -> Map k a
fromList [(Symbol, OVal)]
newNameVals) Map Symbol OVal
varlookup
StateC [OVal] -> ArgParser (StateC [OVal])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateC [OVal] -> ArgParser (StateC [OVal]))
-> StateC [OVal] -> ArgParser (StateC [OVal])
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
Bool -> StateC () -> StateC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
optionsMatch (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Options check failed when executing user-defined module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
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
Bool -> StateC () -> StateC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([StatementI]
suite [StatementI] -> [StatementI] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Suite provided, but module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not accept one. Perhaps a missing semicolon?")
let
argsMapped :: (Maybe (StateC [OVal]), [String])
argsMapped = [(Maybe Symbol, OVal)]
-> ArgParser (StateC [OVal]) -> (Maybe (StateC [OVal]), [String])
forall a.
[(Maybe Symbol, OVal)] -> ArgParser a -> (Maybe a, [String])
argMap [(Maybe Symbol, OVal)]
evaluatedArgs (ArgParser (StateC [OVal]) -> (Maybe (StateC [OVal]), [String]))
-> ArgParser (StateC [OVal]) -> (Maybe (StateC [OVal]), [String])
forall a b. (a -> b) -> a -> b
$ VarLookup -> ArgParser (StateC [OVal])
mod' VarLookup
varLookup
[Text] -> (Text -> StateC ()) -> StateC ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (String -> Text
pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (StateC [OVal]), [String]) -> [String]
forall a b. (a, b) -> b
snd (Maybe (StateC [OVal]), [String])
argsMapped) ((Text -> StateC ()) -> StateC ())
-> (Text -> StateC ()) -> StateC ()
forall a b. (a -> b) -> a -> b
$ SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos
StateC [OVal] -> Maybe (StateC [OVal]) -> StateC [OVal]
forall a. a -> Maybe a -> a
fromMaybe ([OVal] -> StateC [OVal]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) ((Maybe (StateC [OVal]), [String]) -> Maybe (StateC [OVal])
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
[] -> Maybe Bool
forall a. Maybe a
Nothing
(([(Symbol, Bool)]
_, Maybe Bool
suiteInfoFound):[([(Symbol, Bool)], Maybe Bool)]
_) -> Maybe Bool
suiteInfoFound
Bool -> StateC () -> StateC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([([(Symbol, Bool)], Maybe Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([(Symbol, Bool)], Maybe Bool)]
possibleInstances) (do
SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"no instance of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" found to match given parameters.\nInstances available:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (OVal -> String
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))
(Maybe [(Symbol, Bool)] -> StateC Bool)
-> [Maybe [(Symbol, Bool)]] -> StateC ()
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) ([Maybe [(Symbol, Bool)]] -> StateC ())
-> [Maybe [(Symbol, Bool)]] -> StateC ()
forall a b. (a -> b) -> a -> b
$ (([(Symbol, Bool)], Maybe Bool) -> Maybe [(Symbol, Bool)])
-> [([(Symbol, Bool)], Maybe Bool)] -> [Maybe [(Symbol, Bool)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Symbol, Bool)] -> Maybe [(Symbol, Bool)]
forall a. a -> Maybe a
Just ([(Symbol, Bool)] -> Maybe [(Symbol, Bool)])
-> (([(Symbol, Bool)], Maybe Bool) -> [(Symbol, Bool)])
-> ([(Symbol, Bool)], Maybe Bool)
-> Maybe [(Symbol, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Symbol, Bool)], Maybe Bool) -> [(Symbol, Bool)]
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
Bool -> StateC () -> StateC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([OVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OVal]
vals) (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos Text
"Suite required, but none provided.")
[OVal] -> StateC [OVal]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [OVal]
vals
Just Bool
False -> [OVal] -> StateC [OVal]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [OVal]
vals
Maybe Bool
_ -> do
Bool -> StateC () -> StateC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([StatementI]
suite [StatementI] -> [StatementI] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Suite provided, but module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not accept one. Perhaps a missing semicolon?")
[OVal] -> StateC [OVal]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
let
argsMapped :: (Maybe (StateC [OVal]), [String])
argsMapped = [(Maybe Symbol, OVal)]
-> ArgParser (StateC [OVal]) -> (Maybe (StateC [OVal]), [String])
forall a.
[(Maybe Symbol, OVal)] -> ArgParser a -> (Maybe a, [String])
argMap [(Maybe Symbol, OVal)]
evaluatedArgs (ArgParser (StateC [OVal]) -> (Maybe (StateC [OVal]), [String]))
-> ArgParser (StateC [OVal]) -> (Maybe (StateC [OVal]), [String])
forall a b. (a -> b) -> a -> b
$ SourcePosition -> [OVal] -> ArgParser (StateC [OVal])
implementation SourcePosition
sourcePos [OVal]
suiteResults
[Text] -> (Text -> StateC ()) -> StateC ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (String -> Text
pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (StateC [OVal]), [String]) -> [String]
forall a b. (a, b) -> b
snd (Maybe (StateC [OVal]), [String])
argsMapped) ((Text -> StateC ()) -> StateC ())
-> (Text -> StateC ()) -> StateC ()
forall a b. (a -> b) -> a -> b
$ SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos
StateC [OVal] -> Maybe (StateC [OVal]) -> StateC [OVal]
forall a. a -> Maybe a -> a
fromMaybe ([OVal] -> StateC [OVal]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) ((Maybe (StateC [OVal]), [String]) -> Maybe (StateC [OVal])
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
[OVal] -> StateC [OVal]
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 (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Object " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a module!"
[OVal] -> StateC [OVal]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Maybe OVal
_ -> do
SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not in scope."
[OVal] -> StateC [OVal]
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 <- [([(Symbol, Bool)], Maybe Bool)]
-> (([(Symbol, Bool)], Maybe Bool)
-> StateT CompState IO (Maybe ([(Symbol, Bool)], Maybe Bool)))
-> StateT CompState IO [Maybe ([(Symbol, Bool)], Maybe Bool)]
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 ([(Symbol, Bool)] -> Maybe [(Symbol, Bool)]
forall a. a -> Maybe a
Just [(Symbol, Bool)]
args) Bool
False
Maybe ([(Symbol, Bool)], Maybe Bool)
-> StateT CompState IO (Maybe ([(Symbol, Bool)], Maybe Bool))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ([(Symbol, Bool)], Maybe Bool)
-> StateT CompState IO (Maybe ([(Symbol, Bool)], Maybe Bool)))
-> Maybe ([(Symbol, Bool)], Maybe Bool)
-> StateT CompState IO (Maybe ([(Symbol, Bool)], Maybe Bool))
forall a b. (a -> b) -> a -> b
$ if Bool
res then ([(Symbol, Bool)], Maybe Bool)
-> Maybe ([(Symbol, Bool)], Maybe Bool)
forall a. a -> Maybe a
Just ([(Symbol, Bool)]
args, Maybe Bool
suiteInfo) else Maybe ([(Symbol, Bool)], Maybe Bool)
forall a. Maybe a
Nothing
)
[([(Symbol, Bool)], Maybe Bool)]
-> StateC [([(Symbol, Bool)], Maybe Bool)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([([(Symbol, Bool)], Maybe Bool)]
-> StateC [([(Symbol, Bool)], Maybe Bool)])
-> [([(Symbol, Bool)], Maybe Bool)]
-> StateC [([(Symbol, Bool)], Maybe Bool)]
forall a b. (a -> b) -> a -> b
$ [Maybe ([(Symbol, Bool)], Maybe Bool)]
-> [([(Symbol, Bool)], Maybe Bool)]
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 = ((Symbol, Bool) -> Symbol) -> [(Symbol, Bool)] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Symbol, Bool) -> Symbol
forall a b. (a, b) -> a
fst ([(Symbol, Bool)] -> [Symbol]) -> [(Symbol, Bool)] -> [Symbol]
forall a b. (a -> b) -> a -> b
$ ((Symbol, Bool) -> Bool) -> [(Symbol, Bool)] -> [(Symbol, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Symbol, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(Symbol, Bool)] -> [(Symbol, Bool)])
-> [(Symbol, Bool)] -> [(Symbol, Bool)]
forall a b. (a -> b) -> a -> b
$ [(Symbol, Bool)] -> Maybe [(Symbol, Bool)] -> [(Symbol, Bool)]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [(Symbol, Bool)]
args
valNotDefaulted :: [Symbol]
valNotDefaulted = ((Symbol, Bool) -> Symbol) -> [(Symbol, Bool)] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Symbol, Bool) -> Symbol
forall a b. (a, b) -> a
fst ([(Symbol, Bool)] -> [Symbol]) -> [(Symbol, Bool)] -> [Symbol]
forall a b. (a -> b) -> a -> b
$ ((Symbol, Bool) -> Bool) -> [(Symbol, Bool)] -> [(Symbol, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool)
-> ((Symbol, Bool) -> Bool) -> (Symbol, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Symbol, Bool) -> Bool
forall a b. (a, b) -> b
snd) ([(Symbol, Bool)] -> [(Symbol, Bool)])
-> [(Symbol, Bool)] -> [(Symbol, Bool)]
forall a b. (a -> b) -> a -> b
$ [(Symbol, Bool)] -> Maybe [(Symbol, Bool)] -> [(Symbol, Bool)]
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 = (Symbol -> Bool) -> [Symbol] -> [Symbol]
forall a. (a -> Bool) -> [a] -> [a]
filter (Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Symbol]
valNamed) [Symbol]
valDefaulted
mappedNotDefaulted :: [Symbol]
mappedNotDefaulted = (Symbol -> Bool) -> [Symbol] -> [Symbol]
forall a. (a -> Bool) -> [a] -> [a]
filter (Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Symbol]
valNamed) [Symbol]
valNotDefaulted
notMappedNotDefaultable :: [Symbol]
notMappedNotDefaultable = (Symbol -> Bool) -> [Symbol] -> [Symbol]
forall a. (a -> Bool) -> [a] -> [a]
filter (Symbol -> [Symbol] -> Bool
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 = [Symbol] -> [Expr] -> [(Symbol, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Symbol]
notMappedNotDefaultable [Expr]
valUnnamed
missingNotDefaultable :: [Symbol]
missingNotDefaultable = (Symbol -> Bool) -> [Symbol] -> [Symbol]
forall a. (a -> Bool) -> [a] -> [a]
filter (Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Symbol]
mappedDefaulted [Symbol] -> [Symbol] -> [Symbol]
forall a. Semigroup a => a -> a -> a
<> [Symbol]
mappedNotDefaulted [Symbol] -> [Symbol] -> [Symbol]
forall a. Semigroup a => a -> a -> a
<> ((Symbol, Expr) -> Symbol) -> [(Symbol, Expr)] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Symbol, Expr) -> Symbol
forall a b. (a, b) -> a
fst [(Symbol, Expr)]
mapFromUnnamed)) [Symbol]
valNotDefaulted
extraUnnamed :: [Symbol]
extraUnnamed = (Symbol -> Bool) -> [Symbol] -> [Symbol]
forall a. (a -> Bool) -> [a] -> [a]
filter (Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Symbol]
valDefaulted [Symbol] -> [Symbol] -> [Symbol]
forall a. Semigroup a => a -> a -> a
<> [Symbol]
valNotDefaulted)) ([Symbol] -> [Symbol]) -> [Symbol] -> [Symbol]
forall a b. (a -> b) -> a -> b
$ [(Maybe Symbol, Expr)] -> [Symbol]
namedParameters [(Maybe Symbol, Expr)]
argsExpr
parameterReport :: String
parameterReport = String
"Passed " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
(if [Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
valNamed Bool -> Bool -> Bool
&& [Expr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
valUnnamed then String
"no parameters" else String
"" ) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
(if Bool -> Bool
not ([Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
valNamed) then Int -> String
forall a. Show a => a -> String
show ([Symbol] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
valNamed) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if [Symbol] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
valNamed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
" named parameter" else String
" named parameters") else String
"" ) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
(if Bool -> Bool
not ([Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
valNamed) Bool -> Bool -> Bool
&& Bool -> Bool
not ([Expr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
valUnnamed) then String
", and " else String
"") String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
(if Bool -> Bool
not ([Expr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
valUnnamed) then Int -> String
forall a. Show a => a -> String
show ([Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
valUnnamed) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if [Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
valUnnamed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
" un-named parameter." else String
" un-named parameters.") else String
".") String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
(if Bool -> Bool
not ([Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
missingNotDefaultable) then
(if [Symbol] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
missingNotDefaultable Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
then String
" Couldn't match one parameter: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Symbol -> String
showSymbol ([Symbol] -> Symbol
forall a. [a] -> a
last [Symbol]
missingNotDefaultable)
else String
" Couldn't match " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Symbol] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
missingNotDefaultable) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" parameters: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Symbol -> String
showSymbol (Symbol -> String) -> [Symbol] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Symbol] -> [Symbol]
forall a. [a] -> [a]
init [Symbol]
missingNotDefaultable) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" and " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Symbol -> String
showSymbol ([Symbol] -> Symbol
forall a. [a] -> a
last [Symbol]
missingNotDefaultable) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
) else String
"") String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
(if Bool -> Bool
not ([Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
extraUnnamed) then
(if [Symbol] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
extraUnnamed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
then String
" Had one extra parameter: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Symbol -> String
showSymbol ([Symbol] -> Symbol
forall a. [a] -> a
last [Symbol]
extraUnnamed)
else String
" Had " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Symbol] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
extraUnnamed) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" extra parameters. They are:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Symbol -> String
showSymbol (Symbol -> String) -> [Symbol] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Symbol] -> [Symbol]
forall a. [a] -> [a]
init [Symbol]
extraUnnamed) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" and " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Symbol -> String
showSymbol ([Symbol] -> Symbol
forall a. [a] -> a
last [Symbol]
extraUnnamed) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
) else String
"")
showSymbol :: Symbol -> String
showSymbol :: Symbol -> String
showSymbol (Symbol Text
sym) = Text -> String
forall a. Show a => a -> String
show Text
sym
Bool -> StateC () -> StateC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
missingNotDefaultable) Bool -> Bool -> Bool
&& Bool
makeWarnings)
(SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Insufficient parameters. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
parameterReport)
Bool -> StateC () -> StateC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
extraUnnamed) Bool -> Bool -> Bool
&& Maybe [(Symbol, Bool)] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [(Symbol, Bool)]
args Bool -> Bool -> Bool
&& Bool
makeWarnings)
(SourcePosition -> Text -> StateC ()
errorC SourcePosition
sourcePos (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Too many parameters: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [Symbol] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Symbol]
extraUnnamed) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" extra. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
parameterReport)
Bool -> StateC Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> StateC Bool) -> Bool -> StateC Bool
forall a b. (a -> b) -> a -> b
$ [Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
missingNotDefaultable Bool -> Bool -> Bool
&& [Symbol] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol]
extraUnnamed
namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol]
namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol]
namedParameters = ((Maybe Symbol, Expr) -> Maybe Symbol)
-> [(Maybe Symbol, Expr)] -> [Symbol]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Symbol, Expr) -> Maybe Symbol
forall a b. (a, b) -> a
fst
unnamedParameters :: [(Maybe Symbol, Expr)] -> [Expr]
unnamedParameters :: [(Maybe Symbol, Expr)] -> [Expr]
unnamedParameters = ((Maybe Symbol, Expr) -> Maybe Expr)
-> [(Maybe Symbol, Expr)] -> [Expr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (
\(Maybe Symbol
argName, Expr
expr) ->
case Maybe Symbol
argName of
Just Symbol
_ -> Maybe Expr
forall a. Maybe a
Nothing
Maybe Symbol
Nothing -> Expr -> Maybe Expr
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 = [(Maybe Symbol, Expr)]
-> ((Maybe Symbol, Expr)
-> StateT CompState IO (Maybe Symbol, OVal))
-> StateC [(Maybe Symbol, OVal)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Maybe Symbol, Expr)]
args (((Maybe Symbol, Expr) -> StateT CompState IO (Maybe Symbol, OVal))
-> StateC [(Maybe Symbol, OVal)])
-> ((Maybe Symbol, Expr)
-> StateT CompState IO (Maybe Symbol, OVal))
-> StateC [(Maybe Symbol, OVal)]
forall a b. (a -> b) -> a -> b
$ \(Maybe Symbol
posName, Expr
expr) -> do
OVal
val <- SourcePosition -> Expr -> StateC OVal
evalExpr SourcePosition
sourcePos Expr
expr
(Maybe Symbol, OVal) -> StateT CompState IO (Maybe Symbol, OVal)
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 <- IO Bool -> StateC Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> StateC Bool) -> IO Bool -> StateC Bool
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 (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Not importing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": File not found."
else do
String
content <- IO String -> StateC String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> StateC String) -> IO String -> StateC String
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 (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Error parsing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (ParseError -> String
forall a. Show a => a -> String
show ParseError
e)
Right [StatementI]
sts -> String -> StateC () -> StateC ()
forall a. String -> StateC a -> StateC a
withPathShiftedBy (String -> String
takeDirectory (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
name) (StateC () -> StateC ()) -> StateC () -> StateC ()
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 ([OVal] -> StateC ()) -> [OVal] -> StateC ()
forall a b. (a -> b) -> a -> b
$ [OVal]
vals' [OVal] -> [OVal] -> [OVal]
forall a. Semigroup a => a -> a -> a
<> [OVal]
vals
else [OVal] -> StateC ()
putVals [OVal]
vals
else SourcePosition -> Text -> StateC ()
warnC SourcePosition
sourcePos (Text -> StateC ()) -> Text -> StateC ()
forall a b. (a -> b) -> a -> b
$ Text
"Not importing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": File import disabled."
runStatementI (StatementI SourcePosition
_ Statement StatementI
DoNothing) = () -> StateC ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
runSuite :: [StatementI] -> StateC ()
runSuite :: [StatementI] -> StateC ()
runSuite = (StatementI -> StateC ()) -> [StatementI] -> StateC ()
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
([OVal]
res, CompState
s) <- (CompState -> CompState) -> StateT CompState IO CompState
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompState -> CompState
mkSubState StateT CompState IO CompState
-> (CompState -> StateT CompState IO ([OVal], CompState))
-> StateT CompState IO ([OVal], CompState)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ([OVal], CompState) -> StateT CompState IO ([OVal], CompState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([OVal], CompState) -> StateT CompState IO ([OVal], CompState))
-> (CompState -> IO ([OVal], CompState))
-> CompState
-> StateT CompState IO ([OVal], CompState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateC [OVal] -> CompState -> IO ([OVal], CompState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ([StatementI] -> StateC ()
runSuite [StatementI]
suite StateC () -> StateC [OVal] -> StateC [OVal]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateC [OVal]
getVals)
[OVal] -> [OVal]
forall a. [a] -> [a]
reverse [OVal]
res [OVal] -> StateT CompState IO [()] -> StateC [OVal]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Message -> StateC ()) -> [Message] -> StateT CompState IO [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Message -> StateC ()
moveMessage (CompState -> [Message]
messages CompState
s)
where
mkSubState :: CompState -> CompState
mkSubState CompState
s = VarLookup -> [OVal] -> String -> [Message] -> ScadOpts -> CompState
CompState VarLookup
varlookup [] (CompState -> String
sourceDir CompState
s) [] (CompState -> ScadOpts
scadOpts CompState
s)
moveMessage :: Message -> StateC ()
moveMessage (Message MessageType
mtype SourcePosition
mpos Text
text) = MessageType -> SourcePosition -> Text -> StateC ()
addMessage MessageType
mtype SourcePosition
mpos Text
text