{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |
-- Given a Technique Procedure (concrete syntax tree), translate it into an
-- internalized representation (abstract syntax tree) that can be subsequently
-- executed (that is, interpreted; evaluated).
module Technique.Translate where

import Control.Monad (foldM, when)
import Control.Monad.Except (MonadError (..))
import Control.Monad.State.Class (MonadState (..))
import Control.Monad.Trans.Except (Except (), runExcept)
import Control.Monad.Trans.State.Strict (StateT (..), runStateT)
import Core.Data
import Core.Text
import Data.DList (fromList, toList)
import Data.Foldable (traverse_)
import Technique.Builtins
import Technique.Failure
import Technique.Internal
import Technique.Language

-- |
-- Environment in the type-theory sense of the word: the map(s) between
-- names and their bindings.

-- TODO perhaps the role should be Maybe Attribute? This will likely need
-- work as there are three states: 1) as yet unspecified, 2) specified, and
-- 3) explicitly reset to any. Are (1) and (3) the same?
data Environment = Environment
  { Environment -> Map Identifier Name
environmentVariables :: Map Identifier Name,
    Environment -> Map Identifier Function
environmentFunctions :: Map Identifier Function,
    Environment -> Attribute
environmentRole :: Attribute,
    -- for reporting compiler errors
    Environment -> Source
environmentSource :: Source,
    -- the accumulator for the fold that the Translate monad represents
    Environment -> Step
environmentAccumulated :: Step
  }
  deriving (Environment -> Environment -> Bool
(Environment -> Environment -> Bool)
-> (Environment -> Environment -> Bool) -> Eq Environment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Environment -> Environment -> Bool
$c/= :: Environment -> Environment -> Bool
== :: Environment -> Environment -> Bool
$c== :: Environment -> Environment -> Bool
Eq, Int -> Environment -> ShowS
[Environment] -> ShowS
Environment -> String
(Int -> Environment -> ShowS)
-> (Environment -> String)
-> ([Environment] -> ShowS)
-> Show Environment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Environment] -> ShowS
$cshowList :: [Environment] -> ShowS
show :: Environment -> String
$cshow :: Environment -> String
showsPrec :: Int -> Environment -> ShowS
$cshowsPrec :: Int -> Environment -> ShowS
Show)

emptyEnvironment :: Environment
emptyEnvironment :: Environment
emptyEnvironment =
  Environment :: Map Identifier Name
-> Map Identifier Function
-> Attribute
-> Source
-> Step
-> Environment
Environment
    { environmentVariables :: Map Identifier Name
environmentVariables = Map Identifier Name
forall κ ν. Map κ ν
emptyMap,
      environmentFunctions :: Map Identifier Function
environmentFunctions = Map Identifier Function
forall κ ν. Map κ ν
emptyMap,
      environmentRole :: Attribute
environmentRole = Attribute
Inherit,
      environmentSource :: Source
environmentSource = Source
emptySource,
      environmentAccumulated :: Step
environmentAccumulated = Step
NoOp
    }

