{- -----------------------------------------------------------------------------
Copyright 2019-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 FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe #-}

module CompilerCxx.Procedure (
  CxxFunctionType(..),
  categoriesFromTypes,
  categoriesFromDefine,
  categoriesFromRefine,
  compileExecutableProcedure,
  compileMainProcedure,
  compileLazyInit,
  compileRegularInit,
  compileTestProcedure,
  compileWrapTestcase,
  procedureDeclaration,
  selectTestFromArgv1,
) where

import Control.Applicative ((<|>))
import Control.Monad (when)
import Control.Monad.Trans.State (execStateT,get,put,runStateT)
import Control.Monad.Trans (lift)
import Data.List (intercalate,nub)
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 Compilation.ProcedureContext (ExprMap)
import Compilation.ScopeContext
import CompilerCxx.CategoryContext
import CompilerCxx.Code
import CompilerCxx.Naming
import Types.Builtin
import Types.DefinedCategory
import Types.Function
import Types.Procedure
import Types.TypeCategory
import Types.TypeInstance
import Types.Variance


procedureDeclaration :: Monad m => Bool -> Bool -> ScopedFunction c -> m (CompiledData [String])
procedureDeclaration :: forall (m :: * -> *) c.
Monad m =>
Bool -> Bool -> ScopedFunction c -> m (CompiledData [String])
procedureDeclaration Bool
immutable Bool
abstract ScopedFunction c
f = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> CompiledData [String]
onlyCode String
func where
  func :: String
func
    | Bool
abstract = String
"virtual " forall a. [a] -> [a] -> [a]
++ String
proto forall a. [a] -> [a] -> [a]
++ String
" = 0;"
    | Bool
otherwise = String
proto forall a. [a] -> [a] -> [a]
++ String
";"
  name :: String
name = FunctionName -> String
callName (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f)
  suffix :: String
suffix
    | Bool
immutable = String
" const"
    | Bool
otherwise = String
""
  proto :: String
proto
    | forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope =
      String
"ReturnTuple " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"(const ParamsArgs& params_args)"
    | forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f forall a. Eq a => a -> a -> Bool
== SymbolScope
TypeScope =
      String
"ReturnTuple " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"(const ParamsArgs& params_args) const"
    | forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f forall a. Eq a => a -> a -> Bool
== SymbolScope
ValueScope =
      String
"ReturnTuple " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"(const ParamsArgs& params_args)" forall a. [a] -> [a] -> [a]
++ String
suffix
    | Bool
otherwise = forall a. HasCallStack => a
undefined

data CxxFunctionType =
  InlineFunction |
  OutOfLineFunction String |
  FinalInlineFunction
  deriving Int -> CxxFunctionType -> ShowS
[CxxFunctionType] -> ShowS
CxxFunctionType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CxxFunctionType] -> ShowS
$cshowList :: [CxxFunctionType] -> ShowS
show :: CxxFunctionType -> String
$cshow :: CxxFunctionType -> String
showsPrec :: Int -> CxxFunctionType -> ShowS
$cshowsPrec :: Int -> CxxFunctionType -> ShowS
Show

compileExecutableProcedure :: (Ord c, Show c, CollectErrorsM m) =>
  Bool -> Bool -> CxxFunctionType -> ScopeContext c -> ScopedFunction c ->
  ExecutableProcedure c -> m (CompiledData [String])
compileExecutableProcedure :: forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Bool
-> Bool
-> CxxFunctionType
-> ScopeContext c
-> ScopedFunction c
-> ExecutableProcedure c
-> m (CompiledData [String])
compileExecutableProcedure Bool
to Bool
immutable CxxFunctionType
cxxType ScopeContext c
ctx
  ff :: ScopedFunction c
ff@(ScopedFunction [c]
_ FunctionName
_ CategoryName
_ SymbolScope
s FunctionVisibility c
_ Positional (PassedValue c, Maybe (CallArgLabel c))
as1 Positional (PassedValue c)
rs1 Positional (ValueParam c)
ps1 [ParamFilter c]
_ [ScopedFunction c]
_)
  pp :: ExecutableProcedure c
pp@(ExecutableProcedure [c]
c [PragmaProcedure c]
pragmas [c]
c2 FunctionName
n ArgValues c
as2 ReturnValues c
rs2 Procedure c
p) = do
  ProcedureContext c
ctx' <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Bool
-> ScopeContext c
-> ScopedFunction c
-> ExecutableProcedure c
-> m (ProcedureContext c)
getProcedureContext Bool
to ScopeContext c
ctx ScopedFunction c
ff ExecutableProcedure c
pp
  CompiledData [String]
output <- forall c (m :: * -> *) s a b.
CompilerContext c m s a =>
CompilerState a m b -> a -> m (CompiledData s)
runDataCompiler StateT (ProcedureContext c) m ()
compileWithReturn ProcedureContext c
ctx'
  [String]
procedureTrace <- m [String]
setProcedureTrace
  [String]
creationTrace  <- m [String]
setCreationTrace
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CompiledData [String]
-> [String] -> [String] -> CompiledData [String]
wrapProcedure CompiledData [String]
output [String]
procedureTrace [String]
creationTrace
  where
    compileWithReturn :: StateT (ProcedureContext c) m ()
compileWithReturn = do
      ProcedureContext c
ctx0 <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> Bool -> m a
ccSetNoTrace (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall c. PragmaProcedure c -> Bool
isNoTrace [PragmaProcedure c]
pragmas)
      forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure ProcedureContext c
ctx0 Procedure c
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put
      Bool
unreachable <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsUnreachable
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
unreachable) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) c a.
(CollectErrorsM m, Ord c, Show c,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
doImplicitReturn [c]
c2 forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
          String
"In implicit return from " 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
    funcMergeDeps :: ScopedFunction c -> CompiledData [String]
funcMergeDeps ScopedFunction c
f = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ (Set CategoryName -> CompiledData [String]
onlyDeps (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f]))forall a. a -> [a] -> [a]
:(forall a b. (a -> b) -> [a] -> [b]
map ScopedFunction c -> CompiledData [String]
funcMergeDeps forall a b. (a -> b) -> a -> b
$ forall c. ScopedFunction c -> [ScopedFunction c]
sfMerges ScopedFunction c
f)
    wrapProcedure :: CompiledData [String]
-> [String] -> [String] -> CompiledData [String]
wrapProcedure CompiledData [String]
output [String]
pt [String]
ct =
      forall a. Monoid a => [a] -> a
mconcat [
          forall {c}. ScopedFunction c -> CompiledData [String]
funcMergeDeps ScopedFunction c
ff,
          String -> CompiledData [String]
onlyCode String
proto,
          CompiledData [String] -> CompiledData [String]
indentCompiled forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
pt,
          CompiledData [String] -> CompiledData [String]
indentCompiled forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
ct,
          CompiledData [String] -> CompiledData [String]
indentCompiled forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
defineReturns,
          CompiledData [String] -> CompiledData [String]
indentCompiled forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
nameParams,
          CompiledData [String] -> CompiledData [String]
indentCompiled forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
nameArgs,
          CompiledData [String] -> CompiledData [String]
indentCompiled forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
nameReturns,
          CompiledData [String] -> CompiledData [String]
indentCompiled CompiledData [String]
output,
          String -> CompiledData [String]
onlyCode String
close
        ]
    close :: String
close = String
"}"
    name :: String
name = FunctionName -> String
callName FunctionName
n
    prefix :: String
prefix = case CxxFunctionType
cxxType of
                  OutOfLineFunction String
cn -> String
cn forall a. [a] -> [a] -> [a]
++ String
"::"
                  CxxFunctionType
_ -> String
""
    final :: String
final = case CxxFunctionType
cxxType of
                 CxxFunctionType
FinalInlineFunction -> String
" final"
                 CxxFunctionType
_ -> String
""
    suffix :: String
suffix
      | Bool
immutable = String
" const"
      | Bool
otherwise = String
""
    proto :: String
proto
      | SymbolScope
s forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope =
        String
"ReturnTuple " forall a. [a] -> [a] -> [a]
++ String
prefix forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"(const ParamsArgs& params_args)" forall a. [a] -> [a] -> [a]
++ String
final forall a. [a] -> [a] -> [a]
++ String
" {"
      | SymbolScope
s forall a. Eq a => a -> a -> Bool
== SymbolScope
TypeScope =
        String
"ReturnTuple " forall a. [a] -> [a] -> [a]
++ String
prefix forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"(const ParamsArgs& params_args) const" forall a. [a] -> [a] -> [a]
++ String
final forall a. [a] -> [a] -> [a]
++ String
" {"
      | SymbolScope
s forall a. Eq a => a -> a -> Bool
== SymbolScope
ValueScope =
        String
"ReturnTuple " forall a. [a] -> [a] -> [a]
++ String
prefix forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"(const ParamsArgs& params_args)" forall a. [a] -> [a] -> [a]
++ String
suffix forall a. [a] -> [a] -> [a]
++ String
final forall a. [a] -> [a] -> [a]
++ String
" {"
      | Bool
otherwise = forall a. HasCallStack => a
undefined
    setProcedureTrace :: m [String]
setProcedureTrace
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall c. PragmaProcedure c -> Bool
isNoTrace [PragmaProcedure c]
pragmas = forall (m :: * -> *) a. Monad m => a -> m a
return []
      | Bool
otherwise             = forall (m :: * -> *) a. Monad m => a -> m a
return [forall c. CategoryName -> ScopedFunction c -> String
startFunctionTracing (forall c. ScopeContext c -> CategoryName
scName ScopeContext c
ctx) ScopedFunction c
ff]
    setCreationTrace :: m [String]
setCreationTrace
      | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall c. PragmaProcedure c -> Bool
isTraceCreation [PragmaProcedure c]
pragmas = forall (m :: * -> *) a. Monad m => a -> m a
return []
      | SymbolScope
s forall a. Eq a => a -> a -> Bool
/= SymbolScope
ValueScope =
          (forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerWarningM forall a b. (a -> b) -> a -> b
$ String
"Creation tracing ignored for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SymbolScope
s forall a. [a] -> [a] -> [a]
++
            String
" functions" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return [String
showCreationTrace]
    defineReturns :: [String]
defineReturns
      | forall c. ReturnValues c -> Bool
isUnnamedReturns ReturnValues c
rs2 = []
      | Bool
otherwise            = [String
"ReturnTuple returns(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs1) forall a. [a] -> [a] -> [a]
++ String
");"]
    nameParams :: [String]
nameParams = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps1) forall a b. (a -> b) -> a -> b
$
      (\(Int
i,ValueParam c
p2) -> String
paramType forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ ParamName -> String
paramName (forall c. ValueParam c -> ParamName
vpParam ValueParam c
p2) forall a. [a] -> [a] -> [a]
++ String
" = params_args.GetParam(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
");")
    nameArgs :: [String]
nameArgs = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {c} {c}.
Show a =>
(a, (PassedValue c, InputValue c)) -> String
nameSingleArg (forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c, Maybe (CallArgLabel c))
as1) (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall c. ArgValues c -> Positional (InputValue c)
avNames ArgValues c
as2))
    nameSingleArg :: (a, (PassedValue c, InputValue c)) -> String
nameSingleArg (a
i,(PassedValue c
t2,InputValue c
n2))
      | forall c. InputValue c -> Bool
isDiscardedInput InputValue c
n2 = String
"// Arg " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. PassedValue c -> ValueType
pvType PassedValue c
t2) forall a. [a] -> [a] -> [a]
++ String
") is discarded"
      | Bool
otherwise = String
"const " forall a. [a] -> [a] -> [a]
++ ValueType -> String
variableProxyType (forall c. PassedValue c -> ValueType
pvType PassedValue c
t2) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName (forall c. InputValue c -> VariableName
ivName InputValue c
n2) forall a. [a] -> [a] -> [a]
++
                    String
" = " forall a. [a] -> [a] -> [a]
++ ValueType -> ExpressionValue -> String
writeStoredVariable (forall c. PassedValue c -> ValueType
pvType PassedValue c
t2) (String -> ExpressionValue
UnwrappedSingle forall a b. (a -> b) -> a -> b
$ String
"params_args.GetArg(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
")") forall a. [a] -> [a] -> [a]
++ String
";"
    nameReturns :: [String]
nameReturns
      | forall c. ReturnValues c -> Bool
isUnnamedReturns ReturnValues c
rs2 = []
      | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i,(PassedValue c
t2,OutputValue c
n2)) -> forall {a} {c}. Show a => a -> ValueType -> OutputValue c -> String
nameReturn Int
i (forall c. PassedValue c -> ValueType
pvType PassedValue c
t2) OutputValue c
n2) (forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs1) (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall c. ReturnValues c -> Positional (OutputValue c)
nrNames ReturnValues c
rs2))
    nameReturn :: a -> ValueType -> OutputValue c -> String
nameReturn a
i ValueType
t2 OutputValue c
n2
      | ValueType -> Bool
isStoredUnboxed ValueType
t2 = ValueType -> String
variableProxyType ValueType
t2 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName (forall c. OutputValue c -> VariableName
ovName OutputValue c
n2) forall a. [a] -> [a] -> [a]
++ String
";"
      | Bool
otherwise =
        ValueType -> String
variableProxyType ValueType
t2 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName (forall c. OutputValue c -> VariableName
ovName OutputValue c
n2) forall a. [a] -> [a] -> [a]
++
        String
" = " forall a. [a] -> [a] -> [a]
++ ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
t2 (String -> ExpressionValue
UnwrappedSingle forall a b. (a -> b) -> a -> b
$ String
"returns.At(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
")") forall a. [a] -> [a] -> [a]
++ String
";"

compileCondition :: (Ord c, Show c, CollectErrorsM m,
                     CompilerContext c m [String] a) =>
  a -> [c] -> Expression c -> CompilerState a m (String,a)
compileCondition :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> [c] -> Expression c -> CompilerState a m (String, a)
compileCondition a
ctx [c]
c Expression c
e = do
  (String
e',a
ctx') <- forall (m :: * -> *) a. ErrorContextM m => m a -> m a
resetBackgroundM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT a m String
compile a
ctx
  Bool
noTrace <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csGetNoTrace
  if Bool
noTrace
     then forall (m :: * -> *) a. Monad m => a -> m a
return (String
e',a
ctx')
     else do
       let c2 :: [c]
c2 = forall c. Expression c -> [c]
getExpressionContext Expression c
e
       forall c (m :: * -> *) s a.
CompilerContext c m s a =>
String -> CompilerState a m ()
csAddTrace forall a b. (a -> b) -> a -> b
$ forall a. Show a => [a] -> String
formatFullContext [c]
c2
       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Show a => [a] -> String
predTraceContext [c]
c2 forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
e' forall a. [a] -> [a] -> [a]
++ String
")",a
ctx')
  where
    compile :: StateT a m String
compile = String
"In condition 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
      (ExpressionType
ts,ExpressionValue
e') <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
      forall {m :: * -> *}. ErrorContextM m => ExpressionType -> m ()
checkCondition ExpressionType
ts
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveType -> ExpressionValue -> String
useAsUnboxed PrimitiveType
PrimBool ExpressionValue
e'
      where
        checkCondition :: ExpressionType -> m ()
checkCondition (Positional [ValueType
t]) | ValueType
t forall a. Eq a => a -> a -> Bool
== ValueType
boolRequiredValue = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        checkCondition (Positional [ValueType]
ts) =
          forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected exactly one Bool value but got " forall a. [a] -> [a] -> [a]
++
                           forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [ValueType]
ts)

-- Returns the state so that returns can be properly checked for if/elif/else.
compileProcedure :: (Ord c, Show c, CollectErrorsM m,
                     CompilerContext c m [String] a) =>
  a -> Procedure c -> CompilerState a m a
compileProcedure :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure a
ctx (Procedure [c]
_ [Statement c]
ss) = do
  a
ctx' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {c} {a}.
(Show c, Ord c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Statement c -> StateT a m ()
compile [Statement c]
ss) a
ctx
  forall (m :: * -> *) a. Monad m => a -> m a
return a
ctx' where
    compile :: Statement c -> StateT a m ()
compile Statement c
s = do
      Bool
unreachable <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsUnreachable
      if Bool
unreachable Bool -> Bool -> Bool
&& Bool -> Bool
not (forall c. Statement c -> Bool
isRawCodeLine Statement c
s)
         then forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerWarningM forall a b. (a -> b) -> a -> b
$ String
"Statement at " forall a. [a] -> [a] -> [a]
++
                                 forall a. Show a => [a] -> String
formatFullContext (forall c. Statement c -> [c]
getStatementContext Statement c
s) forall a. [a] -> [a] -> [a]
++
                                 String
" is unreachable (skipping compilation)"
         else do
           ()
s' <- forall (m :: * -> *) a. ErrorContextM m => m a -> m a
resetBackgroundM forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Statement c -> CompilerState a m ()
compileStatement Statement c
s
           forall (m :: * -> *) a. Monad m => a -> m a
return ()
s'

maybeSetTrace :: (Ord c, Show c, CollectErrorsM m,
                  CompilerContext c m [String] a) =>
  [c] -> CompilerState a m ()
maybeSetTrace :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c = do
  Bool
noTrace <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csGetNoTrace
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
noTrace) forall a b. (a -> b) -> a -> b
$ do
    forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite forall a b. (a -> b) -> a -> b
$ forall c. Show c => [c] -> [String]
setTraceContext [c]
c
    forall c (m :: * -> *) s a.
CompilerContext c m s a =>
String -> CompilerState a m ()
csAddTrace forall a b. (a -> b) -> a -> b
$ forall a. Show a => [a] -> String
formatFullContext [c]
c

compileStatement :: (Ord c, Show c, CollectErrorsM m,
                     CompilerContext c m [String] a) =>
  Statement c -> CompilerState a m ()
compileStatement :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Statement c -> CompilerState a m ()
compileStatement (EmptyReturn [c]
c) = do
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
  forall (m :: * -> *) c a.
(CollectErrorsM m, Ord c, Show c,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
doImplicitReturn [c]
c
compileStatement (ExplicitReturn [c]
c Positional (Expression c)
es) = do
  [(ExpressionType, ExpressionValue)]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (Expression c)
es
  forall {m :: * -> *} {a} {a}.
(CompilerContext c m [String] a, CollectErrorsM m) =>
[(a, (ExpressionType, ExpressionValue))] -> StateT a m ()
getReturn forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall c. Expression c -> [c]
getExpressionContext forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (Expression c)
es) [(ExpressionType, ExpressionValue)]
es'
  where
    -- Single expression, but possibly multi-return.
    getReturn :: [(a, (ExpressionType, ExpressionValue))] -> StateT a m ()
getReturn [(a
_,(Positional [ValueType]
ts,ExpressionValue
e))] = do
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> Maybe ExpressionType -> CompilerState a m ()
csRegisterReturn [c]
c forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a. [a] -> Positional a
Positional [ValueType]
ts)
      forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
      forall c (m :: * -> *) a.
(Ord c, Eq c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> ExpressionValue -> CompilerState a m ()
autoPositionalCleanup [c]
c ExpressionValue
e
    -- Multi-expression => must all be singles.
    getReturn [(a, (ExpressionType, ExpressionValue))]
rs = do
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a) =>
(a, Positional a) -> m ()
checkArity 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 b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, (ExpressionType, ExpressionValue))]
rs) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        (String
"In return at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c)
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> Maybe ExpressionType -> CompilerState a m ()
csRegisterReturn [c]
c forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Positional a -> [a]
pValues forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, (ExpressionType, ExpressionValue))]
rs
      let e :: ExpressionValue
