{- -----------------------------------------------------------------------------
Copyright 2019-2021,2023 Kevin P. Barry

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
----------------------------------------------------------------------------- -}

-- Author: Kevin P. Barry [ta0kira@gmail.com]

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}

module Compilation.ProcedureContext (
  ExprMap,
  ProcedureContext(..),
  ReturnValidation(..),
  updateArgVariables,
  updateReturnVariables,
) where

import Control.Monad (foldM,when)
import Data.List (nub)
import Data.Maybe (fromJust,isJust)
import Lens.Micro hiding (mapped)
import Lens.Micro.TH
import qualified Data.Map as Map
import qualified Data.Set as Set

import Base.CompilerError
import Base.GeneralType
import Base.MergeTree
import Base.Positional
import Compilation.CompilerState
import Types.DefinedCategory
import Types.Function
import Types.Procedure
import Types.TypeCategory
import Types.TypeInstance


type ExprMap c = Map.Map MacroName (Expression c)

data ReturnValidation c =
  ValidatePositions {
    forall c. ReturnValidation c -> Positional (PassedValue c)
vpReturns :: Positional (PassedValue c)
  } |
  ValidateNames {
    forall c. ReturnValidation c -> Positional VariableName
vnNames :: Positional VariableName,
    forall c. ReturnValidation c -> Positional (PassedValue c)
vnTypes :: Positional (PassedValue c),
    forall c. ReturnValidation c -> DeferVariable c
vnRemaining :: DeferVariable c
  }
  deriving (Int -> ReturnValidation c -> ShowS
forall c. Show c => Int -> ReturnValidation c -> ShowS
forall c. Show c => [ReturnValidation c] -> ShowS
forall c. Show c => ReturnValidation c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReturnValidation c] -> ShowS
$cshowList :: forall c. Show c => [ReturnValidation c] -> ShowS
show :: ReturnValidation c -> String
$cshow :: forall c. Show c => ReturnValidation c -> String
showsPrec :: Int -> ReturnValidation c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> ReturnValidation c -> ShowS
Show)

data ProcedureContext c =
  ProcedureContext {
    forall c. ProcedureContext c -> SymbolScope
_pcScope :: SymbolScope,
    forall c. ProcedureContext c -> CategoryName
_pcType :: CategoryName,
    forall c. ProcedureContext c -> Positional (ValueParam c)
_pcExtParams :: Positional (ValueParam c),
    forall c. ProcedureContext c -> [DefinedMember c]
_pcMembers :: [DefinedMember c],
    forall c. ProcedureContext c -> CategoryMap c
_pcCategories :: CategoryMap c,
    forall c. ProcedureContext c -> ParamFilters
_pcAllFilters :: ParamFilters,
    forall c. ProcedureContext c -> [ParamFilter c]
_pcExtFilters :: [ParamFilter c],
    forall c. ProcedureContext c -> Map ParamName SymbolScope
_pcParamScopes :: Map.Map ParamName SymbolScope,
    forall c. ProcedureContext c -> Map FunctionName (ScopedFunction c)
_pcFunctions :: Map.Map FunctionName (ScopedFunction c),
    forall c. ProcedureContext c -> Map VariableName (VariableValue c)
_pcVariables :: Map.Map VariableName (VariableValue c),
    forall c. ProcedureContext c -> ReturnValidation c
_pcReturns :: ReturnValidation c,
    forall c. ProcedureContext c -> DeferVariable c
_pcDeferred :: DeferVariable c,
    forall c. ProcedureContext c -> JumpType
_pcJumpType :: JumpType,
    forall c. ProcedureContext c -> Bool
_pcIsNamed :: Bool,
    forall c. ProcedureContext c -> [ReturnVariable]
_pcPrimNamed :: [ReturnVariable],
    forall c. ProcedureContext c -> Set CategoryName
_pcRequiredTypes :: Set.Set CategoryName,
    forall c. ProcedureContext c -> [String]
_pcOutput :: [String],
    forall c. ProcedureContext c -> Bool
_pcDisallowInit :: Bool,
    forall c. ProcedureContext c -> LoopSetup [String]
_pcLoopSetup :: LoopSetup [String],
    forall c. ProcedureContext c -> [Maybe (CleanupBlock c [String])]
_pcCleanupBlocks :: [Maybe (CleanupBlock c [String])],
    forall c. ProcedureContext c -> Bool
_pcInCleanup :: Bool,
    forall c. ProcedureContext c -> [UsedVariable c]
_pcUsedVars :: [UsedVariable c],
    forall c. ProcedureContext c -> ExprMap c
_pcExprMap :: ExprMap c,
    forall c. ProcedureContext c -> [(MacroName, [c])]
_pcReservedMacros :: [(MacroName,[c])],
    forall c. ProcedureContext c -> Bool
_pcNoTrace :: Bool,
    forall c. ProcedureContext c -> Bool
_pcTestsOnly :: Bool,
    forall c. ProcedureContext c -> [String]
_pcTraces :: [String],
    forall c.
ProcedureContext c
-> Maybe
     (Positional ParamName,
      Positional (Maybe (CallArgLabel c), InputValue c))
_pcParentCall :: Maybe (Positional ParamName,Positional (Maybe (CallArgLabel c), InputValue c))
  }

$(makeLenses ''ProcedureContext)

instance (Show c, CollectErrorsM m) =>
  CompilerContext c m [String] (ProcedureContext c) where
  ccCurrentScope :: ProcedureContext c -> m SymbolScope
ccCurrentScope = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) SymbolScope
pcScope)
  ccResolver :: ProcedureContext c -> m AnyTypeResolver
ccResolver = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. TypeResolver r => r -> AnyTypeResolver
AnyTypeResolver forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. CategoryMap c -> CategoryResolver c
CategoryResolver forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (CategoryMap c)
pcCategories)
  ccSameType :: ProcedureContext c -> TypeInstance -> m Bool
ccSameType ProcedureContext c
ctx TypeInstance
t
    | ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) SymbolScope
pcScope forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Bool
otherwise = forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m TypeInstance
ccSelfType ProcedureContext c
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== TypeInstance
t)
  ccSelfType :: ProcedureContext c -> m TypeInstance
ccSelfType ProcedureContext c
ctx
    | ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) SymbolScope
pcScope forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
ParamSelf forall a. [a] -> [a] -> [a]
++ String
" not found"
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CategoryName -> InstanceParams -> TypeInstance
TypeInstance (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType)
                                        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ValueParam c -> ParamName
vpParam) forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (Positional (ValueParam c))
pcExtParams)
  ccAllFilters :: ProcedureContext c -> m ParamFilters
ccAllFilters = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) ParamFilters
pcAllFilters)
  ccGetParamScope :: ProcedureContext c -> ParamName -> m SymbolScope
ccGetParamScope ProcedureContext c
ctx ParamName
p = do
    case ParamName
p forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (Map ParamName SymbolScope)
pcParamScopes) of
            (Just SymbolScope
s) -> forall (m :: * -> *) a. Monad m => a -> m a
return SymbolScope
s
            Maybe SymbolScope
_ -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
p forall a. [a] -> [a] -> [a]
++ String
" not found"
  ccAddRequired :: ProcedureContext c -> Set CategoryName -> m (ProcedureContext c)
ccAddRequired ProcedureContext c
ctx Set CategoryName
ts = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) (Set CategoryName)
pcRequiredTypes forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set CategoryName
ts
  ccGetRequired :: ProcedureContext c -> m (Set CategoryName)
ccGetRequired = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (Set CategoryName)
pcRequiredTypes)
  ccGetCategoryFunction :: ProcedureContext c
-> [c]
-> Maybe CategoryName
-> FunctionName
-> m (ScopedFunction c)
ccGetCategoryFunction ProcedureContext c
ctx [c]
c Maybe CategoryName
Nothing FunctionName
n = forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a
-> [c]
-> Maybe CategoryName
-> FunctionName
-> m (ScopedFunction c)
ccGetCategoryFunction ProcedureContext c
ctx [c]
c (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType) FunctionName
n
  ccGetCategoryFunction ProcedureContext c
ctx [c]
c (Just CategoryName
t) FunctionName
n = m (ScopedFunction c)
getFunction where
    getFunction :: m (ScopedFunction c)
getFunction
      -- Same category as the procedure itself.
      | CategoryName
t forall a. Eq a => a -> a -> Bool
== ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType = forall {m :: * -> *} {c}.
ErrorContextM m =>
Maybe (ScopedFunction c) -> m (ScopedFunction c)
checkFunction forall a b. (a -> b) -> a -> b
$ FunctionName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens' (ProcedureContext c) (Map FunctionName (ScopedFunction c))
pcFunctions)
      -- A different category than the procedure.
      | Bool