newtype Translate a = Translate (StateT Environment (Except CompilationError) a)
  deriving (a -> Translate b -> Translate a
(a -> b) -> Translate a -> Translate b
(forall a b. (a -> b) -> Translate a -> Translate b)
-> (forall a b. a -> Translate b -> Translate a)
-> Functor Translate
forall a b. a -> Translate b -> Translate a
forall a b. (a -> b) -> Translate a -> Translate b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Translate b -> Translate a
$c<$ :: forall a b. a -> Translate b -> Translate a
fmap :: (a -> b) -> Translate a -> Translate b
$cfmap :: forall a b. (a -> b) -> Translate a -> Translate b
Functor, Functor Translate
a -> Translate a
Functor Translate
-> (forall a. a -> Translate a)
-> (forall a b. Translate (a -> b) -> Translate a -> Translate b)
-> (forall a b c.
    (a -> b -> c) -> Translate a -> Translate b -> Translate c)
-> (forall a b. Translate a -> Translate b -> Translate b)
-> (forall a b. Translate a -> Translate b -> Translate a)
-> Applicative Translate
Translate a -> Translate b -> Translate b
Translate a -> Translate b -> Translate a
Translate (a -> b) -> Translate a -> Translate b
(a -> b -> c) -> Translate a -> Translate b -> Translate c
forall a. a -> Translate a
forall a b. Translate a -> Translate b -> Translate a
forall a b. Translate a -> Translate b -> Translate b
forall a b. Translate (a -> b) -> Translate a -> Translate b
forall a b c.
(a -> b -> c) -> Translate a -> Translate b -> Translate c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Translate a -> Translate b -> Translate a
$c<* :: forall a b. Translate a -> Translate b -> Translate a
*> :: Translate a -> Translate b -> Translate b
$c*> :: forall a b. Translate a -> Translate b -> Translate b
liftA2 :: (a -> b -> c) -> Translate a -> Translate b -> Translate c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Translate a -> Translate b -> Translate c
<*> :: Translate (a -> b) -> Translate a -> Translate b
$c<*> :: forall a b. Translate (a -> b) -> Translate a -> Translate b
pure :: a -> Translate a
$cpure :: forall a. a -> Translate a
$cp1Applicative :: Functor Translate
Applicative, Applicative Translate
a -> Translate a
Applicative Translate
-> (forall a b. Translate a -> (a -> Translate b) -> Translate b)
-> (forall a b. Translate a -> Translate b -> Translate b)
-> (forall a. a -> Translate a)
-> Monad Translate
Translate a -> (a -> Translate b) -> Translate b
Translate a -> Translate b -> Translate b
forall a. a -> Translate a
forall a b. Translate a -> Translate b -> Translate b
forall a b. Translate a -> (a -> Translate b) -> Translate b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Translate a
$creturn :: forall a. a -> Translate a
>> :: Translate a -> Translate b -> Translate b
$c>> :: forall a b. Translate a -> Translate b -> Translate b
>>= :: Translate a -> (a -> Translate b) -> Translate b
$c>>= :: forall a b. Translate a -> (a -> Translate b) -> Translate b
$cp1Monad :: Applicative Translate
Monad, MonadState Environment, MonadError CompilationError)

-- |
-- Take a translator action and an environment and spin it up into a Step
-- or nest of Steps ("Subroutine") suitable for interpretation. In other
-- words, translate between the concrete syntax types and the abstract
-- syntax we can feed to an evaluator.

-- we use runStateT rather than evalStateT as we did previously so we can
-- access the final state in test cases.
runTranslate :: Environment -> Translate a -> Either CompilationError (a, Environment)
runTranslate :: Environment
-> Translate a -> Either CompilationError (a, Environment)
runTranslate Environment
env (Translate StateT Environment (Except CompilationError) a
action) = Except CompilationError (a, Environment)
-> Either CompilationError (a, Environment)
forall e a. Except e a -> Either e a
runExcept (StateT Environment (Except CompilationError) a
-> Environment -> Except CompilationError (a, Environment)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT Environment (Except CompilationError) a
action Environment
env)
{-# INLINE runTranslate #-}

translateTechnique :: Technique -> Translate [Function]
translateTechnique :: Technique -> Translate [Function]
translateTechnique Technique
technique = do
  -- Stage 1: conduct translation
  [Function]
funcs1 <- (Procedure -> Translate Function)
-> [Procedure] -> Translate [Function]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Procedure -> Translate Function
translateProcedure (Technique -> [Procedure]
techniqueBody Technique
technique)

  -- Stage 2: resolve functions
  [Function]
funcs2 <- (Function -> Translate Function)
-> [Function] -> Translate [Function]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Function -> Translate Function
resolver [Function]
funcs1
  [Function] -> Translate [Function]
forall (m :: * -> *) a. Monad m => a -> m a
return [Function]
funcs2
  where
    resolver :: Function -> Translate Function
    resolver :: Function -> Translate Function
resolver Function
func = case Function
func of
      Subroutine Procedure
proc Step
step -> do
        Step
step' <- Step -> Translate Step
resolveFunctions Step
step
        Function -> Translate Function
forall (m :: * -> *) a. Monad m => a -> m a
return (Procedure -> Step -> Function
Subroutine Procedure
proc Step
step')
      Function
_ -> String -> Translate Function
forall a. HasCallStack => String -> a
error (String
"Illegal state: How did you get a top level " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Function -> String
forall a. Show a => a -> String
show Function
func) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"?")

translateProcedure :: Procedure -> Translate Function
translateProcedure :: Procedure -> Translate Function
translateProcedure Procedure
procedure =
  let is :: [Identifier]
is = Procedure -> [Identifier]
procedureParams Procedure
procedure
      o :: Int
o = Procedure -> Int
procedureOffset Procedure
procedure
      block :: Block
block = Procedure -> Block
procedureBlock Procedure
procedure
   in do
        Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get

        -- calling runTranslate here *is* the act of refining, but there's no way
        -- we're going to remember that so make it explicit. Gives us the
        -- opportunity to modify the environment before descending if necessary.

        let subenv :: Environment
subenv = Environment
env
        let result :: Either CompilationError (Step, Environment)
result = Environment
-> Translate Step -> Either CompilationError (Step, Environment)
forall a.
Environment
-> Translate a -> Either CompilationError (a, Environment)
runTranslate Environment
subenv (Translate Step -> Either CompilationError (Step, Environment))
-> Translate Step -> Either CompilationError (Step, Environment)
forall a b. (a -> b) -> a -> b
$ do
              (Identifier -> Translate Name) -> [Identifier] -> Translate ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Int -> Identifier -> Translate Name
insertVariable Int
o) [Identifier]
is
              Block -> Translate Step