e = String -> ExpressionValue
OpaqueMulti forall a b. (a -> b) -> a -> b
$ String
"ReturnTuple(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map (ExpressionValue -> String
useAsUnwrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, (ExpressionType, ExpressionValue))]
rs) forall a. [a] -> [a] -> [a]
++ String
")"
      forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
      forall c (m :: * -> *) a.
(Ord c, Eq c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> ExpressionValue -> CompilerState a m ()
autoPositionalCleanup [c]
c ExpressionValue
e
    checkArity :: (a, Positional a) -> m ()
checkArity (a
_,Positional [a
_]) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkArity (a
i,Positional [a]
ts)  =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Return position " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
" has " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ts) forall a. [a] -> [a] -> [a]
++ String
" values but should have 1"
compileStatement (LoopBreak [c]
c) = do
  LoopSetup [String]
loop <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m (LoopSetup s)
csGetLoop
  case LoopSetup [String]
loop of
       LoopSetup [String]
NotInLoop ->
         forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Using break outside of while is no allowed" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
       LoopSetup [String]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpBreak
  forall (m :: * -> *) s. Monad m => StateT s m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup [c]
c JumpType
JumpBreak
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"break;"]
compileStatement (LoopContinue [c]
c) = do
  LoopSetup [String]
loop <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m (LoopSetup s)
csGetLoop
  case LoopSetup [String]
loop of
       LoopSetup [String]
NotInLoop ->
         forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Using continue outside of while is no allowed" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
       LoopSetup [String]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpContinue
  forall (m :: * -> *) s. Monad m => StateT s m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup [c]
c JumpType
JumpContinue
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite forall a b. (a -> b) -> a -> b
$ [String
"{"] forall a. [a] -> [a] -> [a]
++ forall s. LoopSetup s -> s
lsUpdate LoopSetup [String]
loop forall a. [a] -> [a] -> [a]
++ [String
"}",String
"continue;"]
compileStatement (FailCall [c]
c Expression c
e) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinFormatted,CategoryName
BuiltinString])
  (ExpressionType, ExpressionValue)
e' <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (ExpressionType, ExpressionValue)
e') forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExpressionValue
e0) = (ExpressionType, ExpressionValue)
e'
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t0 ValueType
formattedRequiredValue) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In fail call at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpImmediateExit
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"BUILTIN_FAIL(" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsUnwrapped ExpressionValue
e0 forall a. [a] -> [a] -> [a]
++ String
")"]
compileStatement (ExitCall [c]
c Expression c
e) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinInt])
  (ExpressionType, ExpressionValue)
e' <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (ExpressionType, ExpressionValue)
e') forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExpressionValue
e0) = (ExpressionType, ExpressionValue)
e'
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t0 ValueType
intRequiredValue) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In exit call at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpImmediateExit
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"BUILTIN_EXIT(" forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExpressionValue -> String
useAsUnboxed PrimitiveType
PrimInt ExpressionValue
e0 forall a. [a] -> [a] -> [a]
++ String
")"]
compileStatement (RawFailCall String
s) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [] JumpType
JumpImmediateExit
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"RAW_FAIL(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
")"]
compileStatement (IgnoreValues [c]
c Expression c
e) = do
  (ExpressionType
_,ExpressionValue
e') <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"(void) (" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsWhatever ExpressionValue
e' forall a. [a] -> [a] -> [a]
++ String
");"]
compileStatement (DeferredVariables [c]
c [Assignable c]
as) = String
message forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {c} {m :: * -> *} {a}.
(CompilerContext c m [String] a, CollectErrorsM m, Show c) =>
Assignable c -> StateT a m ()
createVariable [Assignable c]
as
  where
    message :: String
message = String
"Deferred initialization at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
    createVariable :: Assignable c -> StateT a m ()
createVariable (CreateVariable [c]
c2 ValueType
t1 VariableName
n) =
      String
"In creation of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c2 forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
        GeneralInstance
self <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
        ValueType
t1' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> ValueType -> m ValueType
replaceSelfValueType GeneralInstance
self ValueType
t1
        forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> VariableValue c -> CompilerState a m ()
csAddVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n) (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c2 SymbolScope
LocalScope ValueType
t1' forall c. VariableRule c
VariableDefault)
        forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [ValueType -> String
variableStoredType ValueType
t1' forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n forall a. [a] -> [a] -> [a]
++ String
";"]
        forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csSetDeferred (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n)
    createVariable (ExistingVariable (InputValue [c]
c2 VariableName
n)) =
      String
"In deferring of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c2 forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??>
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csSetDeferred (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n)
    createVariable (ExistingVariable (DiscardInput [c]
c2)) =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Cannot defer discarded value" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c2
compileStatement (VariableSwap [c]
c OutputValue c
vl OutputValue c
vr) = String
message forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> forall {c} {m :: * -> *} {a}.
(CompilerContext c m [String] a, CollectErrorsM m, Show c) =>
OutputValue c -> OutputValue c -> StateT a m ()
handle OutputValue c
vl OutputValue c
vr where
  message :: String
message = String
"In variable swap at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  handle :: OutputValue c -> OutputValue c -> StateT a m ()
handle (OutputValue [c]
cl VariableName
nl) (OutputValue [c]
cr VariableName
nr) = do
    AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
    ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
    (VariableValue [c]
_ SymbolScope
sl ValueType
tl VariableRule c
_) <- forall c (m :: * -> *) a.
(Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> VariableName -> CompilerState a m (VariableValue c)
getWritableVariable [c]
cl VariableName
nl
    (VariableValue [c]
_ SymbolScope
sr ValueType
tr VariableRule c
_) <- forall c (m :: * -> *) a.
(Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> VariableName -> CompilerState a m (VariableValue c)
getWritableVariable [c]
cr VariableName
nr
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
tl ValueType
tr
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
tr ValueType
tl
    forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[UsedVariable c] -> CompilerState a m ()
csCheckVariableInit [forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
cl VariableName
nl, forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
cr VariableName
nr]
    String
scopedL <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
sl
    String
scopedR <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
sr
    forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"SwapValues(" forall a. [a] -> [a] -> [a]
++ String
scopedL forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
nl forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
scopedR forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
nr forall a. [a] -> [a] -> [a]
++ String
");"]
compileStatement (Assignment [c]
c Positional (Assignable c)
as Expression c
e) = String
message forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
  (ExpressionType
ts,ExpressionValue
e') <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  -- Check for a count match first, to avoid the default error message.
  [(VariableName, ValueType)]
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b c.
(MonadTrans t, Monad (t m), Show a, Show b, ErrorContextM m) =>
(a -> b -> t m c) -> Positional a -> Positional b -> t m [c]
processPairsT 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. Assignable c -> VariableName
assignableName Positional (Assignable c)
as) ExpressionType
ts
  [()]
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b c.
(MonadTrans t, Monad (t m), Show a, Show b, ErrorContextM m) =>
(a -> b -> t m c) -> Positional a -> Positional b -> t m [c]
processPairsT (forall {m :: * -> *} {r} {c} {a}.
(CollectErrorsM m, TypeResolver r, CompilerContext c m [String] a,
 Show c) =>
r -> ParamFilters -> Assignable c -> ValueType -> StateT a m ()
createVariable AnyTypeResolver
r ParamFilters
fa) Positional (Assignable c)
as ExpressionType
ts
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
  [ValueType]
variableTypes <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {c} {s} {a}.
CompilerContext c m s a =>
Assignable c -> StateT a m ValueType
getVariableType (forall a. Positional a -> [a]
pValues Positional (Assignable c)
as)
  forall {m :: * -> *} {a} {a}.
(CompilerContext c m [String] a, Show a) =>
[(a, ValueType, Assignable c)]
-> ExpressionValue -> CompilerState a m ()
assignAll (forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ([Int
0..] :: [Int]) [ValueType]
variableTypes (forall a. Positional a -> [a]
pValues Positional (Assignable c)
as)) ExpressionValue
e'
  where
    message :: String
message = String
"In assignment at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
    assignAll :: [(a, ValueType, Assignable c)]
-> ExpressionValue -> CompilerState a m ()
assignAll [(a, ValueType, Assignable c)
v] ExpressionValue
e2 = forall {c} {m :: * -> *} {a} {a}.
CompilerContext c m [String] a =>
(a, ValueType, Assignable c)
-> ExpressionValue -> CompilerState a m ()
assignSingle (a, ValueType, Assignable c)
v ExpressionValue
e2
    assignAll [(a, ValueType, Assignable c)]
vs ExpressionValue
e2 = do
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"{",String
"const auto r = " forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsReturns ExpressionValue
e2 forall a. [a] -> [a] -> [a]
++ String
";"]
      forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {a} {a} {c}.
(CompilerContext c m [String] a, Show a) =>
(a, ValueType, Assignable c) -> CompilerState a m ()
assignMulti [(a, ValueType, Assignable c)]
vs
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]
    getVariableType :: Assignable c -> StateT a m ValueType
getVariableType (CreateVariable [c]
_ ValueType
t VariableName
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ValueType
t
    getVariableType (ExistingVariable (InputValue [c]
c2 VariableName
n)) = do
      (VariableValue [c]
_ SymbolScope
_ ValueType
t VariableRule c
_) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n)
      forall (m :: * -> *) a. Monad m => a -> m a
return ValueType
t
    getVariableType Assignable c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. HasCallStack => a
undefined
    createVariable :: r -> ParamFilters -> Assignable c -> ValueType -> StateT a m ()
createVariable r
r ParamFilters
fa (CreateVariable [c]
c2 ValueType
t1 VariableName
n) ValueType
t2 =
      String
"In creation of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c2 forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
        GeneralInstance
self <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
        ValueType
t1' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> ValueType -> m ValueType
replaceSelfValueType GeneralInstance
self ValueType
t1
        -- TODO: Call csAddRequired for t1'. (Maybe needs a helper function.)
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ [forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> GeneralInstance -> m ()
validateGeneralInstance r
r (forall k a. Map k a -> Set k
Map.keysSet ParamFilters
fa) (ValueType -> GeneralInstance
vtType ValueType
t1'),
                             forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment r
r ParamFilters
fa ValueType
t2 ValueType
t1']
        forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> VariableValue c -> CompilerState a m ()
csAddVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n) (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c2 SymbolScope
LocalScope ValueType
t1' forall c. VariableRule c
VariableDefault)
        forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [ValueType -> String
variableStoredType ValueType
t1' forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n forall a. [a] -> [a] -> [a]
++ String
";"]
    createVariable r
r ParamFilters
fa (ExistingVariable (InputValue [c]
c2 VariableName
n)) ValueType
t2 =
      String
"In assignment to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c2 forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
        (VariableValue [c]
_ SymbolScope
_ ValueType
t1 VariableRule c
_) <- forall c (m :: * -> *) a.
(Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> VariableName -> CompilerState a m (VariableValue c)
getWritableVariable [c]
c2 VariableName
n
        -- TODO: Also show original context.
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment r
r ParamFilters
fa ValueType
t2 ValueType
t1)
        forall c (m :: * -> *) s a.
CompilerContext c m s a =>
VariableName -> CompilerState a m ()
csUpdateAssigned VariableName
n
    createVariable r
_ ParamFilters
_ Assignable c
_ ValueType
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    assignSingle :: (a, ValueType, Assignable c)
-> ExpressionValue -> CompilerState a m ()
assignSingle (a
_,ValueType
t,CreateVariable [c]
_ ValueType
_ VariableName
n) ExpressionValue
e2 =
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [VariableName -> String
variableName VariableName
n forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
t ExpressionValue
e2 forall a. [a] -> [a] -> [a]
++ String
";"]
    assignSingle (a
_,ValueType
t,ExistingVariable (InputValue [c]
c2 VariableName
n)) ExpressionValue
e2 = do
      (VariableValue [c]
_ SymbolScope
s ValueType
_ VariableRule c
_) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n)
      String
scoped <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
scoped forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
t ExpressionValue
e2 forall a. [a] -> [a] -> [a]
++ String
";"]
    assignSingle (a
_,ValueType
_,ExistingVariable (DiscardInput [c]
_)) ExpressionValue
e2 = do
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"(void) (" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsWhatever ExpressionValue
e2 forall a. [a] -> [a] -> [a]
++ String
");"]
    assignMulti :: (a, ValueType, Assignable c) -> CompilerState a m ()
assignMulti (a
i,ValueType
t,CreateVariable [c]
_ ValueType
_ VariableName
n) =
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [VariableName -> String
variableName VariableName
n forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++
               ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
t (String -> ExpressionValue
UnwrappedSingle forall a b. (a -> b) -> a -> b
$ String
"r.At(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
")") forall a. [a] -> [a] -> [a]
++ String
";"]
    assignMulti (a
i,ValueType
t,ExistingVariable (InputValue [c]
_ VariableName
n)) = do
      (VariableValue [c]
_ SymbolScope
s ValueType
_ VariableRule c
_) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n)
      String
scoped <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
scoped forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++
               ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
t (String -> ExpressionValue
UnwrappedSingle forall a b. (a -> b) -> a -> b
$ String
"r.At(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
")") forall a. [a] -> [a] -> [a]
++ String
";"]
    assignMulti (a, ValueType, Assignable c)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileStatement (AssignmentEmpty [c]
c VariableName
n Expression c
e) = do
  (ExpressionType
_,ExpressionValue
e') <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ExpressionStart c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileExpressionStart (forall c.
[c]
-> VariableName
-> AssignmentType
-> Expression c
-> ExpressionStart c
InlineAssignment [c]
c VariableName
n AssignmentType
AssignIfEmpty Expression c
e)
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"(void) (" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsWhatever ExpressionValue
e' forall a. [a] -> [a] -> [a]
++ String
");"]
compileStatement (NoValueExpression [c]
_ VoidExpression c
v) = forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
VoidExpression c -> CompilerState a m ()
compileVoidExpression VoidExpression c
v
compileStatement (MarkReadOnly [c]
c [VariableName]
vs) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\VariableName
v -> forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csSetReadOnly (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
v)) [VariableName]
vs
compileStatement (MarkHidden   [c]
c [VariableName]
vs) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\VariableName
v -> forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csSetHidden   (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
v)) [VariableName]
vs
compileStatement (ValidateRefs [c]
c [VariableName]
vs) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *} {a}.
(CompilerContext c m [String] a, CollectErrorsM m) =>
VariableName -> StateT a m ()
validate [VariableName]
vs where
  validate :: VariableName -> StateT a m ()
validate VariableName
n = do
    (VariableValue [c]
_ SymbolScope
_ ValueType
t VariableRule c
_) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n)
    let e :: ExpressionValue
e = Bool -> ValueType -> String -> ExpressionValue
readStoredVariable Bool
False ValueType
t (VariableName -> String
variableName VariableName
n)
    forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
    forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [ExpressionValue -> String
useAsUnwrapped ExpressionValue
e forall a. [a] -> [a] -> [a]
++ String
".Validate(\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ String
"\");"]
compileStatement (ShowVariable [c]
c ValueType
t VariableName
n) = forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> VariableValue c -> CompilerState a m ()
csAddVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n) (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c SymbolScope
LocalScope ValueType
t forall c. VariableRule c
VariableDefault)
compileStatement (RawCodeLine String
s) = forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
s]

compileRegularInit :: (Ord c, Show c, CollectErrorsM m,
                       CompilerContext c m [String] a) =>
  DefinedMember c -> CompilerState a m ()
compileRegularInit :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
DefinedMember c -> CompilerState a m ()
compileRegularInit (DefinedMember [c]
_ SymbolScope
_ ValueType
_ VariableName
_ Maybe (Expression c)
Nothing) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileRegularInit (DefinedMember [c]
c2 SymbolScope
s ValueType
t VariableName
n2 (Just Expression c
e)) = forall (m :: * -> *) a. ErrorContextM m => m a -> m a
resetBackgroundM forall a b. (a -> b) -> a -> b
$ do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> VariableValue c -> CompilerState a m ()
csAddVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n2) (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c2 SymbolScope
s ValueType
t forall c. VariableRule c
VariableDefault)
  let assign :: Statement c
assign = forall c.
[c] -> Positional (Assignable c) -> Expression c -> Statement c
Assignment [c]
c2 (forall a. [a] -> Positional a
Positional [forall c. InputValue c -> Assignable c
ExistingVariable (forall c. [c] -> VariableName -> InputValue c
InputValue [c]
c2 VariableName
n2)]) Expression c
e
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Statement c -> CompilerState a m ()
compileStatement Statement c
assign

getWritableVariable :: (Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
  [c] -> VariableName -> CompilerState a m (VariableValue c)
getWritableVariable :: forall c (m :: * -> *) a.
(Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> VariableName -> CompilerState a m (VariableValue c)
getWritableVariable [c]
c VariableName
n = do
  v :: VariableValue c
v@(VariableValue [c]
_ SymbolScope
_ ValueType
_ VariableRule c
ro) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n)
  case VariableRule c
ro of
       VariableReadOnly [] -> 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 read-only"
       VariableReadOnly [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
" is marked read-only at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c2
       VariableRule c
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return VariableValue c
v

compileLazyInit :: (Ord c, Show c, CollectErrorsM m,
                   CompilerContext c m [String] a) =>
  DefinedMember c -> CompilerState a m ()
compileLazyInit :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
DefinedMember c -> CompilerState a m ()
compileLazyInit (DefinedMember [c]
_ SymbolScope
_ ValueType
_ VariableName
_ Maybe (Expression c)
Nothing) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileLazyInit (DefinedMember [c]
c SymbolScope
_ ValueType
t1 VariableName
n (Just Expression c
e)) = forall (m :: * -> *) a. ErrorContextM m => m a -> m a
resetBackgroundM forall a b. (a -> b) -> a -> b
$ do
  (ExpressionType
ts,ExpressionValue
e') <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues ExpressionType
ts) forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected single return in initializer" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace (forall c. Expression c -> [c]
getExpressionContext Expression c
e)
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  let Positional [ValueType
t2] = ExpressionType
ts
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t2 ValueType
t1) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In initialization of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [VariableName -> String
variableName VariableName
n forall a. [a] -> [a] -> [a]
++ String
"([this]() { return " forall a. [a] -> [a] -> [a]
++ ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
t1 ExpressionValue
e' forall a. [a] -> [a] -> [a]
++ String
"; })"]

compileVoidExpression :: (Ord c, Show c, CollectErrorsM m,
                         CompilerContext c m [String] a) =>
  VoidExpression c -> CompilerState a m ()
compileVoidExpression :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
VoidExpression c -> CompilerState a m ()
compileVoidExpression (Conditional IfElifElse c
ie) = forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
IfElifElse c -> CompilerState a m ()
compileIfElifElse IfElifElse c
ie
compileVoidExpression (Loop IteratedLoop c
l) = forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
IteratedLoop c -> CompilerState a m ()
compileIteratedLoop IteratedLoop c
l
compileVoidExpression (WithScope ScopedBlock c
s) = forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ScopedBlock c -> CompilerState a m ()
compileScopedBlock ScopedBlock c
s
compileVoidExpression (LineComment String
s) = forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String
"// " forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s
compileVoidExpression (Unconditional Procedure c
p) = do
  a
ctx0 <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
  a
ctx <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure a
ctx0 Procedure c
p
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"{"]
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m ()
autoInlineOutput a
ctx
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]

compileIfElifElse :: (Ord c, Show c, CollectErrorsM m,
                      CompilerContext c m [String] a) =>
  IfElifElse c -> CompilerState a m ()
compileIfElifElse :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
IfElifElse c -> CompilerState a m ()
compileIfElifElse (IfStatement [c]
c Expression c
e Procedure c
p IfElifElse c
es) = do
  a
ctx0 <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
  [a]
cs <- forall {c} {m :: * -> *} {a}.
(CompilerContext c m [String] a, CollectErrorsM m, Show c,
 Ord c) =>