otherwise = do
        ([c]
_,AnyCategory c
ca) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (CategoryMap c)
pcCategories) ([c]
c,CategoryName
t)
        let fa :: Map FunctionName (ScopedFunction c)
fa = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f,ScopedFunction c
f)) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
ca
        forall {m :: * -> *} {c}.
ErrorContextM m =>
Maybe (ScopedFunction c) -> m (ScopedFunction c)
checkFunction forall a b. (a -> b) -> a -> b
$ FunctionName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map FunctionName (ScopedFunction c)
fa
    checkFunction :: Maybe (ScopedFunction c) -> m (ScopedFunction c)
checkFunction (Just ScopedFunction c
f) = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcDisallowInit Bool -> Bool -> Bool
&& CategoryName
t forall a. Eq a => a -> a -> Bool
== ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType Bool -> Bool -> Bool
&& ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) SymbolScope
pcScope forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++
                       String
" disallowed during initialization" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f forall a. Eq a => a -> a -> Bool
/= SymbolScope
CategoryScope) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
t forall a. [a] -> [a] -> [a]
++ String
" cannot be used as a category function"
      forall (m :: * -> *) a. Monad m => a -> m a
return ScopedFunction c
f
    checkFunction Maybe (ScopedFunction c)
_ =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
t forall a. [a] -> [a] -> [a]
++
                       String
" does not have a category function named " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++
                       forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  ccGetTypeFunction :: ProcedureContext c
-> [c]
-> Maybe GeneralInstance
-> FunctionName
-> m (ScopedFunction c)
ccGetTypeFunction ProcedureContext c
ctx [c]
c Maybe GeneralInstance
t FunctionName
n = do
    GeneralInstance
t' <- case ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) SymbolScope
pcScope of
               SymbolScope
CategoryScope -> case Maybe GeneralInstance
t of
                                     Maybe GeneralInstance
Nothing -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType) forall a. [a] -> [a] -> [a]
++
                                                                  String
" does not have a category function named " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++
                                                                  forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
                                     Just GeneralInstance
t0 -> forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
t0
               SymbolScope
_ -> do
                 GeneralInstance
self <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstance -> TypeInstanceOrParam
JustTypeInstance) forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m TypeInstance
ccSelfType ProcedureContext c
ctx
                 case Maybe GeneralInstance
t of
                      Just GeneralInstance
t0 -> forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self GeneralInstance
t0
                      Maybe GeneralInstance
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
self
    ScopedFunction c
f <- forall {m :: * -> *}.
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m (ScopedFunction c)
getFunction GeneralInstance
t' GeneralInstance
t'
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType forall a. Eq a => a -> a -> Bool
/= forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f Bool -> Bool -> Bool
&& ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType forall a. Eq a => a -> a -> Bool
/= CategoryName
CategoryNone) forall a b. (a -> b) -> a -> b
$
      String
"In call to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> forall {m :: * -> *} {c} {c}.
(CollectErrorsM m, Show c, Show c) =>
SymbolScope -> FunctionVisibility c -> ScopedFunction c -> m ()
checkVisibility (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) SymbolScope
pcScope) (forall c. ScopedFunction c -> FunctionVisibility c
sfVisibility ScopedFunction c
f) ScopedFunction c
f
    forall (m :: * -> *) a. Monad m => a -> m a
return ScopedFunction c
f where
      checkVisibility :: SymbolScope -> FunctionVisibility c -> ScopedFunction c -> m ()
checkVisibility SymbolScope
_ FunctionVisibility c
FunctionVisibilityDefault ScopedFunction c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      checkVisibility SymbolScope
CategoryScope FunctionVisibility c
v ScopedFunction c
_ = String
"Function restricted to @type and @value contexts" forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (forall a. Show a => a -> String
show FunctionVisibility c
v)
      checkVisibility SymbolScope
_ FunctionVisibility c
_ ScopedFunction c
f = do
        AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m AnyTypeResolver
ccResolver ProcedureContext c
ctx
        ParamFilters
allFilters <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m ParamFilters
ccAllFilters ProcedureContext c
ctx
        GeneralInstance
self <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstance -> TypeInstanceOrParam
JustTypeInstance) forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m TypeInstance
ccSelfType ProcedureContext c
ctx
        forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ScopedFunction c -> GeneralInstance -> m ()
checkFunctionCallVisibility AnyTypeResolver
r ParamFilters
allFilters ScopedFunction c
f GeneralInstance
self
      multipleMatchError :: a -> [a] -> m a
multipleMatchError a
t2 [a]
fs = do
        String
"Multiple matches for function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" called on " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
t2 forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
!!>
          forall (m :: * -> *) a. CollectErrorsM m => [String] -> m a
mapErrorsM (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [a]
fs)
      tryMergeFrom :: [ScopedFunction c] -> ScopedFunction c -> m (ScopedFunction c)
tryMergeFrom [ScopedFunction c]
fs ScopedFunction c
f = do
        forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {c} {c}.
(CollectErrorsM m, Show c, Show c) =>
ScopedFunction c -> ScopedFunction c -> m ()
tryMergeFunc ScopedFunction c
f) [ScopedFunction c]
fs
        forall (m :: * -> *) a. Monad m => a -> m a
return ScopedFunction c
f
      tryMergeTo :: [ScopedFunction c] -> ScopedFunction c -> m (ScopedFunction c)
tryMergeTo [ScopedFunction c]
fs ScopedFunction c
f = do
        forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {m :: * -> *} {c} {c}.
(CollectErrorsM m, Show c, Show c) =>
ScopedFunction c -> ScopedFunction c -> m ()
tryMergeFunc ScopedFunction c
f) [ScopedFunction c]
fs
        forall (m :: * -> *) a. Monad m => a -> m a
return ScopedFunction c
f
      tryMergeFunc :: ScopedFunction c -> ScopedFunction c -> m ()
tryMergeFunc ScopedFunction c
f1 ScopedFunction c
f2 = do
        FunctionType
f1' <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f1
        FunctionType
f2' <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f2
        AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m AnyTypeResolver
ccResolver ProcedureContext c
ctx
        ParamFilters
allFilters <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m ParamFilters
ccAllFilters ProcedureContext c
ctx
        forall (m :: * -> *) a. CollectErrorsM m => m a -> m a
silenceErrorsM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ParamValues
-> FunctionType
-> FunctionType
-> m ()
checkFunctionConvert AnyTypeResolver
r ParamFilters
allFilters forall k a. Map k a
Map.empty FunctionType
f2' FunctionType
f1'
      getFunction :: GeneralInstance -> GeneralInstance -> m (ScopedFunction c)
getFunction GeneralInstance
t0 GeneralInstance
t2 = forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree forall {m :: * -> *} {f :: * -> *} {a}.
(CollectErrorsM m, Foldable f, Show a) =>
f (m (ScopedFunction a)) -> m (ScopedFunction a)
getFromAny forall {m :: * -> *} {f :: * -> *} {c}.
(Foldable f, CollectErrorsM m, Show c) =>
f (m (ScopedFunction c)) -> m (ScopedFunction c)
getFromAll (GeneralInstance -> TypeInstanceOrParam -> m (ScopedFunction c)
getFromSingle GeneralInstance
t0) GeneralInstance
t2
      getFromAny :: f (m (ScopedFunction a)) -> m (ScopedFunction a)
getFromAny f (m (ScopedFunction a))
fs = do
        let (Just GeneralInstance
t') = Maybe GeneralInstance
t  -- #self will never be a union.
        [ScopedFunction a]
fs2 <- forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAllM f (m (ScopedFunction a))
fs forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!! String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" is not available for type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralInstance
t' forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
        case forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction a
f -> (forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction a
f,forall c. ScopedFunction c -> [c]
sfContext ScopedFunction a
f)) [ScopedFunction a]
fs2 of
             -- For unions, we want the most general rather than the least
             -- general. Since the top level finds the least general, we can
             -- only return one match here.
             [(CategoryName, [a])
_] -> forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {c} {c}.
(CollectErrorsM m, Show c, Show c) =>
[ScopedFunction c] -> ScopedFunction c -> m (ScopedFunction c)
tryMergeTo [ScopedFunction a]
fs2) [ScopedFunction a]
fs2 forall a. [a] -> [a] -> [a]
++ [forall {m :: * -> *} {a} {a} {a}.
(CollectErrorsM m, Show a, Show a) =>
a -> [a] -> m a
multipleMatchError GeneralInstance
t' [ScopedFunction a]
fs2]
             [] -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" is not available for type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralInstance
t' forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
             [(CategoryName, [a])]
cs -> String
"Use an explicit conversion to call " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" for type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralInstance
t' forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
!!>
               forall (m :: * -> *) a. CollectErrorsM m => [String] -> m a
mapErrorsM (forall a b. (a -> b) -> [a] -> [b]
map (\(CategoryName
t2,[a]
c2) -> String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
t2 forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2) [(CategoryName, [a])]
cs)
      getFromAll :: f (m (ScopedFunction c)) -> m (ScopedFunction c)
getFromAll f (m (ScopedFunction c))
fs = do
        let (Just GeneralInstance
t') = Maybe GeneralInstance
t  -- #self will never be an intersection.
        forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectFirstM_ f (m (ScopedFunction c))
fs forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!!
          String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" is not available for type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralInstance
t' forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
        [ScopedFunction c]
fs2 <- forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAnyM f (m (ScopedFunction c))
fs
        forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {c} {c}.
(CollectErrorsM m, Show c, Show c) =>
[ScopedFunction c] -> ScopedFunction c -> m (ScopedFunction c)
tryMergeFrom [ScopedFunction c]
fs2) [ScopedFunction c]
fs2 forall a. [a] -> [a] -> [a]
++ [forall {m :: * -> *} {a} {a} {a}.
(CollectErrorsM m, Show a, Show a) =>
a -> [a] -> m a
multipleMatchError GeneralInstance
t' [ScopedFunction c]
fs2]
      getFromSingle :: GeneralInstance -> TypeInstanceOrParam -> m (ScopedFunction c)
getFromSingle GeneralInstance
t0 (JustParamName Bool
_ ParamName
p) = do
        ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m ParamFilters
ccAllFilters ProcedureContext c
ctx
        [TypeFilter]