translateBlock Block
block

        case Either CompilationError (Step, Environment)
result of
          Left CompilationError
e -> CompilationError -> Translate Function
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CompilationError
e
          Right (Step
step, Environment
_) -> do
            let func :: Function
func = Procedure -> Step -> Function
Subroutine Procedure
procedure Step
step
            Int -> Function -> Translate ()
registerProcedure (Procedure -> Int
forall a. Located a => a -> Int
locationOf Procedure
procedure) Function
func
            Function -> Translate Function
forall (m :: * -> *) a. Monad m => a -> m a
return Function
func

-- |
-- Blocks are scoping mechanisms, so accumulated environment is discarded
-- once we finish resolving names within it.
translateBlock :: Block -> Translate Step
translateBlock :: Block -> Translate Step
translateBlock (Block [Statement]
statements) = do
  (Statement -> Translate ()) -> [Statement] -> Translate ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Statement -> Translate ()
translateStatement [Statement]
statements

  Environment
env' <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get
  let step :: Step
step = Environment -> Step
environmentAccumulated Environment
env'
  Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return Step
step

translateStatement :: Statement -> Translate ()
translateStatement :: Statement -> Translate ()
translateStatement Statement
statement = do
  case Statement
statement of
    Assignment Int
o [Identifier]
vars Expression
expr -> do
      -- FIXME this offset will be incorrect if > 1 variable.
      [Name]
names <- (Identifier -> Translate Name) -> [Identifier] -> Translate [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int -> Identifier -> Translate Name
insertVariable Int
o) [Identifier]
vars
      Step
step <- Expression -> Translate Step
translateExpression Expression
expr

      let step' :: Step
step' = Int -> [Name] -> Step -> Step
Asynchronous Int
o [Name]
names Step
step
      Step -> Translate ()
appendStep Step
step'
    Execute Int
_ Expression
expr -> do
      Step
step <- Expression -> Translate Step
translateExpression Expression
expr
      Step -> Translate ()
appendStep Step
step
    Declaration Int
_ Procedure
proc -> do
      Function
_ <- Procedure -> Translate Function
translateProcedure Procedure
proc
      () -> Translate ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- the remainder are functionally no-ops
    Comment Int
_ Rope
_ -> () -> Translate ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Blank Int
_ -> () -> Translate ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Series Int
_ -> () -> Translate ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |
-- Note that this does NOT add the steps to the Environment.
translateExpression :: Expression -> Translate Step
translateExpression :: Expression -> Translate Step
translateExpression Expression
expr = do
  Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get
  let attr :: Attribute
attr = Environment -> Attribute
environmentRole Environment
env

  case Expression
expr of
    Application Int
o Identifier
i Expression
subexpr -> do
      let func :: Function
func = Identifier -> Function
Unresolved Identifier
i
      Step
step <- Expression -> Translate Step
translateExpression Expression
subexpr
      Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Attribute -> Function -> Step -> Step
Invocation Int
o Attribute
attr Function
func Step
step)
    None Int
o ->
      Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Value -> Step
Known Int
o Value
Unitus)
    Text Int
o Rope
text ->
      Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Value -> Step
Known Int
o (Rope -> Value
Literali Rope
text))
    Amount Int
o Quantity
qty ->
      Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Value -> Step
Known Int
o (Quantity -> Value
Quanticle Quantity
qty))
    Undefined Int
o -> do
      Int -> FailureReason -> Translate Step
forall a. Int -> FailureReason -> Translate a
failBecause Int
o FailureReason
EncounteredUndefined
    Object Int