a
-> String
-> [c]
-> Expression c
-> Procedure c
-> IfElifElse c
-> StateT a m [a]
commonIf a
ctx0 String
"if" [c]
c Expression c
e Procedure c
p IfElifElse c
es
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[a] -> CompilerState a m ()
csInheritStatic [a]
cs
  where
    unwind :: a -> IfElifElse c -> StateT a m [a]
unwind a
ctx0 (IfStatement [c]
c2 Expression c
e2 Procedure c
p2 IfElifElse c
es2) = a
-> String
-> [c]
-> Expression c
-> Procedure c
-> IfElifElse c
-> StateT a m [a]
commonIf a
ctx0 String
"else if" [c]
c2 Expression c
e2 Procedure c
p2 IfElifElse c
es2
    unwind a
ctx0 (ElseStatement [c]
_ Procedure c
p2) = do
      a
ctx <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure a
ctx0 Procedure c
p2
      forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"else {"]
      forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]
      forall (m :: * -> *) a. Monad m => a -> m a
return [a
ctx]
    unwind a
ctx0 IfElifElse c
TerminateConditional = forall (m :: * -> *) a. Monad m => a -> m a
return [a
ctx0]
    commonIf :: a
-> String
-> [c]
-> Expression c
-> Procedure c
-> IfElifElse c
-> StateT a m [a]
commonIf a
ctx0 String
s [c]
c2 Expression c
e2 Procedure c
p2 IfElifElse c
es2 = do
      (String
e2',a
ctx1) <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> [c] -> Expression c -> CompilerState a m (String, a)
compileCondition a
ctx0 [c]
c2 Expression c
e2
      a
ctx <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure a
ctx1 Procedure c
p2
      forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
s forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
e2' forall a. [a] -> [a] -> [a]
++ String
") {"]
      forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]
      [a]
cs <- a -> IfElifElse c -> StateT a m [a]
unwind a
ctx1 IfElifElse c
es2
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a
ctxforall a. a -> [a] -> [a]
:[a]
cs
compileIfElifElse IfElifElse c
_ = forall a. HasCallStack => a
undefined

compileIteratedLoop :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
  IteratedLoop c -> CompilerState a m ()
compileIteratedLoop :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
IteratedLoop c -> CompilerState a m ()
compileIteratedLoop (WhileLoop [c]
c Expression c
e Procedure c
p Maybe (Procedure c)
u) = do
  a
ctx0 <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
  (String
e',a
ctx1) <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> [c] -> Expression c -> CompilerState a m (String, a)
compileCondition a
ctx0 [c]
c Expression c
e
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[a] -> CompilerState a m ()
csInheritStatic [a
ctx1]
  a
ctx0' <- case Maybe (Procedure c)
u of
                Just Procedure c
p2 -> do
                  a
ctx2 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> LoopSetup s -> m a
ccStartLoop a
ctx1 (forall s. s -> LoopSetup s
LoopSetup [])
                  a
ctx3 <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure a
ctx2 Procedure c
p2
                  forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx3
                  [String]
p2' <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx3
                  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> LoopSetup s -> m a
ccStartLoop a
ctx1 (forall s. s -> LoopSetup s
LoopSetup [String]
p2')
                Maybe (Procedure c)
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> LoopSetup s -> m a
ccStartLoop a
ctx1 (forall s. s -> LoopSetup s
LoopSetup [])
  (LoopSetup [String]
u') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m (LoopSetup s)
ccGetLoop a
ctx0'
  a
ctx <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure a
ctx0' Procedure c
p
  forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"while (" forall a. [a] -> [a] -> [a]
++ String
e' forall a. [a] -> [a] -> [a]
++ String
") {"]
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite forall a b. (a -> b) -> a -> b
$ [String
"{"] forall a. [a] -> [a] -> [a]
++ [String]
u' forall a. [a] -> [a] -> [a]
++ [String
"}"]
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]
compileIteratedLoop (TraverseLoop [c]
c1 Expression c
e [c]
c2 Assignable c
a (Procedure [c]
c3 [Statement c]
ss) Maybe (Procedure c)
u) = String
"In compilation of traverse at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c1 forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
  (Positional [ValueType]
ts,ExpressionValue
e') <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
  forall {m :: * -> *} {a}. (ErrorContextM m, Show a) => [a] -> m ()
checkContainer [ValueType]
ts
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  let [ValueType
t] = [ValueType]
ts
  let autoParam :: ParamName
autoParam = String -> ParamName
ParamName String
"#auto"
  let autoType :: GeneralInstance
autoType  = forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False ParamName
autoParam
  (Positional [GeneralInstance
t2]) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) r.
(Ord c, Show c, CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ExpressionType
-> Positional ParamName
-> Positional (InstanceOrInferred c)
-> ExpressionType
-> m (Positional GeneralInstance)
guessParams AnyTypeResolver
r ParamFilters
fa (forall a. [a] -> Positional a
Positional [GeneralInstance -> ValueType
orderOptionalValue GeneralInstance
autoType])
                                               (forall a. [a] -> Positional a
Positional [ParamName
autoParam])
                                               (forall a. [a] -> Positional a
Positional [forall c. [c] -> InstanceOrInferred c
InferredInstance [c]
c1])
                                               (forall a. [a] -> Positional a
Positional [ValueType
t])
  let currVar :: String
currVar = VariableName -> String
hiddenVariableName forall a b. (a -> b) -> a -> b
$ String -> VariableName
VariableName String
"traverse"
  let currType :: ValueType
currType = GeneralInstance -> ValueType
orderOptionalValue forall a b. (a -> b) -> a -> b
$ GeneralInstance -> GeneralInstance
fixTypeParams GeneralInstance
t2
  let currExpr :: ExpressionStart c
currExpr    = forall c. [c] -> FunctionCall c -> ExpressionStart c
BuiltinCall [] forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [] FunctionName
BuiltinRequire (forall a. [a] -> Positional a
Positional []) (forall a. [a] -> Positional a
Positional [(forall a. Maybe a
Nothing,forall c. ExpressionType -> ExpressionValue -> Expression c
RawExpression (forall a. [a] -> Positional a
Positional [ValueType
currType]) (String -> ExpressionValue
UnwrappedSingle String
currVar))])
  let currPresent :: ExpressionStart c
currPresent = forall c. [c] -> FunctionCall c -> ExpressionStart c
BuiltinCall [] forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [] FunctionName
BuiltinPresent (forall a. [a] -> Positional a
Positional []) (forall a. [a] -> Positional a
Positional [(forall a. Maybe a
Nothing,forall c. ExpressionType -> ExpressionValue -> Expression c
RawExpression (forall a. [a] -> Positional a
Positional [ValueType
currType]) (String -> ExpressionValue
UnwrappedSingle String
currVar))])
  let callNext :: Expression c
callNext = forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c1 forall {c}. ExpressionStart c
currExpr [forall c.
[c] -> ValueCallType -> FunctionCall c -> ValueOperation c
ValueCall [c]
c1 ValueCallType
AlwaysCall forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c1 (String -> FunctionName
FunctionName String
"next") (forall a. [a] -> Positional a
Positional []) (forall a. [a] -> Positional a
Positional [])]
  let callGet :: Expression c
callGet  = forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c2 forall {c}. ExpressionStart c
currExpr [forall c.
[c] -> ValueCallType -> FunctionCall c -> ValueOperation c
ValueCall [c]
c2 ValueCallType
AlwaysCall forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c2 (String -> FunctionName
FunctionName String
"get")  (forall a. [a] -> Positional a
Positional []) (forall a. [a] -> Positional a
Positional [])]
  (Positional [ValueType
typeGet],ExpressionValue
exprNext) <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
callNext
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValueType
typeGet forall a. Eq a => a -> a -> Bool
/= ValueType
currType) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Unexpected return type from next(): " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
typeGet forall a. [a] -> [a] -> [a]
++ String
" (expected) " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
currType forall a. [a] -> [a] -> [a]
++ String
" (actual)"
  let assnGet :: [Statement c]
assnGet = if forall c. Assignable c -> Bool
isAssignableDiscard Assignable c
a then [] else [forall c.
[c] -> Positional (Assignable c) -> Expression c -> Statement c
Assignment [c]
c2 (forall a. [a] -> Positional a
Positional [Assignable c
a]) Expression c
callGet]
  let showVar :: [Statement c]
showVar = case Assignable c
a of
                     CreateVariable [c]
c4 ValueType
t3 VariableName
n -> [forall c. [c] -> ValueType -> VariableName -> Statement c
ShowVariable [c]
c4 ValueType
t3 VariableName
n]
                     Assignable c
_ -> []
  let next :: [Statement c]
next = [forall c. String -> Statement c
RawCodeLine forall a b. (a -> b) -> a -> b
$ String
currVar forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
currType ExpressionValue
exprNext forall a. [a] -> [a] -> [a]
++ String
";"]
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ GeneralInstance -> Set CategoryName
categoriesFromTypes forall a b. (a -> b) -> a -> b
$ ValueType -> GeneralInstance
vtType ValueType
currType
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Statement c -> CompilerState a m ()
compileStatement forall a b. (a -> b) -> a -> b
$ forall c. [c] -> VoidExpression c -> Statement c
NoValueExpression [] forall a b. (a -> b) -> a -> b
$ forall c. ScopedBlock c -> VoidExpression c
WithScope forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> Procedure c
-> Maybe (Procedure c)
-> [c]
-> Statement c
-> ScopedBlock c
ScopedBlock []
    (forall c. [c] -> [Statement c] -> Procedure c
Procedure [] [forall c. String -> Statement c
RawCodeLine forall a b. (a -> b) -> a -> b
$ ValueType -> String
variableStoredType ValueType
currType forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
currVar forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
currType ExpressionValue
e' forall a. [a] -> [a] -> [a]
++ String
";"]) forall a. Maybe a
Nothing []
    (forall c. [c] -> VoidExpression c -> Statement c
NoValueExpression [] forall a b. (a -> b) -> a -> b
$ forall c. IteratedLoop c -> VoidExpression c
Loop forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> Expression c
-> Procedure c
-> Maybe (Procedure c)
-> IteratedLoop c
WhileLoop [] (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [] forall {c}. ExpressionStart c
currPresent [])
      (forall c. [c] -> [Statement c] -> Procedure c
Procedure [c]
c3 ([Statement c]
assnGet forall a. [a] -> [a] -> [a]
++ [Statement c]
ss))
      (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall c. [c] -> [Statement c] -> Procedure c
Procedure [] (forall {c}. [Statement c]
next forall a. [a] -> [a] -> [a]
++ [Statement c]
showVar forall a. [a] -> [a] -> [a]
++ [Statement c]
update)))
    where
      update :: [Statement c]
update = case Maybe (Procedure c)
u of
                    Just (Procedure [c]
_ [Statement c]
ss2) -> [Statement c]
ss2
                    Maybe (Procedure c)
_                      -> []
      checkContainer :: [a] -> m ()
checkContainer [a
_] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      checkContainer [a]
ts =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected exactly one Order<?> value but got " forall a. [a] -> [a] -> [a]
++
                         forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [a]
ts)

compileScopedBlock :: (Ord c, Show c, CollectErrorsM m,
                       CompilerContext c m [String] a) =>
  ScopedBlock c -> CompilerState a m ()
compileScopedBlock :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ScopedBlock c -> CompilerState a m ()
compileScopedBlock s :: ScopedBlock c
s@(ScopedBlock [c]
_ Procedure c
_ Maybe (Procedure c)
_ [c]
c2 Statement c
_) = do
  let ([([c], ValueType, VariableName)]
vs,Procedure c
p,Maybe (Procedure c)
cl,Statement c
st) = forall {c}.
ScopedBlock c
-> ([([c], ValueType, VariableName)], Procedure c,
    Maybe (Procedure c), Statement c)
rewriteScoped ScopedBlock c
s
  case Statement c
st of
       DeferredVariables [c]
c3 [Assignable c]
_ ->
         forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Cannot defer variable initialization at the top level of scoped/cleanup in statements" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c3
       Statement c
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  GeneralInstance
self <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  [([c], ValueType, VariableName)]
vs' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {a} {c}.
CollectErrorsM m =>
GeneralInstance -> (a, ValueType, c) -> m (a, ValueType, c)
replaceSelfVariable GeneralInstance
self) [([c], ValueType, VariableName)]
vs
  -- Capture context so we can discard scoped variable names.
  a
ctx0 <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {r} {a} {c} {a} {a}.
(CollectErrorsM m, TypeResolver r, Show a,
 CompilerContext c m [String] a) =>
r
-> Map ParamName a
-> ([a], ValueType, VariableName)
-> StateT a m ()
createVariable AnyTypeResolver
r ParamFilters
fa) [([c], ValueType, VariableName)]
vs'
  a
ctxP0 <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure a
ctx0 Procedure c
p
  -- Make variables to be created visible *after* p has been compiled so that p
  -- can't refer to them.
  a
ctxP <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {c} {m :: * -> *} {s} {a}.
CompilerContext c m s a =>
([c], ValueType, VariableName) -> CompilerState a m ()
showVariable [([c], ValueType, VariableName)]
vs') a
ctxP0
  a
ctxCl0 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a. CompilerContext c m s a => a -> m a
ccClearOutput a
ctxP forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> [c] -> m a
ccStartCleanup [c]
c2
  a
ctxP' <-
    case Maybe (Procedure c)
cl of
         -- Insert cleanup into the context for the in block.
         Just (Procedure [c]
c [Statement c]
ss) -> do
           Bool
noTrace <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csGetNoTrace
           let trace :: [Statement c]
trace = if Bool
noTrace then [] else [forall c. String -> Statement c
RawCodeLine String
startCleanupTracing]
           let p2' :: Procedure c
p2' = forall c. [c] -> [Statement c] -> Procedure c
Procedure [c]
c forall a b. (a -> b) -> a -> b
$ [forall c. String -> Statement c
RawCodeLine String
"{"] forall a. [a] -> [a] -> [a]
++ forall {c}. [Statement c]
trace forall a. [a] -> [a] -> [a]
++ [Statement c]
ss forall a. [a] -> [a] -> [a]
++ [forall c. String -> Statement c
RawCodeLine String
"}"]
           a
ctxCl <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure a
ctxCl0 Procedure c
p2' forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In cleanup starting at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
           a
ctxP' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> a -> m a
ccPushCleanup a
ctxP a
ctxCl
           forall (m :: * -> *) a. Monad m => a -> m a
return a
ctxP'
         -- Insert an empty cleanup so that it can be used below.
         Maybe (Procedure c)
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> a -> m a
ccPushCleanup a
ctxP a
ctxCl0
  a
ctxS <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure a
ctxP' (forall c. [c] -> [Statement c] -> Procedure c
Procedure [] [Statement c
st])
  case Statement c
st of
       -- Make sure that top-level assignments removed deferred status.
       Assignment [c]
_ (Positional [Assignable c]
existing) Expression c
_ -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {c} {m :: * -> *} {s} {a} {c}.
CompilerContext c m s a =>
Assignable c -> CompilerState a m ()
setAssigned [Assignable c]
existing
       Statement c
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"{"]
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m ()
autoInlineOutput a
ctxS
  -- NOTE: Keep this after inlining the in block in case the in block contains a
  -- jump. (If it does, the cleanup will already be inlined.)
  Bool
unreachable <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsUnreachable
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
unreachable) forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup [c]
c2 JumpType
NextStatement a
ctxP'
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]
  forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {c} {m :: * -> *} {s} {a}.
CompilerContext c m s a =>
([c], ValueType, VariableName) -> CompilerState a m ()
showVariable [([c], ValueType, VariableName)]
vs'
  where
    setAssigned :: Assignable c -> CompilerState a m ()
setAssigned (ExistingVariable (InputValue [c]
_ VariableName
n)) = forall c (m :: * -> *) s a.
CompilerContext c m s a =>
VariableName -> CompilerState a m ()
csUpdateAssigned VariableName
n
    setAssigned Assignable c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    replaceSelfVariable :: GeneralInstance -> (a, ValueType, c) -> m (a, ValueType, c)
replaceSelfVariable GeneralInstance
self (a
c,ValueType
t,c
n) = do
      ValueType
t' <- forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> ValueType -> m ValueType
replaceSelfValueType GeneralInstance
self ValueType
t
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
c,ValueType
t',c
n)
    createVariable :: r
-> Map ParamName a
-> ([a], ValueType, VariableName)
-> StateT a m ()
createVariable r
r Map ParamName a
fa ([a]
c,ValueType
t,VariableName
n) = do
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> GeneralInstance -> m ()
validateGeneralInstance r
r (forall k a. Map k a -> Set k
Map.keysSet Map ParamName a
fa) (ValueType -> GeneralInstance
vtType ValueType
t) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In creation of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show VariableName
n forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [a]
c
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [ValueType -> String
variableStoredType ValueType
t forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n forall a. [a] -> [a] -> [a]
++ String
";"]
    showVariable :: ([c], ValueType, VariableName) -> CompilerState a m ()
showVariable ([c]
c,ValueType
t,VariableName
n) = do
      -- TODO: Call csAddRequired for t. (Maybe needs a helper function.)
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> VariableValue c -> CompilerState a m ()
csAddVariable (forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n) (forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c SymbolScope
LocalScope ValueType
t forall c. VariableRule c
VariableDefault)
    -- Don't merge if the second scope has cleanup, so that the latter can't
    -- refer to variables defined in the first scope.
    rewriteScoped :: ScopedBlock c
-> ([([c], ValueType, VariableName)], Procedure c,
    Maybe (Procedure c), Statement c)
rewriteScoped (ScopedBlock [c]
_ Procedure c
p cl :: Maybe (Procedure c)
cl@(Just Procedure c
_) [c]
_
                               s2 :: Statement c
s2@(NoValueExpression [c]
_ (WithScope
                                   (ScopedBlock [c]
_ Procedure c
_ (Just Procedure c
_) [c]
_ Statement c
_)))) =
      ([],Procedure c
p,Maybe (Procedure c)
cl,Statement c
s2)
    -- Merge chained scoped sections into a single section.
    rewriteScoped (ScopedBlock [c]
c (Procedure [c]
c3 [Statement c]
ss1) Maybe (Procedure c)
cl1 [c]
c4
                               (NoValueExpression [c]
_ (WithScope
                                (ScopedBlock [c]
_ (Procedure [c]
_ [Statement c]
ss2) Maybe (Procedure c)
cl2 [c]
_ Statement c
s2)))) =
      ScopedBlock c
-> ([([c], ValueType, VariableName)], Procedure c,
    Maybe (Procedure c), Statement c)
rewriteScoped forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> Procedure c
-> Maybe (Procedure c)
-> [c]
-> Statement c
-> ScopedBlock c
ScopedBlock [c]
c (forall c. [c] -> [Statement c] -> Procedure c
Procedure [c]
c3 forall a b. (a -> b) -> a -> b
$ [Statement c]
ss1 forall a. [a] -> [a] -> [a]
++ [Statement c]
ss2) (Maybe (Procedure c)
cl1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Procedure c)
cl2) [c]
c4 Statement c
s2
    -- Gather to-be-created variables.
    rewriteScoped (ScopedBlock [c]
_ Procedure c
p Maybe (Procedure c)
cl [c]
_ (Assignment [c]
c3 Positional (Assignable c)
vs Expression c
e)) =
      ([([c], ValueType, VariableName)]
created,Procedure c
p,Maybe (Procedure c)
cl,forall c.
[c] -> Positional (Assignable c) -> Expression c -> Statement c
Assignment [c]
c3 (forall a. [a] -> Positional a
Positional [Assignable c]
existing) Expression c
e) where
        ([([c], ValueType, VariableName)]
created,[Assignable c]
existing) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {c}.
Assignable c
-> ([([c], ValueType, VariableName)], [Assignable c])
-> ([([c], ValueType, VariableName)], [Assignable c])
update ([],[]) (forall a. Positional a -> [a]
pValues Positional (Assignable c)
vs)
        update :: Assignable c
