{- 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, 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)

-- | 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)) ->
          [(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
    -- 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: " 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
    -- Interpret a module declaration.
    [(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
        -- 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
              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
              -- Evaluate the suite.
              --suiteResults <- runSuiteCapture varlookup suite
              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?")
              -- Run the module.
              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
                                            )
              -- 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
                                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 []
              -- Run the module.
              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
              -- 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
              [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
                -- 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  = ((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
                -- function definition has no default value.
                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
                -- 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 = (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
                -- 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 = (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
                -- arguments we need to find a mapping for, from the unnamed expressions.
                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
                -- 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 = [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
                  {-
              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))
                 -}
              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
    -- 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 <- 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