o (Tablet [Binding]
bindings) -> do
      [(Label, Step)]
pairs <- ([(Label, Step)] -> Binding -> Translate [(Label, Step)])
-> [(Label, Step)] -> [Binding] -> Translate [(Label, Step)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [(Label, Step)] -> Binding -> Translate [(Label, Step)]
f [] [Binding]
bindings
      Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [(Label, Step)] -> Step
Bench Int
o [(Label, Step)]
pairs)
      where
        f :: [(Label, Step)] -> Binding -> Translate [(Label, Step)]
        f :: [(Label, Step)] -> Binding -> Translate [(Label, Step)]
f [(Label, Step)]
acc (Binding Label
label Expression
subexpr) = do
          Step
step <- Expression -> Translate Step
translateExpression Expression
subexpr
          [(Label, Step)] -> Translate [(Label, Step)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Label, Step)]
acc [(Label, Step)] -> [(Label, Step)] -> [(Label, Step)]
forall a. Semigroup a => a -> a -> a
<> [(Label
label, Step
step)])
    Variable Int
o [Identifier]
is -> do
      [Step]
steps <- (Identifier -> Translate Step) -> [Identifier] -> Translate [Step]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Identifier -> Translate Step
g [Identifier]
is
      case [Step]
steps of
        [] -> Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return Step
NoOp
        [Step
step] -> Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return Step
step
        [Step]
_ -> Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Step] -> Step
Tuple Int
o [Step]
steps)
      where
        g :: Identifier -> Translate Step
        g :: Identifier -> Translate Step
g Identifier
i = do
          Name
name <- Int -> Identifier -> Translate Name
lookupVariable Int
o Identifier
i
          Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Name -> Step
Depends Int
o Name
name)
    Operation Int
o Operator
oper Expression
subexpr1 Expression
subexpr2 ->
      let prim :: Function
prim = case Operator
oper of
            Operator
WaitEither -> Function
builtinProcedureWaitEither
            Operator
WaitBoth -> Function
builtinProcedureWaitBoth
            Operator
Combine -> Function
builtinProcedureCombineValues
       in do
            Step
step1 <- Expression -> Translate Step
translateExpression Expression
subexpr1
            Step
step2 <- Expression -> Translate Step
translateExpression Expression
subexpr2
            let tuple :: Step
tuple = Int -> [Step] -> Step
Tuple Int
o [Step
step1, Step
step2]
            Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Attribute -> Function -> Step -> Step
Invocation Int
o Attribute
attr Function
prim Step
tuple)
    Grouping Int
_ Expression
subexpr ->
      Expression -> Translate Step
translateExpression Expression
subexpr
    Restriction Int
_ Attribute
subattr Block
block ->
      Attribute -> Block -> Translate Step
applyRestriction Attribute
subattr Block
block

-- |
-- A given procedure call can either be to a user declared in-scope
-- procedure or to a primative builtin. We have Invocation as the Step
-- constructors for these cases.
registerProcedure :: Offset -> Function -> Translate ()
registerProcedure :: Int -> Function -> Translate ()
registerProcedure Int
o Function
func = do
  Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get

  let i :: Identifier
i = Function -> Identifier
functionName Function
func
  let known :: Map Identifier Function
known = Environment -> Map Identifier Function
environmentFunctions Environment
env
  let defined :: Bool
defined = Identifier -> Map Identifier Function -> Bool
forall κ ν. Key κ => κ -> Map κ ν -> Bool
containsKey Identifier
i Map Identifier Function
known

  Bool -> Translate () -> Translate ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
defined (Translate () -> Translate ()) -> Translate () -> Translate ()
forall a b. (a -> b) -> a -> b
$ do
    Int -> FailureReason -> Translate ()
forall a. Int -> FailureReason -> Translate a
failBecause Int
o (Identifier -> FailureReason
ProcedureAlreadyDeclared Identifier
i)

  let known' :: Map Identifier Function
known' = Identifier
-> Function -> Map Identifier Function -> Map Identifier Function
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue Identifier
i Function
func Map Identifier Function
known
  let env' :: Environment