-> ([([c], ValueType, VariableName)], [Assignable c])
-> ([([c], ValueType, VariableName)], [Assignable c])
update (CreateVariable [c]
c ValueType
t VariableName
n) ([([c], ValueType, VariableName)]
cs,[Assignable c]
es) = (([c]
c,ValueType
t,VariableName
n)forall a. a -> [a] -> [a]
:[([c], ValueType, VariableName)]
cs,(forall c. InputValue c -> Assignable c
ExistingVariable forall a b. (a -> b) -> a -> b
$ forall c. [c] -> VariableName -> InputValue c
InputValue [c]
c VariableName
n)forall a. a -> [a] -> [a]
:[Assignable c]
es)
        update Assignable c
e2 ([([c], ValueType, VariableName)]
cs,[Assignable c]
es) = ([([c], ValueType, VariableName)]
cs,Assignable c
e2forall a. a -> [a] -> [a]
:[Assignable c]
es)
    rewriteScoped (ScopedBlock [c]
_ Procedure c
p Maybe (Procedure c)
cl [c]
_ (DeferredVariables [c]
c3 [Assignable c]
vs)) =
      ([([c], ValueType, VariableName)]
created,Procedure c
p,Maybe (Procedure c)
cl,forall c. [c] -> [Assignable c] -> Statement c
DeferredVariables [c]
c3 [Assignable c]
existing) where
        ([([c], ValueType, VariableName)]
created,[Assignable c]
existing) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {c}.
Assignable c
-> ([([c], ValueType, VariableName)], [Assignable c])
-> ([([c], ValueType, VariableName)], [Assignable c])
update ([],[]) [Assignable c]
vs
        update :: Assignable c
-> ([([c], ValueType, VariableName)], [Assignable c])
-> ([([c], ValueType, VariableName)], [Assignable c])
update (CreateVariable [c]
c ValueType
t VariableName
n) ([([c], ValueType, VariableName)]
cs,[Assignable c]
es) = (([c]
c,ValueType
t,VariableName
n)forall a. a -> [a] -> [a]
:[([c], ValueType, VariableName)]
cs,(forall c. InputValue c -> Assignable c
ExistingVariable forall a b. (a -> b) -> a -> b
$ forall c. [c] -> VariableName -> InputValue c
InputValue [c]
c VariableName
n)forall a. a -> [a] -> [a]
:[Assignable c]
es)
        update Assignable c
e2 ([([c], ValueType, VariableName)]
cs,[Assignable c]
es) = ([([c], ValueType, VariableName)]
cs,Assignable c
e2forall a. a -> [a] -> [a]
:[Assignable c]
es)
    -- Merge the statement into the scoped block.
    rewriteScoped (ScopedBlock [c]
_ Procedure c
p Maybe (Procedure c)
cl [c]
_ Statement c
s2) =
      ([],Procedure c
p,Maybe (Procedure c)
cl,Statement c
s2)

compileExpression :: (Ord c, Show c, CollectErrorsM m,
                      CompilerContext c m [String] a) =>
  Expression c -> CompilerState a m (ExpressionType,ExpressionValue)
compileExpression :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression = forall {m :: * -> *} {c} {a}.
(CollectErrorsM m, CompilerContext c m [String] a, Ord c,
 Show c) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile where
  callFunctionSpec :: [c]
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionSpec c
-> CompilerState a m (ExpressionType, ExpressionValue)
callFunctionSpec [c]
c Positional (Maybe (CallArgLabel c), Expression c)
as (FunctionSpec [c]
_ (CategoryFunction [c]
c2 CategoryName
cn) FunctionName
fn Positional (InstanceOrInferred c)
ps) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c.
[c] -> CategoryName -> FunctionCall c -> ExpressionStart c
CategoryCall [c]
c2 CategoryName
cn (forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
as)) [])
  callFunctionSpec [c]
c Positional (Maybe (CallArgLabel c), Expression c)
as (FunctionSpec [c]
_ (TypeFunction [c]
c2 TypeInstanceOrParam
tn) FunctionName
fn Positional (InstanceOrInferred c)
ps) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c.
[c] -> TypeInstanceOrParam -> FunctionCall c -> ExpressionStart c
TypeCall [c]
c2 TypeInstanceOrParam
tn (forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
as)) [])
  callFunctionSpec [c]
c Positional (Maybe (CallArgLabel c), Expression c)
as (FunctionSpec [c]
_ (ValueFunction [c]
c2 Expression c
e0) FunctionName
fn Positional (InstanceOrInferred c)
ps) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c. [c] -> Expression c -> ExpressionStart c
ParensExpression [c]
c2 Expression c
e0) [forall c.
[c] -> ValueCallType -> FunctionCall c -> ValueOperation c
ValueCall [c]
c ValueCallType
AlwaysCall (forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
as)])
  callFunctionSpec [c]
c Positional (Maybe (CallArgLabel c), Expression c)
as (FunctionSpec [c]
c2 FunctionQualifier c
UnqualifiedFunction FunctionName
fn Positional (InstanceOrInferred c)
ps) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c. [c] -> FunctionCall c -> ExpressionStart c
UnqualifiedCall [c]
c2 (forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
as)) [])
  compile :: Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (Literal ValueLiteral c
l) = forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ValueLiteral c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileValueLiteral ValueLiteral c
l
  compile (Expression [c]
_ ExpressionStart c
s [ValueOperation c]
os) = do
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {m :: * -> *} {a} {a}.
(Show a, CollectErrorsM m, Ord a,
 CompilerContext a m [String] a) =>
StateT a m (ExpressionType, ExpressionValue)
-> ValueOperation a -> StateT a m (ExpressionType, ExpressionValue)
transform (forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ExpressionStart c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileExpressionStart ExpressionStart c
s) [ValueOperation c]
os
  compile (DelegatedFunctionCall [c]
c FunctionSpec c
f) = String
"In function delegation 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
    Positional (Maybe (CallArgLabel c), VariableName)
args <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState
  a m (Positional (Maybe (CallArgLabel c), VariableName))
csDelegateArgs
    let vars :: Positional (Maybe (CallArgLabel c), Expression c)
vars = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Maybe (CallArgLabel c)
l,VariableName
v) -> (Maybe (CallArgLabel c)
l,forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c. OutputValue c -> ExpressionStart c
NamedVariable (forall c. [c] -> VariableName -> OutputValue c
OutputValue [c]
c VariableName
v)) [])) Positional (Maybe (CallArgLabel c), VariableName)
args
    [c]
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionSpec c
-> CompilerState a m (ExpressionType, ExpressionValue)
callFunctionSpec [c]
c Positional (Maybe (CallArgLabel c), Expression c)
vars FunctionSpec c
f
  compile (DelegatedInitializeValue [c]
c Maybe TypeInstance
t) = String
"In initialization delegation 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
    Positional (Maybe (CallArgLabel c), VariableName)
args <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState
  a m (Positional (Maybe (CallArgLabel c), VariableName))
csDelegateArgs
    let vars :: Positional (Expression c)
vars = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Maybe (CallArgLabel c)
_,VariableName
v) -> forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c. OutputValue c -> ExpressionStart c
NamedVariable (forall c. [c] -> VariableName -> OutputValue c
OutputValue [c]
c VariableName
v)) []) Positional (Maybe (CallArgLabel c), VariableName)
args
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c  (forall c.
[c]
-> Maybe TypeInstance
-> Positional (Expression c)
-> ExpressionStart c
InitializeValue [c]
c Maybe TypeInstance
t Positional (Expression c)
vars) [])
  compile (UnaryExpression [c]
c (FunctionOperator [c]
_ fa :: FunctionSpec c
fa@(FunctionSpec [c]
_ FunctionQualifier c
_ FunctionName
_ Positional (InstanceOrInferred c)
_)) Expression c
e) =
    [c]
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionSpec c
-> CompilerState a m (ExpressionType, ExpressionValue)
callFunctionSpec [c]
c (forall a. [a] -> Positional a
Positional [(forall a. Maybe a
Nothing,Expression c
e)]) FunctionSpec c
fa
  compile (UnaryExpression [c]
_ (NamedOperator [c]
c String
"-") (Literal (IntegerLiteral [c]
_ Bool
_ Integer
l))) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c. ValueLiteral c -> Expression c
Literal (forall c. [c] -> Bool -> Integer -> ValueLiteral c
IntegerLiteral [c]
c Bool
False (-Integer
l)))
  compile (UnaryExpression [c]
_ (NamedOperator [c]
c String
"-") (Literal (DecimalLiteral [c]
_ Integer
l Integer
e Integer
b))) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c. ValueLiteral c -> Expression c
Literal (forall c. [c] -> Integer -> Integer -> Integer -> ValueLiteral c
DecimalLiteral [c]
c (-Integer
l) Integer
e Integer
b))
  compile (UnaryExpression [c]
_ (NamedOperator [c]
c String
o) Expression c
e) = do
    (Positional [ValueType]
ts,ExpressionValue
e') <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
    ValueType
t' <- forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [c]
c [ValueType]
ts
    forall {m :: * -> *}.
ErrorContextM m =>
ValueType -> ExpressionValue -> m (ExpressionType, ExpressionValue)
doUnary ValueType
t' ExpressionValue
e'
    where
      doUnary :: ValueType -> ExpressionValue -> m (ExpressionType, ExpressionValue)
doUnary ValueType
t ExpressionValue
e2
        | String
o forall a. Eq a => a -> a -> Bool
== String
"!" = forall {m :: * -> *}.
ErrorContextM m =>
ValueType -> ExpressionValue -> m (ExpressionType, ExpressionValue)
doNot ValueType
t ExpressionValue
e2
        | String
o forall a. Eq a => a -> a -> Bool
== String
"-" = forall {m :: * -> *}.
ErrorContextM m =>
ValueType -> ExpressionValue -> m (ExpressionType, ExpressionValue)
doNeg ValueType
t ExpressionValue
e2
        | String
o forall a. Eq a => a -> a -> Bool
== String
"~" = forall {m :: * -> *}.
ErrorContextM m =>
ValueType -> ExpressionValue -> m (ExpressionType, ExpressionValue)
doComp ValueType
t ExpressionValue
e2
        | Bool
otherwise = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Unknown unary operator \"" forall a. [a] -> [a] -> [a]
++ String
o forall a. [a] -> [a] -> [a]
++ String
"\" " forall a. [a] -> [a] -> [a]
++
                                       forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
      doNot :: ValueType -> ExpressionValue -> m (ExpressionType, ExpressionValue)
doNot ValueType
t ExpressionValue
e2 = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValueType
t forall a. Eq a => a -> a -> Bool
/= ValueType
boolRequiredValue) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Cannot use " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
t forall a. [a] -> [a] -> [a]
++ String
" with unary ! operator" forall a. [a] -> [a] -> [a]
++
                            forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType -> String -> ExpressionValue
UnboxedPrimitive PrimitiveType
PrimBool forall a b. (a -> b) -> a -> b
$ String
"!(" forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExpressionValue -> String
useAsUnboxed PrimitiveType
PrimBool ExpressionValue
e2 forall a. [a] -> [a] -> [a]
++ String
")")
      doNeg :: ValueType -> ExpressionValue -> m (ExpressionType, ExpressionValue)
doNeg ValueType
t ExpressionValue
e2
        | ValueType
t forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],
                                            PrimitiveType -> String -> ExpressionValue
UnboxedPrimitive PrimitiveType
PrimInt forall a b. (a -> b) -> a -> b
$ String
"-" forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExpressionValue -> String
useAsUnboxed PrimitiveType
PrimInt ExpressionValue
e2)
        | ValueType
t forall a. Eq a => a -> a -> Bool
== ValueType
floatRequiredValue = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Positional a
Positional [ValueType
floatRequiredValue],
                                             PrimitiveType -> String -> ExpressionValue
UnboxedPrimitive PrimitiveType
PrimFloat forall a b. (a -> b) -> a -> b
$ String
"-(" forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExpressionValue -> String
useAsUnboxed PrimitiveType
PrimFloat ExpressionValue
e2 forall a. [a] -> [a] -> [a]
++ String
")")
        | Bool
otherwise = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Cannot use " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
t forall a. [a] -> [a] -> [a]
++ String
" with unary - operator" forall a. [a] -> [a] -> [a]
++
                                       forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
      doComp :: ValueType -> ExpressionValue -> m (ExpressionType, ExpressionValue)
doComp ValueType
t ExpressionValue
e2
        | ValueType
t forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],
                                            PrimitiveType -> String -> ExpressionValue
UnboxedPrimitive PrimitiveType
PrimInt forall a b. (a -> b) -> a -> b
$ String
"~(" forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExpressionValue -> String
useAsUnboxed PrimitiveType
PrimInt ExpressionValue
e2 forall a. [a] -> [a] -> [a]
++ String
")")
        | Bool
otherwise = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Cannot use " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
t forall a. [a] -> [a] -> [a]
++ String
" with unary ~ operator" forall a. [a] -> [a] -> [a]
++
                                       forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  compile (InfixExpression [c]
c Expression c
e1 (FunctionOperator [c]
_ (FunctionSpec [c]
_ (CategoryFunction [c]
c2 CategoryName
cn) FunctionName
fn Positional (InstanceOrInferred c)
ps)) Expression c
e2) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c.
[c] -> CategoryName -> FunctionCall c -> ExpressionStart c
CategoryCall [c]
c2 CategoryName
cn (forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps (forall a. [a] -> Positional a
Positional [(forall a. Maybe a
Nothing,Expression c
e1),(forall a. Maybe a
Nothing,Expression c
e2)]))) [])
  compile (InfixExpression [c]
c Expression c
e1 (FunctionOperator [c]
_ (FunctionSpec [c]
_ (TypeFunction [c]
c2 TypeInstanceOrParam
tn) FunctionName
fn Positional (InstanceOrInferred c)
ps)) Expression c
e2) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c.
[c] -> TypeInstanceOrParam -> FunctionCall c -> ExpressionStart c
TypeCall [c]
c2 TypeInstanceOrParam
tn (forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps (forall a. [a] -> Positional a
Positional [(forall a. Maybe a
Nothing,Expression c
e1),(forall a. Maybe a
Nothing,Expression c
e2)]))) [])
  compile (InfixExpression [c]
c Expression c
e1 (FunctionOperator [c]
_ (FunctionSpec [c]
_ (ValueFunction [c]
c2 Expression c
e0) FunctionName
fn Positional (InstanceOrInferred c)
ps)) Expression c
e2) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c. [c] -> Expression c -> ExpressionStart c
ParensExpression [c]
c2 Expression c
e0) [forall c.
[c] -> ValueCallType -> FunctionCall c -> ValueOperation c
ValueCall [c]
c ValueCallType
AlwaysCall (forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps (forall a. [a] -> Positional a
Positional [(forall a. Maybe a
Nothing,Expression c
e1),(forall a. Maybe a
Nothing,Expression c
e2)]))])
  compile (InfixExpression [c]
c Expression c
e1 (FunctionOperator [c]
_ (FunctionSpec [c]
c2 FunctionQualifier c
UnqualifiedFunction FunctionName
fn Positional (InstanceOrInferred c)
ps)) Expression c
e2) =
    Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compile (forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c (forall c. [c] -> FunctionCall c -> ExpressionStart c
UnqualifiedCall [c]
c2 (forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Maybe (CallArgLabel c), Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps (forall a. [a] -> Positional a
Positional [(forall a. Maybe a
Nothing,Expression c
e1),(forall a. Maybe a
Nothing,Expression c
e2)]))) [])
  compile (InfixExpression [c]
_ Expression c
e1 (NamedOperator [c]
c String
o) Expression c
e2) = do
    (ExpressionType, ExpressionValue)
e1' <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e1
    (ExpressionType, ExpressionValue)
e2' <- if String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
logical
              then forall {m :: * -> *} {c} {s}.
(CollectErrorsM m, CompilerContext c m [String] s, Show c,
 Ord c) =>
Expression c -> StateT s m (ExpressionType, ExpressionValue)
isolateExpression Expression c
e2 -- Ignore named-return assignments.
              else forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e2
    forall {m :: * -> *} {a}.
(ErrorContextM m, Show a) =>
[a]
-> (ExpressionType, ExpressionValue)
-> String
-> (ExpressionType, ExpressionValue)
-> m (ExpressionType, ExpressionValue)
bindInfix [c]
c (ExpressionType, ExpressionValue)
e1' String
o (ExpressionType, ExpressionValue)
e2'
  compile (RawExpression ExpressionType
ts ExpressionValue
e) = forall (m :: * -> *) a. Monad m => a -> m a
return (ExpressionType
ts,ExpressionValue
e)
  isolateExpression :: Expression c -> StateT s m (ExpressionType, ExpressionValue)
isolateExpression Expression c
e = do
    s
ctx <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
    ((ExpressionType, ExpressionValue)
e',s
ctx') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e) s
ctx
    forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired s
ctx'
    forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> CompilerState a m ()
csInheritUsed s
ctx'
    forall (m :: * -> *) a. Monad m => a -> m a
return (ExpressionType, ExpressionValue)
e'
  arithmetic1 :: Set String
arithmetic1 = forall a. Ord a => [a] -> Set a
Set.fromList [String
"*",String
"/"]
  arithmetic2 :: Set String
arithmetic2 = forall a. Ord a => [a] -> Set a
Set.fromList [String
"%"]
  arithmetic3 :: Set String
arithmetic3 = forall a. Ord a => [a] -> Set a
Set.fromList [String
"+",String
"-"]
  equals :: Set String
equals = forall a. Ord a => [a] -> Set a
Set.fromList [String
"==",String
"!="]
  comparison :: Set String
comparison = forall a. Ord a => [a] -> Set a
Set.fromList [String
"==",String
"!=",String
"<",String
"<=",String
">",String
">="]
  logical :: Set String
logical = forall a. Ord a => [a] -> Set a
Set.fromList [String
"&&",String
"||"]
  bitwise :: Set String
bitwise = forall a. Ord a => [a] -> Set a
Set.fromList [String
"&",String
"|",String
"^",String
">>",String
"<<"]
  bindInfix :: [a]
-> (ExpressionType, ExpressionValue)
-> String
-> (ExpressionType, ExpressionValue)
-> m (ExpressionType, ExpressionValue)
bindInfix [a]
c (Positional [ValueType]
ts1,ExpressionValue
e1) String
o (Positional [ValueType]
ts2,ExpressionValue
e2) = do
    -- TODO: Needs better error messages.
    ValueType
t1' <- forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [a]
c [ValueType]
ts1
    ValueType
t2' <- forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [a]
c [ValueType]
ts2
    forall {m :: * -> *}.
ErrorContextM m =>
ValueType -> ValueType -> m (ExpressionType, ExpressionValue)
bind ValueType
t1' ValueType
t2'
    where
      bind :: ValueType -> ValueType -> m (ExpressionType, ExpressionValue)
bind ValueType
t1 ValueType
t2
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
comparison Bool -> Bool -> Bool
&& ValueType -> Bool
isIdentifierRequiredValue ValueType
t1 Bool -> Bool -> Bool
&& ValueType -> Bool
isIdentifierRequiredValue ValueType
t2 = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimIdentifier PrimitiveType
PrimBool ExpressionValue
e1 String
o ExpressionValue
e2)
        | ValueType
t1 forall a. Eq a => a -> a -> Bool
/= ValueType
t2 =
          forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Cannot " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
o forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
t1 forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++
                           forall a. Show a => a -> String