ff <- case ParamName
p forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` ParamFilters
fa of
                   (Just [TypeFilter]
fs) -> forall (m :: * -> *) a. Monad m => a -> m a
return [TypeFilter]
fs
                   Maybe [TypeFilter]
_ -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
p forall a. [a] -> [a] -> [a]
++ String
" not found"
        let ts :: [GeneralInstance]
ts = forall a b. (a -> b) -> [a] -> [b]
map TypeFilter -> GeneralInstance
tfType forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter TypeFilter -> Bool
isRequiresFilter [TypeFilter]
ff
        let ds :: [DefinesInstance]
ds = forall a b. (a -> b) -> [a] -> [b]
map TypeFilter -> DefinesInstance
dfType forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter TypeFilter -> Bool
isDefinesFilter  [TypeFilter]
ff
        let fs :: [m (ScopedFunction c)]
fs = forall a b. (a -> b) -> [a] -> [b]
map (GeneralInstance -> GeneralInstance -> m (ScopedFunction c)
getFunction GeneralInstance
t0) [GeneralInstance]
ts forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *}.
CollectErrorsM m =>
GeneralInstance -> DefinesInstance -> m (ScopedFunction c)
checkDefine GeneralInstance
t0) [DefinesInstance]
ds
        forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectFirstM_ [m (ScopedFunction c)]
fs forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!!
          String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" not available for param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
p forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
        [ScopedFunction c]
fs2 <- forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAnyM [m (ScopedFunction c)]
fs
        forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {c} {c}.
(CollectErrorsM m, Show c, Show c) =>
[ScopedFunction c] -> ScopedFunction c -> m (ScopedFunction c)
tryMergeFrom [ScopedFunction c]
fs2) [ScopedFunction c]
fs2 forall a. [a] -> [a] -> [a]
++ [forall {m :: * -> *} {a} {a} {a}.
(CollectErrorsM m, Show a, Show a) =>
a -> [a] -> m a
multipleMatchError ParamName
p [ScopedFunction c]
fs2]
      getFromSingle GeneralInstance
t0 (JustTypeInstance TypeInstance
t2)
        -- Same category as the procedure itself.
        | TypeInstance -> CategoryName
tiName TypeInstance
t2 forall a. Eq a => a -> a -> Bool
== ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType =
          forall {m :: * -> *} {c}.
(CollectErrorsM m, Show c) =>
GeneralInstance
-> CategoryName
-> Positional ParamName
-> InstanceParams
-> Maybe (ScopedFunction c)
-> m (ScopedFunction c)
subAndCheckFunction GeneralInstance
t0 (TypeInstance -> CategoryName
tiName TypeInstance
t2) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (Positional (ValueParam c))
pcExtParams) (TypeInstance -> InstanceParams
tiParams TypeInstance
t2) forall a b. (a -> b) -> a -> b
$ FunctionName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens' (ProcedureContext c) (Map FunctionName (ScopedFunction c))
pcFunctions)
        -- A different category than the procedure.
        | Bool
otherwise = do
          ([c]
_,AnyCategory c
ca) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (CategoryMap c)
pcCategories) ([c]
c,TypeInstance -> CategoryName
tiName TypeInstance
t2)
          let params :: Positional ParamName
params = forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
ca
          let fa :: Map FunctionName (ScopedFunction c)
fa = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f,ScopedFunction c
f)) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
ca
          forall {m :: * -> *} {c}.
(CollectErrorsM m, Show c) =>
GeneralInstance
-> CategoryName
-> Positional ParamName
-> InstanceParams
-> Maybe (ScopedFunction c)
-> m (ScopedFunction c)
subAndCheckFunction GeneralInstance
t0 (TypeInstance -> CategoryName
tiName TypeInstance
t2) Positional ParamName
params (TypeInstance -> InstanceParams
tiParams TypeInstance
t2) forall a b. (a -> b) -> a -> b
$ FunctionName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map FunctionName (ScopedFunction c)
fa
      getFromSingle GeneralInstance
_ TypeInstanceOrParam
_ = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe GeneralInstance
t forall a. [a] -> [a] -> [a]
++ String
" contains unresolved types"
      checkDefine :: GeneralInstance -> DefinesInstance -> m (ScopedFunction c)
checkDefine GeneralInstance
t0 DefinesInstance
t2 = do
        ([c]
_,AnyCategory c
ca) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (CategoryMap c)
pcCategories) ([c]
c,DefinesInstance -> CategoryName
diName DefinesInstance
t2)
        let params :: Positional ParamName
params = forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
ca
        let fa :: Map FunctionName (ScopedFunction c)
fa = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f,ScopedFunction c
f)) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
ca
        forall {m :: * -> *} {c}.
(CollectErrorsM m, Show c) =>
GeneralInstance
-> CategoryName
-> Positional ParamName
-> InstanceParams
-> Maybe (ScopedFunction c)
-> m (ScopedFunction c)
subAndCheckFunction GeneralInstance
t0 (DefinesInstance -> CategoryName
diName DefinesInstance
t2) Positional ParamName
params (DefinesInstance -> InstanceParams
diParams DefinesInstance
t2) forall a b. (a -> b) -> a -> b
$ FunctionName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map FunctionName (ScopedFunction c)
fa
      subAndCheckFunction :: GeneralInstance
-> CategoryName
-> Positional ParamName
-> InstanceParams
-> Maybe (ScopedFunction c)
-> m (ScopedFunction c)
subAndCheckFunction GeneralInstance
t0 CategoryName
t2 Positional ParamName
ps1 InstanceParams
ps2 (Just ScopedFunction c
f) = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcDisallowInit Bool -> Bool -> Bool
&& CategoryName
t2 forall a. Eq a => a -> a -> Bool
== ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++
                           String
" disallowed during initialization" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
t2 forall a. [a] -> [a] -> [a]
++
                           String
" is a category function" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
        [(ParamName, GeneralInstance)]
paired <- forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair Positional ParamName
ps1 InstanceParams
ps2 forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
          String
"In external function call at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
        let assigned :: ParamValues
assigned = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ParamName, GeneralInstance)]
paired
        forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ParamValues -> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction ParamValues
assigned ScopedFunction c
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction (GeneralInstance -> GeneralInstance
fixTypeParams GeneralInstance
t0)
      subAndCheckFunction GeneralInstance
_ CategoryName
t2 Positional ParamName
_ InstanceParams
_ Maybe (ScopedFunction c)
_ =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
t2 forall a. [a] -> [a] -> [a]
++
                         String
" does not have a type or value function named " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  ccCheckValueInit :: ProcedureContext c -> [c] -> TypeInstance -> ExpressionType -> m ()
ccCheckValueInit ProcedureContext c
ctx [c]
c (TypeInstance CategoryName
t InstanceParams
as) ExpressionType
ts
    | CategoryName
t forall a. Eq a => a -> a -> Bool
/= ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType) forall a. [a] -> [a] -> [a]
++ String
" cannot initialize values from " forall a. [a] -> [a] -> [a]
++
                     forall a. Show a => a -> String
show CategoryName
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
    | Bool
otherwise = String
"In initialization at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      let t' :: TypeInstance
t' = CategoryName -> InstanceParams -> TypeInstance
TypeInstance (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) CategoryName
pcType) InstanceParams
as
      AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m AnyTypeResolver
ccResolver ProcedureContext c
ctx
      ParamFilters
allFilters <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m ParamFilters
ccAllFilters ProcedureContext c
ctx
      ParamValues
pa  <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (Positional (ValueParam c))
pcExtParams) InstanceParams
as
      forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> TypeInstance -> m ()
validateTypeInstanceForCall AnyTypeResolver
r ParamFilters
allFilters TypeInstance
t'
      -- Check initializer types.
      Positional (MemberValue c)
ms <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {c}.
CollectErrorsM m =>
ParamValues -> DefinedMember c -> m (MemberValue c)
subSingle ParamValues
pa) (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [DefinedMember c]
pcMembers)
      -- Do a size comparison first so that the error message is readable.
      forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. MemberValue c -> ValueType
mvType Positional (MemberValue c)
ms) ExpressionType
ts
      forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ (forall {m :: * -> *} {r} {a} {a}.
(CollectErrorsM m, TypeResolver r, Show a, Show a) =>
r -> ParamFilters -> MemberValue a -> (a, ValueType) -> m ()
checkInit AnyTypeResolver
r ParamFilters
allFilters) Positional (MemberValue c)
ms (forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1..] :: [Int]) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues ExpressionType
ts)
      forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        checkInit :: r -> ParamFilters -> MemberValue a -> (a, ValueType) -> m ()
checkInit r
r ParamFilters
fa (MemberValue [a]
c2 VariableName
n ValueType
t0) (a
i,ValueType
t1) = do
          forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment r
r ParamFilters
fa ValueType
t1 ValueType
t0 forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
            String
"In initializer " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
" for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
        subSingle :: ParamValues -> DefinedMember c -> m (MemberValue c)
subSingle ParamValues
pa (DefinedMember [c]
c2 SymbolScope
_ ValueType
t2 VariableName
n Maybe (Expression c)
_) = do
          ValueType
t2' <- forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance) -> ValueType -> m ValueType
uncheckedSubValueType (forall (m :: * -> *).
ErrorContextM m =>
ParamValues -> ParamName -> m GeneralInstance
getValueForParam ParamValues
pa) ValueType
t2
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> VariableName -> ValueType -> MemberValue c
MemberValue [c]
c2 VariableName
n ValueType
t2'
  ccGetVariable :: ProcedureContext c -> UsedVariable c -> m (VariableValue c)
ccGetVariable ProcedureContext c
ctx (UsedVariable [c]
c VariableName
n) =
    case VariableName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens' (ProcedureContext c) (Map VariableName (VariableValue c))
pcVariables) of
           (Just (VariableValue [c]
_ SymbolScope
_ ValueType
_ (VariableHidden []))) ->
             forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++
                              String
" is hidden"
           (Just (VariableValue [c]
_ SymbolScope
_ ValueType
_ (VariableHidden [c]
c2))) ->
             forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++
                              String
" was explicitly hidden at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c2
           (Just VariableValue c
v) -> forall (m :: * -> *) a. Monad m => a -> m a
return VariableValue c
v
           Maybe (VariableValue c)
_ -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++ String
" is not defined"
  ccAddVariable :: ProcedureContext c
-> UsedVariable c -> VariableValue c -> m (ProcedureContext c)
ccAddVariable ProcedureContext c
ctx (UsedVariable [c]
c VariableName
n) VariableValue c
t = do
    case VariableName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens' (ProcedureContext c) (Map VariableName (VariableValue c))
pcVariables) of
          Maybe (VariableValue c)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (Just VariableValue c
v) -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++
                                       forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++
                                       String
" is already defined: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableValue c
v
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c.
Lens' (ProcedureContext c) (Map VariableName (VariableValue c))
pcVariables forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(VariableName
n,VariableValue c
t)]
  ccSetReadOnly :: ProcedureContext c -> UsedVariable c -> m (ProcedureContext c)
ccSetReadOnly ProcedureContext c
ctx v :: UsedVariable c
v@(UsedVariable [c]
c VariableName
n) = do
    (VariableValue [c]
c2 SymbolScope
s ValueType
t VariableRule c
_) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> UsedVariable c -> m (VariableValue c)
ccGetVariable ProcedureContext c
ctx UsedVariable c
v
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c.
Lens' (ProcedureContext c) (Map VariableName (VariableValue c))
pcVariables forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert VariableName
n (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c2 SymbolScope
s ValueType
t (forall c. [c] -> VariableRule c
VariableReadOnly [c]
c))
  ccSetDeferred :: ProcedureContext c -> UsedVariable c -> m (ProcedureContext c)
ccSetDeferred ProcedureContext c
ctx v :: UsedVariable c
v@(UsedVariable [c]
c VariableName
n) = do
    (VariableValue [c]
c2 SymbolScope
_ ValueType
t VariableRule c
r) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> UsedVariable c -> m (VariableValue c)
ccGetVariable ProcedureContext c
ctx UsedVariable c
v
    case VariableRule c
r of
         VariableReadOnly [c]
c3 -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c2 forall a. [a] -> [a] -> [a]
++
                                  String
" cannot be marked as deferred " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++
                                  String
" because it is read-only" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c3
         VariableHidden [c]
c3 -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c2 forall a. [a] -> [a] -> [a]
++
                                  String
" cannot be marked as deferred " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++
                                  String
" because it is hidden" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c3
         VariableRule c
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall c.
VariableName -> PassedValue c -> DeferVariable c -> DeferVariable c
addDeferred VariableName
n (forall c. [c] -> ValueType -> PassedValue c
PassedValue [c]
c ValueType
t)
  ccSetHidden :: ProcedureContext c -> UsedVariable c -> m (ProcedureContext c)
ccSetHidden ProcedureContext c
ctx v :: UsedVariable c
v@(UsedVariable [c]
c VariableName
n) = do
    (VariableValue [c]
c2 SymbolScope
s ValueType
t VariableRule c
_) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> UsedVariable c -> m (VariableValue c)
ccGetVariable ProcedureContext c
ctx UsedVariable c
v
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c.
Lens' (ProcedureContext c) (Map VariableName (VariableValue c))
pcVariables forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert VariableName
n (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c2 SymbolScope
s ValueType
t (forall c. [c] -> VariableRule c
VariableHidden [c]
c))
  ccCheckVariableInit :: ProcedureContext c -> [UsedVariable c] -> m ()
ccCheckVariableInit ProcedureContext c
ctx [UsedVariable c]
vs
    -- Deferred variables are checked during cleanup inlining.
    | ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcInCleanup = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = do
        case ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (ReturnValidation c)
pcReturns of
              ValidateNames Positional VariableName
_ Positional (PassedValue c)
_ DeferVariable c
na -> forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {f :: * -> *} {a} {c}.
(ErrorContextM f, Show a) =>
DeferVariable c -> UsedVariable a -> f ()
checkSingle DeferVariable c
na) [UsedVariable c]
vs
              ReturnValidation c
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {f :: * -> *} {a} {c}.
(ErrorContextM f, Show a) =>
DeferVariable c -> UsedVariable a -> f ()
checkSingle forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred) [UsedVariable c]
vs
        where
          checkSingle :: DeferVariable c -> UsedVariable a -> f ()
checkSingle DeferVariable c
na (UsedVariable [a]
c VariableName
n) =
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VariableName
n forall c. VariableName -> DeferVariable c -> Bool
`checkDeferred` DeferVariable c
na) forall a b. (a -> b) -> a -> b
$
              forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Deferred variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++
                               String
" might not be initialized" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
  ccWrite :: ProcedureContext c -> [String] -> m (ProcedureContext c)
ccWrite ProcedureContext c
ctx [String]
ss = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [String]
pcOutput forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [String]
ss
  ccGetOutput :: ProcedureContext c -> m [String]
ccGetOutput = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [String]
pcOutput)
  ccClearOutput :: ProcedureContext c -> m (ProcedureContext c)
ccClearOutput ProcedureContext c
ctx = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [String]
pcOutput forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty
  ccUpdateAssigned :: ProcedureContext c -> VariableName -> m (ProcedureContext c)
ccUpdateAssigned ProcedureContext c
ctx VariableName
n = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) (ReturnValidation c)
pcReturns forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {c}. ReturnValidation c -> ReturnValidation c
updateReturns forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {c}. DeferVariable c -> DeferVariable c
updateDeferred where
    updateReturns :: ReturnValidation c -> ReturnValidation c
updateReturns (ValidateNames Positional VariableName
ns Positional (PassedValue c)
ts DeferVariable c
ra) = forall c.
Positional VariableName
-> Positional (PassedValue c)
-> DeferVariable c
-> ReturnValidation c
ValidateNames Positional VariableName
ns Positional (PassedValue c)
ts forall a b. (a -> b) -> a -> b
$ VariableName
n forall c. VariableName -> DeferVariable c -> DeferVariable c
`removeDeferred` DeferVariable c
ra
    updateReturns ReturnValidation c
rs                       = ReturnValidation c
rs
    updateDeferred :: DeferVariable c -> DeferVariable c
updateDeferred = (VariableName
n forall c. VariableName -> DeferVariable c -> DeferVariable c
`removeDeferred`)
  ccAddUsed :: ProcedureContext c -> UsedVariable c -> m (ProcedureContext c)
ccAddUsed ProcedureContext c
ctx UsedVariable c
v
    | ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcInCleanup = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [UsedVariable c]
pcUsedVars forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [UsedVariable c
v]
    | Bool
otherwise          = forall (m :: * -> *) a. Monad m => a -> m a
return ProcedureContext c
ctx
  ccInheritStatic :: ProcedureContext c
-> [ProcedureContext c] -> m (ProcedureContext c)
ccInheritStatic ProcedureContext c
ctx [] = forall (m :: * -> *) a. Monad m => a -> m a
return ProcedureContext c
ctx
  ccInheritStatic ProcedureContext c
ctx [ProcedureContext c]
cs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) (ReturnValidation c)
pcReturns forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReturnValidation c
returns forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) JumpType
pcJumpType forall s t a b. ASetter s t a b -> b -> s -> t
.~ JumpType
jump forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [UsedVariable c]
pcUsedVars forall s t a b. ASetter s t a b -> b -> s -> t
.~ [UsedVariable c]
used forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred forall s t a b. ASetter s t a b -> b -> s -> t
.~ DeferVariable c
deferred forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [String]
pcTraces forall s t a b. ASetter s t a b -> b -> s -> t
.~ [String]
traces where
    traces :: [String]
traces = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [String]
pcTraces forall a. [a] -> [a] -> [a]
++ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [String]
pcTraces) [ProcedureContext c]
cs)
    used :: [UsedVariable c]
used = ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [UsedVariable c]
pcUsedVars forall a. [a] -> [a] -> [a]
++ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [UsedVariable c]
pcUsedVars) [ProcedureContext c]
cs)
    deferred :: DeferVariable c
deferred = (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred) forall c. DeferVariable c -> DeferVariable c -> DeferVariable c
`followDeferred` DeferVariable c
deferred2
    (ReturnValidation c
returns,JumpType
jump) = forall {b} {c}.
Ord b =>
(ReturnValidation c, b)
-> (ReturnValidation c, b) -> (ReturnValidation c, b)
combineSeries (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (ReturnValidation c)
pcReturns,ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) JumpType
pcJumpType) (ReturnValidation c
returns2,JumpType
jump2)
    combineSeries :: (ReturnValidation c, b)
-> (ReturnValidation c, b) -> (ReturnValidation c, b)
combineSeries (r :: ReturnValidation c
r@(ValidatePositions Positional (PassedValue c)
_),b
j1) (ReturnValidation c
_,b
j2) = (ReturnValidation c
r,forall a. Ord a => a -> a -> a
max b
j1 b
j2)
    combineSeries (ReturnValidation c
_,b
j1) (r :: ReturnValidation c
r@(ValidatePositions Positional (PassedValue c)
_),b
j2) = (ReturnValidation c
r,forall a. Ord a => a -> a -> a
max b
j1 b
j2)
    combineSeries (ValidateNames Positional VariableName
ns Positional (PassedValue c)
ts DeferVariable c
ra1,b
j1) (ValidateNames Positional VariableName
_ Positional (PassedValue c)
_ DeferVariable c
ra2,b
j2) = (forall c.
Positional VariableName
-> Positional (PassedValue c)
-> DeferVariable c
-> ReturnValidation c
ValidateNames Positional VariableName
ns Positional (PassedValue c)
ts forall a b. (a -> b) -> a -> b
$ DeferVariable c
ra1 forall c. DeferVariable c -> DeferVariable c -> DeferVariable c
`followDeferred` DeferVariable c
ra2,forall a. Ord a => a -> a -> a
max b
j1 b
j2)
    (DeferVariable c
deferred2,ReturnValidation c
returns2,JumpType
jump2) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {c} {c}.
(DeferVariable c, ReturnValidation c, JumpType)
-> (DeferVariable c, ReturnValidation c, JumpType)
-> (DeferVariable c, ReturnValidation c, JumpType)
combineParallel (forall c. DeferVariable c
emptyDeferred,forall c.
Positional VariableName
-> Positional (PassedValue c)
-> DeferVariable c
-> ReturnValidation c
ValidateNames (forall a. [a] -> Positional a
Positional []) (forall a. [a] -> Positional a
Positional []) forall c. DeferVariable c
emptyDeferred,JumpType
JumpMax) forall a b. (a -> b) -> a -> b
$
      forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred) [ProcedureContext c]
cs) (forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (ReturnValidation c)
pcReturns) [ProcedureContext c]
cs) (forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) JumpType
pcJumpType) [ProcedureContext c]
cs)
    -- Ignore a branch if it jumps to a higher scope.
    combineParallel :: (DeferVariable c, ReturnValidation c, JumpType)
-> (DeferVariable c, ReturnValidation c, JumpType)
-> (DeferVariable c, ReturnValidation c, JumpType)
combineParallel (DeferVariable c
_,ReturnValidation c
_,JumpType
j1) (DeferVariable c
da2,ReturnValidation c
r,JumpType
j2) | JumpType
j1 forall a. Ord a => a -> a -> Bool
> JumpType
NextStatement = (DeferVariable c
da2,ReturnValidation c
r,forall a. Ord a => a -> a -> a
min JumpType
j1 JumpType
j2)
    combineParallel (DeferVariable c
da1,ValidateNames Positional VariableName
ns Positional (PassedValue c)
ts DeferVariable c
ra1,JumpType
j1) (DeferVariable c
da2,ValidateNames Positional VariableName
_ Positional (PassedValue c)
_ DeferVariable c
ra2,JumpType
j2) = (forall c. [DeferVariable c] -> DeferVariable c
branchDeferred [DeferVariable c
da1,DeferVariable c
da2],forall c.
Positional VariableName
-> Positional (PassedValue c)
-> DeferVariable c
-> ReturnValidation c
ValidateNames Positional VariableName
ns Positional (PassedValue c)
ts forall a b. (a -> b) -> a -> b
$ forall c. [DeferVariable c] -> DeferVariable c
branchDeferred [DeferVariable c
ra1,DeferVariable c
ra2],forall a. Ord a => a -> a -> a
min JumpType
j1 JumpType
j2)
    combineParallel (DeferVariable c
da1,r :: ReturnValidation c
r@(ValidatePositions Positional (PassedValue c)
_),JumpType
j1) (DeferVariable c
da2,ReturnValidation c
_,JumpType
j2) = (forall c. [DeferVariable c] -> DeferVariable c
branchDeferred [DeferVariable c
da1,DeferVariable c
da2],ReturnValidation c
r,forall a. Ord a => a -> a -> a
min JumpType
j1 JumpType
j2)
    combineParallel (DeferVariable c
da1,ReturnValidation c
_,JumpType
j1) (DeferVariable c
da2,r :: ReturnValidation c
r@(ValidatePositions Positional (PassedValue c)
_),JumpType
j2) = (forall c. [DeferVariable c] -> DeferVariable c
branchDeferred [DeferVariable c
da1,DeferVariable c
da2],ReturnValidation c
r,forall a. Ord a => a -> a -> a
min JumpType
j1 JumpType
j2)
  ccInheritDeferred :: ProcedureContext c -> DeferVariable c -> m (ProcedureContext c)
ccInheritDeferred ProcedureContext c
ctx DeferVariable c
ds = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred forall s t a b. ASetter s t a b -> b -> s -> t
.~ DeferVariable c
deferred where
    deferred :: DeferVariable c
deferred = (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred) forall c. DeferVariable c -> DeferVariable c -> DeferVariable c
`followDeferred` DeferVariable c
ds
  ccInheritUsed :: ProcedureContext c -> ProcedureContext c -> m (ProcedureContext c)
ccInheritUsed ProcedureContext c
ctx ProcedureContext c
ctx2 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [UsedVariable c]
pcUsedVars forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ (ProcedureContext c
ctx2 forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [UsedVariable c]
pcUsedVars)
  ccRegisterReturn :: ProcedureContext c
-> [c] -> Maybe ExpressionType -> m (ProcedureContext c)
ccRegisterReturn ProcedureContext c
ctx [c]
c Maybe ExpressionType
vs = do
    ReturnValidation c
returns <- forall {m :: * -> *} {c}.
(CollectErrorsM m, Show c) =>
ReturnValidation c -> m (ReturnValidation c)
check (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (ReturnValidation c)
pcReturns)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) (ReturnValidation c)
pcReturns forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReturnValidation c
returns forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) JumpType
pcJumpType forall s t a b. ASetter s t a b -> b -> s -> t
.~ JumpType
JumpReturn
    where
      check :: ReturnValidation c -> m (ReturnValidation c)
check (ValidatePositions Positional (PassedValue c)
rs) = do
        let vs' :: ExpressionType
vs' = case Maybe ExpressionType
vs of
                       Maybe ExpressionType
Nothing -> forall a. [a] -> Positional a
Positional []
                       Just ExpressionType
vs2 -> ExpressionType
vs2
        -- Check for a count match first, to avoid the default error message.
        forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. PassedValue c -> ValueType
pvType Positional (PassedValue c)
rs) ExpressionType
vs' forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
          String
"In procedure return at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
        forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ forall {m :: * -> *} {c} {a}.
(CollectErrorsM m, Show c, Show a) =>
PassedValue c -> (a, ValueType) -> m ()
checkReturnType Positional (PassedValue c)
rs (forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues ExpressionType
vs') forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
          String
"In procedure return at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall c. Positional (PassedValue c) -> ReturnValidation c
ValidatePositions Positional (PassedValue c)
rs)
        where
          checkReturnType :: PassedValue c -> (a, ValueType) -> m ()
checkReturnType ta0 :: PassedValue c
ta0@(PassedValue [c]
_ ValueType
t0) (a
n,ValueType
t) = do
            AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m AnyTypeResolver
ccResolver ProcedureContext c
ctx
            ParamFilters
pa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m ParamFilters
ccAllFilters ProcedureContext c
ctx
            forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
pa ValueType
t ValueType
t0 forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!!
              String
"Cannot convert " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
t forall a. [a] -> [a] -> [a]
++ String
" to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PassedValue c
ta0 forall a. [a] -> [a] -> [a]
++ String
" in return " forall a. [a] -> [a] -> [a]
++
               forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
      check (ValidateNames Positional VariableName
ns Positional (PassedValue c)
ts DeferVariable c
ra) = do
        case Maybe ExpressionType
vs of
             Just ExpressionType
_  -> ReturnValidation c -> m (ReturnValidation c)
check (forall c. Positional (PassedValue c) -> ReturnValidation c
ValidatePositions Positional (PassedValue c)
ts) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
             Maybe ExpressionType
Nothing -> forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall {m :: * -> *} {a} {b} {a}.
(ErrorContextM m, Show a) =>
(a, b) -> m a
alwaysError forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall c. DeferVariable c -> Map VariableName (PassedValue c)
dvDeferred DeferVariable c
ra
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall c.
Positional VariableName
-> Positional (PassedValue c)
-> DeferVariable c
-> ReturnValidation c
ValidateNames Positional VariableName
ns Positional (PassedValue c)
ts forall c. DeferVariable c
emptyDeferred)
      alwaysError :: (a, b) -> m a
alwaysError (a
n,b
_) = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Named return " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++
                                           String
" might not be initialized" forall a. [a] -> [a] -> [a]
++
                                           forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  ccPrimNamedReturns :: ProcedureContext c -> m [ReturnVariable]
ccPrimNamedReturns = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [ReturnVariable]
pcPrimNamed)
  ccIsUnreachable :: ProcedureContext c -> m Bool
ccIsUnreachable ProcedureContext c
ctx
    | ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcInCleanup = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) JumpType
pcJumpType forall a. Ord a => a -> a -> Bool
> JumpType
JumpReturn
    | Bool
otherwise          = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) JumpType
pcJumpType forall a. Ord a => a -> a -> Bool
> JumpType
NextStatement
  ccIsNamedReturns :: ProcedureContext c -> m Bool
ccIsNamedReturns = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcIsNamed)
  ccSetJumpType :: ProcedureContext c -> [c] -> JumpType -> m (ProcedureContext c)
ccSetJumpType ProcedureContext c
ctx [c]
c JumpType
j
    | ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcInCleanup Bool -> Bool -> Bool
&& JumpType
j forall a. Eq a => a -> a -> Bool
== JumpType
JumpBreak =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Explicit break at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c forall a. [a] -> [a] -> [a]
++ String
" not allowed in cleanup"
    | ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcInCleanup Bool -> Bool -> Bool
&& JumpType
j forall a. Eq a => a -> a -> Bool
== JumpType
JumpContinue =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Explicit continue at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c forall a. [a] -> [a] -> [a]
++ String
" not allowed in cleanup"
    | ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcInCleanup Bool -> Bool -> Bool
&& JumpType
j forall a. Eq a => a -> a -> Bool
== JumpType
JumpReturn =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Explicit return at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c forall a. [a] -> [a] -> [a]
++ String
" not allowed in cleanup"
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) JumpType
pcJumpType forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> a -> a
max JumpType
j
  ccStartLoop :: ProcedureContext c -> LoopSetup [String] -> m (ProcedureContext c)
ccStartLoop ProcedureContext c
ctx LoopSetup [String]
l = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) (LoopSetup [String])
pcLoopSetup forall s t a b. ASetter s t a b -> b -> s -> t
.~ LoopSetup [String]
l forall a b. a -> (a -> b) -> b
& forall c.
Lens' (ProcedureContext c) [Maybe (CleanupBlock c [String])]
pcCleanupBlocks forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Maybe a
Nothingforall a. a -> [a] -> [a]
:)
  ccGetLoop :: ProcedureContext c -> m (LoopSetup [String])
ccGetLoop = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (LoopSetup [String])
pcLoopSetup)
  ccStartCleanup :: ProcedureContext c -> [c] -> m (ProcedureContext c)
ccStartCleanup ProcedureContext c
ctx [c]
c = do
    let vars :: Map VariableName (VariableValue c)
vars = forall {c}.
ReturnValidation c
-> Map VariableName (VariableValue c)
-> Map VariableName (VariableValue c)
protectReturns (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (ReturnValidation c)
pcReturns) (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens' (ProcedureContext c) (Map VariableName (VariableValue c))
pcVariables)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c.
Lens' (ProcedureContext c) (Map VariableName (VariableValue c))
pcVariables forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map VariableName (VariableValue c)
vars forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) Bool
pcInCleanup forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True where
    protectReturns :: ReturnValidation c
-> Map VariableName (VariableValue c)
-> Map VariableName (VariableValue c)
protectReturns (ValidateNames Positional VariableName
ns Positional (PassedValue c)
_ DeferVariable c
_) Map VariableName (VariableValue c)
vs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {k}.
Ord k =>
k -> Map k (VariableValue c) -> Map k (VariableValue c)
protect Map VariableName (VariableValue c)
vs (forall a. Positional a -> [a]
pValues Positional VariableName
ns)
    protectReturns ReturnValidation c
_                      Map VariableName (VariableValue c)
vs = Map VariableName (VariableValue c)
vs
    protect :: k -> Map k (VariableValue c) -> Map k (VariableValue c)
protect k
n Map k (VariableValue c)
vs =
      case k
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map k (VariableValue c)
vs of
           Just (VariableValue [c]
c2 s :: SymbolScope
s@SymbolScope
LocalScope ValueType
t VariableRule c
_) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
n (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c2 SymbolScope
s ValueType
t (forall c. [c] -> VariableRule c
VariableReadOnly [c]
c)) Map k (VariableValue c)
vs
           Maybe (VariableValue c)
_ -> Map k (VariableValue c)
vs
  ccPushCleanup :: ProcedureContext c -> ProcedureContext c -> m (ProcedureContext c)
ccPushCleanup ProcedureContext c
ctx ProcedureContext c
ctx2 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c.
Lens' (ProcedureContext c) [Maybe (CleanupBlock c [String])]
pcCleanupBlocks forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. a -> Maybe a
Just CleanupBlock c [String]
cleanupforall a. a -> [a] -> [a]
:) forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [String]
pcTraces forall s t a b. ASetter s t a b -> b -> s -> t
.~ [String]
traces where
    traces :: [String]
traces = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [String]
pcTraces forall a. [a] -> [a] -> [a]
++ ProcedureContext c
ctx2 forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [String]
pcTraces
    cleanup :: CleanupBlock c [String]
cleanup = forall c s.
s
-> DeferVariable c
-> [UsedVariable c]
-> JumpType
-> Set CategoryName
-> CleanupBlock c s
CleanupBlock (ProcedureContext c
ctx2 forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [String]
pcOutput) (ProcedureContext c
ctx2 forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred) (ProcedureContext c
ctx2 forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [UsedVariable c]
pcUsedVars) (ProcedureContext c
ctx2 forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) JumpType
pcJumpType) (ProcedureContext c
ctx2 forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (Set CategoryName)
pcRequiredTypes)
  ccGetCleanup :: ProcedureContext c -> JumpType -> m (CleanupBlock c [String])
ccGetCleanup ProcedureContext c
ctx JumpType
j = forall (m :: * -> *) a. Monad m => a -> m a
return CleanupBlock c [String]
combined where
    combined :: CleanupBlock c [String]
combined
      | JumpType
j forall a. Eq a => a -> a -> Bool
== JumpType
NextStatement =
          case ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens' (ProcedureContext c) [Maybe (CleanupBlock c [String])]
pcCleanupBlocks of
               ((Just CleanupBlock c [String]
b):[Maybe (CleanupBlock c [String])]
_) -> CleanupBlock c [String]
b
               [Maybe (CleanupBlock c [String])]
_            -> forall s c. Monoid s => CleanupBlock c s
emptyCleanupBlock
      | JumpType
j forall a. Eq a => a -> a -> Bool
== JumpType
JumpReturn                     = forall {a}. [CleanupBlock c [a]] -> CleanupBlock c [a]
combine forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter    forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens' (ProcedureContext c) [Maybe (CleanupBlock c [String])]
pcCleanupBlocks
      | JumpType
j forall a. Eq a => a -> a -> Bool
== JumpType
JumpBreak Bool -> Bool -> Bool
|| JumpType
j forall a. Eq a => a -> a -> Bool
== JumpType
JumpContinue = forall {a}. [CleanupBlock c [a]] -> CleanupBlock c [a]
combine forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens' (ProcedureContext c) [Maybe (CleanupBlock c [String])]
pcCleanupBlocks
      | Bool
otherwise = forall s c. Monoid s => CleanupBlock c s
emptyCleanupBlock
    combine :: [CleanupBlock c [a]] -> CleanupBlock c [a]
combine [CleanupBlock c [a]]
cs = forall c s.
s
-> DeferVariable c
-> [UsedVariable c]
-> JumpType
-> Set CategoryName
-> CleanupBlock c s
CleanupBlock (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c s. CleanupBlock c s -> s
csCleanup [CleanupBlock c [a]]
cs)
                              (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall c. DeferVariable c -> DeferVariable c -> DeferVariable c
followDeferred (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (DeferVariable c)
pcDeferred) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c s. CleanupBlock c s -> DeferVariable c
csDeferred [CleanupBlock c [a]]
cs)
                              (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c s. CleanupBlock c s -> [UsedVariable c]
csUsesVars [CleanupBlock c [a]]
cs)
                              (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Ord a => a -> a -> a
max JumpType
NextStatement (forall a b. (a -> b) -> [a] -> [b]
map forall c s. CleanupBlock c s -> JumpType
csJumpType [CleanupBlock c [a]]
cs))
                              (forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c s. CleanupBlock c s -> Set CategoryName
csRequires [CleanupBlock c [a]]
cs)
  ccExprLookup :: ProcedureContext c -> [c] -> MacroName -> m (Expression c)
ccExprLookup ProcedureContext c
ctx [c]
c MacroName
n =
    case MacroName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) (ExprMap c)
pcExprMap) of
         Maybe (Expression c)
Nothing -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Env expression " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show MacroName
n forall a. [a] -> [a] -> [a]
++ String
" is not defined" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
         Just Expression c
e -> do
           forall {m :: * -> *} {a}.
(CollectErrorsM m, Show a) =>
[(MacroName, [a])] -> [(MacroName, [a])] -> m ()
checkReserved (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [(MacroName, [c])]
pcReservedMacros) [(MacroName
n,[c]
c)]
           forall (m :: * -> *) a. Monad m => a -> m a
return Expression c
e
    where
      checkReserved :: [(MacroName, [a])] -> [(MacroName, [a])] -> m ()
checkReserved [] [(MacroName, [a])]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      checkReserved (m :: (MacroName, [a])
m@(MacroName
n2,[a]
_):[(MacroName, [a])]
ms) [(MacroName, [a])]
rs
        | MacroName
n2 forall a. Eq a => a -> a -> Bool
/= MacroName
n = [(MacroName, [a])] -> [(MacroName, [a])] -> m ()
checkReserved [(MacroName, [a])]
ms ((MacroName, [a])
mforall a. a -> [a] -> [a]
:[(MacroName, [a])]
rs)
        | Bool
otherwise = (forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall {m :: * -> *} {a} {a} {a}.
(ErrorContextM m, Show a, Show a) =>
(a, [a]) -> m a
singleError ((MacroName, [a])
mforall a. a -> [a] -> [a]
:[(MacroName, [a])]
rs)) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!!
            String
"Expression macro " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show MacroName
n forall a. [a] -> [a] -> [a]
++ String
" references itself"
      singleError :: (a, [a]) -> m a
singleError (a
n2,[a]
c2) = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
n2 forall a. [a] -> [a] -> [a]
++ String
" expanded at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [a]
c2
  ccReserveExprMacro :: ProcedureContext c -> [c] -> MacroName -> m (ProcedureContext c)
ccReserveExprMacro ProcedureContext c
ctx [c]
c MacroName
n = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [(MacroName, [c])]
pcReservedMacros forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((MacroName
n,[c]
c)forall a. a -> [a] -> [a]
:)
  ccReleaseExprMacro :: ProcedureContext c -> [c] -> MacroName -> m (ProcedureContext c)
ccReleaseExprMacro ProcedureContext c
ctx [c]
_ MacroName
n = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [(MacroName, [c])]
pcReservedMacros forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= MacroName
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))
  ccSetNoTrace :: ProcedureContext c -> Bool -> m (ProcedureContext c)
ccSetNoTrace ProcedureContext c
ctx Bool
t = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) Bool
pcNoTrace forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
t
  ccGetNoTrace :: ProcedureContext c -> m Bool
ccGetNoTrace = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcNoTrace)
  ccGetTestsOnly :: ProcedureContext c -> m Bool
ccGetTestsOnly = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) Bool
pcTestsOnly)
  ccAddTrace :: ProcedureContext c -> String -> m (ProcedureContext c)
ccAddTrace ProcedureContext c
ctx String
"" = forall (m :: * -> *) a. Monad m => a -> m a
return ProcedureContext c
ctx
  ccAddTrace ProcedureContext c
ctx String
t = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcedureContext c
ctx forall a b. a -> (a -> b) -> b
& forall c. Lens' (ProcedureContext c) [String]
pcTraces forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [String
t]
  ccGetTraces :: ProcedureContext c -> m [String]
ccGetTraces = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall c. Lens' (ProcedureContext c) [String]
pcTraces)
  ccCanForward :: ProcedureContext c -> [ParamName] -> [VariableName] -> m Bool
ccCanForward ProcedureContext c
ctx [ParamName]
ps [VariableName]
as = forall {m :: * -> *} {a} {c}.
CollectErrorsM m =>
Maybe (Positional ParamName, Positional (a, InputValue c))
-> m Bool
handle (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens'
  (ProcedureContext c)
  (Maybe
     (Positional ParamName,
      Positional (Maybe (CallArgLabel c), InputValue c)))
pcParentCall) where
    nameOrError :: InputValue c -> m VariableName
nameOrError (InputValue [c]
_ VariableName
n) = forall (m :: * -> *) a. Monad m => a -> m a
return VariableName
n
    nameOrError InputValue c
_                = forall (m :: * -> *) a. CollectErrorsM m => m a
emptyErrorM
    handle :: Maybe (Positional ParamName, Positional (a, InputValue c))
-> m Bool
handle Maybe (Positional ParamName, Positional (a, InputValue c))
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    handle (Just (Positional ParamName
ps0,Positional (a, InputValue c)
as0)) = forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM [forall {m :: * -> *} {a} {c}.
CollectErrorsM m =>
Positional ParamName -> Positional (a, InputValue c) -> m Bool
checkMatch Positional ParamName
ps0 Positional (a, InputValue c)
as0,forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False]
    checkMatch :: Positional ParamName -> Positional (a, InputValue c) -> m Bool
checkMatch Positional ParamName
ps0 Positional (a, InputValue c)
as0 = do
      Positional VariableName
as0' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {c}.
CollectErrorsM m =>
InputValue c -> m VariableName
nameOrError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (a, InputValue c)
as0
      forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ forall {a} {m :: * -> *}.
(Eq a, CollectErrorsM m) =>
a -> a -> m ()
equalOrError Positional ParamName
ps0 (forall a. [a] -> Positional a
Positional [ParamName]
ps)
      forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ forall {a} {m :: * -> *}.
(Eq a, CollectErrorsM m) =>
a -> a -> m ()
equalOrError Positional VariableName
as0' (forall a. [a] -> Positional a
Positional [VariableName]
as)
      forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    equalOrError :: a -> a -> m ()
equalOrError a
x a
y
      | a
x forall a. Eq a => a -> a -> Bool
== a
y    = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise = forall (m :: * -> *) a. CollectErrorsM m => m a
emptyErrorM
  ccDelegateArgs :: ProcedureContext c
-> m (Positional (Maybe (CallArgLabel c), VariableName))
ccDelegateArgs ProcedureContext c
ctx = forall {m :: * -> *} {a} {a} {a}.
(CollectErrorsM m, Show a) =>
Maybe (a, Positional (a, InputValue a))
-> m (Positional (a, VariableName))
handle (ProcedureContext c
ctx forall s a. s -> Getting a s a -> a
^. forall c.
Lens'
  (ProcedureContext c)
  (Maybe
     (Positional ParamName,
      Positional (Maybe (CallArgLabel c), InputValue c)))
pcParentCall) where
    nameOrError :: (a, InputValue a) -> m (a, VariableName)
nameOrError (a
l,InputValue [a]
_ VariableName
n) = forall (m :: * -> *) a. Monad m => a -> m a
return (a
l,VariableName
n)
    nameOrError (a
_,DiscardInput [a]
c) = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Delegation is not allowed with ignored args" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    handle :: Maybe (a, Positional (a, InputValue a))
-> m (Positional (a, VariableName))
handle Maybe (a, Positional (a, InputValue a))
Nothing = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM String
"Delegation is only allowed within function calls"
    handle (Just (a
_,Positional (a, InputValue a)
as0)) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a) =>
(a, InputValue a) -> m (a, VariableName)
nameOrError forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (a, InputValue a)
as0

updateReturnVariables :: (Show c, CollectErrorsM m) =>
  (Map.Map VariableName (VariableValue c)) ->
  Positional (PassedValue c) -> ReturnValues c ->
  m (Map.Map VariableName (VariableValue c))
updateReturnVariables :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map VariableName (VariableValue c)
-> Positional (PassedValue c)
-> ReturnValues c
-> m (Map VariableName (VariableValue c))
updateReturnVariables Map VariableName (VariableValue c)
ma Positional (PassedValue c)
rs1 ReturnValues c
rs2 = m (Map VariableName (VariableValue c))
updated where
  updated :: m (Map VariableName (VariableValue c))
updated
    | forall c. ReturnValues c -> Bool
isUnnamedReturns ReturnValues c
rs2 = forall (m :: * -> *) a. Monad m => a -> m a
return Map VariableName (VariableValue c)
ma
    | Bool
otherwise = do
      [(PassedValue c, OutputValue c)]
rs <- forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair Positional (PassedValue c)
rs1 (forall c. ReturnValues c -> Positional (OutputValue c)
nrNames ReturnValues c
rs2)
      forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a, Show a) =>
(PassedValue a, OutputValue a)
-> m (Map VariableName (VariableValue a))
-> m (Map VariableName (VariableValue a))
update (forall (m :: * -> *) a. Monad m => a -> m a
return Map VariableName (VariableValue c)
ma) [(PassedValue c, OutputValue c)]
rs where
        update :: (PassedValue a, OutputValue a)
-> m (Map VariableName (VariableValue a))
-> m (Map VariableName (VariableValue a))
update (PassedValue [a]
c ValueType
t,OutputValue a
r) m (Map VariableName (VariableValue a))
va = do
          Map VariableName (VariableValue a)
va' <- m (Map VariableName (VariableValue a))
va
          case forall c. OutputValue c -> VariableName
ovName OutputValue a
r forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map VariableName (VariableValue a)
va' of
               Maybe (VariableValue a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall c. OutputValue c -> VariableName
ovName OutputValue a
r) (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [a]
c SymbolScope
LocalScope ValueType
t forall c. VariableRule c
VariableDefault) Map VariableName (VariableValue a)
va'
               (Just VariableValue a
v) -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. OutputValue c -> VariableName
ovName OutputValue a
r) forall a. [a] -> [a] -> [a]
++
                                          forall a. Show a => [a] -> String
formatFullContextBrace (forall c. OutputValue c -> [c]
ovContext OutputValue a
r) forall a. [a] -> [a] -> [a]
++
                                          String
" is already defined" forall a. [a] -> [a] -> [a]
++
                                          forall a. Show a => [a] -> String
formatFullContextBrace (forall c. VariableValue c -> [c]
vvContext VariableValue a
v)

updateArgVariables :: (Show c, CollectErrorsM m) =>
  (Map.Map VariableName (VariableValue c)) ->
  Positional (PassedValue c, Maybe (CallArgLabel c)) -> ArgValues c ->
  m (Map.Map VariableName (VariableValue c))
updateArgVariables :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map VariableName (VariableValue c)
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> ArgValues c
-> m (Map VariableName (VariableValue c))
updateArgVariables Map VariableName (VariableValue c)
ma Positional (PassedValue c, Maybe (CallArgLabel c))
as1 ArgValues c
as2 = do
  [((PassedValue c, Maybe (CallArgLabel c)), InputValue c)]
as <- forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair Positional (PassedValue c, Maybe (CallArgLabel c))
as1 (forall c. ArgValues c -> Positional (InputValue c)
avNames ArgValues c
as2)
  let as' :: [((PassedValue c, Maybe (CallArgLabel c)), InputValue c)]
as' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. InputValue c -> Bool
isDiscardedInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((PassedValue c, Maybe (CallArgLabel c)), InputValue c)]
as
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {m :: * -> *} {c} {c} {c}.
(ErrorContextM m, Show c, Show c) =>
Map VariableName (VariableValue c)
-> ((PassedValue c, Maybe (CallArgLabel c)), InputValue c)
-> m (Map VariableName (VariableValue c))
update Map VariableName (VariableValue c)
ma [((PassedValue c, Maybe (CallArgLabel c)), InputValue c)]
as' where
    checkName :: Maybe (CallArgLabel c) -> InputValue a -> m ()
checkName (Just CallArgLabel c
l) (InputValue [a]
c (VariableName String
n))
      | CallArgLabel c
l forall c. CallArgLabel c -> String -> Bool
`matchesCallArgLabel` String
n = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise = forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerWarningM forall a b. (a -> b) -> a -> b
$ String
"Variable " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++
                                         forall a. Show a => [a] -> String
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++
                                         String
" has a different name than arg label " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CallArgLabel c
l
    checkName Maybe (CallArgLabel c)
_ InputValue a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    update :: Map VariableName (VariableValue c)
-> ((PassedValue c, Maybe (CallArgLabel c)), InputValue c)
-> m (Map VariableName (VariableValue c))
update Map VariableName (VariableValue c)
va ((PassedValue [c]
_ ValueType
t,Maybe (CallArgLabel c)
n),InputValue c
a) = do
      let c :: [c]
c = forall c. InputValue c -> [c]
ivContext InputValue c
a
      case forall c. InputValue c -> VariableName
ivName InputValue c
a forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map VariableName (VariableValue c)
va of
            Maybe (VariableValue c)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (Just VariableValue c
v) -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. InputValue c -> VariableName
ivName InputValue c
a) forall a. [a] -> [a] -> [a]
++
                                         forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++
                                         String
" is already defined" forall a. [a] -> [a] -> [a]
++
                                         forall a. Show a => [a] -> String
formatFullContextBrace (forall c. VariableValue c -> [c]
vvContext VariableValue c
v)
      forall {m :: * -> *} {a} {c}.
(ErrorContextM m, Show a, Show c) =>
Maybe (CallArgLabel c) -> InputValue a -> m ()
checkName Maybe (CallArgLabel c)
n InputValue c
a
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall c. InputValue c -> VariableName
ivName InputValue c
a) (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c SymbolScope
LocalScope ValueType
t (forall c. [c] -> VariableRule c
VariableReadOnly [c]
c)) Map VariableName (VariableValue c)
va