env' = Environment
env {environmentFunctions :: Map Identifier Function
environmentFunctions = Map Identifier Function
known'}

  Environment -> Translate ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Environment
env'

-- the overloading of throw between MonadError / ExceptT and the GHC
-- exceptions mechansism is unfortunate. We're not throwing an exception,
-- end it's definitely not pure `error`. Wrap it for clarity.
failBecause :: Offset -> FailureReason -> Translate a
failBecause :: Int -> FailureReason -> Translate a
failBecause Int
o FailureReason
reason = do
  Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get
  let source :: Source
source = Environment -> Source
environmentSource Environment
env
  let source' :: Source
source' = Source
source {sourceOffset :: Int
sourceOffset = Int
o}

  let failure :: CompilationError
failure = Source -> FailureReason -> CompilationError
CompilationError Source
source' FailureReason
reason
  CompilationError -> Translate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CompilationError
failure

lookupVariable :: Offset -> Identifier -> Translate Name
lookupVariable :: Int -> Identifier -> Translate Name
lookupVariable Int
o Identifier
i = do
  Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get
  let known :: Maybe Name
known = Identifier -> Map Identifier Name -> Maybe Name
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Identifier
i (Environment -> Map Identifier Name
environmentVariables Environment
env)

  case Maybe Name
known of
    Just Name
name -> Name -> Translate Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
    Maybe Name
Nothing -> Int -> FailureReason -> Translate Name
forall a. Int -> FailureReason -> Translate a
failBecause Int
o (Identifier -> FailureReason
UseOfUnknownIdentifier Identifier
i)

-- |
-- Identifiers are valid names but Names are unique, so that we can put
-- them into the environment map. This is where we check for reuse of an
-- already declared name (TODO) and given the local use of the identifier a
-- scope-local (or globally?) unique name.
insertVariable :: Offset -> Identifier -> Translate Name
insertVariable :: Int -> Identifier -> Translate Name
insertVariable Int
o Identifier
i = do
  Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get
  let known :: Map Identifier Name
known = Environment -> Map Identifier Name
environmentVariables Environment
env

  Bool -> Translate () -> Translate ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Identifier -> Map Identifier Name -> Bool
forall κ ν. Key κ => κ -> Map κ ν -> Bool
containsKey Identifier
i Map Identifier Name
known) (Translate () -> Translate ()) -> Translate () -> Translate ()
forall a b. (a -> b) -> a -> b
$ do
    Int -> FailureReason -> Translate ()
forall a. Int -> FailureReason -> Translate a
failBecause Int
o (Identifier -> FailureReason
VariableAlreadyInUse Identifier
i)

  let n :: Name
n = Rope -> Name
Name (Char -> Rope
singletonRope Char
'!' Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Identifier -> Rope
unIdentifier Identifier
i) -- TODO
  let known' :: Map Identifier Name
known' = Identifier -> Name -> Map Identifier Name -> Map Identifier Name
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue Identifier
i Name
n Map Identifier Name
known
  let env' :: Environment
env' = Environment
env {environmentVariables :: Map Identifier Name
environmentVariables = Map Identifier Name
known'}
  Environment -> Translate ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Environment
env'
  Name -> Translate Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n

-- |
-- Accumulate a Step.
appendStep :: Step -> Translate ()
appendStep :: Step -> Translate ()
appendStep Step
step = do
  Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get
  let steps :: Step
steps = Environment -> Step
environmentAccumulated Environment
env

  -- see the Monoid instance for Step for the clever here
  let steps' :: Step
steps' = Step -> Step -> Step
forall a. Monoid a => a -> a -> a
mappend Step
steps Step
step

  let env' :: Environment
env' = Environment
env {environmentAccumulated :: Step
environmentAccumulated = Step
steps'}
  Environment -> Translate ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Environment
env'

-- |
-- This begins a new (more refined) scope and does *not* add its
-- declarations or variables to the current environment.
applyRestriction :: Attribute -> Block -> Translate Step
applyRestriction :: Attribute -> Block -> Translate Step
applyRestriction Attribute
attr Block
block = do
  Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get

  let subenv :: Environment
subenv =
        Environment
env
          { environmentRole :: Attribute
environmentRole = Attribute
attr
          }

  let result :: Either CompilationError (Step, Environment)
result = Environment
-> Translate Step -> Either CompilationError (Step, Environment)
forall a.
Environment
-> Translate a -> Either CompilationError (a, Environment)
runTranslate Environment
subenv (Block -> Translate Step
translateBlock Block
block)

  case Either CompilationError (Step, Environment)
result of
    Left CompilationError
e -> CompilationError -> Translate Step
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CompilationError
e
    Right (Step
steps, Environment
_) -> Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return Step
steps

-----------------------------------------------------------------------------

-- |
-- The second stage of translation phase: iterate through the Steps and
-- where a function call is made, look up to see if we actually know what
-- it is.
resolveFunctions :: Step -> Translate Step
resolveFunctions :: Step -> Translate Step
resolveFunctions Step
step = case Step
step of
  Invocation Int
o Attribute
attr Function
func Step
substep -> do
    Function
func' <- Int -> Function -> Translate Function
lookupFunction Int
o Function
func
    Step
substep' <- Step -> Translate Step
resolveFunctions Step
substep
    Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Attribute -> Function -> Step -> Step
Invocation Int
o Attribute
attr Function
func' Step
substep')
  Tuple Int
o [Step]
substeps -> do
    [Step]
substeps' <- (Step -> Translate Step) -> [Step] -> Translate [Step]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Step -> Translate Step
resolveFunctions [Step]
substeps
    Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Step] -> Step
Tuple Int
o [Step]
substeps')
  Asynchronous Int
o [Name]
names Step
substep -> do
    Step
substep' <- Step -> Translate Step
resolveFunctions Step
substep
    Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Name] -> Step -> Step