show ValueType
t2 forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
comparison Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimBool ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
comparison Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
floatRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimFloat PrimitiveType
PrimBool ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
comparison Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
stringRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimString PrimitiveType
PrimBool ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
comparison Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
charRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimChar PrimitiveType
PrimBool ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic1 Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimInt ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
bitwise Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimInt ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic2 Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimInt ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic3 Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimInt ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic1 Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
floatRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
floatRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimFloat PrimitiveType
PrimFloat ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic3 Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
floatRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
floatRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimFloat PrimitiveType
PrimFloat ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Eq a => a -> a -> Bool
== String
"+" Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
stringRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
stringRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimString PrimitiveType
PrimString ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
logical Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
boolRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimBool PrimitiveType
PrimBool ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Eq a => a -> a -> Bool
== String
"^" Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
boolRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimBool PrimitiveType
PrimBool ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Eq a => a -> a -> Bool
== String
"-" Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
charRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimChar PrimitiveType
PrimInt ExpressionValue
e1 String
o ExpressionValue
e2)
        | String
o forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
equals Bool -> Bool -> Bool
&& ValueType
t1 forall a. Eq a => a -> a -> Bool
== ValueType
boolRequiredValue = do
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
PrimBool PrimitiveType
PrimBool ExpressionValue
e1 String
o ExpressionValue
e2)
        | Bool
otherwise =
          forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Cannot " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
o forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
t1 forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++
                                 forall a. Show a => a -> String
show ValueType
t2 forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
      glueInfix :: PrimitiveType
-> PrimitiveType
-> ExpressionValue
-> String
-> ExpressionValue
-> ExpressionValue
glueInfix PrimitiveType
t1 PrimitiveType
t2 ExpressionValue
e3 String
o2 ExpressionValue
e4 =
        PrimitiveType -> String -> ExpressionValue
UnboxedPrimitive PrimitiveType
t2 forall a b. (a -> b) -> a -> b
$ String
"(" forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExpressionValue -> String
useAsUnboxed PrimitiveType
t1 ExpressionValue
e3 forall a. [a] -> [a] -> [a]
++ String
")" forall a. [a] -> [a] -> [a]
++ String
o2 forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExpressionValue -> String
useAsUnboxed PrimitiveType
t1 ExpressionValue
e4 forall a. [a] -> [a] -> [a]
++ String
")"
  transform :: StateT a m (ExpressionType, ExpressionValue)
-> ValueOperation a -> StateT a m (ExpressionType, ExpressionValue)
transform StateT a m (ExpressionType, ExpressionValue)
e (TypeConversion [a]
c GeneralInstance
t) = do
    (Positional [ValueType]
ts,ExpressionValue
e') <- StateT a m (ExpressionType, ExpressionValue)
e
    ValueType
t' <- forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [a]
c [ValueType]
ts
    AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
    ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
    let vt :: ValueType
vt = StorageType -> GeneralInstance -> ValueType
ValueType (ValueType -> StorageType
vtRequired ValueType
t') GeneralInstance
t
    (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t' ValueType
vt) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
      String
"In explicit type conversion at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [a]
c
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
vt],ExpressionValue
e')
  transform StateT a m (ExpressionType, ExpressionValue)
e (ValueCall [a]
c ValueCallType
o FunctionCall a
f) = do
    (Positional [ValueType]
ts,ExpressionValue
e') <- StateT a m (ExpressionType, ExpressionValue)
e
    ValueType
t' <- forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [a]
c [ValueType]
ts
    ScopedFunction a
f' <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ValueType
-> ValueCallType
-> FunctionCall c
-> CompilerState a m (ScopedFunction c)
lookupValueFunction ValueType
t' ValueCallType
o FunctionCall a
f
    forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Bool
-> Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileFunctionCall (ValueCallType
o forall a. Eq a => a -> a -> Bool
== ValueCallType
CallUnlessEmpty) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExpressionValue -> String
useAsUnwrapped ExpressionValue
e') ScopedFunction a
f' FunctionCall a
f
  transform StateT a m (ExpressionType, ExpressionValue)
e (SelectReturn [a]
c Int
pos) = do
    (Positional [ValueType]
ts,ExpressionValue
e') <- StateT a m (ExpressionType, ExpressionValue)
e
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ExpressionValue -> Bool
isOpaqueMulti ExpressionValue
e') forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Return selection can only be used with function returns" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pos forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [ValueType]
ts) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Position " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
pos forall a. [a] -> [a] -> [a]
++ String
" exceeds return count " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ValueType]
ts) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [a]
c
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [[ValueType]
ts forall a. [a] -> Int -> a
!! Int
pos],String -> ExpressionValue
WrappedSingle forall a b. (a -> b) -> a -> b
$ ExpressionValue -> String
useAsReturns ExpressionValue
e' forall a. [a] -> [a] -> [a]
++ String
".At(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
pos forall a. [a] -> [a] -> [a]
++ String
")")
  requireSingle :: [a] -> [a] -> m a
requireSingle [a]
_ [a
t] = forall (m :: * -> *) a. Monad m => a -> m a
return a
t
  requireSingle [a]
c2 [a]
ts =
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Function call requires one return but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatTypes [a]
ts forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
  formatTypes :: [a] -> String
formatTypes [] = String
"none"
  formatTypes [a]
ts = forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [a]
ts)

forceOptionalReturns :: [c] -> ScopedFunction c -> ScopedFunction c
forceOptionalReturns :: forall c. [c] -> ScopedFunction c -> ScopedFunction c
forceOptionalReturns [c]
c0 (ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s FunctionVisibility c
v Positional (PassedValue c, Maybe (CallArgLabel c))
as Positional (PassedValue c)
rs Positional (ValueParam c)
ps [ParamFilter c]
fs [ScopedFunction c]
ms) =
  forall c.
[c]
-> FunctionName
-> CategoryName
-> SymbolScope
-> FunctionVisibility c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s FunctionVisibility c
v Positional (PassedValue c, Maybe (CallArgLabel c))
as Positional (PassedValue c)
rs' Positional (ValueParam c)
ps [ParamFilter c]
fs [ScopedFunction c]
ms where
    rs' :: Positional (PassedValue c)
rs' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PassedValue c -> PassedValue c
forceOptional Positional (PassedValue c)
rs
    forceOptional :: PassedValue c -> PassedValue c
forceOptional (PassedValue [c]
c2 (ValueType StorageType
RequiredValue GeneralInstance
t2)) = (forall c. [c] -> ValueType -> PassedValue c
PassedValue ([c]
c0 forall a. [a] -> [a] -> [a]
++ [c]
c2) (StorageType -> GeneralInstance -> ValueType
ValueType StorageType
OptionalValue GeneralInstance
t2))
    forceOptional PassedValue c
t2 = PassedValue c
t2

lookupValueFunction :: (Ord c, Show c, CollectErrorsM m,
                        CompilerContext c m [String] a) =>
  ValueType -> ValueCallType -> FunctionCall c -> CompilerState a m (ScopedFunction c)
lookupValueFunction :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ValueType
-> ValueCallType
-> FunctionCall c
-> CompilerState a m (ScopedFunction c)
lookupValueFunction (ValueType StorageType
OptionalValue GeneralInstance
t) ValueCallType
CallUnlessEmpty f :: FunctionCall c
f@(FunctionCall [c]
c FunctionName
_ Positional (InstanceOrInferred c)
_ Positional (Maybe (CallArgLabel c), Expression c)
_) = do
  ScopedFunction c
f' <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ValueType
-> ValueCallType
-> FunctionCall c
-> CompilerState a m (ScopedFunction c)
lookupValueFunction (StorageType -> GeneralInstance -> ValueType
ValueType StorageType
RequiredValue GeneralInstance
t) ValueCallType
AlwaysCall FunctionCall c
f
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> ScopedFunction c -> ScopedFunction c
forceOptionalReturns [c]
c ScopedFunction c
f'
lookupValueFunction ValueType
t ValueCallType
CallUnlessEmpty (FunctionCall [c]
c FunctionName
_ Positional (InstanceOrInferred c)
_ Positional (Maybe (CallArgLabel c), Expression c)
_) =
  forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Optional type required for &. but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
lookupValueFunction (ValueType StorageType
WeakValue GeneralInstance
t) ValueCallType
_ (FunctionCall [c]
c FunctionName
_ Positional (InstanceOrInferred c)
_ Positional (Maybe (CallArgLabel c), Expression c)
_) =
  forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Use strong to convert weak " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralInstance
t forall a. [a] -> [a] -> [a]
++
                        String
" to optional first" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
lookupValueFunction (ValueType StorageType
OptionalValue GeneralInstance
t) ValueCallType
_ (FunctionCall [c]
c FunctionName
_ Positional (InstanceOrInferred c)
_ Positional (Maybe (CallArgLabel c), Expression c)
_) =
  forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Use require to convert optional " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralInstance
t forall a. [a] -> [a] -> [a]
++
                        String
" to required first" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
lookupValueFunction (ValueType StorageType
RequiredValue GeneralInstance
t) ValueCallType
_ (FunctionCall [c]
c FunctionName
n Positional (InstanceOrInferred c)
_ Positional (Maybe (CallArgLabel c), Expression c)
_) = do
  ScopedFunction c
f' <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetTypeFunction [c]
c (forall a. a -> Maybe a
Just GeneralInstance
t) FunctionName
n
  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
ValueScope) 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
" cannot be used as a value function" forall a. [a] -> [a] -> [a]
++
                                                     forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (m :: * -> *) a. Monad m => a -> m a
return ScopedFunction c
f'

compileExpressionStart :: (Ord c, Show c, CollectErrorsM m,
                           CompilerContext c m [String] a) =>
  ExpressionStart c -> CompilerState a m (ExpressionType,ExpressionValue)
compileExpressionStart :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ExpressionStart c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileExpressionStart (NamedVariable (OutputValue [c]
c VariableName
n)) = do
  let var :: UsedVariable c
var = forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n
  (VariableValue [c]
_ SymbolScope
s ValueType
t VariableRule c
_) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable UsedVariable c
var
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[UsedVariable c] -> CompilerState a m ()
csCheckVariableInit [UsedVariable c
var]
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csAddUsed UsedVariable c
var
  String
scoped <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
  let lazy :: Bool
lazy = SymbolScope
s forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
t],Bool -> ValueType -> String -> ExpressionValue
readStoredVariable Bool
lazy ValueType
t (String
scoped forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n))
compileExpressionStart (NamedMacro [c]
c MacroName
n) = do
  Expression c
e <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> MacroName -> CompilerState a m (Expression c)
csExprLookup [c]
c MacroName
n
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> MacroName -> CompilerState a m ()
csReserveExprMacro [c]
c MacroName
n
  (ExpressionType, ExpressionValue)
e' <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In expansion of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show MacroName
n forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  -- NOTE: This will be skipped if expression compilation fails.
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> MacroName -> CompilerState a m ()
csReleaseExprMacro [c]
c MacroName
n
  forall (m :: * -> *) a. Monad m => a -> m a
return (ExpressionType, ExpressionValue)
e'
compileExpressionStart (ExpressionMacro [c]
c MacroExpression
MacroCallTrace) = do
  Bool
to <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csGetTestsOnly
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
to) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"$CallTrace$ is a $TestsOnly$ macro" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinOrder,CategoryName
BuiltinFormatted]
  let formatted :: GeneralInstance
formatted = forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (CategoryName -> Positional GeneralInstance -> TypeInstance
TypeInstance CategoryName
BuiltinFormatted (forall a. [a] -> Positional a
Positional []))
  let order :: GeneralInstance
order = forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (CategoryName -> Positional GeneralInstance -> TypeInstance
TypeInstance CategoryName
BuiltinOrder (forall a. [a] -> Positional a
Positional [GeneralInstance
formatted]))
  ScopedFunction c
nextFunc <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetTypeFunction [c]
c (forall a. a -> Maybe a
Just GeneralInstance
order) (String -> FunctionName
FunctionName String
"next")
  ScopedFunction c
getFunc <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetTypeFunction [c]
c (forall a. a -> Maybe a
Just GeneralInstance
order) (String -> FunctionName
FunctionName String
"get")
  let getTrace :: String
getTrace = String
"GetCallTrace(" forall a. [a] -> [a] -> [a]
++ forall c. ScopedFunction c -> String
functionName ScopedFunction c
getFunc forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall c. ScopedFunction c -> String
functionName ScopedFunction c
nextFunc forall a. [a] -> [a] -> [a]
++ String
")"
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [GeneralInstance -> ValueType
orderOptionalValue GeneralInstance
formatted],String -> ExpressionValue
UnwrappedSingle String
getTrace)
compileExpressionStart (CategoryCall [c]
c CategoryName
t f :: FunctionCall c
f@(FunctionCall [c]
_ FunctionName
n Positional (InstanceOrInferred c)
_ Positional (Maybe (CallArgLabel c), Expression c)
_)) = do
  ScopedFunction c
f' <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe CategoryName
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetCategoryFunction [c]
c (forall a. a -> Maybe a
Just CategoryName
t) FunctionName
n
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
t,forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f']
  String
t' <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CategoryName -> CompilerState a m String
expandCategory CategoryName
t
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Bool
-> Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileFunctionCall Bool
False (forall a. a -> Maybe a
Just String
t') ScopedFunction c
f' FunctionCall c
f
compileExpressionStart (TypeCall [c]
c TypeInstanceOrParam
t f :: FunctionCall c
f@(FunctionCall [c]
_ FunctionName
n Positional (InstanceOrInferred c)
_ Positional (Maybe (CallArgLabel c), Expression c)
_)) = do
  GeneralInstance
self <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  GeneralInstance
t' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType TypeInstanceOrParam
t)
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> m ()
validateGeneralInstanceForCall AnyTypeResolver
r ParamFilters
fa GeneralInstance
t' forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In function call at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  ScopedFunction c
f' <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetTypeFunction [c]
c (forall a. a -> Maybe a
Just GeneralInstance
t') FunctionName
n
  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
TypeScope) 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
" cannot be used as a type function" forall a. [a] -> [a] -> [a]
++
                                                    forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ 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 GeneralInstance -> Set CategoryName
categoriesFromTypes [GeneralInstance
t']
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f']
  Bool
same <- GeneralInstance -> StateT a m (Maybe (T GeneralInstance))
maybeSingleType GeneralInstance
t' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {c} {m :: * -> *} {s} {a}.
CompilerContext c m s a =>
Maybe TypeInstanceOrParam -> CompilerState a m Bool
checkSame
  Maybe String
t2 <- if Bool
same
           then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
           else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t'
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Bool
-> Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileFunctionCall Bool
False Maybe String
t2 ScopedFunction c
f' FunctionCall c
f
  where
    maybeSingleType :: GeneralInstance -> StateT a m (Maybe (T GeneralInstance))
maybeSingleType = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. CollectErrorsM m => m a -> m (Maybe a)
tryCompilerM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf
    checkSame :: Maybe TypeInstanceOrParam -> CompilerState a m Bool
checkSame (Just (JustTypeInstance TypeInstance
t2)) = forall c (m :: * -> *) s a.
CompilerContext c m s a =>
TypeInstance -> CompilerState a m Bool
csSameType TypeInstance
t2
    checkSame Maybe TypeInstanceOrParam
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
compileExpressionStart (UnqualifiedCall [c]
c f :: FunctionCall c
f@(FunctionCall [c]
_ FunctionName
n Positional (InstanceOrInferred c)
_ Positional (Maybe (CallArgLabel c), Expression c)
_)) = do
  a
ctx <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  ScopedFunction c
f' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM [forall {m :: * -> *} {s} {a}.
CompilerContext c m s a =>
a -> m (ScopedFunction c)
tryCategory a
ctx,forall {m :: * -> *} {s} {a}.
(CompilerContext c m s a, ErrorContextM m) =>
a -> m (ScopedFunction c)
tryNonCategory a
ctx] forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In function call at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f']
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Bool
-> Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileFunctionCall Bool
False forall a. Maybe a
Nothing ScopedFunction c
f' FunctionCall c
f
  where
    tryCategory :: a -> m (ScopedFunction c)
tryCategory a
ctx = forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a
-> [c]
-> Maybe CategoryName
-> FunctionName
-> m (ScopedFunction c)
ccGetCategoryFunction a
ctx [c]
c forall a. Maybe a
Nothing FunctionName
n
    tryNonCategory :: a -> m (ScopedFunction c)
tryNonCategory a
ctx = do
      ScopedFunction c
f' <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a
-> [c]
-> Maybe GeneralInstance
-> FunctionName
-> m (ScopedFunction c)
ccGetTypeFunction a
ctx [c]
c forall a. Maybe a
Nothing FunctionName
n
      SymbolScope
s <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m SymbolScope
ccCurrentScope a
ctx
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f' forall a. Ord a => a -> a -> Bool
> SymbolScope
s) 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
" is not in scope here" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
      forall (m :: * -> *) a. Monad m => a -> m a
return ScopedFunction c
f'
-- TODO: Compile BuiltinCall like regular functions, for consistent validation.
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinPresent Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
es)) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinBool])
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 0 type parameters" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es) forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 1 argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  [(ExpressionType, ExpressionValue)]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression 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 (Maybe (CallArgLabel c), Expression c)
es
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es') forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExpressionValue
e) = forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValueType -> Bool
isWeakValue ValueType
t0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Weak values not allowed here" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],
            PrimitiveType -> String -> ExpressionValue
UnboxedPrimitive PrimitiveType
PrimBool forall a b. (a -> b) -> a -> b
$ String
"BoxedValue::Present(" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsUnwrapped ExpressionValue
e forall a. [a] -> [a] -> [a]
++ String
")")
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinIdentify Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
es)) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 0 type parameters" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es) forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 1 argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  [(ExpressionType, ExpressionValue)]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression 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 (Maybe (CallArgLabel c), Expression c)
es
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es') forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExpressionValue
e) = forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValueType -> Bool
isWeakValue ValueType
t0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Weak values not allowed here" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinIdentifier]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Positional a
Positional [StorageType -> GeneralInstance -> ValueType
ValueType StorageType
RequiredValue (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (CategoryName -> Positional GeneralInstance -> TypeInstance
TypeInstance CategoryName
BuiltinIdentifier (forall a. [a] -> Positional a
Positional [(ValueType -> GeneralInstance
vtType ValueType
t0)])))],
            PrimitiveType -> String -> ExpressionValue
UnboxedPrimitive PrimitiveType
PrimIdentifier forall a b. (a -> b) -> a -> b
$ String
"BoxedValue::Identify(" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsUnwrapped ExpressionValue
e forall a. [a] -> [a] -> [a]
++ String
")")
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinReduce Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
es)) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) forall a. Eq a => a -> a -> Bool
/= Int
2) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 2 type parameters" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es) forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 1 argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  [(ExpressionType, ExpressionValue)]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression 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 (Maybe (CallArgLabel c), Expression c)
es
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es') forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExpressionValue
e) = forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es'
  GeneralInstance
self <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  [GeneralInstance]
ps' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Positional (InstanceOrInferred c) -> m [GeneralInstance]
disallowInferred Positional (InstanceOrInferred c)
ps
  [GeneralInstance
t1,GeneralInstance
t2] <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self) [GeneralInstance]
ps'
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> GeneralInstance -> m ()
validateGeneralInstance AnyTypeResolver
r (forall k a. Map k a -> Set k
Map.keysSet ParamFilters
fa) GeneralInstance
t1
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> GeneralInstance -> m ()
validateGeneralInstance AnyTypeResolver
r (forall k a. Map k a -> Set k
Map.keysSet ParamFilters
fa) GeneralInstance
t2
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t0 (StorageType -> GeneralInstance -> ValueType
ValueType StorageType
OptionalValue GeneralInstance
t1)) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In argument to reduce call at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  -- TODO: If t1 -> t2 then just return e without a Reduce call.
  String
t1' <- forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t1
  String
t2' <- forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t2
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ GeneralInstance -> Set CategoryName
categoriesFromTypes GeneralInstance
t1
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ GeneralInstance -> Set CategoryName
categoriesFromTypes GeneralInstance
t2
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Positional a
Positional [StorageType -> GeneralInstance -> ValueType
ValueType StorageType
OptionalValue GeneralInstance
t2],
            String -> ExpressionValue
UnwrappedSingle forall a b. (a -> b) -> a -> b
$ String
typeBase forall a. [a] -> [a] -> [a]
++ String
"::Reduce(" forall a. [a] -> [a] -> [a]
++ String
t1' forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
t2' forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsUnwrapped ExpressionValue
e forall a. [a] -> [a] -> [a]
++ String
")")
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinRequire Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
es)) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 0 type parameters" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es) forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 1 argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  [(ExpressionType, ExpressionValue)]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression 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 (Maybe (CallArgLabel c), Expression c)
es
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es') forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExpressionValue
e) = forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValueType -> Bool
isWeakValue ValueType
t0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Weak values not allowed here" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Positional a
Positional [StorageType -> GeneralInstance -> ValueType
ValueType StorageType
RequiredValue (ValueType -> GeneralInstance
vtType ValueType
t0)],
            String -> ExpressionValue
UnwrappedSingle forall a b. (a -> b) -> a -> b
$ String
"BoxedValue::Require(" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsUnwrapped ExpressionValue
e forall a. [a] -> [a] -> [a]
++ String
")")
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinStrong Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
es)) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 0 type parameters" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es) forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 1 argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  [(ExpressionType, ExpressionValue)]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression 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 (Maybe (CallArgLabel c), Expression c)
es
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es') forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExpressionValue
e) = forall a. [a] -> a
head [(ExpressionType, ExpressionValue)]
es'
  let t1 :: ExpressionType
t1 = forall a. [a] -> Positional a
Positional [StorageType -> GeneralInstance -> ValueType
ValueType StorageType
OptionalValue (ValueType -> GeneralInstance
vtType ValueType
t0)]
  if ValueType -> Bool
isWeakValue ValueType
t0
     -- Weak values are already unboxed.
     then forall (m :: * -> *) a. Monad m => a -> m a
return (ExpressionType
t1,String -> ExpressionValue
UnwrappedSingle forall a b. (a -> b) -> a -> b
$ String
"BoxedValue::Strong(" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsUnwrapped ExpressionValue
e forall a. [a] -> [a] -> [a]
++ String
")")
     else forall (m :: * -> *) a. Monad m => a -> m a
return (ExpressionType
t1,ExpressionValue
e)
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinTypename Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
es)) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 1 type parameter" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es) forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected 0 arguments" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  GeneralInstance
self <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  [GeneralInstance]
ps' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Positional (InstanceOrInferred c) -> m [GeneralInstance]
disallowInferred Positional (InstanceOrInferred c)
ps
  [GeneralInstance
t] <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self) [GeneralInstance]
ps'
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> GeneralInstance -> m ()
validateGeneralInstance AnyTypeResolver
r (forall k a. Map k a -> Set k
Map.keysSet ParamFilters
fa) GeneralInstance
t
  String
t' <- forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ 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 GeneralInstance -> Set CategoryName
categoriesFromTypes [GeneralInstance
t]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Positional a
Positional [ValueType
formattedRequiredValue],
            ExpressionValue -> ExpressionValue
valueAsWrapped forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> ExpressionValue
UnboxedPrimitive PrimitiveType
PrimString forall a b. (a -> b) -> a -> b
$ String
typeBase forall a. [a] -> [a] -> [a]
++ String
"::TypeName(" forall a. [a] -> [a] -> [a]
++ String
t' forall a. [a] -> [a] -> [a]
++ String
")")
compileExpressionStart (BuiltinCall [c]
_ FunctionCall c
_) = forall a. HasCallStack => a
undefined
compileExpressionStart (ParensExpression [c]
_ Expression c
e) = forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
compileExpressionStart (InlineAssignment [c]
c VariableName
n AssignmentType
o Expression c
e) = do
  (VariableValue [c]
_ SymbolScope
s ValueType
t0 VariableRule c
_) <- forall c (m :: * -> *) a.
(Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> VariableName -> CompilerState a m (VariableValue c)
getWritableVariable [c]
c VariableName
n
  (ExpressionType, ExpressionValue)
e2 <- forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression Expression c
e
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ (ExpressionType, ExpressionValue)
e2) forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected single return" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t],ExpressionValue
e') = (ExpressionType, ExpressionValue)
e2
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AssignmentType
o forall a. Eq a => a -> a -> Bool
== AssignmentType
AssignIfEmpty Bool -> Bool -> Bool
&& Bool -> Bool
not (ValueType -> Bool
isOptionalValue ValueType
t0)) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Variable must have an optional type" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AssignmentType
o forall a. Eq a => a -> a -> Bool
== AssignmentType
AssignIfEmpty) forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[UsedVariable c] -> CompilerState a m ()
csCheckVariableInit [forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n]
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t ValueType
t0) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In assignment at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
VariableName -> CompilerState a m ()
csUpdateAssigned VariableName
n
  String
scoped <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
  let lazy :: Bool
lazy = SymbolScope
s forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope
  let variable :: String
variable = String
scoped forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n
  let assign :: String
assign = String
variable forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
t0 ExpressionValue
e'
  let check :: String
check = String
"BoxedValue::Present(" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsUnwrapped (Bool -> ValueType -> String -> ExpressionValue
readStoredVariable Bool
lazy ValueType
t0 String
variable) forall a. [a] -> [a] -> [a]
++ String
")"
  let assignAndGet :: ExpressionValue
assignAndGet = Bool -> ValueType -> String -> ExpressionValue
readStoredVariable Bool
lazy ValueType
t0 String
assign
  let alwaysAssign :: ExpressionValue
alwaysAssign = if ValueType -> Bool
isWeakValue ValueType
t0 Bool -> Bool -> Bool
&& Bool -> Bool
not (ValueType -> Bool
isWeakValue ValueType
t)
                        then String -> ExpressionValue
UnwrappedSingle forall a b. (a -> b) -> a -> b
$ String
"BoxedValue::Strong(" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsUnwrapped ExpressionValue
assignAndGet forall a. [a] -> [a] -> [a]
++ String
")"
                        else ExpressionValue
assignAndGet
  let maybeAssign :: ExpressionValue
maybeAssign = Bool -> ValueType -> String -> ExpressionValue
readStoredVariable Bool
lazy ValueType
t0 forall a b. (a -> b) -> a -> b
$ String
check forall a. [a] -> [a] -> [a]
++ String
" ? " forall a. [a] -> [a] -> [a]
++ String
variable forall a. [a] -> [a] -> [a]
++ String
" : (" forall a. [a] -> [a] -> [a]
++ String
assign forall a. [a] -> [a] -> [a]
++ String
")"
  case AssignmentType
o of
       AssignmentType
AlwaysAssign -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
t],ExpressionValue
alwaysAssign)
       AssignmentType
AssignIfEmpty -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType -> ValueType -> ValueType
combineTypes ValueType
t0 ValueType
t],ExpressionValue
maybeAssign)
  where
    combineTypes :: ValueType -> ValueType -> ValueType
combineTypes (ValueType StorageType
_ GeneralInstance
t1) (ValueType StorageType
s GeneralInstance
_) = StorageType -> GeneralInstance -> ValueType
ValueType StorageType
s GeneralInstance
t1
compileExpressionStart (InitializeValue [c]
c Maybe TypeInstance
t Positional (Expression c)
es) = do
  SymbolScope
scope <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m SymbolScope
csCurrentScope
  TypeInstance
t' <- case SymbolScope
scope of
              SymbolScope
CategoryScope -> case Maybe TypeInstance
t of
                                    Maybe TypeInstance
Nothing -> 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"
                                    Just TypeInstance
t0 -> forall (m :: * -> *) a. Monad m => a -> m a
return TypeInstance
t0
              SymbolScope
_ -> do
                TypeInstance
self <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m TypeInstance
csSelfType
                case Maybe TypeInstance
t of
                    Just TypeInstance
t0 -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> TypeInstance -> m TypeInstance
replaceSelfSingle (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
self) TypeInstance
t0
                    Maybe TypeInstance
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return TypeInstance
self
  [(ExpressionType, ExpressionValue)]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (Expression c)
es
  ([ValueType]
ts,String
es'') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
CollectErrorsM m =>
[(Positional a, ExpressionValue)] -> m ([a], String)
getValues [(ExpressionType, ExpressionValue)]
es'
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> TypeInstance -> ExpressionType -> CompilerState a m ()
csCheckValueInit [c]
c TypeInstance
t' (forall a. [a] -> Positional a
Positional [ValueType]
ts)
  String
params <- forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
Positional GeneralInstance -> CompilerState a m String
expandParams forall a b. (a -> b) -> a -> b
$ TypeInstance -> Positional GeneralInstance
tiParams TypeInstance
t'
  Bool
sameType <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
TypeInstance -> CompilerState a m Bool
csSameType TypeInstance
t'
  SymbolScope
s <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m SymbolScope
csCurrentScope
  let typeInstance :: String
typeInstance = TypeInstance -> Bool -> SymbolScope -> ShowS
getType TypeInstance
t' Bool
sameType SymbolScope
s String
params
  String
args <- forall {m :: * -> *} {c} {s} {a}.
(CollectErrorsM m, CompilerContext c m s a) =>
String -> StateT a m String
getArgs String
es''
  -- TODO: This is unsafe if used in a type or category constructor.
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [StorageType -> GeneralInstance -> ValueType
ValueType StorageType
RequiredValue forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t'],
          String -> ExpressionValue
UnwrappedSingle forall a b. (a -> b) -> a -> b
$ CategoryName -> String
valueCreator (TypeInstance -> CategoryName
tiName TypeInstance
t') forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
typeInstance forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
args forall a. [a] -> [a] -> [a]
++ String
")")
  where
    getType :: TypeInstance -> Bool -> SymbolScope -> ShowS
getType TypeInstance
_  Bool
True SymbolScope
ValueScope String
_      = String
"PARAM_SELF"
    getType TypeInstance
_  Bool
True SymbolScope
TypeScope  String
_      = String
"PARAM_SELF"
    getType TypeInstance
t2 Bool
_    SymbolScope
_          String
params = CategoryName -> String
typeCreator (TypeInstance -> CategoryName
tiName TypeInstance
t2) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
params forall a. [a] -> [a] -> [a]
++ String
")"
    -- Single expression, but possibly multi-return.
    getValues :: [(Positional a, ExpressionValue)] -> m ([a], String)
getValues [(Positional [a]
ts,ExpressionValue
e)] = forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
ts,ExpressionValue -> String
useAsArgs ExpressionValue
e)
    -- Multi-expression => must all be singles.
    getValues [(Positional a, ExpressionValue)]
rs = do
      (forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a) =>
(a, Positional a) -> m ()
checkArity 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 b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Positional a, ExpressionValue)]
rs) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In 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 a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Positional a -> [a]
pValues forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Positional a, ExpressionValue)]
rs, forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map (ExpressionValue -> String
useAsUnwrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Positional a, ExpressionValue)]
rs))
    checkArity :: (a, Positional a) -> m ()
checkArity (a
_,Positional [a
_]) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkArity (a
i,Positional [a]
ts)  =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Initializer position " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
" has " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ts) forall a. [a] -> [a] -> [a]
++ String
" values but should have 1"
    getArgs :: String -> StateT a m String
getArgs String
argEs = do
      Maybe [VariableName]
asNames <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) c.
CollectErrorsM m =>
[Expression c] -> m (Maybe [VariableName])
collectArgNames forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (Expression c)
es
      Bool
canForward <- case Maybe [VariableName]
asNames of
                         Just [VariableName]
an -> forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[ParamName] -> [VariableName] -> CompilerState a m Bool
csCanForward [] [VariableName]
an
                         Maybe [VariableName]
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      if Bool
canForward
         then forall (m :: * -> *) a. Monad m => a -> m a
return String
"params_args"
         else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"PassParamsArgs(" forall a. [a] -> [a] -> [a]
++ String
argEs forall a. [a] -> [a] -> [a]
++ String
")"
compileExpressionStart (UnambiguousLiteral ValueLiteral c
l) = forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ValueLiteral c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileValueLiteral ValueLiteral c
l

compileValueLiteral :: (Ord c, Show c, CollectErrorsM m,
                           CompilerContext c m [String] a) =>
  ValueLiteral c -> CompilerState a m (ExpressionType,ExpressionValue)
compileValueLiteral :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ValueLiteral c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileValueLiteral (StringLiteral [c]
_ String
l) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinString])
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> (ExpressionType, ExpressionValue)
expressionFromLiteral PrimitiveType
PrimString (ShowS
escapeChars String
l)
compileValueLiteral (CharLiteral [c]
_ Char
l) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinChar])
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> (ExpressionType, ExpressionValue)
expressionFromLiteral PrimitiveType
PrimChar (String
"'" forall a. [a] -> [a] -> [a]
++ Char -> String
escapeChar Char
l forall a. [a] -> [a] -> [a]
++ String
"'")
compileValueLiteral (IntegerLiteral [c]
c Bool
True Integer
l) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinInt])
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
l forall a. Ord a => a -> a -> Bool
> Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
64 :: Integer) forall a. Num a => a -> a -> a
- Integer
1) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$
    String
"Literal " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
l forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++ String
" is greater than the max value for 64-bit unsigned"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> (ExpressionType, ExpressionValue)
expressionFromLiteral PrimitiveType
PrimInt (forall a. Show a => a -> String
show Integer
l forall a. [a] -> [a] -> [a]
++ String
"ULL")
compileValueLiteral (IntegerLiteral [c]
c Bool
False Integer
l) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinInt])
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
l forall a. Ord a => a -> a -> Bool
> Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
63 :: Integer) forall a. Num a => a -> a -> a
- Integer
1) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$
    String
"Literal " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
l forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++ String
" is greater than the max value for 64-bit signed"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((-Integer
l) forall a. Ord a => a -> a -> Bool
> Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
63 :: Integer)) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$
    String
"Literal " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
l forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++ String
" is less than the min value for 64-bit signed"
  -- NOTE: clang++ processes -abcLL as -(abcLL), which means that -(2^63)
  -- written out as a literal looks like an unsigned overflow. Using ULL here
  -- silences that warning.
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> (ExpressionType, ExpressionValue)
expressionFromLiteral PrimitiveType
PrimInt (forall a. Show a => a -> String
show Integer
l forall a. [a] -> [a] -> [a]
++ String
"ULL")
compileValueLiteral (DecimalLiteral [c]
_ Integer
l Integer
e Integer
10) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinFloat])
  -- TODO: Check bounds.
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> (ExpressionType, ExpressionValue)
expressionFromLiteral PrimitiveType
PrimFloat (forall a. Show a => a -> String
show Integer
l forall a. [a] -> [a] -> [a]
++ String
"E" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
e)
compileValueLiteral (DecimalLiteral [c]
_ Integer
l Integer
e Integer
b) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinFloat])
  let scale :: String
scale = if Integer
e forall a. Ord a => a -> a -> Bool
< Integer
0
                 then String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Integer
bforall a b. (Num a, Integral b) => a -> b -> a
^(-Integer
e))
                 else String
"*" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Integer
bforall a b. (Num a, Integral b) => a -> b -> a
^Integer
e)
  -- TODO: Check bounds.
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> (ExpressionType, ExpressionValue)
expressionFromLiteral PrimitiveType
PrimFloat (String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
l forall a. [a] -> [a] -> [a]
++ String
"E0" forall a. [a] -> [a] -> [a]
++ String
scale forall a. [a] -> [a] -> [a]
++ String
")")
compileValueLiteral (BoolLiteral [c]
_ Bool
True) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinBool])
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> (ExpressionType, ExpressionValue)
expressionFromLiteral PrimitiveType
PrimBool String
"true"
compileValueLiteral (BoolLiteral [c]
_ Bool
False) = do
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinBool])
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> (ExpressionType, ExpressionValue)
expressionFromLiteral PrimitiveType
PrimBool String
"false"
compileValueLiteral (EmptyLiteral [c]
_) = do
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Positional a
Positional [ValueType
emptyType],String -> ExpressionValue
UnwrappedSingle String
"Var_empty")

disallowInferred :: (Ord c, Show c, CollectErrorsM m) => Positional (InstanceOrInferred c) -> m [GeneralInstance]
disallowInferred :: forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Positional (InstanceOrInferred c) -> m [GeneralInstance]
disallowInferred = forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM forall {m :: * -> *} {a}.
(ErrorContextM m, Show a) =>
InstanceOrInferred a -> m GeneralInstance
disallow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Positional a -> [a]
pValues where
  disallow :: InstanceOrInferred a -> m GeneralInstance
disallow (AssignedInstance [a]
_ GeneralInstance
t) = forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
t
  disallow (InferredInstance [a]
c) =
    forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Type inference is not allowed in reduce calls" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c

compileFunctionCall :: (Ord c, Show c, CollectErrorsM m,
                        CompilerContext c m [String] a) =>
  Bool -> Maybe String -> ScopedFunction c -> FunctionCall c ->
  CompilerState a m (ExpressionType,ExpressionValue)
compileFunctionCall :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Bool
-> Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExpressionValue)
compileFunctionCall Bool
optionalValue Maybe String
e ScopedFunction c
f (FunctionCall [c]
c FunctionName
_ Positional (InstanceOrInferred c)
ps Positional (Maybe (CallArgLabel c), Expression c)
es) = String
message forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  [(ExpressionType, ExpressionValue)]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExpressionValue)
compileExpression 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 (Maybe (CallArgLabel c), Expression c)
es
  ([ValueType]
ts,[String]
es'') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
CollectErrorsM m =>
[(Positional a, ExpressionValue)] -> m ([a], [String])
getValues [(ExpressionType, ExpressionValue)]
es'
  FunctionType
f' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f
  let psActual :: Positional (InstanceOrInferred c)
psActual = case Positional (InstanceOrInferred c)
ps of
                      (Positional []) -> forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ FunctionType -> Positional ParamName
ftParams FunctionType
f') forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat (forall c. [c] -> InstanceOrInferred c
InferredInstance [c]
c)
                      Positional (InstanceOrInferred c)
_ -> Positional (InstanceOrInferred c)
ps
  GeneralInstance
self <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  Positional (InstanceOrInferred c)
ps' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 =>
GeneralInstance -> InstanceOrInferred c -> m (InstanceOrInferred c)
replaceSelfParam GeneralInstance
self) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
psActual
  Positional GeneralInstance
ps2 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) r.
(Ord c, Show c, CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ScopedFunction c
-> Positional (InstanceOrInferred c)
-> ExpressionType
-> m (Positional GeneralInstance)
guessParamsFromArgs AnyTypeResolver
r ParamFilters
fa ScopedFunction c
f Positional (InstanceOrInferred c)
ps' (forall a. [a] -> Positional a
Positional [ValueType]
ts)
  FunctionType
f'' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ParamValues
-> Positional GeneralInstance
-> FunctionType
-> m FunctionType
assignFunctionParams AnyTypeResolver
r ParamFilters
fa forall k a. Map k a
Map.empty Positional GeneralInstance
ps2 FunctionType
f'
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall {m :: * -> *} {a} {a} {a}.
(ErrorContextM m, Show a, Show a, Show a) =>
(a, InstanceOrInferred a, a) -> m ()
backgroundMessage 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 c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall c. ScopedFunction c -> Positional (ValueParam c)
sfParams ScopedFunction c
f) (forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps') (forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps2)
  -- Called an extra time so arg count mismatches have reasonable errors.
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 ()
processPairs_ (\ValueType
_ ValueType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) (FunctionType -> ExpressionType
ftArgs FunctionType
f'') (forall a. [a] -> Positional a
Positional [ValueType]
ts)
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ if (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ValueType]
ts forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es))
            then do
              forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {a}.