Asynchronous Int
o [Name]
names Step
substep')
  Nested Int
o DList Step
sublist -> do
    let actual :: [Step]
actual = DList Step -> [Step]
forall a. DList a -> [a]
toList DList Step
sublist
    [Step]
actual' <- (Step -> Translate Step) -> [Step] -> Translate [Step]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Step -> Translate Step
resolveFunctions [Step]
actual
    let sublist' :: DList Step
sublist' = [Step] -> DList Step
forall a. [a] -> DList a
fromList [Step]
actual'
    Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> DList Step -> Step
Nested Int
o DList Step
sublist')
  Bench Int
o [(Label, Step)]
pairs -> do
    [(Label, Step)]
pairs' <- ((Label, Step) -> Translate (Label, Step))
-> [(Label, Step)] -> Translate [(Label, Step)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Label, Step) -> Translate (Label, Step)
f [(Label, Step)]
pairs
    Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [(Label, Step)] -> Step
Bench Int
o [(Label, Step)]
pairs')
    where
      f :: (Label, Step) -> Translate (Label, Step)
      f :: (Label, Step) -> Translate (Label, Step)
f (Label
label, Step
substep) = do
        Step
substep' <- Step -> Translate Step
resolveFunctions Step
substep
        (Label, Step) -> Translate (Label, Step)
forall (m :: * -> *) a. Monad m => a -> m a
return (Label
label, Step
substep')
  Known Int
_ Value
_ -> Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return Step
step
  Depends Int
_ Name
_ -> Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return Step
step
  Step
NoOp -> Step -> Translate Step
forall (m :: * -> *) a. Monad m => a -> m a
return Step
step

lookupFunction :: Offset -> Function -> Translate Function
lookupFunction :: Int -> Function -> Translate Function
lookupFunction Int
o Function
func = do
  Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get

  let i :: Identifier
i = Function -> Identifier
functionName Function
func
      known :: Map Identifier Function
known = Environment -> Map Identifier Function
environmentFunctions Environment
env
      result :: Maybe Function
result = Identifier -> Map Identifier Function -> Maybe Function
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Identifier
i Map Identifier Function
known

  case Maybe Function
result of
    Maybe Function
Nothing -> Int -> FailureReason -> Translate Function
forall a. Int -> FailureReason -> Translate a
failBecause Int
o (Identifier -> FailureReason
CallToUnknownProcedure Identifier
i)
    Just Function
actual -> Function -> Translate Function
forall (m :: * -> *) a. Monad m => a -> m a
return Function
actual

-- |
-- Update the environment's idea of where in the source we are, so that if
-- we need to generate an error message we can offer one with position
-- information.
setLocationFrom :: (Located a) => a -> Translate ()
setLocationFrom :: a -> Translate ()
setLocationFrom a
thing = do
  Environment
env <- Translate Environment
forall s (m :: * -> *). MonadState s m => m s
get
  let source :: Source
source = Environment -> Source
environmentSource Environment
env
  let o :: Int
o = a -> Int
forall a. Located a => a -> Int
locationOf a
thing
  let source' :: Source
source' = Source
source {sourceOffset :: Int
sourceOffset = Int
o}
  let env' :: Environment
env' = Environment
env {environmentSource :: Source
environmentSource = Source
source'}
  Environment -> Translate ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Environment
env'