(ErrorContextM m, Show a) =>
Maybe a -> m ()
labelNotAllowedError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es
              forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {a}.
(ErrorContextM m, Show a) =>
Maybe a -> m ()
labelNotSetError 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 forall a b. (a -> b) -> a -> b
$ forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f
            else forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ forall {m :: * -> *} {a} {c} {c}.
(ErrorContextM m, Show a, Show c, Show c) =>
Maybe (CallArgLabel c) -> (a, Maybe (CallArgLabel c)) -> m ()
checkArgLabel (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f) (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 b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es)
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 ()
processPairs_ (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> ParamFilters -> ValueType -> (a, ValueType) -> m ()
checkArg AnyTypeResolver
r ParamFilters
fa) (FunctionType -> ExpressionType
ftArgs FunctionType
f'') (forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) [ValueType]
ts)
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ 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 GeneralInstance -> Set CategoryName
categoriesFromTypes forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps2
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f])
  [String]
params <- forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
Positional GeneralInstance -> CompilerState a m [String]
expandParams2 Positional GeneralInstance
ps2
  SymbolScope
scope <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m SymbolScope
csCurrentScope
  String
scoped <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f)
  String
paramsArgs <- forall {c} {s} {a}.
CompilerContext c m s a =>
[GeneralInstance] -> [String] -> [String] -> StateT a m String
getParamsArgs (forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps2) [String]
params [String]
es''
  String
call <- forall {m :: * -> *}.
Monad m =>
Maybe String
-> String -> SymbolScope -> SymbolScope -> String -> m String
assemble Maybe String
e String
scoped SymbolScope
scope (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f) String
paramsArgs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (FunctionType -> ExpressionType
ftReturns FunctionType
f'',String -> ExpressionValue
OpaqueMulti String
call)
  where
    labelNotAllowedError :: Maybe a -> m ()
labelNotAllowedError (Just a
l) = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Arg label " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
l forall a. [a] -> [a] -> [a]
++ String
" not allowed when forwarding multiple returns"
    labelNotAllowedError Maybe a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    labelNotSetError :: Maybe a -> m ()
labelNotSetError (Just a
l) = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Arg label " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
l forall a. [a] -> [a] -> [a]
++ String
" cannot be set when forwarding multiple returns"
    labelNotSetError Maybe a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    replaceSelfParam :: GeneralInstance -> InstanceOrInferred c -> m (InstanceOrInferred c)
replaceSelfParam GeneralInstance
self (AssignedInstance [c]
c2 GeneralInstance
t) = do
      GeneralInstance
t' <- forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self GeneralInstance
t
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> GeneralInstance -> InstanceOrInferred c
AssignedInstance [c]
c2 GeneralInstance
t'
    replaceSelfParam GeneralInstance
_ InstanceOrInferred c
t = forall (m :: * -> *) a. Monad m => a -> m a
return InstanceOrInferred c
t
    message :: String
message = 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]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
    backgroundMessage :: (a, InstanceOrInferred a, a) -> m ()
backgroundMessage (a
n,(InferredInstance [a]
c2),a
t) = do
      let funcName :: String
funcName = forall c. CategoryName -> ScopedFunction c -> String
functionDebugName (forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f) ScopedFunction c
f
      forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerBackgroundM forall a b. (a -> b) -> a -> b
$ String
"Parameter " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ String
" (from " forall a. [a] -> [a] -> [a]
++ String
funcName forall a. [a] -> [a] -> [a]
++
        String
") inferred as " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
t forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [a]
c2
    backgroundMessage (a, InstanceOrInferred a, a)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    getParamsArgs :: [GeneralInstance] -> [String] -> [String] -> StateT a m String
getParamsArgs [GeneralInstance]
ps2 [String]
paramEs [String]
argEs = do
      Maybe [ParamName]
psNames <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [GeneralInstance] -> m (Maybe [ParamName])
collectParamNames [GeneralInstance]
ps2
      Maybe [VariableName]
asNames <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) c.
CollectErrorsM m =>
[Expression c] -> m (Maybe [VariableName])
collectArgNames forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (Maybe (CallArgLabel c), Expression c)
es
      Bool
canForward <- case (Maybe [ParamName]
psNames,Maybe [VariableName]
asNames) of
                         (Just [ParamName]
pn,Just [VariableName]
an) -> forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[ParamName] -> [VariableName] -> CompilerState a m Bool
csCanForward [ParamName]
pn [VariableName]
an
                         (Maybe [ParamName], Maybe [VariableName])
_                 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      if Bool
canForward
         then forall (m :: * -> *) a. Monad m => a -> m a
return String
"params_args"
         else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"PassParamsArgs(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String]
paramEs forall a. [a] -> [a] -> [a]
++ [String]
argEs) forall a. [a] -> [a] -> [a]
++ String
")"
    assemble :: Maybe String
-> String -> SymbolScope -> SymbolScope -> String -> m String
assemble Maybe String
Nothing String
_ SymbolScope
ValueScope SymbolScope
ValueScope String
paramsArgs =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FunctionName -> String
callName (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
paramsArgs forall a. [a] -> [a] -> [a]
++ String
")"
    assemble Maybe String
Nothing String
_ SymbolScope
TypeScope SymbolScope
TypeScope String
paramsArgs =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FunctionName -> String
callName (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
paramsArgs forall a. [a] -> [a] -> [a]
++ String
")"
    assemble Maybe String
Nothing String
scoped SymbolScope
ValueScope SymbolScope
TypeScope String
paramsArgs =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
scoped forall a. [a] -> [a] -> [a]
++ FunctionName -> String
callName (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
paramsArgs forall a. [a] -> [a] -> [a]
++ String
")"
    assemble Maybe String
Nothing String
scoped SymbolScope
_ SymbolScope
_ String
paramsArgs =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
scoped forall a. [a] -> [a] -> [a]
++ FunctionName -> String
callName (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
paramsArgs forall a. [a] -> [a] -> [a]
++ String
")"
    assemble (Just String
e2) String
_ SymbolScope
_ SymbolScope
ValueScope String
paramsArgs =
      if Bool
optionalValue
         then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"TYPE_VALUE_CALL_UNLESS_EMPTY(" forall a. [a] -> [a] -> [a]
++ String
e2 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall c. ScopedFunction c -> String
functionName ScopedFunction c
f forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
paramsArgs forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
returnCount forall a. [a] -> [a] -> [a]
++ String
")"
         else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
valueBase forall a. [a] -> [a] -> [a]
++ String
"::Call(" forall a. [a] -> [a] -> [a]
++ String
e2 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall c. ScopedFunction c -> String
functionName ScopedFunction c
f forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
paramsArgs forall a. [a] -> [a] -> [a]
++ String
")"
    assemble (Just String
e2) String
_ SymbolScope
_ SymbolScope
TypeScope String
paramsArgs =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
typeBase forall a. [a] -> [a] -> [a]
++ String
"::Call(" forall a. [a] -> [a] -> [a]
++ String
e2 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall c. ScopedFunction c -> String
functionName ScopedFunction c
f forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
paramsArgs forall a. [a] -> [a] -> [a]
++ String
")"
    assemble (Just String
e2) String
_ SymbolScope
_ SymbolScope
_ String
paramsArgs =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
e2 forall a. [a] -> [a] -> [a]
++ String
".Call(" forall a. [a] -> [a] -> [a]
++ forall c. ScopedFunction c -> String
functionName ScopedFunction c
f forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
paramsArgs forall a. [a] -> [a] -> [a]
++ String
")"
    returnCount :: Int
returnCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall c. ScopedFunction c -> Positional (PassedValue c)
sfReturns ScopedFunction c
f
    -- TODO: Lots of duplication with assignments and initialization.
    -- Single expression, but possibly multi-return.
    getValues :: [(Positional a, ExpressionValue)] -> m ([a], [String])
getValues [(Positional [a]
ts,ExpressionValue
e2)] = forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
ts,[ExpressionValue -> String
useAsArgs ExpressionValue
e2])
    -- Multi-expression => must all be singles.
    getValues [(Positional a, ExpressionValue)]
rs = do
      (forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a) =>
(a, Positional a) -> m ()
checkArity 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 b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Positional a, ExpressionValue)]
rs) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In 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 a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Positional a -> [a]
pValues forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Positional a, ExpressionValue)]
rs,forall a b. (a -> b) -> [a] -> [b]
map (ExpressionValue -> String
useAsUnwrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Positional a, ExpressionValue)]
rs)
    checkArity :: (a, Positional a) -> m ()
checkArity (a
_,Positional [a
_]) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkArity (a
i,Positional [a]
ts)  =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Return position " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
" has " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ts) forall a. [a] -> [a] -> [a]
++ String
" values but should have 1"
    checkArg :: r -> ParamFilters -> ValueType -> (a, ValueType) -> m ()
checkArg r
r ParamFilters
fa 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 argument " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
" to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f)
    checkArgLabel :: Maybe (CallArgLabel c) -> (a, Maybe (CallArgLabel c)) -> m ()
checkArgLabel (Just (CallArgLabel [c]
_ String
n1)) (a
_,Just (CallArgLabel [c]
_ String
n2))
      | String
n1 forall a. Eq a => a -> a -> Bool
== String
n2 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkArgLabel Maybe (CallArgLabel c)
l1 (a
i,Maybe (CallArgLabel c)
l2) = String
"In argument " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
" to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a, Show a) =>
Maybe a -> Maybe a -> m ()
labelError Maybe (CallArgLabel c)
l1 Maybe (CallArgLabel c)
l2
    labelError :: Maybe a -> Maybe a -> m ()
labelError (Just a
l1) (Just a
l2) =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected arg label " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
l1 forall a. [a] -> [a] -> [a]
++ String
" but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
l2
    labelError (Just a
l1) Maybe a
_ =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected arg label " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
l1 forall a. [a] -> [a] -> [a]
++ String
" but label is missing"
    labelError Maybe a
_ (Just a
l2) =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected no arg label but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
l2
    labelError Maybe a
_ Maybe a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    collectParamNames :: [GeneralInstance] -> m (Maybe [ParamName])
collectParamNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM GeneralInstance -> m (Maybe ParamName)
collectParamName
    collectParamName :: GeneralInstance -> m (Maybe ParamName)
collectParamName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe TypeInstanceOrParam -> Maybe ParamName
getParamName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. CollectErrorsM m => m a -> m (Maybe a)
tryCompilerM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf
    getParamName :: Maybe TypeInstanceOrParam -> Maybe ParamName
getParamName (Just (JustParamName Bool
_ ParamName
n)) = forall a. a -> Maybe a
Just ParamName
n
    getParamName Maybe TypeInstanceOrParam
_ = forall a. Maybe a
Nothing

collectArgNames :: CollectErrorsM m => [Expression c] -> m (Maybe [VariableName])
collectArgNames :: forall (m :: * -> *) c.
CollectErrorsM m =>
[Expression c] -> m (Maybe [VariableName])
collectArgNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM forall {m :: * -> *} {c}.
Monad m =>
Expression c -> m (Maybe VariableName)
collectArgName where
  collectArgName :: Expression c -> m (Maybe VariableName)
collectArgName (Expression [c]
_ (NamedVariable (OutputValue [c]
_ VariableName
n)) []) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just VariableName
n
  collectArgName Expression c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

guessParamsFromArgs :: (Ord c, Show c, CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) ->
  Positional ValueType -> m (Positional GeneralInstance)
guessParamsFromArgs :: forall c (m :: * -> *) r.
(Ord c, Show c, CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ScopedFunction c
-> Positional (InstanceOrInferred c)
-> ExpressionType
-> m (Positional GeneralInstance)
guessParamsFromArgs r
r ParamFilters
fa ScopedFunction c
f Positional (InstanceOrInferred c)
ps ExpressionType
ts = do
  ParamFilters
fm <- forall (m :: * -> *) c.
CollectErrorsM m =>
ScopedFunction c -> m ParamFilters
getFunctionFilterMap ScopedFunction c
f
  [PatternMatch]
args <- forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs (\ValueType
t1 ValueType
t2 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Variance -> ValueType -> ValueType -> PatternMatch
TypePattern Variance
Covariant ValueType
t1 ValueType
t2) ExpressionType
ts (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall c. PassedValue c -> ValueType
pvType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f)
  [PatternMatch]
filts <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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 :: * -> *).
CollectErrorsM m =>
ParamFilters -> ValueType -> ValueType -> m [PatternMatch]
guessesFromFilters ParamFilters
fm) ExpressionType
ts (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall c. PassedValue c -> ValueType
pvType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f)
  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 :: * -> *} {c}.
Monad m =>
ParamName -> InstanceOrInferred c -> m (ParamName, GeneralInstance)
toInstance (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
$ forall c. ScopedFunction c -> Positional (ValueParam c)
sfParams ScopedFunction c
f) Positional (InstanceOrInferred c)
ps
  MergeTree InferredTypeGuess
gs <- forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ParamValues
-> [PatternMatch]
-> m (MergeTree InferredTypeGuess)
inferParamTypes r
r ParamFilters
fa ParamValues
pa ([PatternMatch]
args forall a. [a] -> [a] -> [a]
++ [PatternMatch]
filts)
  ParamValues
gs' <- forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ParamFilters
-> ParamValues
-> MergeTree InferredTypeGuess
-> m ParamValues
mergeInferredTypes r
r ParamFilters
fa ParamFilters
fm ParamValues
pa MergeTree InferredTypeGuess
gs
  let pa3 :: ParamValues
pa3 = ParamValues
gs' forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` ParamValues
pa
  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}.
(ErrorContextM m, Show a) =>
ParamValues -> ValueParam a -> m GeneralInstance
subPosition ParamValues
pa3) (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall c. ScopedFunction c -> Positional (ValueParam c)
sfParams ScopedFunction c
f) where
    subPosition :: ParamValues -> ValueParam a -> m GeneralInstance
subPosition ParamValues
pa2 ValueParam a
p =
      case (forall c. ValueParam c -> ParamName
vpParam ValueParam a
p) forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` ParamValues
pa2 of
           Just GeneralInstance
t  -> if Bool -> Bool
not (GeneralInstance -> Bool
hasInferredParams GeneralInstance
t)
                         then forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
t
                         else forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Could not infer param " forall a. [a] -> [a] -> [a]
++
                              forall a. Show a => a -> String
show (forall c. ValueParam c -> ParamName
vpParam ValueParam a
p) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace (forall c. ValueParam c -> [c]
vpContext ValueParam a
p)
           Maybe GeneralInstance
Nothing -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Something went wrong inferring " forall a. [a] -> [a] -> [a]
++
                      forall a. Show a => a -> String
show (forall c. ValueParam c -> ParamName
vpParam ValueParam a
p) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace (forall c. ValueParam c -> [c]
vpContext ValueParam a
p)
    toInstance :: ParamName -> InstanceOrInferred c -> m (ParamName, GeneralInstance)
toInstance ParamName
p1 (AssignedInstance [c]
_ GeneralInstance
t) = forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
p1,GeneralInstance
t)
    toInstance ParamName
p1 (InferredInstance [c]
_)   = forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
p1,forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ ParamName -> TypeInstanceOrParam
JustInferredType ParamName
p1)

guessParams :: (Ord c, Show c, CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> Positional ValueType -> Positional ParamName ->
  Positional (InstanceOrInferred c) -> Positional ValueType -> m (Positional GeneralInstance)
guessParams :: forall c (m :: * -> *) r.
(Ord c, Show c, CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ExpressionType
-> Positional ParamName
-> Positional (InstanceOrInferred c)
-> ExpressionType
-> m (Positional GeneralInstance)
guessParams r
r ParamFilters
fa ExpressionType
args Positional ParamName
params Positional (InstanceOrInferred c)
ps ExpressionType
ts = do
  [PatternMatch]
args' <- forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs (\ValueType
t1 ValueType
t2 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Variance -> ValueType -> ValueType -> PatternMatch
TypePattern Variance
Covariant ValueType
t1 ValueType
t2) ExpressionType
ts ExpressionType
args
  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 :: * -> *} {c}.
Monad m =>
ParamName -> InstanceOrInferred c -> m (ParamName, GeneralInstance)
toInstance Positional ParamName
params Positional (InstanceOrInferred c)
ps
  MergeTree InferredTypeGuess
gs <- forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ParamValues
-> [PatternMatch]
-> m (MergeTree InferredTypeGuess)
inferParamTypes r
r ParamFilters
fa ParamValues
pa [PatternMatch]
args'
  ParamValues
gs' <- forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ParamFilters
-> ParamValues
-> MergeTree InferredTypeGuess
-> m ParamValues
mergeInferredTypes r
r ParamFilters
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)]
zip (forall a. Positional a -> [a]
pValues Positional ParamName
params) (forall a. a -> [a]
repeat [])) ParamValues
pa MergeTree InferredTypeGuess
gs
  let pa3 :: ParamValues
pa3 = ParamValues
gs' forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` ParamValues
pa
  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 {a} {m :: * -> *} {a}.
(Ord a, ErrorContextM m, Show a) =>
Map a a -> a -> m a
subPosition ParamValues
pa3) (forall a. Positional a -> [a]
pValues Positional ParamName
params) where
    subPosition :: Map a a -> a -> m a
subPosition Map a a
pa2 a
p =
      case a
p forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a a
pa2 of
           Just a
t  -> forall (m :: * -> *) a. Monad m => a -> m a
return a
t
           Maybe a
Nothing -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Something went wrong inferring " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
p
    toInstance :: ParamName -> InstanceOrInferred c -> m (ParamName, GeneralInstance)
toInstance ParamName
p1 (AssignedInstance [c]
_ GeneralInstance
t) = forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
p1,GeneralInstance
t)
    toInstance ParamName
p1 (InferredInstance [c]
_)   = forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
p1,forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ ParamName -> TypeInstanceOrParam
JustInferredType ParamName
p1)

compileMainProcedure :: (Ord c, Show c, CollectErrorsM m) =>
  CategoryMap c -> ExprMap c -> Expression c -> m (CompiledData [String])
compileMainProcedure :: forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
CategoryMap c
-> ExprMap c -> Expression c -> m (CompiledData [String])
compileMainProcedure CategoryMap c
tm ExprMap c
em Expression c
e = do
  ProcedureContext c
ctx <- forall (m :: * -> *) c.
CollectErrorsM m =>
Bool -> CategoryMap c -> ExprMap c -> m (ProcedureContext c)
getMainContext Bool
False CategoryMap c
tm ExprMap c
em
  forall c (m :: * -> *) s a b.
CompilerContext c m s a =>
CompilerState a m b -> a -> m (CompiledData s)
runDataCompiler StateT (ProcedureContext c) m ()
compiler ProcedureContext c
ctx where
    procedure :: Procedure c
procedure = forall c. [c] -> [Statement c] -> Procedure c
Procedure [] [forall c. [c] -> Expression c -> Statement c
IgnoreValues [] Expression c
e]
    compiler :: StateT (ProcedureContext c) m ()
compiler = do
      ProcedureContext c
ctx0 <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
      forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure ProcedureContext c
ctx0 Procedure c
procedure forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put

compileWrapTestcase :: (Ord c, Show c, CollectErrorsM m) =>
  CategoryMap c -> ([c],TypeInstance) -> m (CompiledData [String])
compileWrapTestcase :: forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], TypeInstance) -> m (CompiledData [String])
compileWrapTestcase CategoryMap c
tm ([c]
c,TypeInstance
t) = do
  ProcedureContext c
ctx <- forall (m :: * -> *) c.
CollectErrorsM m =>
Bool -> CategoryMap c -> ExprMap c -> m (ProcedureContext c)
getMainContext Bool
False CategoryMap c
tm forall k a. Map k a
Map.empty
  forall c (m :: * -> *) s a b.
CompilerContext c m s a =>
CompilerState a m b -> a -> m (CompiledData s)
runDataCompiler StateT (ProcedureContext c) m ()
compiler ProcedureContext c
ctx forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In custom testcase checker at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  where
    compiler :: StateT (ProcedureContext c) m ()
compiler = do
      ProcedureContext c
ctx0 <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT StateT (ProcedureContext c) m ()
testcase ProcedureContext c
ctx0) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put
    testcase :: StateT (ProcedureContext c) m ()
testcase = do
      let t2 :: GeneralInstance
t2 = forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t
      AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> m ()
validateGeneralInstanceForCall AnyTypeResolver
r forall k a. Map k a
Map.empty GeneralInstance
t2
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> [TypeFilter] -> m ()
validateAssignment AnyTypeResolver
r forall k a. Map k a
Map.empty GeneralInstance
t2 [DefinesInstance -> TypeFilter
DefinesFilter (CategoryName -> Positional GeneralInstance -> DefinesInstance
DefinesInstance CategoryName
BuiltinTestcase (forall a. [a] -> Positional a
Positional []))]
      ScopedFunction c
start <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetTypeFunction [c]
c (forall a. a -> Maybe a
Just GeneralInstance
t2) (String -> FunctionName
FunctionName String
"start")
      ScopedFunction c
finish <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetTypeFunction [c]
c (forall a. a -> Maybe a
Just GeneralInstance
t2) (String -> FunctionName
FunctionName String
"finish")
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
start,forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
finish]
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired forall a b. (a -> b) -> a -> b
$ GeneralInstance -> Set CategoryName
categoriesFromTypes GeneralInstance
t2
      String
t2' <- forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t2
      forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"WrapTypeCall check_test(" forall a. [a] -> [a] -> [a]
++ String
t2' forall a. [a] -> [a] -> [a]
++ String
", &" forall a. [a] -> [a] -> [a]
++ forall c. ScopedFunction c -> String
functionName ScopedFunction c
start forall a. [a] -> [a] -> [a]
++ String
", &" forall a. [a] -> [a] -> [a]
++ forall c. ScopedFunction c -> String
functionName ScopedFunction c
finish forall a. [a] -> [a] -> [a]
++ String
");"]

compileTestProcedure :: (Ord c, Show c, CollectErrorsM m) =>
  CategoryMap c -> ExprMap c -> TestProcedure c -> m (CompiledData [String])
compileTestProcedure :: forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
CategoryMap c
-> ExprMap c -> TestProcedure c -> m (CompiledData [String])
compileTestProcedure CategoryMap c
tm ExprMap c
em (TestProcedure [c]
c FunctionName
n Bool
cov Procedure c
p) = do
  ProcedureContext c
ctx <- forall (m :: * -> *) c.
CollectErrorsM m =>
Bool -> CategoryMap c -> ExprMap c -> m (ProcedureContext c)
getMainContext Bool
True CategoryMap c
tm ExprMap c
em
  CompiledData [String]
p' <- forall c (m :: * -> *) s a b.
CompilerContext c m s a =>
CompilerState a m b -> a -> m (CompiledData s)
runDataCompiler StateT (ProcedureContext c) m ()
compiler ProcedureContext c
ctx forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In unittest " 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
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [
      String -> CompiledData [String]
onlyCode forall a b. (a -> b) -> a -> b
$ String
"ReturnTuple " forall a. [a] -> [a] -> [a]
++ FunctionName -> String
testFunctionName FunctionName
n forall a. [a] -> [a] -> [a]
++ String
"() {",
      CompiledData [String] -> CompiledData [String]
indentCompiled CompiledData [String]
handleCoverage,
      CompiledData [String] -> CompiledData [String]
indentCompiled forall a b. (a -> b) -> a -> b
$ String -> CompiledData [String]
onlyCode forall a b. (a -> b) -> a -> b
$ FunctionName -> String
startTestTracing FunctionName
n,
      CompiledData [String] -> CompiledData [String]
indentCompiled CompiledData [String]
p',
      CompiledData [String] -> CompiledData [String]
indentCompiled forall a b. (a -> b) -> a -> b
$ String -> CompiledData [String]
onlyCode forall a b. (a -> b) -> a -> b
$ String
"return ReturnTuple();",
      String -> CompiledData [String]
onlyCode String
"}"
    ] where
    compiler :: StateT (ProcedureContext c) m ()
compiler = do
      ProcedureContext c
ctx0 <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
      forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> Procedure c -> CompilerState a m a
compileProcedure ProcedureContext c
ctx0 Procedure c
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put
    handleCoverage :: CompiledData [String]
handleCoverage
      | Bool
cov       = String -> CompiledData [String]
onlyCode String
"LogCalls::DisableCallLogging();"
      | Bool
otherwise = CompiledData [String]
emptyCode

selectTestFromArgv1 :: CollectErrorsM m => [FunctionName] -> m ([String],CompiledData [String])
selectTestFromArgv1 :: forall (m :: * -> *).
CollectErrorsM m =>
[FunctionName] -> m ([String], CompiledData [String])
selectTestFromArgv1 [FunctionName]
fs = forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
includes,CompiledData [String]
allCode) where
  allCode :: CompiledData [String]
allCode = forall a. Monoid a => [a] -> a
mconcat [
      CompiledData [String]
initMap,
      CompiledData [String]
selectFromMap
    ]
  initMap :: CompiledData [String]
initMap = [String] -> CompiledData [String]
onlyCodes forall a b. (a -> b) -> a -> b
$ [
      String
"const std::unordered_map<std::string, ReturnTuple(*)()> tests{"
    ] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctionName -> String
testEntry) [FunctionName]
fs forall a. [a] -> [a] -> [a]
++ [
      String
"};"
    ]
  selectFromMap :: CompiledData [String]
selectFromMap = [String] -> CompiledData [String]
onlyCodes [
      String
"if (argc < 2) FAIL() << argv[0] << \" [unittest name]\";",
      String
"const auto name = argv[1];",
      String
"const auto test = tests.find(name);",
      String
"if (test != tests.end()) {",
      String
"  (void) (*test->second)();",
      String
" } else {",
      String
"  FAIL() << argv[0] << \": unittest \" << name << \" does not exist\";",
      String
"}"
    ]
  testEntry :: FunctionName -> String
testEntry FunctionName
f = String
"{ \"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
f forall a. [a] -> [a] -> [a]
++ String
"\", &" forall a. [a] -> [a] -> [a]
++ FunctionName -> String
testFunctionName FunctionName
f forall a. [a] -> [a] -> [a]
++ String
" },"
  includes :: [String]
includes = [
      String
"#include <string>",
      String
"#include <unordered_map>"
    ]

autoScope :: CompilerContext c m s a =>
  SymbolScope -> CompilerState a m String
autoScope :: forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s = do
  SymbolScope
s1 <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m SymbolScope
csCurrentScope
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SymbolScope -> SymbolScope -> String
scoped SymbolScope
s1 SymbolScope
s
  where
    scoped :: SymbolScope -> SymbolScope -> String
scoped SymbolScope
ValueScope SymbolScope
TypeScope     = String
"parent->"
    scoped SymbolScope
ValueScope SymbolScope
CategoryScope = String
"parent->parent."
    scoped SymbolScope
TypeScope  SymbolScope
CategoryScope = String
"parent."
    -- NOTE: Don't use this->; otherwise, self won't work properly.
    scoped SymbolScope
_ SymbolScope
_ = String
""

categoriesFromTypes :: GeneralInstance -> Set.Set CategoryName
categoriesFromTypes :: GeneralInstance -> Set CategoryName
categoriesFromTypes = forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions TypeInstanceOrParam -> Set CategoryName
getAll where
  getAll :: TypeInstanceOrParam -> Set CategoryName
getAll (JustTypeInstance (TypeInstance CategoryName
t Positional GeneralInstance
ps)) =
    CategoryName
t forall a. Ord a => a -> Set a -> Set a
`Set.insert` (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 GeneralInstance -> Set CategoryName
categoriesFromTypes forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps)
  getAll TypeInstanceOrParam
_ = forall a. Set a
Set.empty

categoriesFromRefine :: TypeInstance -> Set.Set CategoryName
categoriesFromRefine :: TypeInstance -> Set CategoryName
categoriesFromRefine (TypeInstance CategoryName
t Positional GeneralInstance
ps) = CategoryName
t forall a. Ord a => a -> Set a -> Set a
`Set.insert` (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 GeneralInstance -> Set CategoryName
categoriesFromTypes forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps)

categoriesFromDefine :: DefinesInstance -> Set.Set CategoryName
categoriesFromDefine :: DefinesInstance -> Set CategoryName
categoriesFromDefine (DefinesInstance CategoryName
t Positional GeneralInstance
ps) = CategoryName
t forall a. Ord a => a -> Set a -> Set a
`Set.insert` (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 GeneralInstance -> Set CategoryName
categoriesFromTypes forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps)

expandParams :: (CollectErrorsM m, CompilerContext c m s a) =>
  Positional GeneralInstance -> CompilerState a m String
expandParams :: forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
Positional GeneralInstance -> CompilerState a m String
expandParams Positional GeneralInstance
ps = do
  [String]
ps' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"T_get(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ps' forall a. [a] -> [a] -> [a]
++ String
")"

expandParams2 :: (CollectErrorsM m, CompilerContext c m s a) =>
  Positional GeneralInstance -> CompilerState a m [String]
expandParams2 :: forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
Positional GeneralInstance -> CompilerState a m [String]
expandParams2 Positional GeneralInstance
ps = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps

expandCategory :: CompilerContext c m s a =>
  CategoryName -> CompilerState a m String
expandCategory :: forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CategoryName -> CompilerState a m String
expandCategory CategoryName
t = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CategoryName -> String
categoryGetter CategoryName
t forall a. [a] -> [a] -> [a]
++ String
"()"

expandGeneralInstance :: (CollectErrorsM m, CompilerContext c m s a) =>
  GeneralInstance -> CompilerState a m String
expandGeneralInstance :: forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t = do
  AnyTypeResolver
r <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
f <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  SymbolScope
scope <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m SymbolScope
csCurrentScope
  GeneralInstance
t' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> m GeneralInstance
dedupGeneralInstance AnyTypeResolver
r ParamFilters
f GeneralInstance
t
  GeneralInstance
t'' <-  case SymbolScope
scope of
               SymbolScope
CategoryScope -> forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
t'
               SymbolScope
_ -> do
                 TypeInstance
self <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m TypeInstance
csSelfType
                 forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
CollectErrorsM m =>
TypeInstance -> GeneralInstance -> m GeneralInstance
reverseSelfInstance TypeInstance
self GeneralInstance
t'
  forall {m :: * -> *} {c} {s} {a}.
CompilerContext c m s a =>
GeneralInstance -> StateT a m String
expand GeneralInstance
t'' where
    expand :: GeneralInstance -> StateT a m String
expand GeneralInstance
t2
      | GeneralInstance
t2 forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
allGetter forall a. [a] -> [a] -> [a]
++ String
"()"
      | GeneralInstance
t2 forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
anyGetter forall a. [a] -> [a] -> [a]
++ String
"()"
      | Bool
otherwise = forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree forall {m :: * -> *}. Monad m => [m String] -> m String
getAny forall {m :: * -> *}. Monad m => [m String] -> m String
getAll TypeInstanceOrParam -> StateT a m String
getSingle GeneralInstance
t2
    getAny :: [m String] -> m String
getAny [m String]
ts = forall {m :: * -> *}. Monad m => [m String] -> m String
combine [m String]
ts 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
. (String
unionGetter forall a. [a] -> [a] -> [a]
++)
    getAll :: [m String] -> m String
getAll [m String]
ts = forall {m :: * -> *}. Monad m => [m String] -> m String
combine [m String]
ts 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
. (String
intersectGetter forall a. [a] -> [a] -> [a]
++)
    getSingle :: TypeInstanceOrParam -> StateT a m String
getSingle (JustTypeInstance (TypeInstance CategoryName
t2 Positional GeneralInstance
ps)) = do
      [String]
ps' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> StateT a m String
expand forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps
      let count :: Int
count = forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ps'
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CategoryName -> String
typeGetter CategoryName
t2 forall a. [a] -> [a] -> [a]
++ String
"(Params<" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count forall a. [a] -> [a] -> [a]
++ String
">::Type(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
ps' forall a. [a] -> [a] -> [a]
++ String
"))"
    getSingle (JustParamName Bool
_ ParamName
ParamSelf) = forall (m :: * -> *) a. Monad m => a -> m a
return String
"S<const TypeInstance>(PARAM_SELF)"
    getSingle (JustParamName Bool
_ ParamName
p)  = do
      SymbolScope
s <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
ParamName -> CompilerState a m SymbolScope
csGetParamScope ParamName
p
      String
scoped <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
scoped forall a. [a] -> [a] -> [a]
++ ParamName -> String
paramName ParamName
p
    getSingle (JustInferredType ParamName
p) = TypeInstanceOrParam -> StateT a m String
getSingle (Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False ParamName
p)
    combine :: [m String] -> m String
combine [m String]
ps = do
      [String]
ps' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m String]
ps
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"(L_get<S<const " forall a. [a] -> [a] -> [a]
++ String
typeBase forall a. [a] -> [a] -> [a]
++ String
">>(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
ps' forall a. [a] -> [a] -> [a]
++ String
"))"

doImplicitReturn :: (CollectErrorsM m, Ord c, Show c, CompilerContext c m [String] a) =>
  [c] -> CompilerState a m ()
doImplicitReturn :: forall (m :: * -> *) c a.
(CollectErrorsM m, Ord c, Show c,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
doImplicitReturn [c]
c = do
  Bool
named <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsNamedReturns
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> Maybe ExpressionType -> CompilerState a m ()
csRegisterReturn [c]
c forall a. Maybe a
Nothing
  forall (m :: * -> *) s. Monad m => StateT s m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup [c]
c JumpType
JumpReturn
  if Bool -> Bool
not Bool
named
     then forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"return ReturnTuple();"]
     else do
       forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
CompilerState a m ()
getPrimNamedReturns
       forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"return returns;"]
  where

autoPositionalCleanup :: (Ord c,Eq c,Show c,CollectErrorsM m, CompilerContext c m [String] a) =>
  [c] -> ExpressionValue -> CompilerState a m ()
autoPositionalCleanup :: forall c (m :: * -> *) a.
(Ord c, Eq c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> ExpressionValue -> CompilerState a m ()
autoPositionalCleanup [c]
c ExpressionValue
e = do
  Bool
named <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsNamedReturns
  (CleanupBlock [String]
ss DeferVariable c
_ [UsedVariable c]
_ JumpType
_ Set CategoryName
_) <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
JumpType -> CompilerState a m (CleanupBlock c s)
csGetCleanup JumpType
JumpReturn
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ss
     then do
       forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpReturn
       forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"return " forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsReturns ExpressionValue
e forall a. [a] -> [a] -> [a]
++ String
";"]
     else do
       if Bool
named
          then do
            forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"returns.TransposeFrom(" forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsReturns ExpressionValue
e forall a. [a] -> [a] -> [a]
++ String
");"]
            forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
CompilerState a m ()
setPrimNamedReturns
            forall (m :: * -> *) s. Monad m => StateT s m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup [c]
c JumpType
JumpReturn
            forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"return returns;"]
          else do
            forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"{",String
"ReturnTuple returns = " forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsReturns ExpressionValue
e forall a. [a] -> [a] -> [a]
++ String
";"]
            forall (m :: * -> *) s. Monad m => StateT s m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup [c]
c JumpType
JumpReturn
            forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"return returns;",String
"}"]

setPrimNamedReturns ::  (CollectErrorsM m, CompilerContext c m [String] a) =>
  CompilerState a m ()
setPrimNamedReturns :: forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
CompilerState a m ()
setPrimNamedReturns = do
  [ReturnVariable]
vars <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m [ReturnVariable]
csPrimNamedReturns
  forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReturnVariable -> String
assign) [ReturnVariable]
vars where
    assign :: ReturnVariable -> String
assign (ReturnVariable Int
i VariableName
n ValueType
t) =
      VariableName -> String
variableName VariableName
n forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ ValueType -> ExpressionValue -> String
writeStoredVariable ValueType
t (forall {a}. Show a => a -> ExpressionValue
position Int
i) forall a. [a] -> [a] -> [a]
++ String
";"
    position :: a -> ExpressionValue
position a
i = String -> ExpressionValue
WrappedSingle forall a b. (a -> b) -> a -> b
$ String
"returns.At(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
")"

getPrimNamedReturns ::  (CollectErrorsM m, CompilerContext c m [String] a) =>
  CompilerState a m ()
getPrimNamedReturns :: forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
CompilerState a m ()
getPrimNamedReturns = do
  [ReturnVariable]
vars <- forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m [ReturnVariable]
csPrimNamedReturns
  forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReturnVariable -> String
assign) [ReturnVariable]
vars where
    assign :: ReturnVariable -> String
assign (ReturnVariable Int
i VariableName
n ValueType
t) =
      String
"returns.At(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
") = " forall a. [a] -> [a] -> [a]
++ ExpressionValue -> String
useAsUnwrapped (Bool -> ValueType -> String -> ExpressionValue
readStoredVariable Bool
False ValueType
t forall a b. (a -> b) -> a -> b
$ VariableName -> String
variableName VariableName
n) forall a. [a] -> [a] -> [a]
++ String
";"

autoInsertCleanup :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
  [c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup [c]
c JumpType
j a
ctx = do
  (CleanupBlock [String]
ss DeferVariable c
ds [UsedVariable c]
vs JumpType
jump Set CategoryName
req) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> JumpType -> m (CleanupBlock c s)
ccGetCleanup a
ctx JumpType
j
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[UsedVariable c] -> CompilerState a m ()
csCheckVariableInit (forall a. Eq a => [a] -> [a]
nub [UsedVariable c]
vs) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In inlining of cleanup block after statement at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c
  let vs2 :: [UsedVariable c]
vs2 = forall a b. (a -> b) -> [a] -> [b]
map (\(UsedVariable [c]
c0 VariableName
v) -> forall c. [c] -> VariableName -> UsedVariable c
UsedVariable ([c]
c forall a. [a] -> [a] -> [a]
++ [c]
c0) VariableName
v) [UsedVariable c]
vs
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
DeferVariable c -> CompilerState a m ()
csInheritDeferred DeferVariable c
ds
  -- This is needed in case a cleanup is inlined within another cleanup, e.g.,
  -- e.g., if the latter has a break statement.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csAddUsed [UsedVariable c]
vs2
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String]
ss
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired Set CategoryName
req
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
jump

inheritRequired :: (CollectErrorsM m, CompilerContext c m [String] a) =>
  a -> CompilerState a m ()
inheritRequired :: forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx = do
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m (Set CategoryName)
ccGetRequired a
ctx) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m [String]
ccGetTraces a
ctx) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall c (m :: * -> *) s a.
CompilerContext c m s a =>
String -> CompilerState a m ()
csAddTrace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

autoInlineOutput :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
  a -> CompilerState a m ()
autoInlineOutput :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m ()
autoInlineOutput a
ctx = do
  forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx
  forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite
  forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[a] -> CompilerState a m ()
csInheritStatic [a
ctx]

getAndIndentOutput :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>
  a -> CompilerState a m [String]
getAndIndentOutput :: forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> [String]
indentCode (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *) s a. CompilerContext c m s a => a -> m s
ccGetOutput a
ctx)

indentCode :: [String] -> [String]
indentCode :: [String] -> [String]
indentCode = forall a b. (a -> b) -> [a] -> [b]
map (String
"  " forall a. [a] -> [a] -> [a]
++)