{- -----------------------------------------------------------------------------
Copyright 2019-2021 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,
  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 -> ScopedFunction c -> m (CompiledData [String])
procedureDeclaration :: Bool -> ScopedFunction c -> m (CompiledData [String])
procedureDeclaration Bool
abstract ScopedFunction c
f = CompiledData [String] -> m (CompiledData [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (CompiledData [String] -> m (CompiledData [String]))
-> CompiledData [String] -> m (CompiledData [String])
forall a b. (a -> b) -> a -> b
$ String -> CompiledData [String]
onlyCode String
func where
  func :: String
func
    | Bool
abstract = String
"virtual " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
proto String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = 0;"
    | Bool
otherwise = String
proto String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
  name :: String
name = FunctionName -> String
callName (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f)
  proto :: String
proto
    | ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope =
      String
"ReturnTuple " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(const ParamTuple& params, const ValueTuple& args)"
    | ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
TypeScope =
      String
"ReturnTuple " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"(const S<TypeInstance>& Param_self, const ParamTuple& params, const ValueTuple& args)"
    | ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
ValueScope =
      String
"ReturnTuple " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args)"
    | Bool
otherwise = String
forall a. HasCallStack => a
undefined

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

compileExecutableProcedure :: (Ord c, Show c, CollectErrorsM m) =>
  CxxFunctionType -> ScopeContext c -> ScopedFunction c ->
  ExecutableProcedure c -> m (CompiledData [String])
compileExecutableProcedure :: CxxFunctionType
-> ScopeContext c
-> ScopedFunction c
-> ExecutableProcedure c
-> m (CompiledData [String])
compileExecutableProcedure CxxFunctionType
cxxType ScopeContext c
ctx
  ff :: ScopedFunction c
ff@(ScopedFunction [c]
_ FunctionName
_ CategoryName
_ SymbolScope
s Positional (PassedValue 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' <- ScopeContext c
-> ScopedFunction c
-> ExecutableProcedure c
-> m (ProcedureContext c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopeContext c
-> ScopedFunction c
-> ExecutableProcedure c
-> m (ProcedureContext c)
getProcedureContext ScopeContext c
ctx ScopedFunction c
ff ExecutableProcedure c
pp
  CompiledData [String]
output <- CompilerState (ProcedureContext c) m ()
-> ProcedureContext c -> m (CompiledData [String])
forall c (m :: * -> *) s a b.
CompilerContext c m s a =>
CompilerState a m b -> a -> m (CompiledData s)
runDataCompiler CompilerState (ProcedureContext c) m ()
compileWithReturn ProcedureContext c
ctx'
  [String]
procedureTrace <- m [String]
setProcedureTrace
  [String]
creationTrace  <- m [String]
setCreationTrace
  CompiledData [String] -> m (CompiledData [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (CompiledData [String] -> m (CompiledData [String]))
-> CompiledData [String] -> m (CompiledData [String])
forall a b. (a -> b) -> a -> b
$ CompiledData [String]
-> [String] -> [String] -> CompiledData [String]
wrapProcedure CompiledData [String]
output [String]
procedureTrace [String]
creationTrace
  where
    compileWithReturn :: CompilerState (ProcedureContext c) m ()
compileWithReturn = do
      ProcedureContext c
ctx0 <- CompilerState (ProcedureContext c) m (ProcedureContext c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext CompilerState (ProcedureContext c) m (ProcedureContext c)
-> (ProcedureContext c
    -> CompilerState (ProcedureContext c) m (ProcedureContext c))
-> CompilerState (ProcedureContext c) m (ProcedureContext c)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (ProcedureContext c)
-> CompilerState (ProcedureContext c) m (ProcedureContext c)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ProcedureContext c)
 -> CompilerState (ProcedureContext c) m (ProcedureContext c))
-> (ProcedureContext c -> m (ProcedureContext c))
-> ProcedureContext c
-> CompilerState (ProcedureContext c) m (ProcedureContext c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProcedureContext c -> Bool -> m (ProcedureContext c))
-> Bool -> ProcedureContext c -> m (ProcedureContext c)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProcedureContext c -> Bool -> m (ProcedureContext c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> Bool -> m a
ccSetNoTrace ((PragmaProcedure c -> Bool) -> [PragmaProcedure c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PragmaProcedure c -> Bool
forall c. PragmaProcedure c -> Bool
isNoTrace [PragmaProcedure c]
pragmas)
      ProcedureContext c
-> Procedure c
-> CompilerState (ProcedureContext c) m (ProcedureContext c)
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 CompilerState (ProcedureContext c) m (ProcedureContext c)
-> (ProcedureContext c -> CompilerState (ProcedureContext c) m ())
-> CompilerState (ProcedureContext c) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcedureContext c -> CompilerState (ProcedureContext c) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put
      Bool
unreachable <- CompilerState (ProcedureContext c) m Bool
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsUnreachable
      Bool
-> CompilerState (ProcedureContext c) m ()
-> CompilerState (ProcedureContext c) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
unreachable) (CompilerState (ProcedureContext c) m ()
 -> CompilerState (ProcedureContext c) m ())
-> CompilerState (ProcedureContext c) m ()
-> CompilerState (ProcedureContext c) m ()
forall a b. (a -> b) -> a -> b
$
        [c] -> CompilerState (ProcedureContext c) m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, Ord c, Show c,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
doImplicitReturn [c]
c2 CompilerState (ProcedureContext c) m ()
-> String -> CompilerState (ProcedureContext c) m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
          String
"In implicit return from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
    funcMergeDeps :: ScopedFunction c -> CompiledData [a]
funcMergeDeps ScopedFunction c
f = [CompiledData [a]] -> CompiledData [a]
forall a. Monoid a => [a] -> a
mconcat ([CompiledData [a]] -> CompiledData [a])
-> [CompiledData [a]] -> CompiledData [a]
forall a b. (a -> b) -> a -> b
$ (Set CategoryName -> [a] -> CompiledData [a]
forall s. Set CategoryName -> s -> CompiledData s
CompiledData ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f]) [])CompiledData [a] -> [CompiledData [a]] -> [CompiledData [a]]
forall a. a -> [a] -> [a]
:((ScopedFunction c -> CompiledData [a])
-> [ScopedFunction c] -> [CompiledData [a]]
forall a b. (a -> b) -> [a] -> [b]
map ScopedFunction c -> CompiledData [a]
funcMergeDeps ([ScopedFunction c] -> [CompiledData [a]])
-> [ScopedFunction c] -> [CompiledData [a]]
forall a b. (a -> b) -> a -> b
$ ScopedFunction c -> [ScopedFunction c]
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 =
      [CompiledData [String]] -> CompiledData [String]
forall a. Monoid a => [a] -> a
mconcat [
          ScopedFunction c -> CompiledData [String]
forall c a. ScopedFunction c -> CompiledData [a]
funcMergeDeps ScopedFunction c
ff,
          String -> CompiledData [String]
onlyCode String
proto,
          CompiledData [String] -> CompiledData [String]
indentCompiled (CompiledData [String] -> CompiledData [String])
-> CompiledData [String] -> CompiledData [String]
forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
pt,
          CompiledData [String] -> CompiledData [String]
indentCompiled (CompiledData [String] -> CompiledData [String])
-> CompiledData [String] -> CompiledData [String]
forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
ct,
          CompiledData [String] -> CompiledData [String]
indentCompiled (CompiledData [String] -> CompiledData [String])
-> CompiledData [String] -> CompiledData [String]
forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
defineReturns,
          CompiledData [String] -> CompiledData [String]
indentCompiled (CompiledData [String] -> CompiledData [String])
-> CompiledData [String] -> CompiledData [String]
forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
nameParams,
          CompiledData [String] -> CompiledData [String]
indentCompiled (CompiledData [String] -> CompiledData [String])
-> CompiledData [String] -> CompiledData [String]
forall a b. (a -> b) -> a -> b
$ [String] -> CompiledData [String]
onlyCodes [String]
nameArgs,
          CompiledData [String] -> CompiledData [String]
indentCompiled (CompiledData [String] -> CompiledData [String])
-> CompiledData [String] -> CompiledData [String]
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::"
                  CxxFunctionType
_ -> String
""
    final :: String
final = case CxxFunctionType
cxxType of
                CxxFunctionType
FinalInlineFunction -> String
" final"
                CxxFunctionType
_ -> String
""
    proto :: String
proto
      | SymbolScope
s SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope =
        String
returnType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(const ParamTuple& params, const ValueTuple& args)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
final String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" {"
      | SymbolScope
s SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
TypeScope =
        String
returnType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
"(const S<TypeInstance>& Param_self, const ParamTuple& params, const ValueTuple& args)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
final String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" {"
      | SymbolScope
s SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
ValueScope =
        String
returnType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
"(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
final String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" {"
      | Bool
otherwise = String
forall a. HasCallStack => a
undefined
    returnType :: String
returnType = String
"ReturnTuple"
    setProcedureTrace :: m [String]
setProcedureTrace
      | (PragmaProcedure c -> Bool) -> [PragmaProcedure c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PragmaProcedure c -> Bool
forall c. PragmaProcedure c -> Bool
isNoTrace [PragmaProcedure c]
pragmas = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      | Bool
otherwise             = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [ScopedFunction c -> String
forall c. ScopedFunction c -> String
startFunctionTracing ScopedFunction c
ff]
    setCreationTrace :: m [String]
setCreationTrace
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PragmaProcedure c -> Bool) -> [PragmaProcedure c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PragmaProcedure c -> Bool
forall c. PragmaProcedure c -> Bool
isTraceCreation [PragmaProcedure c]
pragmas = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      | SymbolScope
s SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
/= SymbolScope
ValueScope =
          (String -> m ()
forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerWarningM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Creation tracing ignored for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolScope -> String
forall a. Show a => a -> String
show SymbolScope
s String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
" functions" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c) m () -> m [String] -> m [String]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      | Bool
otherwise = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
showCreationTrace]
    defineReturns :: [String]
defineReturns
      | ReturnValues c -> Bool
forall c. ReturnValues c -> Bool
isUnnamedReturns ReturnValues c
rs2 = []
      | Bool
otherwise            = [String
returnType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returns(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([PassedValue c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PassedValue c] -> Int) -> [PassedValue c] -> Int
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c) -> [PassedValue c]
forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"]
    nameParams :: [String]
nameParams = (((Int, ValueParam c) -> String)
 -> [(Int, ValueParam c)] -> [String])
-> [(Int, ValueParam c)]
-> ((Int, ValueParam c) -> String)
-> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, ValueParam c) -> String)
-> [(Int, ValueParam c)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [ValueParam c] -> [(Int, ValueParam c)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) ([ValueParam c] -> [(Int, ValueParam c)])
-> [ValueParam c] -> [(Int, ValueParam c)]
forall a b. (a -> b) -> a -> b
$ Positional (ValueParam c) -> [ValueParam c]
forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps1) (((Int, ValueParam c) -> String) -> [String])
-> ((Int, ValueParam c) -> String) -> [String]
forall a b. (a -> b) -> a -> b
$
      (\(Int
i,ValueParam c
p2) -> String
paramType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
paramName (ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ValueParam c
p2) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = params.At(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");")
    nameArgs :: [String]
nameArgs = (((Int, (PassedValue c, InputValue c)) -> String)
 -> [(Int, (PassedValue c, InputValue c))] -> [String])
-> [(Int, (PassedValue c, InputValue c))]
-> ((Int, (PassedValue c, InputValue c)) -> String)
-> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, (PassedValue c, InputValue c)) -> String)
-> [(Int, (PassedValue c, InputValue c))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([Int]
-> [(PassedValue c, InputValue c)]
-> [(Int, (PassedValue c, InputValue c))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) ([(PassedValue c, InputValue c)]
 -> [(Int, (PassedValue c, InputValue c))])
-> [(PassedValue c, InputValue c)]
-> [(Int, (PassedValue c, InputValue c))]
forall a b. (a -> b) -> a -> b
$ ((PassedValue c, InputValue c) -> Bool)
-> [(PassedValue c, InputValue c)]
-> [(PassedValue c, InputValue c)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((PassedValue c, InputValue c) -> Bool)
-> (PassedValue c, InputValue c)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputValue c -> Bool
forall c. InputValue c -> Bool
isDiscardedInput (InputValue c -> Bool)
-> ((PassedValue c, InputValue c) -> InputValue c)
-> (PassedValue c, InputValue c)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PassedValue c, InputValue c) -> InputValue c
forall a b. (a, b) -> b
snd) ([(PassedValue c, InputValue c)]
 -> [(PassedValue c, InputValue c)])
-> [(PassedValue c, InputValue c)]
-> [(PassedValue c, InputValue c)]
forall a b. (a -> b) -> a -> b
$ [PassedValue c]
-> [InputValue c] -> [(PassedValue c, InputValue c)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Positional (PassedValue c) -> [PassedValue c]
forall a. Positional a -> [a]
pValues Positional (PassedValue c)
as1) (Positional (InputValue c) -> [InputValue c]
forall a. Positional a -> [a]
pValues (Positional (InputValue c) -> [InputValue c])
-> Positional (InputValue c) -> [InputValue c]
forall a b. (a -> b) -> a -> b
$ ArgValues c -> Positional (InputValue c)
forall c. ArgValues c -> Positional (InputValue c)
avNames ArgValues c
as2)) (((Int, (PassedValue c, InputValue c)) -> String) -> [String])
-> ((Int, (PassedValue c, InputValue c)) -> String) -> [String]
forall a b. (a -> b) -> a -> b
$
      (\(Int
i,(PassedValue c
t2,InputValue c
n2)) -> String
"const " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> String
variableProxyType (PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType PassedValue c
t2) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName (InputValue c -> VariableName
forall c. InputValue c -> VariableName
ivName InputValue c
n2) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> ExprValue -> String
writeStoredVariable (PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType PassedValue c
t2) (String -> ExprValue
UnwrappedSingle (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"args.At(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";")
    nameReturns :: [String]
nameReturns
      | ReturnValues c -> Bool
forall c. ReturnValues c -> Bool
isUnnamedReturns ReturnValues c
rs2 = []
      | Bool
otherwise = ((Int, (PassedValue c, OutputValue c)) -> String)
-> [(Int, (PassedValue c, OutputValue c))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i,(PassedValue c
t2,OutputValue c
n2)) -> Int -> ValueType -> OutputValue c -> String
forall a c. Show a => a -> ValueType -> OutputValue c -> String
nameReturn Int
i (PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType PassedValue c
t2) OutputValue c
n2) ([Int]
-> [(PassedValue c, OutputValue c)]
-> [(Int, (PassedValue c, OutputValue c))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) ([(PassedValue c, OutputValue c)]
 -> [(Int, (PassedValue c, OutputValue c))])
-> [(PassedValue c, OutputValue c)]
-> [(Int, (PassedValue c, OutputValue c))]
forall a b. (a -> b) -> a -> b
$ [PassedValue c]
-> [OutputValue c] -> [(PassedValue c, OutputValue c)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Positional (PassedValue c) -> [PassedValue c]
forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs1) (Positional (OutputValue c) -> [OutputValue c]
forall a. Positional a -> [a]
pValues (Positional (OutputValue c) -> [OutputValue c])
-> Positional (OutputValue c) -> [OutputValue c]
forall a b. (a -> b) -> a -> b
$ ReturnValues c -> Positional (OutputValue c)
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
isPrimType ValueType
t2 = ValueType -> String
variableProxyType ValueType
t2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName (OutputValue c -> VariableName
forall c. OutputValue c -> VariableName
ovName OutputValue c
n2) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
      | Bool
otherwise =
        ValueType -> String
variableProxyType ValueType
t2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName (OutputValue c -> VariableName
forall c. OutputValue c -> VariableName
ovName OutputValue c
n2) String -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> ExprValue -> String
writeStoredVariable ValueType
t2 (String -> ExprValue
UnwrappedSingle (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"returns.At(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") String -> String -> 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 :: a -> [c] -> Expression c -> CompilerState a m (String, a)
compileCondition a
ctx [c]
c Expression c
e = do
  (String
e',a
ctx') <- CompilerState a m (String, a) -> CompilerState a m (String, a)
forall (m :: * -> *) a. ErrorContextM m => m a -> m a
resetBackgroundM (CompilerState a m (String, a) -> CompilerState a m (String, a))
-> CompilerState a m (String, a) -> CompilerState a m (String, a)
forall a b. (a -> b) -> a -> b
$ m (String, a) -> CompilerState a m (String, a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (String, a) -> CompilerState a m (String, a))
-> m (String, a) -> CompilerState a m (String, a)
forall a b. (a -> b) -> a -> b
$ StateT a m String -> a -> m (String, a)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT a m String
compile a
ctx
  Bool
noTrace <- CompilerState a m Bool
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csGetNoTrace
  if Bool
noTrace
     then (String, a) -> CompilerState a m (String, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
e',a
ctx')
     else (String, a) -> CompilerState a m (String, a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([c] -> String
forall a. Show a => [a] -> String
predTraceContext [c]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e',a
ctx')
  where
    compile :: StateT a m String
compile = String
"In condition at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c String -> StateT a m String -> StateT a m String
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      (ExpressionType
ts,ExprValue
e') <- Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e
      ExpressionType -> StateT a m ()
forall (m :: * -> *). ErrorContextM m => ExpressionType -> m ()
checkCondition ExpressionType
ts
      String -> StateT a m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> StateT a m String) -> String -> StateT a m String
forall a b. (a -> b) -> a -> b
$ PrimitiveType -> ExprValue -> String
useAsUnboxed PrimitiveType
PrimBool ExprValue
e'
      where
        checkCondition :: ExpressionType -> m ()
checkCondition (Positional [ValueType
t]) | ValueType
t ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
boolRequiredValue = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        checkCondition (Positional [ValueType]
ts) =
          String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected exactly one Bool value but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((ValueType -> String) -> [ValueType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ValueType -> String
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 :: a -> Procedure c -> CompilerState a m a
compileProcedure a
ctx (Procedure [c]
_ [Statement c]
ss) = do
  a
ctx' <- m a -> CompilerState a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CompilerState a m a) -> m a -> CompilerState a m a
forall a b. (a -> b) -> a -> b
$ StateT a m [()] -> a -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ([StateT a m ()] -> StateT a m [()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([StateT a m ()] -> StateT a m [()])
-> [StateT a m ()] -> StateT a m [()]
forall a b. (a -> b) -> a -> b
$ (Statement c -> StateT a m ()) -> [Statement c] -> [StateT a m ()]
forall a b. (a -> b) -> [a] -> [b]
map Statement c -> StateT a m ()
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
  a -> CompilerState a m a
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 <- CompilerState a m Bool
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsUnreachable
      if Bool
unreachable Bool -> Bool -> Bool
&& Bool -> Bool
not (Statement c -> Bool
forall c. Statement c -> Bool
isRawCodeLine Statement c
s)
         then String -> StateT a m ()
forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerWarningM (String -> StateT a m ()) -> String -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ String
"Statement at " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                 [c] -> String
forall a. Show a => [a] -> String
formatFullContext (Statement c -> [c]
forall c. Statement c -> [c]
getStatementContext Statement c
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                 String
" is unreachable (skipping compilation)"
         else do
           ()
s' <- StateT a m () -> StateT a m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> m a
resetBackgroundM (StateT a m () -> StateT a m ()) -> StateT a m () -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ Statement c -> StateT a m ()
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Statement c -> CompilerState a m ()
compileStatement Statement c
s
           () -> StateT a m ()
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 :: [c] -> CompilerState a m ()
maybeSetTrace [c]
c = do
  Bool
noTrace <- CompilerState a m Bool
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csGetNoTrace
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
noTrace) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite ([String] -> CompilerState a m ())
-> [String] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [c] -> [String]
forall c. Show c => [c] -> [String]
setTraceContext [c]
c

compileStatement :: (Ord c, Show c, CollectErrorsM m,
                     CompilerContext c m [String] a) =>
  Statement c -> CompilerState a m ()
compileStatement :: Statement c -> CompilerState a m ()
compileStatement (EmptyReturn [c]
c) = do
  [c] -> CompilerState a m ()
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
  [c] -> CompilerState a m ()
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, ExprValue)]
es' <- [StateT a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([StateT a m (ExpressionType, ExprValue)]
 -> StateT a m [(ExpressionType, ExprValue)])
-> [StateT a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ (Expression c -> StateT a m (ExpressionType, ExprValue))
-> [Expression c] -> [StateT a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> [a] -> [b]
map Expression c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression ([Expression c] -> [StateT a m (ExpressionType, ExprValue)])
-> [Expression c] -> [StateT a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es
  [([c], (ExpressionType, ExprValue))] -> CompilerState a m ()
forall (m :: * -> *) a a.
(CompilerContext c m [String] a, CollectErrorsM m) =>
[(a, (ExpressionType, ExprValue))] -> StateT a m ()
getReturn ([([c], (ExpressionType, ExprValue))] -> CompilerState a m ())
-> [([c], (ExpressionType, ExprValue))] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [[c]]
-> [(ExpressionType, ExprValue)]
-> [([c], (ExpressionType, ExprValue))]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Expression c -> [c]) -> [Expression c] -> [[c]]
forall a b. (a -> b) -> [a] -> [b]
map Expression c -> [c]
forall c. Expression c -> [c]
getExpressionContext ([Expression c] -> [[c]]) -> [Expression c] -> [[c]]
forall a b. (a -> b) -> a -> b
$ Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es) [(ExpressionType, ExprValue)]
es'
  where
    -- Single expression, but possibly multi-return.
    getReturn :: [(a, (ExpressionType, ExprValue))] -> StateT a m ()
getReturn [(a
_,(Positional [ValueType]
ts,ExprValue
e))] = do
      [c] -> Maybe ExpressionType -> StateT a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> Maybe ExpressionType -> CompilerState a m ()
csRegisterReturn [c]
c (Maybe ExpressionType -> StateT a m ())
-> Maybe ExpressionType -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ ExpressionType -> Maybe ExpressionType
forall a. a -> Maybe a
Just ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType]
ts)
      [c] -> StateT a m ()
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
      [c] -> ExprValue -> StateT a m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> ExprValue -> CompilerState a m ()
autoPositionalCleanup [c]
c ExprValue
e
    -- Multi-expression => must all be singles.
    getReturn [(a, (ExpressionType, ExprValue))]
rs = do
      m () -> StateT a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (((Int, ExpressionType) -> m ()) -> [(Int, ExpressionType)] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (Int, ExpressionType) -> m ()
forall (m :: * -> *) a a.
(ErrorContextM m, Show a) =>
(a, Positional a) -> m ()
checkArity ([(Int, ExpressionType)] -> m ())
-> [(Int, ExpressionType)] -> m ()
forall a b. (a -> b) -> a -> b
$ [Int] -> [ExpressionType] -> [(Int, ExpressionType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) ([ExpressionType] -> [(Int, ExpressionType)])
-> [ExpressionType] -> [(Int, ExpressionType)]
forall a b. (a -> b) -> a -> b
$ ((a, (ExpressionType, ExprValue)) -> ExpressionType)
-> [(a, (ExpressionType, ExprValue))] -> [ExpressionType]
forall a b. (a -> b) -> [a] -> [b]
map ((ExpressionType, ExprValue) -> ExpressionType
forall a b. (a, b) -> a
fst ((ExpressionType, ExprValue) -> ExpressionType)
-> ((a, (ExpressionType, ExprValue))
    -> (ExpressionType, ExprValue))
-> (a, (ExpressionType, ExprValue))
-> ExpressionType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, (ExpressionType, ExprValue)) -> (ExpressionType, ExprValue)
forall a b. (a, b) -> b
snd) [(a, (ExpressionType, ExprValue))]
rs) StateT a m () -> String -> StateT a m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        (String
"In return at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c)
      [c] -> Maybe ExpressionType -> StateT a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> Maybe ExpressionType -> CompilerState a m ()
csRegisterReturn [c]
c (Maybe ExpressionType -> StateT a m ())
-> Maybe ExpressionType -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ ExpressionType -> Maybe ExpressionType
forall a. a -> Maybe a
Just (ExpressionType -> Maybe ExpressionType)
-> ExpressionType -> Maybe ExpressionType
forall a b. (a -> b) -> a -> b
$ [ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional ([ValueType] -> ExpressionType) -> [ValueType] -> ExpressionType
forall a b. (a -> b) -> a -> b
$ ((a, (ExpressionType, ExprValue)) -> ValueType)
-> [(a, (ExpressionType, ExprValue))] -> [ValueType]
forall a b. (a -> b) -> [a] -> [b]
map ([ValueType] -> ValueType
forall a. [a] -> a
head ([ValueType] -> ValueType)
-> ((a, (ExpressionType, ExprValue)) -> [ValueType])
-> (a, (ExpressionType, ExprValue))
-> ValueType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpressionType -> [ValueType]
forall a. Positional a -> [a]
pValues (ExpressionType -> [ValueType])
-> ((a, (ExpressionType, ExprValue)) -> ExpressionType)
-> (a, (ExpressionType, ExprValue))
-> [ValueType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a, b) -> a
fst ((ExpressionType, ExprValue) -> ExpressionType)
-> ((a, (ExpressionType, ExprValue))
    -> (ExpressionType, ExprValue))
-> (a, (ExpressionType, ExprValue))
-> ExpressionType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, (ExpressionType, ExprValue)) -> (ExpressionType, ExprValue)
forall a b. (a, b) -> b
snd) [(a, (ExpressionType, ExprValue))]
rs
      let e :: ExprValue
e = String -> ExprValue
OpaqueMulti (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"ReturnTuple(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (((a, (ExpressionType, ExprValue)) -> String)
-> [(a, (ExpressionType, ExprValue))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ExprValue -> String
useAsUnwrapped (ExprValue -> String)
-> ((a, (ExpressionType, ExprValue)) -> ExprValue)
-> (a, (ExpressionType, ExprValue))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExpressionType, ExprValue) -> ExprValue
forall a b. (a, b) -> b
snd ((ExpressionType, ExprValue) -> ExprValue)
-> ((a, (ExpressionType, ExprValue))
    -> (ExpressionType, ExprValue))
-> (a, (ExpressionType, ExprValue))
-> ExprValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, (ExpressionType, ExprValue)) -> (ExpressionType, ExprValue)
forall a b. (a, b) -> b
snd) [(a, (ExpressionType, ExprValue))]
rs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      [c] -> StateT a m ()
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
      [c] -> ExprValue -> StateT a m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
[c] -> ExprValue -> CompilerState a m ()
autoPositionalCleanup [c]
c ExprValue
e
    checkArity :: (a, Positional a) -> m ()
checkArity (a
_,Positional [a
_]) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkArity (a
i,Positional [a]
ts)  =
      String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Return position " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" values but should have 1"
compileStatement (LoopBreak [c]
c) = do
  LoopSetup [String]
loop <- CompilerState a m (LoopSetup [String])
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m (LoopSetup s)
csGetLoop
  case LoopSetup [String]
loop of
       LoopSetup [String]
NotInLoop ->
         String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Using break outside of while is no allowed" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
       LoopSetup [String]
_ -> () -> CompilerState a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  [c] -> JumpType -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpBreak
  StateT a m a
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT a m a -> (a -> CompilerState a m ()) -> CompilerState a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [c] -> JumpType -> a -> CompilerState a m ()
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
  [String] -> CompilerState a m ()
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 <- CompilerState a m (LoopSetup [String])
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m (LoopSetup s)
csGetLoop
  case LoopSetup [String]
loop of
       LoopSetup [String]
NotInLoop ->
         String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Using continue outside of while is no allowed" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
       LoopSetup [String]
_ -> () -> CompilerState a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  [c] -> JumpType -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpContinue
  StateT a m a
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT a m a -> (a -> CompilerState a m ()) -> CompilerState a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [c] -> JumpType -> a -> CompilerState a m ()
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
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite ([String] -> CompilerState a m ())
-> [String] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [String
"{"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ LoopSetup [String] -> [String]
forall s. LoopSetup s -> s
lsUpdate LoopSetup [String]
loop [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"}",String
"continue;"]
compileStatement (FailCall [c]
c Expression c
e) = do
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinFormatted,CategoryName
BuiltinString])
  (ExpressionType, ExprValue)
e' <- Expression c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ValueType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ExpressionType -> [ValueType]
forall a. Positional a -> [a]
pValues (ExpressionType -> [ValueType]) -> ExpressionType -> [ValueType]
forall a b. (a -> b) -> a -> b
$ (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a, b) -> a
fst (ExpressionType, ExprValue)
e') Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExprValue
e0) = (ExpressionType, ExprValue)
e'
  AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- CompilerState a m ParamFilters
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  m () -> CompilerState a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CompilerState a m ()) -> m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (AnyTypeResolver -> ParamFilters -> ValueType -> ValueType -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t0 ValueType
formattedRequiredValue) m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In fail call at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
  [c] -> JumpType -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpFailCall
  [c] -> CompilerState a m ()
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"BUILTIN_FAIL(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsUnwrapped ExprValue
e0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"]
compileStatement (RawFailCall String
s) = do
  [c] -> JumpType -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [] JumpType
JumpFailCall
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"RAW_FAIL(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"]
compileStatement (IgnoreValues [c]
c Expression c
e) = do
  (ExpressionType
_,ExprValue
e') <- Expression c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e
  [c] -> CompilerState a m ()
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"(void) (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsWhatever ExprValue
e' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"]
compileStatement (Assignment [c]
c Positional (Assignable c)
as Expression c
e) = String
message String -> CompilerState a m () -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
  (ExpressionType
ts,ExprValue
e') <- Expression c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e
  AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- CompilerState a m ParamFilters
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)]
_ <- (VariableName -> ValueType -> StateT a m (VariableName, ValueType))
-> Positional VariableName
-> ExpressionType
-> StateT a m [(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 VariableName -> ValueType -> StateT a m (VariableName, ValueType)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ((Assignable c -> VariableName)
-> Positional (Assignable c) -> Positional VariableName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Assignable c -> VariableName
forall c. Assignable c -> VariableName
assignableName Positional (Assignable c)
as) ExpressionType
ts
  [()]
_ <- (Assignable c -> ValueType -> CompilerState a m ())
-> Positional (Assignable c) -> ExpressionType -> StateT a m [()]
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 (AnyTypeResolver
-> ParamFilters
-> Assignable c
-> ValueType
-> CompilerState a m ()
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
  [c] -> CompilerState a m ()
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
[c] -> CompilerState a m ()
maybeSetTrace [c]
c
  [ValueType]
variableTypes <- [StateT a m ValueType] -> StateT a m [ValueType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([StateT a m ValueType] -> StateT a m [ValueType])
-> [StateT a m ValueType] -> StateT a m [ValueType]
forall a b. (a -> b) -> a -> b
$ ((Assignable c, ValueType) -> StateT a m ValueType)
-> [(Assignable c, ValueType)] -> [StateT a m ValueType]
forall a b. (a -> b) -> [a] -> [b]
map ((Assignable c -> ValueType -> StateT a m ValueType)
-> (Assignable c, ValueType) -> StateT a m ValueType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Assignable c -> ValueType -> StateT a m ValueType
forall (m :: * -> *) c s a.
CompilerContext c m s a =>
Assignable c -> ValueType -> StateT a m ValueType
getVariableType) ([(Assignable c, ValueType)] -> [StateT a m ValueType])
-> [(Assignable c, ValueType)] -> [StateT a m ValueType]
forall a b. (a -> b) -> a -> b
$ [Assignable c] -> [ValueType] -> [(Assignable c, ValueType)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Positional (Assignable c) -> [Assignable c]
forall a. Positional a -> [a]
pValues Positional (Assignable c)
as) (ExpressionType -> [ValueType]
forall a. Positional a -> [a]
pValues ExpressionType
ts)
  [(Int, ValueType, Assignable c)]
-> ExprValue -> CompilerState a m ()
forall (m :: * -> *) a a.
(CompilerContext c m [String] a, Show a) =>
[(a, ValueType, Assignable c)] -> ExprValue -> CompilerState a m ()
assignAll ([Int]
-> [ValueType]
-> [Assignable c]
-> [(Int, ValueType, Assignable c)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ([Int
0..] :: [Int]) [ValueType]
variableTypes (Positional (Assignable c) -> [Assignable c]
forall a. Positional a -> [a]
pValues Positional (Assignable c)
as)) ExprValue
e'
  where
    message :: String
message = String
"In assignment at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
    assignAll :: [(a, ValueType, Assignable c)] -> ExprValue -> CompilerState a m ()
assignAll [(a, ValueType, Assignable c)
v] ExprValue
e2 = (a, ValueType, Assignable c) -> ExprValue -> CompilerState a m ()
forall c (m :: * -> *) a a.
CompilerContext c m [String] a =>
(a, ValueType, Assignable c) -> ExprValue -> CompilerState a m ()
assignSingle (a, ValueType, Assignable c)
v ExprValue
e2
    assignAll [(a, ValueType, Assignable c)]
vs ExprValue
e2 = do
      [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"{",String
"const auto r = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsReturns ExprValue
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"]
      [CompilerState a m ()] -> CompilerState a m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([CompilerState a m ()] -> CompilerState a m ())
-> [CompilerState a m ()] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ ((a, ValueType, Assignable c) -> CompilerState a m ())
-> [(a, ValueType, Assignable c)] -> [CompilerState a m ()]
forall a b. (a -> b) -> [a] -> [b]
map (a, ValueType, Assignable c) -> CompilerState a m ()
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
      [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]
    getVariableType :: Assignable c -> ValueType -> StateT a m ValueType
getVariableType (CreateVariable [c]
_ ValueType
t VariableName
_) ValueType
_ = ValueType -> StateT a m ValueType
forall (m :: * -> *) a. Monad m => a -> m a
return ValueType
t
    getVariableType (ExistingVariable (InputValue [c]
c2 VariableName
n)) ValueType
_ = do
      (VariableValue [c]
_ SymbolScope
_ ValueType
t VariableRule c
_) <- UsedVariable c -> CompilerState a m (VariableValue c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable ([c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n)
      ValueType -> StateT a m ValueType
forall (m :: * -> *) a. Monad m => a -> m a
return ValueType
t
    getVariableType (ExistingVariable (DiscardInput [c]
_)) ValueType
t = ValueType -> StateT a m ValueType
forall (m :: * -> *) a. Monad m => a -> m a
return ValueType
t
    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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
forall a. Show a => a -> String
show VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c2 String -> StateT a m () -> StateT a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
        GeneralInstance
self <- CompilerState a m GeneralInstance
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
        ValueType
t1' <- m ValueType -> StateT a m ValueType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ValueType -> StateT a m ValueType)
-> m ValueType -> StateT a m ValueType
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> ValueType -> m ValueType
replaceSelfValueType GeneralInstance
self ValueType
t1
        -- TODO: Call csAddRequired for t1'. (Maybe needs a helper function.)
        m () -> StateT a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT a m ()) -> m () -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ [r -> ParamFilters -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> m ()
validateGeneralInstance r
r ParamFilters
fa (ValueType -> GeneralInstance
vtType ValueType
t1'),
                             r -> ParamFilters -> ValueType -> ValueType -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment r
r ParamFilters
fa ValueType
t2 ValueType
t1']
        UsedVariable c -> VariableValue c -> StateT a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> VariableValue c -> CompilerState a m ()
csAddVariable ([c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n) ([c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c2 SymbolScope
LocalScope ValueType
t1' VariableRule c
forall c. VariableRule c
VariableDefault)
        [String] -> StateT a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [ValueType -> String
variableStoredType ValueType
t1' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"]
    createVariable r
r ParamFilters
fa (ExistingVariable (InputValue [c]
c2 VariableName
n)) ValueType
t2 =
      String
"In assignment to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
forall a. Show a => a -> String
show VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c2 String -> StateT a m () -> StateT a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
        (VariableValue [c]
_ SymbolScope
_ ValueType
t1 VariableRule c
_) <- [c] -> VariableName -> CompilerState a m (VariableValue 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.
        m () -> StateT a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT a m ()) -> m () -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ (r -> ParamFilters -> ValueType -> ValueType -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment r
r ParamFilters
fa ValueType
t2 ValueType
t1)
        VariableName -> StateT a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
VariableName -> CompilerState a m ()
csUpdateAssigned VariableName
n
    createVariable r
_ ParamFilters
_ Assignable c
_ ValueType
_ = () -> StateT a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    assignSingle :: (a, ValueType, Assignable c) -> ExprValue -> CompilerState a m ()
assignSingle (a
_,ValueType
t,CreateVariable [c]
_ ValueType
_ VariableName
n) ExprValue
e2 =
      [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [VariableName -> String
variableName VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> ExprValue -> String
writeStoredVariable ValueType
t ExprValue
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"]
    assignSingle (a
_,ValueType
t,ExistingVariable (InputValue [c]
c2 VariableName
n)) ExprValue
e2 = do
      (VariableValue [c]
_ SymbolScope
s ValueType
_ VariableRule c
_) <- UsedVariable c -> CompilerState a m (VariableValue c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable ([c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n)
      String
scoped <- SymbolScope -> CompilerState a m String
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
      [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
scoped String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> ExprValue -> String
writeStoredVariable ValueType
t ExprValue
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"]
    assignSingle (a, ValueType, Assignable c)
_ ExprValue
_ = () -> CompilerState a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    assignMulti :: (a, ValueType, Assignable c) -> CompilerState a m ()
assignMulti (a
i,ValueType
t,CreateVariable [c]
_ ValueType
_ VariableName
n) =
      [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [VariableName -> String
variableName VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               ValueType -> ExprValue -> String
writeStoredVariable ValueType
t (String -> ExprValue
UnwrappedSingle (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"r.At(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") String -> String -> 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
_) <- UsedVariable c -> CompilerState a m (VariableValue c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable ([c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n)
      String
scoped <- SymbolScope -> CompilerState a m String
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
      [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
scoped String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               ValueType -> ExprValue -> String
writeStoredVariable ValueType
t (String -> ExprValue
UnwrappedSingle (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"r.At(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"]
    assignMulti (a, ValueType, Assignable c)
_ = () -> CompilerState a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileStatement (NoValueExpression [c]
_ VoidExpression c
v) = VoidExpression c -> CompilerState a m ()
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) = (VariableName -> CompilerState a m ())
-> [VariableName] -> CompilerState a m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\VariableName
v -> UsedVariable c -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csSetReadOnly ([c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
v)) [VariableName]
vs
compileStatement (MarkHidden   [c]
c [VariableName]
vs) = (VariableName -> CompilerState a m ())
-> [VariableName] -> CompilerState a m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\VariableName
v -> UsedVariable c -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csSetHidden   ([c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
v)) [VariableName]
vs
compileStatement (RawCodeLine String
s) = [String] -> CompilerState a m ()
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 :: DefinedMember c -> CompilerState a m ()
compileRegularInit (DefinedMember [c]
_ SymbolScope
_ ValueType
_ VariableName
_ Maybe (Expression c)
Nothing) = () -> CompilerState a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileRegularInit (DefinedMember [c]
c2 SymbolScope
s ValueType
t VariableName
n2 (Just Expression c
e)) = CompilerState a m () -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> m a
resetBackgroundM (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ do
  UsedVariable c -> VariableValue c -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> VariableValue c -> CompilerState a m ()
csAddVariable ([c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c2 VariableName
n2) ([c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c2 SymbolScope
s ValueType
t VariableRule c
forall c. VariableRule c
VariableDefault)
  let assign :: Statement c
assign = [c] -> Positional (Assignable c) -> Expression c -> Statement c
forall c.
[c] -> Positional (Assignable c) -> Expression c -> Statement c
Assignment [c]
c2 ([Assignable c] -> Positional (Assignable c)
forall a. [a] -> Positional a
Positional [InputValue c -> Assignable c
forall c. InputValue c -> Assignable c
ExistingVariable ([c] -> VariableName -> InputValue c
forall c. [c] -> VariableName -> InputValue c
InputValue [c]
c2 VariableName
n2)]) Expression c
e
  Statement c -> CompilerState a m ()
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 :: [c] -> VariableName -> CompilerState a m (VariableValue c)
getWritableVariable [c]
c VariableName
n = do
  v :: VariableValue c
v@(VariableValue [c]
_ SymbolScope
_ ValueType
_ VariableRule c
ro) <- UsedVariable c -> CompilerState a m (VariableValue c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable ([c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n)
  case VariableRule c
ro of
       VariableReadOnly [] -> String -> CompilerState a m (VariableValue c)
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m (VariableValue c))
-> String -> CompilerState a m (VariableValue c)
forall a b. (a -> b) -> a -> b
$ String
"Variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
forall a. Show a => a -> String
show VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                              [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is read-only"
       VariableReadOnly [c]
c2 -> String -> CompilerState a m (VariableValue c)
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m (VariableValue c))
-> String -> CompilerState a m (VariableValue c)
forall a b. (a -> b) -> a -> b
$ String
"Variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
forall a. Show a => a -> String
show VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                              [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is marked read-only at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c2
       VariableRule c
_ -> VariableValue c -> CompilerState a m (VariableValue 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 :: DefinedMember c -> CompilerState a m ()
compileLazyInit (DefinedMember [c]
_ SymbolScope
_ ValueType
_ VariableName
_ Maybe (Expression c)
Nothing) = () -> CompilerState a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileLazyInit (DefinedMember [c]
c SymbolScope
_ ValueType
t1 VariableName
n (Just Expression c
e)) = CompilerState a m () -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> m a
resetBackgroundM (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ do
  (ExpressionType
ts,ExprValue
e') <- Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ValueType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ExpressionType -> [ValueType]
forall a. Positional a -> [a]
pValues ExpressionType
ts) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected single return in initializer" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace (Expression c -> [c]
forall c. Expression c -> [c]
getExpressionContext Expression c
e)
  AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- CompilerState a m ParamFilters
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  let Positional [ValueType
t2] = ExpressionType
ts
  m () -> CompilerState a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CompilerState a m ()) -> m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (AnyTypeResolver -> ParamFilters -> ValueType -> ValueType -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t2 ValueType
t1) m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In initialization of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
forall a. Show a => a -> String
show VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [VariableName -> String
variableName VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"([this]() { return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> ExprValue -> String
writeStoredVariable ValueType
t1 ExprValue
e' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; })"]

compileVoidExpression :: (Ord c, Show c, CollectErrorsM m,
                         CompilerContext c m [String] a) =>
  VoidExpression c -> CompilerState a m ()
compileVoidExpression :: VoidExpression c -> CompilerState a m ()
compileVoidExpression (Conditional IfElifElse c
ie) = IfElifElse c -> CompilerState a m ()
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 WhileLoop c
l) = WhileLoop c -> CompilerState a m ()
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
WhileLoop c -> CompilerState a m ()
compileWhileLoop WhileLoop c
l
compileVoidExpression (WithScope ScopedBlock c
s) = ScopedBlock c -> CompilerState a m ()
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) = [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite ([String] -> CompilerState a m ())
-> [String] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"// " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s
compileVoidExpression (Unconditional Procedure c
p) = do
  a
ctx0 <- CompilerState a m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
  a
ctx <- a -> Procedure c -> CompilerState a m a
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
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"{"]
  a -> CompilerState a m ()
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m ()
autoInlineOutput a
ctx
  [String] -> CompilerState a m ()
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 :: IfElifElse c -> CompilerState a m ()
compileIfElifElse (IfStatement [c]
c Expression c
e Procedure c
p IfElifElse c
es) = do
  a
ctx0 <- CompilerState a m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
  [a]
cs <- a
-> String
-> [c]
-> Expression c
-> Procedure c
-> IfElifElse c
-> StateT a m [a]
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
  [a] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[a] -> CompilerState a m ()
csInheritReturns [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 <- a -> Procedure c -> CompilerState a m a
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
      a -> CompilerState a m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx
      [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"else {"]
      a -> CompilerState a m [String]
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx CompilerState a m [String]
-> ([String] -> CompilerState a m ()) -> CompilerState a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite
      [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]
      [a] -> StateT a m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a
ctx]
    unwind a
ctx0 IfElifElse c
TerminateConditional = [a] -> StateT a m [a]
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) <- a -> [c] -> Expression c -> CompilerState a m (String, a)
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 <- a -> Procedure c -> CompilerState a m a
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
      a -> CompilerState a m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx
      [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e2' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") {"]
      a -> CompilerState a m [String]
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx CompilerState a m [String]
-> ([String] -> CompilerState a m ()) -> CompilerState a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite
      [String] -> CompilerState a m ()
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
      [a] -> StateT a m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> StateT a m [a]) -> [a] -> StateT a m [a]
forall a b. (a -> b) -> a -> b
$ a
ctxa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
cs
compileIfElifElse IfElifElse c
_ = CompilerState a m ()
forall a. HasCallStack => a
undefined

compileWhileLoop :: (Ord c, Show c, CollectErrorsM m,
                     CompilerContext c m [String] a) =>
  WhileLoop c -> CompilerState a m ()
compileWhileLoop :: WhileLoop c -> CompilerState a m ()
compileWhileLoop (WhileLoop [c]
c Expression c
e Procedure c
p Maybe (Procedure c)
u) = do
  a
ctx0 <- CompilerState a m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
  (String
e',a
ctx1) <- a -> [c] -> Expression c -> CompilerState a m (String, a)
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
  [a] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[a] -> CompilerState a m ()
csInheritReturns [a
ctx1]
  a
ctx0' <- case Maybe (Procedure c)
u of
                Just Procedure c
p2 -> do
                  a
ctx2 <- m a -> CompilerState a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CompilerState a m a) -> m a -> CompilerState a m a
forall a b. (a -> b) -> a -> b
$ a -> LoopSetup [String] -> m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> LoopSetup s -> m a
ccStartLoop a
ctx1 ([String] -> LoopSetup [String]
forall s. s -> LoopSetup s
LoopSetup [])
                  a
ctx3 <- a -> Procedure c -> CompilerState a m a
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
                  a -> CompilerState a m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx3
                  [String]
p2' <- a -> CompilerState a m [String]
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx3
                  m a -> CompilerState a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CompilerState a m a) -> m a -> CompilerState a m a
forall a b. (a -> b) -> a -> b
$ a -> LoopSetup [String] -> m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> LoopSetup s -> m a
ccStartLoop a
ctx1 ([String] -> LoopSetup [String]
forall s. s -> LoopSetup s
LoopSetup [String]
p2')
                Maybe (Procedure c)
_ -> m a -> CompilerState a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CompilerState a m a) -> m a -> CompilerState a m a
forall a b. (a -> b) -> a -> b
$ a -> LoopSetup [String] -> m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> LoopSetup s -> m a
ccStartLoop a
ctx1 ([String] -> LoopSetup [String]
forall s. s -> LoopSetup s
LoopSetup [])
  (LoopSetup [String]
u') <- m (LoopSetup [String]) -> StateT a m (LoopSetup [String])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (LoopSetup [String]) -> StateT a m (LoopSetup [String]))
-> m (LoopSetup [String]) -> StateT a m (LoopSetup [String])
forall a b. (a -> b) -> a -> b
$ a -> m (LoopSetup [String])
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m (LoopSetup s)
ccGetLoop a
ctx0'
  a
ctx <- a -> Procedure c -> CompilerState a m a
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
  a -> CompilerState a m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"while (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") {"]
  a -> CompilerState a m [String]
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
a -> CompilerState a m [String]
getAndIndentOutput a
ctx CompilerState a m [String]
-> ([String] -> CompilerState a m ()) -> CompilerState a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite ([String] -> CompilerState a m ())
-> [String] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [String
"{"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
u' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"}"]
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]

compileScopedBlock :: (Ord c, Show c, CollectErrorsM m,
                       CompilerContext c m [String] a) =>
  ScopedBlock c -> CompilerState a m ()
compileScopedBlock :: 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) = ScopedBlock c
-> ([([c], ValueType, VariableName)], Procedure c,
    Maybe (Procedure c), Statement c)
forall c.
ScopedBlock c
-> ([([c], ValueType, VariableName)], Procedure c,
    Maybe (Procedure c), Statement c)
rewriteScoped ScopedBlock c
s
  GeneralInstance
self <- CompilerState a m GeneralInstance
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  [([c], ValueType, VariableName)]
vs' <- m [([c], ValueType, VariableName)]
-> StateT a m [([c], ValueType, VariableName)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [([c], ValueType, VariableName)]
 -> StateT a m [([c], ValueType, VariableName)])
-> m [([c], ValueType, VariableName)]
-> StateT a m [([c], ValueType, VariableName)]
forall a b. (a -> b) -> a -> b
$ (([c], ValueType, VariableName)
 -> m ([c], ValueType, VariableName))
-> [([c], ValueType, VariableName)]
-> m [([c], ValueType, VariableName)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (GeneralInstance
-> ([c], ValueType, VariableName)
-> m ([c], ValueType, VariableName)
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 <- CompilerState a m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
  AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- CompilerState a m ParamFilters
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  [CompilerState a m ()] -> CompilerState a m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([CompilerState a m ()] -> CompilerState a m ())
-> [CompilerState a m ()] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (([c], ValueType, VariableName) -> CompilerState a m ())
-> [([c], ValueType, VariableName)] -> [CompilerState a m ()]
forall a b. (a -> b) -> [a] -> [b]
map (AnyTypeResolver
-> ParamFilters
-> ([c], ValueType, VariableName)
-> CompilerState a m ()
forall (m :: * -> *) r a c a.
(CollectErrorsM m, TypeResolver r, Show a,
 CompilerContext c m [String] a) =>
r
-> ParamFilters -> ([a], ValueType, VariableName) -> StateT a m ()
createVariable AnyTypeResolver
r ParamFilters
fa) [([c], ValueType, VariableName)]
vs'
  a
ctxP0 <- a -> Procedure c -> CompilerState a m a
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 <- m a -> CompilerState a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CompilerState a m a) -> m a -> CompilerState a m a
forall a b. (a -> b) -> a -> b
$ StateT a m [()] -> a -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ([CompilerState a m ()] -> StateT a m [()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([CompilerState a m ()] -> StateT a m [()])
-> [CompilerState a m ()] -> StateT a m [()]
forall a b. (a -> b) -> a -> b
$ (([c], ValueType, VariableName) -> CompilerState a m ())
-> [([c], ValueType, VariableName)] -> [CompilerState a m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([c], ValueType, VariableName) -> CompilerState a m ()
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 <- m a -> CompilerState a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CompilerState a m a) -> m a -> CompilerState a m a
forall a b. (a -> b) -> a -> b
$ a -> m a
forall c (m :: * -> *) s a. CompilerContext c m s a => a -> m a
ccClearOutput a
ctxP m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> [c] -> m a) -> [c] -> a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> [c] -> m a
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 <- CompilerState a m Bool
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 [String -> Statement c
forall c. String -> Statement c
RawCodeLine String
startCleanupTracing]
           let p2' :: Procedure c
p2' = [c] -> [Statement c] -> Procedure c
forall c. [c] -> [Statement c] -> Procedure c
Procedure [c]
c ([Statement c] -> Procedure c) -> [Statement c] -> Procedure c
forall a b. (a -> b) -> a -> b
$ [String -> Statement c
forall c. String -> Statement c
RawCodeLine String
"{"] [Statement c] -> [Statement c] -> [Statement c]
forall a. [a] -> [a] -> [a]
++ [Statement c]
forall c. [Statement c]
trace [Statement c] -> [Statement c] -> [Statement c]
forall a. [a] -> [a] -> [a]
++ [Statement c]
ss [Statement c] -> [Statement c] -> [Statement c]
forall a. [a] -> [a] -> [a]
++ [String -> Statement c
forall c. String -> Statement c
RawCodeLine String
"}"]
           a
ctxCl <- a -> Procedure c -> CompilerState a m a
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' CompilerState a m a -> String -> CompilerState a m a
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In cleanup starting at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
           a
ctxP' <- m a -> CompilerState a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CompilerState a m a) -> m a -> CompilerState a m a
forall a b. (a -> b) -> a -> b
$ a -> a -> m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> a -> m a
ccPushCleanup a
ctxP a
ctxCl
           a -> CompilerState a m a
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 -> m a -> CompilerState a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CompilerState a m a) -> m a -> CompilerState a m a
forall a b. (a -> b) -> a -> b
$ a -> a -> m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> a -> m a
ccPushCleanup a
ctxP a
ctxCl0
  a
ctxS <- a -> Procedure c -> CompilerState a m a
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' ([c] -> [Statement c] -> Procedure c
forall c. [c] -> [Statement c] -> Procedure c
Procedure [] [Statement c
st])
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"{"]
  a -> CompilerState a m ()
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 <- CompilerState a m Bool
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsUnreachable
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
unreachable) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [c] -> JumpType -> a -> CompilerState a m ()
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'
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"}"]
  [CompilerState a m ()] -> CompilerState a m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([CompilerState a m ()] -> CompilerState a m ())
-> [CompilerState a m ()] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (([c], ValueType, VariableName) -> CompilerState a m ())
-> [([c], ValueType, VariableName)] -> [CompilerState a m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([c], ValueType, VariableName) -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
([c], ValueType, VariableName) -> CompilerState a m ()
showVariable [([c], ValueType, VariableName)]
vs'
  where
    replaceSelfVariable :: GeneralInstance -> (a, ValueType, c) -> m (a, ValueType, c)
replaceSelfVariable GeneralInstance
self (a
c,ValueType
t,c
n) = do
      ValueType
t' <- GeneralInstance -> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> ValueType -> m ValueType
replaceSelfValueType GeneralInstance
self ValueType
t
      (a, ValueType, c) -> m (a, ValueType, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
c,ValueType
t',c
n)
    createVariable :: r
-> ParamFilters -> ([a], ValueType, VariableName) -> StateT a m ()
createVariable r
r ParamFilters
fa ([a]
c,ValueType
t,VariableName
n) = do
      m () -> StateT a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT a m ()) -> m () -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ r -> ParamFilters -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> m ()
validateGeneralInstance r
r ParamFilters
fa (ValueType -> GeneralInstance
vtType ValueType
t) m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In creation of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
forall a. Show a => a -> String
show VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContext [a]
c
      [String] -> StateT a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [ValueType -> String
variableStoredType ValueType
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n String -> String -> String
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.)
      UsedVariable c -> VariableValue c -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> VariableValue c -> CompilerState a m ()
csAddVariable ([c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n) ([c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
forall c.
[c]
-> SymbolScope -> ValueType -> VariableRule c -> VariableValue c
VariableValue [c]
c SymbolScope
LocalScope ValueType
t VariableRule c
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 (ScopedBlock c
 -> ([([c], ValueType, VariableName)], Procedure c,
     Maybe (Procedure c), Statement c))
-> ScopedBlock c
-> ([([c], ValueType, VariableName)], Procedure c,
    Maybe (Procedure c), Statement c)
forall a b. (a -> b) -> a -> b
$ [c]
-> Procedure c
-> Maybe (Procedure c)
-> [c]
-> Statement c
-> ScopedBlock c
forall c.
[c]
-> Procedure c
-> Maybe (Procedure c)
-> [c]
-> Statement c
-> ScopedBlock c
ScopedBlock [c]
c ([c] -> [Statement c] -> Procedure c
forall c. [c] -> [Statement c] -> Procedure c
Procedure [c]
c3 ([Statement c] -> Procedure c) -> [Statement c] -> Procedure c
forall a b. (a -> b) -> a -> b
$ [Statement c]
ss1 [Statement c] -> [Statement c] -> [Statement c]
forall a. [a] -> [a] -> [a]
++ [Statement c]
ss2) (Maybe (Procedure c)
cl1 Maybe (Procedure c) -> Maybe (Procedure c) -> Maybe (Procedure c)
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,[c] -> Positional (Assignable c) -> Expression c -> Statement c
forall c.
[c] -> Positional (Assignable c) -> Expression c -> Statement c
Assignment [c]
c3 ([Assignable c] -> Positional (Assignable c)
forall a. [a] -> Positional a
Positional [Assignable c]
existing) Expression c
e) where
        ([([c], ValueType, VariableName)]
created,[Assignable c]
existing) = (Assignable c
 -> ([([c], ValueType, VariableName)], [Assignable c])
 -> ([([c], ValueType, VariableName)], [Assignable c]))
-> ([([c], ValueType, VariableName)], [Assignable c])
-> [Assignable c]
-> ([([c], ValueType, VariableName)], [Assignable c])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Assignable c
-> ([([c], ValueType, VariableName)], [Assignable c])
-> ([([c], ValueType, VariableName)], [Assignable c])
forall c.
Assignable c
-> ([([c], ValueType, VariableName)], [Assignable c])
-> ([([c], ValueType, VariableName)], [Assignable c])
update ([],[]) (Positional (Assignable c) -> [Assignable c]
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)([c], ValueType, VariableName)
-> [([c], ValueType, VariableName)]
-> [([c], ValueType, VariableName)]
forall a. a -> [a] -> [a]
:[([c], ValueType, VariableName)]
cs,(InputValue c -> Assignable c
forall c. InputValue c -> Assignable c
ExistingVariable (InputValue c -> Assignable c) -> InputValue c -> Assignable c
forall a b. (a -> b) -> a -> b
$ [c] -> VariableName -> InputValue c
forall c. [c] -> VariableName -> InputValue c
InputValue [c]
c VariableName
n)Assignable c -> [Assignable c] -> [Assignable c]
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
e2Assignable c -> [Assignable c] -> [Assignable c]
forall 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,ExprValue)
compileExpression :: Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression = Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a, Ord c,
 Show c) =>
Expression c -> StateT a m (ExpressionType, ExprValue)
compile where
  compile :: Expression c -> StateT a m (ExpressionType, ExprValue)
compile (Literal (StringLiteral [c]
_ String
l)) = do
    Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinString])
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
stringRequiredValue],PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimString (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"PrimString_FromLiteral(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escapeChars String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
  compile (Literal (CharLiteral [c]
_ Char
l)) = do
    Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinChar])
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
charRequiredValue],PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimChar (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"PrimChar('" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
escapeChar Char
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"')")
  compile (Literal (IntegerLiteral [c]
c Bool
True Integer
l)) = do
    Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinInt])
    Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
64 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
      String
"Literal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is greater than the max value for 64-bit unsigned"
    let l' :: Integer
l' = if Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
63 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 then Integer
l Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
64 :: Integer) else Integer
l
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimInt (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"PrimInt(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
l' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
  compile (Literal (IntegerLiteral [c]
c Bool
False Integer
l)) = do
    Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinInt])
    Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
63 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
      String
"Literal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is greater than the max value for 64-bit signed"
    Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((-Integer
l) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> (Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
63 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
2)) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
      String
"Literal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is less than the min value for 64-bit signed"
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimInt (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"PrimInt(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
  compile (Literal (DecimalLiteral [c]
_ Integer
l Integer
e)) = do
    Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinFloat])
    -- TODO: Check bounds.
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
floatRequiredValue],PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimFloat (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"PrimFloat(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"E" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
  compile (Literal (BoolLiteral [c]
_ Bool
True)) = do
    Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinBool])
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimBool String
"true")
  compile (Literal (BoolLiteral [c]
_ Bool
False)) = do
    Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinBool])
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimBool String
"false")
  compile (Literal (EmptyLiteral [c]
_)) = do
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
emptyValue],String -> ExprValue
UnwrappedSingle String
"Var_empty")
  compile (Expression [c]
_ ExpressionStart c
s [ValueOperation c]
os) = do
    (StateT a m (ExpressionType, ExprValue)
 -> ValueOperation c -> StateT a m (ExpressionType, ExprValue))
-> StateT a m (ExpressionType, ExprValue)
-> [ValueOperation c]
-> StateT a m (ExpressionType, ExprValue)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl StateT a m (ExpressionType, ExprValue)
-> ValueOperation c -> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) c a.
(Show c, CollectErrorsM m, Ord c,
 CompilerContext c m [String] a) =>
StateT a m (ExpressionType, ExprValue)
-> ValueOperation c -> StateT a m (ExpressionType, ExprValue)
transform (ExpressionStart c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ExpressionStart c -> CompilerState a m (ExpressionType, ExprValue)
compileExpressionStart ExpressionStart c
s) [ValueOperation c]
os
  compile (UnaryExpression [c]
c (FunctionOperator [c]
_ (FunctionSpec [c]
_ (CategoryFunction [c]
c2 CategoryName
cn) FunctionName
fn Positional (InstanceOrInferred c)
ps)) Expression c
e) =
    Expression c -> StateT a m (ExpressionType, ExprValue)
compile ([c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c ([c] -> CategoryName -> FunctionCall c -> ExpressionStart c
forall c.
[c] -> CategoryName -> FunctionCall c -> ExpressionStart c
CategoryCall [c]
c2 CategoryName
cn ([c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps ([Expression c] -> Positional (Expression c)
forall a. [a] -> Positional a
Positional [Expression c
e]))) [])
  compile (UnaryExpression [c]
c (FunctionOperator [c]
_ (FunctionSpec [c]
_ (TypeFunction [c]
c2 TypeInstanceOrParam
tn) FunctionName
fn Positional (InstanceOrInferred c)
ps)) Expression c
e) =
    Expression c -> StateT a m (ExpressionType, ExprValue)
compile ([c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c ([c] -> TypeInstanceOrParam -> FunctionCall c -> ExpressionStart c
forall c.
[c] -> TypeInstanceOrParam -> FunctionCall c -> ExpressionStart c
TypeCall [c]
c2 TypeInstanceOrParam
tn ([c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps ([Expression c] -> Positional (Expression c)
forall a. [a] -> Positional a
Positional [Expression c
e]))) [])
  compile (UnaryExpression [c]
c (FunctionOperator [c]
_ (FunctionSpec [c]
_ (ValueFunction [c]
c2 Expression c
e0) FunctionName
fn Positional (InstanceOrInferred c)
ps)) Expression c
e) =
    Expression c -> StateT a m (ExpressionType, ExprValue)
compile ([c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c ([c] -> Expression c -> ExpressionStart c
forall c. [c] -> Expression c -> ExpressionStart c
ParensExpression [c]
c2 Expression c
e0) [[c] -> FunctionCall c -> ValueOperation c
forall c. [c] -> FunctionCall c -> ValueOperation c
ValueCall [c]
c ([c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps ([Expression c] -> Positional (Expression c)
forall a. [a] -> Positional a
Positional [Expression c
e]))])
  compile (UnaryExpression [c]
c (FunctionOperator [c]
_ (FunctionSpec [c]
c2 FunctionQualifier c
UnqualifiedFunction FunctionName
fn Positional (InstanceOrInferred c)
ps)) Expression c
e) =
    Expression c -> StateT a m (ExpressionType, ExprValue)
compile ([c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c ([c] -> FunctionCall c -> ExpressionStart c
forall c. [c] -> FunctionCall c -> ExpressionStart c
UnqualifiedCall [c]
c2 ([c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps ([Expression c] -> Positional (Expression c)
forall a. [a] -> Positional a
Positional [Expression c
e]))) [])
  compile (UnaryExpression [c]
_ (NamedOperator [c]
c String
"-") (Literal (IntegerLiteral [c]
_ Bool
_ Integer
l))) =
    Expression c -> StateT a m (ExpressionType, ExprValue)
compile (ValueLiteral c -> Expression c
forall c. ValueLiteral c -> Expression c
Literal ([c] -> Bool -> Integer -> ValueLiteral c
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))) =
    Expression c -> StateT a m (ExpressionType, ExprValue)
compile (ValueLiteral c -> Expression c
forall c. ValueLiteral c -> Expression c
Literal ([c] -> Integer -> Integer -> ValueLiteral c
forall c. [c] -> Integer -> Integer -> ValueLiteral c
DecimalLiteral [c]
c (-Integer
l) Integer
e))
  compile (UnaryExpression [c]
_ (NamedOperator [c]
c String
o) Expression c
e) = do
    (Positional [ValueType]
ts,ExprValue
e') <- Expression c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e
    ValueType
t' <- [c] -> [ValueType] -> StateT a m ValueType
forall (m :: * -> *) a a.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [c]
c [ValueType]
ts
    ValueType -> ExprValue -> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *).
ErrorContextM m =>
ValueType -> ExprValue -> m (ExpressionType, ExprValue)
doUnary ValueType
t' ExprValue
e'
    where
      doUnary :: ValueType -> ExprValue -> m (ExpressionType, ExprValue)
doUnary ValueType
t ExprValue
e2
        | String
o String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"!" = ValueType -> ExprValue -> m (ExpressionType, ExprValue)
forall (m :: * -> *).
ErrorContextM m =>
ValueType -> ExprValue -> m (ExpressionType, ExprValue)
doNot ValueType
t ExprValue
e2
        | String
o String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-" = ValueType -> ExprValue -> m (ExpressionType, ExprValue)
forall (m :: * -> *).
ErrorContextM m =>
ValueType -> ExprValue -> m (ExpressionType, ExprValue)
doNeg ValueType
t ExprValue
e2
        | String
o String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"~" = ValueType -> ExprValue -> m (ExpressionType, ExprValue)
forall (m :: * -> *).
ErrorContextM m =>
ValueType -> ExprValue -> m (ExpressionType, ExprValue)
doComp ValueType
t ExprValue
e2
        | Bool
otherwise = String -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m (ExpressionType, ExprValue))
-> String -> m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ String
"Unknown unary operator \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                             [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
      doNot :: ValueType -> ExprValue -> m (ExpressionType, ExprValue)
doNot ValueType
t ExprValue
e2 = do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValueType
t ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
/= ValueType
boolRequiredValue) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot use " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> String
forall a. Show a => a -> String
show ValueType
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with unary ! operator" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                 [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
        (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExpressionType, ExprValue) -> m (ExpressionType, ExprValue))
-> (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimBool (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExprValue -> String
useAsUnboxed PrimitiveType
PrimBool ExprValue
e2)
      doNeg :: ValueType -> ExprValue -> m (ExpressionType, ExprValue)
doNeg ValueType
t ExprValue
e2
        | ValueType
t ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExpressionType, ExprValue) -> m (ExpressionType, ExprValue))
-> (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],
                                            PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimInt (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExprValue -> String
useAsUnboxed PrimitiveType
PrimInt ExprValue
e2)
        | ValueType
t ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
floatRequiredValue = (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExpressionType, ExprValue) -> m (ExpressionType, ExprValue))
-> (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
floatRequiredValue],
                                             PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimFloat (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExprValue -> String
useAsUnboxed PrimitiveType
PrimFloat ExprValue
e2)
        | Bool
otherwise = String -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m (ExpressionType, ExprValue))
-> String -> m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ String
"Cannot use " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> String
forall a. Show a => a -> String
show ValueType
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with unary - operator" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                             [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
      doComp :: ValueType -> ExprValue -> m (ExpressionType, ExprValue)
doComp ValueType
t ExprValue
e2
        | ValueType
t ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExpressionType, ExprValue) -> m (ExpressionType, ExprValue))
-> (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],
                                            PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimInt (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"~" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExprValue -> String
useAsUnboxed PrimitiveType
PrimInt ExprValue
e2)
        | Bool
otherwise = String -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m (ExpressionType, ExprValue))
-> String -> m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ String
"Cannot use " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> String
forall a. Show a => a -> String
show ValueType
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with unary ~ operator" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                             [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  compile (InitializeValue [c]
c Maybe TypeInstance
t Positional GeneralInstance
ps Positional (Expression c)
es) = do
    SymbolScope
scope <- CompilerState a m SymbolScope
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 -> String -> StateT a m TypeInstance
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> StateT a m TypeInstance)
-> String -> StateT a m TypeInstance
forall a b. (a -> b) -> a -> b
$ String
"Param " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
ParamSelf String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found"
                                     Just TypeInstance
t0 -> TypeInstance -> StateT a m TypeInstance
forall (m :: * -> *) a. Monad m => a -> m a
return TypeInstance
t0
               SymbolScope
_ -> do
                 TypeInstance
self <- StateT a m TypeInstance
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m TypeInstance
csSelfType
                 case Maybe TypeInstance
t of
                      Just TypeInstance
t0 -> m TypeInstance -> StateT a m TypeInstance
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m TypeInstance -> StateT a m TypeInstance)
-> m TypeInstance -> StateT a m TypeInstance
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> TypeInstance -> m TypeInstance
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> TypeInstance -> m TypeInstance
replaceSelfSingle (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
self) TypeInstance
t0
                      Maybe TypeInstance
Nothing -> TypeInstance -> StateT a m TypeInstance
forall (m :: * -> *) a. Monad m => a -> m a
return TypeInstance
self
    [(ExpressionType, ExprValue)]
es' <- [StateT a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([StateT a m (ExpressionType, ExprValue)]
 -> StateT a m [(ExpressionType, ExprValue)])
-> [StateT a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ (Expression c -> StateT a m (ExpressionType, ExprValue))
-> [Expression c] -> [StateT a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> [a] -> [b]
map Expression c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression ([Expression c] -> [StateT a m (ExpressionType, ExprValue)])
-> [Expression c] -> [StateT a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es
    ([ValueType]
ts,String
es'') <- m ([ValueType], String) -> StateT a m ([ValueType], String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ([ValueType], String) -> StateT a m ([ValueType], String))
-> m ([ValueType], String) -> StateT a m ([ValueType], String)
forall a b. (a -> b) -> a -> b
$ [(ExpressionType, ExprValue)] -> m ([ValueType], String)
forall (m :: * -> *) b.
CollectErrorsM m =>
[(Positional b, ExprValue)] -> m ([b], String)
getValues [(ExpressionType, ExprValue)]
es'
    [c]
-> TypeInstance
-> ExpressionType
-> Positional GeneralInstance
-> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> TypeInstance
-> ExpressionType
-> Positional GeneralInstance
-> CompilerState a m ()
csCheckValueInit [c]
c TypeInstance
t' ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType]
ts) Positional GeneralInstance
ps
    String
params <- Positional GeneralInstance -> CompilerState a m String
forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
Positional GeneralInstance -> CompilerState a m String
expandParams (Positional GeneralInstance -> CompilerState a m String)
-> Positional GeneralInstance -> CompilerState a m String
forall a b. (a -> b) -> a -> b
$ TypeInstance -> Positional GeneralInstance
tiParams TypeInstance
t'
    String
params2 <- Positional GeneralInstance -> CompilerState a m String
forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
Positional GeneralInstance -> CompilerState a m String
expandParams2 (Positional GeneralInstance -> CompilerState a m String)
-> Positional GeneralInstance -> CompilerState a m String
forall a b. (a -> b) -> a -> b
$ Positional GeneralInstance
ps
    Bool
sameType <- TypeInstance -> CompilerState a m Bool
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
TypeInstance -> CompilerState a m Bool
csSameType TypeInstance
t'
    SymbolScope
s <- CompilerState a m SymbolScope
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m SymbolScope
csCurrentScope
    let typeInstance :: String
typeInstance = TypeInstance -> Bool -> SymbolScope -> String -> String
getType TypeInstance
t' Bool
sameType SymbolScope
s String
params
    -- TODO: This is unsafe if used in a type or category constructor.
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [StorageType -> GeneralInstance -> ValueType
ValueType StorageType
RequiredValue (GeneralInstance -> ValueType) -> GeneralInstance -> ValueType
forall a b. (a -> b) -> a -> b
$ TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t'],
            String -> ExprValue
UnwrappedSingle (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ CategoryName -> String
valueCreator (TypeInstance -> CategoryName
tiName TypeInstance
t') String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeInstance String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
params2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es'' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
    where
      getType :: TypeInstance -> Bool -> SymbolScope -> String -> String
getType TypeInstance
_  Bool
True SymbolScope
ValueScope String
_      = String
"parent"
      getType TypeInstance
t2 Bool
_    SymbolScope
_          String
params = CategoryName -> String
typeCreator (TypeInstance -> CategoryName
tiName TypeInstance
t2) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
params String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      -- Single expression, but possibly multi-return.
      getValues :: [(Positional b, ExprValue)] -> m ([b], String)
getValues [(Positional [b]
ts,ExprValue
e)] = ([b], String) -> m ([b], String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
ts,ExprValue -> String
useAsArgs ExprValue
e)
      -- Multi-expression => must all be singles.
      getValues [(Positional b, ExprValue)]
rs = do
        (((Int, Positional b) -> m ()) -> [(Int, Positional b)] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (Int, Positional b) -> m ()
forall (m :: * -> *) a a.
(ErrorContextM m, Show a) =>
(a, Positional a) -> m ()
checkArity ([(Int, Positional b)] -> m ()) -> [(Int, Positional b)] -> m ()
forall a b. (a -> b) -> a -> b
$ [Int] -> [Positional b] -> [(Int, Positional b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) ([Positional b] -> [(Int, Positional b)])
-> [Positional b] -> [(Int, Positional b)]
forall a b. (a -> b) -> a -> b
$ ((Positional b, ExprValue) -> Positional b)
-> [(Positional b, ExprValue)] -> [Positional b]
forall a b. (a -> b) -> [a] -> [b]
map (Positional b, ExprValue) -> Positional b
forall a b. (a, b) -> a
fst [(Positional b, ExprValue)]
rs) m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
          String
"In return at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
        ([b], String) -> m ([b], String)
forall (m :: * -> *) a. Monad m => a -> m a
return (((Positional b, ExprValue) -> b)
-> [(Positional b, ExprValue)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map ([b] -> b
forall a. [a] -> a
head ([b] -> b)
-> ((Positional b, ExprValue) -> [b])
-> (Positional b, ExprValue)
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positional b -> [b]
forall a. Positional a -> [a]
pValues (Positional b -> [b])
-> ((Positional b, ExprValue) -> Positional b)
-> (Positional b, ExprValue)
-> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Positional b, ExprValue) -> Positional b
forall a b. (a, b) -> a
fst) [(Positional b, ExprValue)]
rs,
                String
"ArgTuple(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((Positional b, ExprValue) -> String)
-> [(Positional b, ExprValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ExprValue -> String
useAsUnwrapped (ExprValue -> String)
-> ((Positional b, ExprValue) -> ExprValue)
-> (Positional b, ExprValue)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Positional b, ExprValue) -> ExprValue
forall a b. (a, b) -> b
snd) [(Positional b, ExprValue)]
rs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
      checkArity :: (a, Positional a) -> m ()
checkArity (a
_,Positional [a
_]) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      checkArity (a
i,Positional [a]
ts)  =
        String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Initializer position " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" values but should have 1"
  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 -> StateT a m (ExpressionType, ExprValue)
compile ([c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c ([c] -> CategoryName -> FunctionCall c -> ExpressionStart c
forall c.
[c] -> CategoryName -> FunctionCall c -> ExpressionStart c
CategoryCall [c]
c2 CategoryName
cn ([c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps ([Expression c] -> Positional (Expression c)
forall a. [a] -> Positional a
Positional [Expression c
e1,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 -> StateT a m (ExpressionType, ExprValue)
compile ([c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c ([c] -> TypeInstanceOrParam -> FunctionCall c -> ExpressionStart c
forall c.
[c] -> TypeInstanceOrParam -> FunctionCall c -> ExpressionStart c
TypeCall [c]
c2 TypeInstanceOrParam
tn ([c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps ([Expression c] -> Positional (Expression c)
forall a. [a] -> Positional a
Positional [Expression c
e1,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 -> StateT a m (ExpressionType, ExprValue)
compile ([c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c ([c] -> Expression c -> ExpressionStart c
forall c. [c] -> Expression c -> ExpressionStart c
ParensExpression [c]
c2 Expression c
e0) [[c] -> FunctionCall c -> ValueOperation c
forall c. [c] -> FunctionCall c -> ValueOperation c
ValueCall [c]
c ([c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps ([Expression c] -> Positional (Expression c)
forall a. [a] -> Positional a
Positional [Expression c
e1,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 -> StateT a m (ExpressionType, ExprValue)
compile ([c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
forall c.
[c] -> ExpressionStart c -> [ValueOperation c] -> Expression c
Expression [c]
c ([c] -> FunctionCall c -> ExpressionStart c
forall c. [c] -> FunctionCall c -> ExpressionStart c
UnqualifiedCall [c]
c2 ([c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
forall c.
[c]
-> FunctionName
-> Positional (InstanceOrInferred c)
-> Positional (Expression c)
-> FunctionCall c
FunctionCall [c]
c FunctionName
fn Positional (InstanceOrInferred c)
ps ([Expression c] -> Positional (Expression c)
forall a. [a] -> Positional a
Positional [Expression c
e1,Expression c
e2]))) [])
  compile (InfixExpression [c]
_ Expression c
e1 (NamedOperator [c]
c String
o) Expression c
e2) = do
    (ExpressionType, ExprValue)
e1' <- Expression c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e1
    (ExpressionType, ExprValue)
e2' <- if String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
logical
              then Expression c -> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a, Show c,
 Ord c) =>
Expression c -> StateT a m (ExpressionType, ExprValue)
isolateExpression Expression c
e2 -- Ignore named-return assignments.
              else Expression c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e2
    [c]
-> (ExpressionType, ExprValue)
-> String
-> (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a.
(ErrorContextM m, Show a) =>
[a]
-> (ExpressionType, ExprValue)
-> String
-> (ExpressionType, ExprValue)
-> m (ExpressionType, ExprValue)
bindInfix [c]
c (ExpressionType, ExprValue)
e1' String
o (ExpressionType, ExprValue)
e2'
  isolateExpression :: Expression c -> StateT a m (ExpressionType, ExprValue)
isolateExpression Expression c
e = do
    a
ctx <- CompilerState a m a
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
    ((ExpressionType, ExprValue)
e',a
ctx') <- m ((ExpressionType, ExprValue), a)
-> StateT a m ((ExpressionType, ExprValue), a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ((ExpressionType, ExprValue), a)
 -> StateT a m ((ExpressionType, ExprValue), a))
-> m ((ExpressionType, ExprValue), a)
-> StateT a m ((ExpressionType, ExprValue), a)
forall a b. (a -> b) -> a -> b
$ StateT a m (ExpressionType, ExprValue)
-> a -> m ((ExpressionType, ExprValue), a)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Expression c -> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e) a
ctx
    a -> CompilerState a m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
a -> CompilerState a m ()
inheritRequired a
ctx'
    a -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> CompilerState a m ()
csInheritUsed a
ctx'
    (ExpressionType, ExprValue)
-> StateT a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpressionType, ExprValue)
e'
  arithmetic1 :: Set String
arithmetic1 = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"*",String
"/"]
  arithmetic2 :: Set String
arithmetic2 = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"%"]
  arithmetic3 :: Set String
arithmetic3 = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"+",String
"-"]
  equals :: Set String
equals = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"==",String
"!="]
  comparison :: Set String
comparison = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"==",String
"!=",String
"<",String
"<=",String
">",String
">="]
  logical :: Set String
logical = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"&&",String
"||"]
  bitwise :: Set String
bitwise = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"&",String
"|",String
"^",String
">>",String
"<<"]
  bindInfix :: [a]
-> (ExpressionType, ExprValue)
-> String
-> (ExpressionType, ExprValue)
-> m (ExpressionType, ExprValue)
bindInfix [a]
c (Positional [ValueType]
ts1,ExprValue
e1) String
o (Positional [ValueType]
ts2,ExprValue
e2) = do
    -- TODO: Needs better error messages.
    ValueType
t1' <- [a] -> [ValueType] -> m ValueType
forall (m :: * -> *) a a.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [a]
c [ValueType]
ts1
    ValueType
t2' <- [a] -> [ValueType] -> m ValueType
forall (m :: * -> *) a a.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [a]
c [ValueType]
ts2
    ValueType -> ValueType -> m (ExpressionType, ExprValue)
forall (m :: * -> *).
ErrorContextM m =>
ValueType -> ValueType -> m (ExpressionType, ExprValue)
bind ValueType
t1' ValueType
t2'
    where
      bind :: ValueType -> ValueType -> m (ExpressionType, ExprValue)
bind ValueType
t1 ValueType
t2
        | ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
/= ValueType
t2 =
          String -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m (ExpressionType, ExprValue))
-> String -> m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ String
"Cannot " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> String
forall a. Show a => a -> String
show ValueType
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           ValueType -> String
forall a. Show a => a -> String
show ValueType
t2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
comparison Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimBool ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
comparison Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
floatRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimFloat PrimitiveType
PrimBool ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
comparison Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
stringRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimString PrimitiveType
PrimBool ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
comparison Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
charRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimChar PrimitiveType
PrimBool ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic1 Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimInt ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
bitwise Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimInt ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic2 Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimInt ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic3 Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
intRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimInt PrimitiveType
PrimInt ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic1 Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
floatRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
floatRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimFloat PrimitiveType
PrimFloat ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
arithmetic3 Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
floatRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
floatRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimFloat PrimitiveType
PrimFloat ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"+" Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
stringRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
stringRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimString PrimitiveType
PrimString ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
logical Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
boolRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimBool PrimitiveType
PrimBool ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"^" Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
boolRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimBool PrimitiveType
PrimBool ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-" Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
charRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
intRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimChar PrimitiveType
PrimInt ExprValue
e1 String
o ExprValue
e2)
        | String
o String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
equals Bool -> Bool -> Bool
&& ValueType
t1 ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ValueType
boolRequiredValue = do
          (ExpressionType, ExprValue) -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
PrimBool PrimitiveType
PrimBool ExprValue
e1 String
o ExprValue
e2)
        | Bool
otherwise =
          String -> m (ExpressionType, ExprValue)
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m (ExpressionType, ExprValue))
-> String -> m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ String
"Cannot " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> String
forall a. Show a => a -> String
show ValueType
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                 ValueType -> String
forall a. Show a => a -> String
show ValueType
t2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
      glueInfix :: PrimitiveType
-> PrimitiveType -> ExprValue -> String -> ExprValue -> ExprValue
glueInfix PrimitiveType
t1 PrimitiveType
t2 ExprValue
e3 String
o2 ExprValue
e4 =
        PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
t2 (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ PrimitiveType -> ExprValue -> String
useAsUnboxed PrimitiveType
t1 ExprValue
e3 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrimitiveType -> ExprValue -> String
useAsUnboxed PrimitiveType
t1 ExprValue
e4
  transform :: StateT a m (ExpressionType, ExprValue)
-> ValueOperation c -> StateT a m (ExpressionType, ExprValue)
transform StateT a m (ExpressionType, ExprValue)
e (ConvertedCall [c]
c TypeInstance
t FunctionCall c
f) = do
    (Positional [ValueType]
ts,ExprValue
e') <- StateT a m (ExpressionType, ExprValue)
e
    ValueType
t' <- [c] -> [ValueType] -> StateT a m ValueType
forall (m :: * -> *) a a.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [c]
c [ValueType]
ts
    AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
    ParamFilters
fa <- CompilerState a m ParamFilters
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
    let vt :: ValueType
vt = StorageType -> GeneralInstance -> ValueType
ValueType StorageType
RequiredValue (GeneralInstance -> ValueType) -> GeneralInstance -> ValueType
forall a b. (a -> b) -> a -> b
$ TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t
    (m () -> StateT a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT a m ()) -> m () -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ AnyTypeResolver -> ParamFilters -> ValueType -> ValueType -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t' ValueType
vt) StateT a m () -> String -> StateT a m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
      String
"In converted call at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
    ScopedFunction c
f' <- ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c)
lookupValueFunction ValueType
vt FunctionCall c
f
    Maybe String
-> ScopedFunction c
-> FunctionCall c
-> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExprValue)
compileFunctionCall (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ExprValue -> String
useAsUnwrapped ExprValue
e') ScopedFunction c
f' FunctionCall c
f
  transform StateT a m (ExpressionType, ExprValue)
e (ValueCall [c]
c FunctionCall c
f) = do
    (Positional [ValueType]
ts,ExprValue
e') <- StateT a m (ExpressionType, ExprValue)
e
    ValueType
t' <- [c] -> [ValueType] -> StateT a m ValueType
forall (m :: * -> *) a a.
(ErrorContextM m, Show a, Show a) =>
[a] -> [a] -> m a
requireSingle [c]
c [ValueType]
ts
    ScopedFunction c
f' <- ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c)
lookupValueFunction ValueType
t' FunctionCall c
f
    Maybe String
-> ScopedFunction c
-> FunctionCall c
-> StateT a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExprValue)
compileFunctionCall (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ExprValue -> String
useAsUnwrapped ExprValue
e') ScopedFunction c
f' FunctionCall c
f
  requireSingle :: [a] -> [a] -> m a
requireSingle [a]
_ [a
t] = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t
  requireSingle [a]
c2 [a]
ts =
    String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Function call requires 1 return but found but found {" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
ts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2

lookupValueFunction :: (Ord c, Show c, CollectErrorsM m,
                        CompilerContext c m [String] a) =>
  ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c)
lookupValueFunction :: ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c)
lookupValueFunction (ValueType StorageType
WeakValue GeneralInstance
t) (FunctionCall [c]
c FunctionName
_ Positional (InstanceOrInferred c)
_ Positional (Expression c)
_) =
  String -> CompilerState a m (ScopedFunction c)
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m (ScopedFunction c))
-> String -> CompilerState a m (ScopedFunction c)
forall a b. (a -> b) -> a -> b
$ String
"Use strong to convert " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
t String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
" to optional first" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
lookupValueFunction (ValueType StorageType
OptionalValue GeneralInstance
t) (FunctionCall [c]
c FunctionName
_ Positional (InstanceOrInferred c)
_ Positional (Expression c)
_) =
  String -> CompilerState a m (ScopedFunction c)
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m (ScopedFunction c))
-> String -> CompilerState a m (ScopedFunction c)
forall a b. (a -> b) -> a -> b
$ String
"Use require to convert " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
t String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
" to required first" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
lookupValueFunction (ValueType StorageType
RequiredValue GeneralInstance
t) (FunctionCall [c]
c FunctionName
n Positional (InstanceOrInferred c)
_ Positional (Expression c)
_) =
  [c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetTypeFunction [c]
c (GeneralInstance -> Maybe GeneralInstance
forall a. a -> Maybe a
Just GeneralInstance
t) FunctionName
n

compileExpressionStart :: (Ord c, Show c, CollectErrorsM m,
                           CompilerContext c m [String] a) =>
  ExpressionStart c -> CompilerState a m (ExpressionType,ExprValue)
compileExpressionStart :: ExpressionStart c -> CompilerState a m (ExpressionType, ExprValue)
compileExpressionStart (NamedVariable (OutputValue [c]
c VariableName
n)) = do
  let var :: UsedVariable c
var = [c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable [c]
c VariableName
n
  (VariableValue [c]
_ SymbolScope
s ValueType
t VariableRule c
_) <- UsedVariable c -> CompilerState a m (VariableValue c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m (VariableValue c)
csGetVariable UsedVariable c
var
  [UsedVariable c] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[UsedVariable c] -> CompilerState a m ()
csCheckVariableInit [UsedVariable c
var]
  UsedVariable c -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csAddUsed UsedVariable c
var
  String
scoped <- SymbolScope -> CompilerState a m String
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
  let lazy :: Bool
lazy = SymbolScope
s SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope
  (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
t],Bool -> ValueType -> String -> ExprValue
readStoredVariable Bool
lazy ValueType
t (String
scoped String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n))
compileExpressionStart (NamedMacro [c]
c MacroName
n) = do
  Expression c
e <- [c] -> MacroName -> CompilerState a m (Expression c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> MacroName -> CompilerState a m (Expression c)
csExprLookup [c]
c MacroName
n
  [c] -> MacroName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> MacroName -> CompilerState a m ()
csReserveExprMacro [c]
c MacroName
n
  (ExpressionType, ExprValue)
e' <- Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e CompilerState a m (ExpressionType, ExprValue)
-> String -> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In expansion of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MacroName -> String
forall a. Show a => a -> String
show MacroName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
  -- NOTE: This will be skipped if expression compilation fails.
  [c] -> MacroName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> MacroName -> CompilerState a m ()
csReleaseExprMacro [c]
c MacroName
n
  (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpressionType, ExprValue)
e'
compileExpressionStart (CategoryCall [c]
c CategoryName
t f :: FunctionCall c
f@(FunctionCall [c]
_ FunctionName
n Positional (InstanceOrInferred c)
_ Positional (Expression c)
_)) = do
  ScopedFunction c
f' <- [c]
-> Maybe CategoryName
-> FunctionName
-> CompilerState a m (ScopedFunction c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe CategoryName
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetCategoryFunction [c]
c (CategoryName -> Maybe CategoryName
forall a. a -> Maybe a
Just CategoryName
t) FunctionName
n
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (Set CategoryName -> CompilerState a m ())
-> Set CategoryName -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
t,ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f']
  String
t' <- CategoryName -> CompilerState a m String
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CategoryName -> CompilerState a m String
expandCategory CategoryName
t
  Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExprValue)
compileFunctionCall (String -> Maybe String
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 (Expression c)
_)) = do
  GeneralInstance
self <- CompilerState a m GeneralInstance
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  GeneralInstance
t' <- m GeneralInstance -> CompilerState a m GeneralInstance
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m GeneralInstance -> CompilerState a m GeneralInstance)
-> m GeneralInstance -> CompilerState a m GeneralInstance
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType TypeInstanceOrParam
t)
  AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- CompilerState a m ParamFilters
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  m () -> CompilerState a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CompilerState a m ()) -> m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ AnyTypeResolver -> ParamFilters -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> m ()
validateGeneralInstance AnyTypeResolver
r ParamFilters
fa GeneralInstance
t' m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In function call at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
  ScopedFunction c
f' <- [c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c]
-> Maybe GeneralInstance
-> FunctionName
-> CompilerState a m (ScopedFunction c)
csGetTypeFunction [c]
c (GeneralInstance -> Maybe GeneralInstance
forall a. a -> Maybe a
Just GeneralInstance
t') FunctionName
n
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f' SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
/= SymbolScope
TypeScope) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                    String
" cannot be used as a type function" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                    [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (Set CategoryName -> CompilerState a m ())
-> Set CategoryName -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [Set CategoryName] -> Set CategoryName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set CategoryName] -> Set CategoryName)
-> [Set CategoryName] -> Set CategoryName
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> Set CategoryName)
-> [GeneralInstance] -> [Set CategoryName]
forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> Set CategoryName
categoriesFromTypes [GeneralInstance
t']
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (Set CategoryName -> CompilerState a m ())
-> Set CategoryName -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f']
  String
t2 <- GeneralInstance -> CompilerState a m String
forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t'
  Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExprValue)
compileFunctionCall (String -> Maybe String
forall a. a -> Maybe a
Just String
t2) ScopedFunction c
f' FunctionCall c
f
compileExpressionStart (UnqualifiedCall [c]
c f :: FunctionCall c
f@(FunctionCall [c]
_ FunctionName
n Positional (InstanceOrInferred c)
_ Positional (Expression c)
_)) = do
  a
ctx <- StateT a m a
forall (m :: * -> *) s. Monad m => StateT s m s
get
  ScopedFunction c
f' <- m (ScopedFunction c) -> CompilerState a m (ScopedFunction c)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ScopedFunction c) -> CompilerState a m (ScopedFunction c))
-> m (ScopedFunction c) -> CompilerState a m (ScopedFunction c)
forall a b. (a -> b) -> a -> b
$ [m (ScopedFunction c)] -> m (ScopedFunction c)
forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM [a -> m (ScopedFunction c)
forall (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m (ScopedFunction c)
tryCategory a
ctx,a -> m (ScopedFunction c)
forall (m :: * -> *) s a.
(CompilerContext c m s a, ErrorContextM m) =>
a -> m (ScopedFunction c)
tryNonCategory a
ctx]
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (Set CategoryName -> CompilerState a m ())
-> Set CategoryName -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f']
  Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExprValue)
compileFunctionCall Maybe String
forall a. Maybe a
Nothing ScopedFunction c
f' FunctionCall c
f
  where
    tryCategory :: a -> m (ScopedFunction c)
tryCategory a
ctx = a
-> [c]
-> Maybe CategoryName
-> FunctionName
-> m (ScopedFunction c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a
-> [c]
-> Maybe CategoryName
-> FunctionName
-> m (ScopedFunction c)
ccGetCategoryFunction a
ctx [c]
c Maybe CategoryName
forall a. Maybe a
Nothing FunctionName
n
    tryNonCategory :: a -> m (ScopedFunction c)
tryNonCategory a
ctx = do
      ScopedFunction c
f' <- a
-> [c]
-> Maybe GeneralInstance
-> FunctionName
-> m (ScopedFunction c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a
-> [c]
-> Maybe GeneralInstance
-> FunctionName
-> m (ScopedFunction c)
ccGetTypeFunction a
ctx [c]
c Maybe GeneralInstance
forall a. Maybe a
Nothing FunctionName
n
      SymbolScope
s <- a -> m SymbolScope
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m SymbolScope
ccCurrentScope a
ctx
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f' SymbolScope -> SymbolScope -> Bool
forall a. Ord a => a -> a -> Bool
> SymbolScope
s) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
        String
"Function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not in scope here" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
      ScopedFunction c -> m (ScopedFunction 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 (Expression c)
es)) = do
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
BuiltinBool])
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([InstanceOrInferred c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (InstanceOrInferred c) -> [InstanceOrInferred c]
forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 0 type parameters" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Expression c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 1 argument" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  [(ExpressionType, ExprValue)]
es' <- [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([CompilerState a m (ExpressionType, ExprValue)]
 -> StateT a m [(ExpressionType, ExprValue)])
-> [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ (Expression c -> CompilerState a m (ExpressionType, ExprValue))
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> [a] -> [b]
map Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression ([Expression c] -> [CompilerState a m (ExpressionType, ExprValue)])
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ValueType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ExpressionType -> [ValueType]
forall a. Positional a -> [a]
pValues (ExpressionType -> [ValueType]) -> ExpressionType -> [ValueType]
forall a b. (a -> b) -> a -> b
$ (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a, b) -> a
fst ((ExpressionType, ExprValue) -> ExpressionType)
-> (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a -> b) -> a -> b
$ [(ExpressionType, ExprValue)] -> (ExpressionType, ExprValue)
forall a. [a] -> a
head [(ExpressionType, ExprValue)]
es') Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExprValue
e) = [(ExpressionType, ExprValue)] -> (ExpressionType, ExprValue)
forall a. [a] -> a
head [(ExpressionType, ExprValue)]
es'
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValueType -> Bool
isWeakValue ValueType
t0) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Weak values not allowed here" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExpressionType, ExprValue)
 -> CompilerState a m (ExpressionType, ExprValue))
-> (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
boolRequiredValue],
            PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimBool (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
valueBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::Present(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsUnwrapped ExprValue
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinReduce Positional (InstanceOrInferred c)
ps Positional (Expression c)
es)) = do
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([InstanceOrInferred c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (InstanceOrInferred c) -> [InstanceOrInferred c]
forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
2) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 2 type parameters" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Expression c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 1 argument" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  [(ExpressionType, ExprValue)]
es' <- [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([CompilerState a m (ExpressionType, ExprValue)]
 -> StateT a m [(ExpressionType, ExprValue)])
-> [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ (Expression c -> CompilerState a m (ExpressionType, ExprValue))
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> [a] -> [b]
map Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression ([Expression c] -> [CompilerState a m (ExpressionType, ExprValue)])
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ValueType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ExpressionType -> [ValueType]
forall a. Positional a -> [a]
pValues (ExpressionType -> [ValueType]) -> ExpressionType -> [ValueType]
forall a b. (a -> b) -> a -> b
$ (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a, b) -> a
fst ((ExpressionType, ExprValue) -> ExpressionType)
-> (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a -> b) -> a -> b
$ [(ExpressionType, ExprValue)] -> (ExpressionType, ExprValue)
forall a. [a] -> a
head [(ExpressionType, ExprValue)]
es') Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExprValue
e) = [(ExpressionType, ExprValue)] -> (ExpressionType, ExprValue)
forall a. [a] -> a
head [(ExpressionType, ExprValue)]
es'
  GeneralInstance
self <- CompilerState a m GeneralInstance
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  [GeneralInstance]
ps' <- m [GeneralInstance] -> StateT a m [GeneralInstance]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [GeneralInstance] -> StateT a m [GeneralInstance])
-> m [GeneralInstance] -> StateT a m [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ Positional (InstanceOrInferred c) -> m [GeneralInstance]
forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Positional (InstanceOrInferred c) -> m [GeneralInstance]
disallowInferred Positional (InstanceOrInferred c)
ps
  [GeneralInstance
t1,GeneralInstance
t2] <- m [GeneralInstance] -> StateT a m [GeneralInstance]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [GeneralInstance] -> StateT a m [GeneralInstance])
-> m [GeneralInstance] -> StateT a m [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> m GeneralInstance)
-> [GeneralInstance] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (GeneralInstance -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self) [GeneralInstance]
ps'
  AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- CompilerState a m ParamFilters
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  m () -> CompilerState a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CompilerState a m ()) -> m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ AnyTypeResolver -> ParamFilters -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> m ()
validateGeneralInstance AnyTypeResolver
r ParamFilters
fa GeneralInstance
t1
  m () -> CompilerState a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CompilerState a m ()) -> m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ AnyTypeResolver -> ParamFilters -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> m ()
validateGeneralInstance AnyTypeResolver
r ParamFilters
fa GeneralInstance
t2
  m () -> CompilerState a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CompilerState a m ()) -> m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (AnyTypeResolver -> ParamFilters -> ValueType -> ValueType -> m ()
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)) m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In argument to reduce call at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
  -- TODO: If t1 -> t2 then just return e without a Reduce call.
  String
t1' <- GeneralInstance -> CompilerState a m String
forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t1
  String
t2' <- GeneralInstance -> CompilerState a m String
forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t2
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (Set CategoryName -> CompilerState a m ())
-> Set CategoryName -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> Set CategoryName
categoriesFromTypes GeneralInstance
t1
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (Set CategoryName -> CompilerState a m ())
-> Set CategoryName -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> Set CategoryName
categoriesFromTypes GeneralInstance
t2
  (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExpressionType, ExprValue)
 -> CompilerState a m (ExpressionType, ExprValue))
-> (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [StorageType -> GeneralInstance -> ValueType
ValueType StorageType
OptionalValue GeneralInstance
t2],
            String -> ExprValue
UnwrappedSingle (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
typeBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::Reduce(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t1' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t2' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsUnwrapped ExprValue
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinRequire Positional (InstanceOrInferred c)
ps Positional (Expression c)
es)) = do
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([InstanceOrInferred c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (InstanceOrInferred c) -> [InstanceOrInferred c]
forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 0 type parameters" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Expression c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 1 argument" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  [(ExpressionType, ExprValue)]
es' <- [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([CompilerState a m (ExpressionType, ExprValue)]
 -> StateT a m [(ExpressionType, ExprValue)])
-> [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ (Expression c -> CompilerState a m (ExpressionType, ExprValue))
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> [a] -> [b]
map Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression ([Expression c] -> [CompilerState a m (ExpressionType, ExprValue)])
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ValueType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ExpressionType -> [ValueType]
forall a. Positional a -> [a]
pValues (ExpressionType -> [ValueType]) -> ExpressionType -> [ValueType]
forall a b. (a -> b) -> a -> b
$ (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a, b) -> a
fst ((ExpressionType, ExprValue) -> ExpressionType)
-> (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a -> b) -> a -> b
$ [(ExpressionType, ExprValue)] -> (ExpressionType, ExprValue)
forall a. [a] -> a
head [(ExpressionType, ExprValue)]
es') Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExprValue
e) = [(ExpressionType, ExprValue)] -> (ExpressionType, ExprValue)
forall a. [a] -> a
head [(ExpressionType, ExprValue)]
es'
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValueType -> Bool
isWeakValue ValueType
t0) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Weak values not allowed here" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExpressionType, ExprValue)
 -> CompilerState a m (ExpressionType, ExprValue))
-> (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [StorageType -> GeneralInstance -> ValueType
ValueType StorageType
RequiredValue (ValueType -> GeneralInstance
vtType ValueType
t0)],
            String -> ExprValue
UnwrappedSingle (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
valueBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::Require(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsUnwrapped ExprValue
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinStrong Positional (InstanceOrInferred c)
ps Positional (Expression c)
es)) = do
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([InstanceOrInferred c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (InstanceOrInferred c) -> [InstanceOrInferred c]
forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 0 type parameters" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Expression c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 1 argument" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  [(ExpressionType, ExprValue)]
es' <- [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([CompilerState a m (ExpressionType, ExprValue)]
 -> StateT a m [(ExpressionType, ExprValue)])
-> [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ (Expression c -> CompilerState a m (ExpressionType, ExprValue))
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> [a] -> [b]
map Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression ([Expression c] -> [CompilerState a m (ExpressionType, ExprValue)])
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ValueType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ExpressionType -> [ValueType]
forall a. Positional a -> [a]
pValues (ExpressionType -> [ValueType]) -> ExpressionType -> [ValueType]
forall a b. (a -> b) -> a -> b
$ (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a, b) -> a
fst ((ExpressionType, ExprValue) -> ExpressionType)
-> (ExpressionType, ExprValue) -> ExpressionType
forall a b. (a -> b) -> a -> b
$ [(ExpressionType, ExprValue)] -> (ExpressionType, ExprValue)
forall a. [a] -> a
head [(ExpressionType, ExprValue)]
es') Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected single return in argument" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  let (Positional [ValueType
t0],ExprValue
e) = [(ExpressionType, ExprValue)] -> (ExpressionType, ExprValue)
forall a. [a] -> a
head [(ExpressionType, ExprValue)]
es'
  let t1 :: ExpressionType
t1 = [ValueType] -> ExpressionType
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 (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpressionType
t1,String -> ExprValue
UnwrappedSingle (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
valueBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::Strong(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsUnwrapped ExprValue
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
     else (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpressionType
t1,ExprValue
e)
compileExpressionStart (BuiltinCall [c]
c (FunctionCall [c]
_ FunctionName
BuiltinTypename Positional (InstanceOrInferred c)
ps Positional (Expression c)
es)) = do
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([InstanceOrInferred c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (InstanceOrInferred c) -> [InstanceOrInferred c]
forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 1 type parameter" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  Bool -> CompilerState a m () -> CompilerState a m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Expression c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (CompilerState a m () -> CompilerState a m ())
-> CompilerState a m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$
    String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> CompilerState a m ()) -> String -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected 0 arguments" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  GeneralInstance
self <- CompilerState a m GeneralInstance
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  [GeneralInstance]
ps' <- m [GeneralInstance] -> StateT a m [GeneralInstance]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [GeneralInstance] -> StateT a m [GeneralInstance])
-> m [GeneralInstance] -> StateT a m [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ Positional (InstanceOrInferred c) -> m [GeneralInstance]
forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Positional (InstanceOrInferred c) -> m [GeneralInstance]
disallowInferred Positional (InstanceOrInferred c)
ps
  [GeneralInstance
t] <- m [GeneralInstance] -> StateT a m [GeneralInstance]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [GeneralInstance] -> StateT a m [GeneralInstance])
-> m [GeneralInstance] -> StateT a m [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> m GeneralInstance)
-> [GeneralInstance] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (GeneralInstance -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self) [GeneralInstance]
ps'
  AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- CompilerState a m ParamFilters
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  m () -> CompilerState a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CompilerState a m ()) -> m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ AnyTypeResolver -> ParamFilters -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> GeneralInstance -> m ()
validateGeneralInstance AnyTypeResolver
r ParamFilters
fa GeneralInstance
t
  String
t' <- GeneralInstance -> CompilerState a m String
forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (Set CategoryName -> CompilerState a m ())
-> Set CategoryName -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ [Set CategoryName] -> Set CategoryName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set CategoryName] -> Set CategoryName)
-> [Set CategoryName] -> Set CategoryName
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> Set CategoryName)
-> [GeneralInstance] -> [Set CategoryName]
forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> Set CategoryName
categoriesFromTypes [GeneralInstance
t]
  (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExpressionType, ExprValue)
 -> CompilerState a m (ExpressionType, ExprValue))
-> (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
formattedRequiredValue],
            ExprValue -> ExprValue
valueAsWrapped (ExprValue -> ExprValue) -> ExprValue -> ExprValue
forall a b. (a -> b) -> a -> b
$ PrimitiveType -> String -> ExprValue
UnboxedPrimitive PrimitiveType
PrimString (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
typeBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::TypeName(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
compileExpressionStart (BuiltinCall [c]
_ FunctionCall c
_) = CompilerState a m (ExpressionType, ExprValue)
forall a. HasCallStack => a
undefined
compileExpressionStart (ParensExpression [c]
_ Expression c
e) = Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e
compileExpressionStart (InlineAssignment [c]
c VariableName
n Expression c
e) = do
  (VariableValue [c]
_ SymbolScope
s ValueType
t0 VariableRule c
_) <- [c] -> VariableName -> CompilerState a m (VariableValue 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
  (Positional [ValueType
t],ExprValue
e') <- Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression Expression c
e -- TODO: Get rid of the Positional matching here.
  AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- CompilerState a m ParamFilters
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  m () -> CompilerState a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CompilerState a m ()) -> m () -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (AnyTypeResolver -> ParamFilters -> ValueType -> ValueType -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment AnyTypeResolver
r ParamFilters
fa ValueType
t ValueType
t0) m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In assignment at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
  VariableName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
VariableName -> CompilerState a m ()
csUpdateAssigned VariableName
n
  String
scoped <- SymbolScope -> CompilerState a m String
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
  let lazy :: Bool
lazy = SymbolScope
s SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope
  (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType
t0],Bool -> ValueType -> String -> ExprValue
readStoredVariable Bool
lazy ValueType
t0 (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
scoped String -> String -> String
forall a. [a] -> [a] -> [a]
++ VariableName -> String
variableName VariableName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                     String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> ExprValue -> String
writeStoredVariable ValueType
t0 ExprValue
e' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")

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

compileFunctionCall :: (Ord c, Show c, CollectErrorsM m,
                        CompilerContext c m [String] a) =>
  Maybe String -> ScopedFunction c -> FunctionCall c ->
  CompilerState a m (ExpressionType,ExprValue)
compileFunctionCall :: Maybe String
-> ScopedFunction c
-> FunctionCall c
-> CompilerState a m (ExpressionType, ExprValue)
compileFunctionCall Maybe String
e ScopedFunction c
f (FunctionCall [c]
c FunctionName
_ Positional (InstanceOrInferred c)
ps Positional (Expression c)
es) = String
message String
-> CompilerState a m (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
  AnyTypeResolver
r <- CompilerState a m AnyTypeResolver
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m AnyTypeResolver
csResolver
  ParamFilters
fa <- CompilerState a m ParamFilters
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m ParamFilters
csAllFilters
  [(ExpressionType, ExprValue)]
es' <- [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([CompilerState a m (ExpressionType, ExprValue)]
 -> StateT a m [(ExpressionType, ExprValue)])
-> [CompilerState a m (ExpressionType, ExprValue)]
-> StateT a m [(ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ (Expression c -> CompilerState a m (ExpressionType, ExprValue))
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> [a] -> [b]
map Expression c -> CompilerState a m (ExpressionType, ExprValue)
forall c (m :: * -> *) a.
(Ord c, Show c, CollectErrorsM m,
 CompilerContext c m [String] a) =>
Expression c -> CompilerState a m (ExpressionType, ExprValue)
compileExpression ([Expression c] -> [CompilerState a m (ExpressionType, ExprValue)])
-> [Expression c]
-> [CompilerState a m (ExpressionType, ExprValue)]
forall a b. (a -> b) -> a -> b
$ Positional (Expression c) -> [Expression c]
forall a. Positional a -> [a]
pValues Positional (Expression c)
es
  ([ValueType]
ts,String
es'') <- m ([ValueType], String) -> StateT a m ([ValueType], String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ([ValueType], String) -> StateT a m ([ValueType], String))
-> m ([ValueType], String) -> StateT a m ([ValueType], String)
forall a b. (a -> b) -> a -> b
$ [(ExpressionType, ExprValue)] -> m ([ValueType], String)
forall (m :: * -> *) b.
CollectErrorsM m =>
[(Positional b, ExprValue)] -> m ([b], String)
getValues [(ExpressionType, ExprValue)]
es'
  GeneralInstance
self <- CompilerState a m GeneralInstance
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m GeneralInstance
autoSelfType
  Positional (InstanceOrInferred c)
ps' <- m (Positional (InstanceOrInferred c))
-> StateT a m (Positional (InstanceOrInferred c))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Positional (InstanceOrInferred c))
 -> StateT a m (Positional (InstanceOrInferred c)))
-> m (Positional (InstanceOrInferred c))
-> StateT a m (Positional (InstanceOrInferred c))
forall a b. (a -> b) -> a -> b
$ ([InstanceOrInferred c] -> Positional (InstanceOrInferred c))
-> m [InstanceOrInferred c]
-> m (Positional (InstanceOrInferred c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [InstanceOrInferred c] -> Positional (InstanceOrInferred c)
forall a. [a] -> Positional a
Positional (m [InstanceOrInferred c] -> m (Positional (InstanceOrInferred c)))
-> m [InstanceOrInferred c]
-> m (Positional (InstanceOrInferred c))
forall a b. (a -> b) -> a -> b
$ (InstanceOrInferred c -> m (InstanceOrInferred c))
-> [InstanceOrInferred c] -> m [InstanceOrInferred c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (GeneralInstance -> InstanceOrInferred c -> m (InstanceOrInferred c)
forall (m :: * -> *) c.
CollectErrorsM m =>
GeneralInstance -> InstanceOrInferred c -> m (InstanceOrInferred c)
replaceSelfParam GeneralInstance
self) ([InstanceOrInferred c] -> m [InstanceOrInferred c])
-> [InstanceOrInferred c] -> m [InstanceOrInferred c]
forall a b. (a -> b) -> a -> b
$ Positional (InstanceOrInferred c) -> [InstanceOrInferred c]
forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps
  Positional GeneralInstance
ps2 <- m (Positional GeneralInstance)
-> StateT a m (Positional GeneralInstance)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Positional GeneralInstance)
 -> StateT a m (Positional GeneralInstance))
-> m (Positional GeneralInstance)
-> StateT a m (Positional GeneralInstance)
forall a b. (a -> b) -> a -> b
$ AnyTypeResolver
-> ParamFilters
-> ScopedFunction c
-> Positional (InstanceOrInferred c)
-> ExpressionType
-> m (Positional GeneralInstance)
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' ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType]
ts)
  m () -> StateT a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT a m ()) -> m () -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ ((ParamName, InstanceOrInferred c, GeneralInstance) -> m ())
-> [(ParamName, InstanceOrInferred c, GeneralInstance)] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (ParamName, InstanceOrInferred c, GeneralInstance) -> m ()
forall (m :: * -> *) a a a.
(ErrorContextM m, Show a, Show a, Show a) =>
(a, InstanceOrInferred a, a) -> m ()
backgroundMessage ([(ParamName, InstanceOrInferred c, GeneralInstance)] -> m ())
-> [(ParamName, InstanceOrInferred c, GeneralInstance)] -> m ()
forall a b. (a -> b) -> a -> b
$ [ParamName]
-> [InstanceOrInferred c]
-> [GeneralInstance]
-> [(ParamName, InstanceOrInferred c, GeneralInstance)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ((ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ Positional (ValueParam c) -> [ValueParam c]
forall a. Positional a -> [a]
pValues (Positional (ValueParam c) -> [ValueParam c])
-> Positional (ValueParam c) -> [ValueParam c]
forall a b. (a -> b) -> a -> b
$ ScopedFunction c -> Positional (ValueParam c)
forall c. ScopedFunction c -> Positional (ValueParam c)
sfParams ScopedFunction c
f) (Positional (InstanceOrInferred c) -> [InstanceOrInferred c]
forall a. Positional a -> [a]
pValues Positional (InstanceOrInferred c)
ps') (Positional GeneralInstance -> [GeneralInstance]
forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps2)
  FunctionType
f' <- m FunctionType -> StateT a m FunctionType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m FunctionType -> StateT a m FunctionType)
-> m FunctionType -> StateT a m FunctionType
forall a b. (a -> b) -> a -> b
$ ScopedFunction c -> m FunctionType
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f
  FunctionType
f'' <- m FunctionType -> StateT a m FunctionType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m FunctionType -> StateT a m FunctionType)
-> m FunctionType -> StateT a m FunctionType
forall a b. (a -> b) -> a -> b
$ AnyTypeResolver
-> ParamFilters
-> ParamValues
-> Positional GeneralInstance
-> FunctionType
-> m FunctionType
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ParamValues
-> Positional GeneralInstance
-> FunctionType
-> m FunctionType
assignFunctionParams AnyTypeResolver
r ParamFilters
fa ParamValues
forall k a. Map k a
Map.empty Positional GeneralInstance
ps2 FunctionType
f'
  -- Called an extra time so arg count mismatches have reasonable errors.
  m () -> StateT a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT a m ()) -> m () -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ (ValueType -> ValueType -> m ())
-> ExpressionType -> ExpressionType -> m ()
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ (\ValueType
_ ValueType
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (FunctionType -> ExpressionType
ftArgs FunctionType
f'') ([ValueType] -> ExpressionType
forall a. [a] -> Positional a
Positional [ValueType]
ts)
  m () -> StateT a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT a m ()) -> m () -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ (ValueType -> (Int, ValueType) -> m ())
-> ExpressionType -> Positional (Int, ValueType) -> m ()
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ (AnyTypeResolver
-> ParamFilters -> ValueType -> (Int, ValueType) -> m ()
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'') ([(Int, ValueType)] -> Positional (Int, ValueType)
forall a. [a] -> Positional a
Positional ([(Int, ValueType)] -> Positional (Int, ValueType))
-> [(Int, ValueType)] -> Positional (Int, ValueType)
forall a b. (a -> b) -> a -> b
$ [Int] -> [ValueType] -> [(Int, ValueType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) [ValueType]
ts)
  Set CategoryName -> StateT a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired (Set CategoryName -> StateT a m ())
-> Set CategoryName -> StateT a m ()
forall a b. (a -> b) -> a -> b
$ [Set CategoryName] -> Set CategoryName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set CategoryName] -> Set CategoryName)
-> [Set CategoryName] -> Set CategoryName
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> Set CategoryName)
-> [GeneralInstance] -> [Set CategoryName]
forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> Set CategoryName
categoriesFromTypes ([GeneralInstance] -> [Set CategoryName])
-> [GeneralInstance] -> [Set CategoryName]
forall a b. (a -> b) -> a -> b
$ Positional GeneralInstance -> [GeneralInstance]
forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps2
  Set CategoryName -> StateT a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList [ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f])
  String
params <- Positional GeneralInstance -> CompilerState a m String
forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
Positional GeneralInstance -> CompilerState a m String
expandParams2 Positional GeneralInstance
ps2
  SymbolScope
scope <- CompilerState a m SymbolScope
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m SymbolScope
csCurrentScope
  String
scoped <- SymbolScope -> CompilerState a m String
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope (ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f)
  String
call <- Maybe String
-> String
-> SymbolScope
-> SymbolScope
-> String
-> String
-> CompilerState a m String
forall (m :: * -> *).
Monad m =>
Maybe String
-> String
-> SymbolScope
-> SymbolScope
-> String
-> String
-> m String
assemble Maybe String
e String
scoped SymbolScope
scope (ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f) String
params String
es''
  (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExpressionType, ExprValue)
 -> CompilerState a m (ExpressionType, ExprValue))
-> (ExpressionType, ExprValue)
-> CompilerState a m (ExpressionType, ExprValue)
forall a b. (a -> b) -> a -> b
$ (FunctionType -> ExpressionType
ftReturns FunctionType
f'',String -> ExprValue
OpaqueMulti String
call)
  where
    replaceSelfParam :: GeneralInstance -> InstanceOrInferred c -> m (InstanceOrInferred c)
replaceSelfParam GeneralInstance
self (AssignedInstance [c]
c2 GeneralInstance
t) = do
      GeneralInstance
t' <- GeneralInstance -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self GeneralInstance
t
      InstanceOrInferred c -> m (InstanceOrInferred c)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstanceOrInferred c -> m (InstanceOrInferred c))
-> InstanceOrInferred c -> m (InstanceOrInferred c)
forall a b. (a -> b) -> a -> b
$ [c] -> GeneralInstance -> InstanceOrInferred c
forall c. [c] -> GeneralInstance -> InstanceOrInferred c
AssignedInstance [c]
c2 GeneralInstance
t'
    replaceSelfParam GeneralInstance
_ InstanceOrInferred c
t = InstanceOrInferred c -> m (InstanceOrInferred c)
forall (m :: * -> *) a. Monad m => a -> m a
return InstanceOrInferred c
t
    message :: String
message = String
"In call to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
    backgroundMessage :: (a, InstanceOrInferred a, a) -> m ()
backgroundMessage (a
n,(InferredInstance [a]
c2),a
t) =
      String -> m ()
forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerBackgroundM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Parameter " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show (ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++
        FunctionName -> String
forall a. Show a => a -> String
show (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") inferred as " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContext [a]
c2
    backgroundMessage (a, InstanceOrInferred a, a)
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    assemble :: Maybe String
-> String
-> SymbolScope
-> SymbolScope
-> String
-> String
-> m String
assemble Maybe String
Nothing String
_ SymbolScope
ValueScope SymbolScope
ValueScope String
ps2 String
es2 =
      String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ FunctionName -> String
callName (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(Var_self, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ps2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    assemble Maybe String
Nothing String
_ SymbolScope
TypeScope SymbolScope
TypeScope String
ps2 String
es2 =
      String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ FunctionName -> String
callName (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(Param_self, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ps2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    assemble Maybe String
Nothing String
_ SymbolScope
ValueScope SymbolScope
TypeScope String
ps2 String
es2 =
      String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
typeBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::Call(parent, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall c. ScopedFunction c -> String
functionName ScopedFunction c
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ps2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    assemble Maybe String
Nothing String
scoped SymbolScope
_ SymbolScope
_ String
ps2 String
es2 =
      String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
scoped String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
callName (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ps2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    assemble (Just String
e2) String
_ SymbolScope
_ SymbolScope
ValueScope String
ps2 String
es2 =
      String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
valueBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::Call(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall c. ScopedFunction c -> String
functionName ScopedFunction c
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ps2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    assemble (Just String
e2) String
_ SymbolScope
_ SymbolScope
TypeScope String
ps2 String
es2 =
      String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
typeBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::Call(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall c. ScopedFunction c -> String
functionName ScopedFunction c
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ps2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    assemble (Just String
e2) String
_ SymbolScope
_ SymbolScope
_ String
ps2 String
es2 =
      String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".Call(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall c. ScopedFunction c -> String
functionName ScopedFunction c
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ps2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    -- TODO: Lots of duplication with assignments and initialization.
    -- Single expression, but possibly multi-return.
    getValues :: [(Positional b, ExprValue)] -> m ([b], String)
getValues [(Positional [b]
ts,ExprValue
e2)] = ([b], String) -> m ([b], String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
ts,ExprValue -> String
useAsArgs ExprValue
e2)
    -- Multi-expression => must all be singles.
    getValues [(Positional b, ExprValue)]
rs = do
      (((Int, Positional b) -> m ()) -> [(Int, Positional b)] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (Int, Positional b) -> m ()
forall (m :: * -> *) a a.
(ErrorContextM m, Show a) =>
(a, Positional a) -> m ()
checkArity ([(Int, Positional b)] -> m ()) -> [(Int, Positional b)] -> m ()
forall a b. (a -> b) -> a -> b
$ [Int] -> [Positional b] -> [(Int, Positional b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) ([Positional b] -> [(Int, Positional b)])
-> [Positional b] -> [(Int, Positional b)]
forall a b. (a -> b) -> a -> b
$ ((Positional b, ExprValue) -> Positional b)
-> [(Positional b, ExprValue)] -> [Positional b]
forall a b. (a -> b) -> [a] -> [b]
map (Positional b, ExprValue) -> Positional b
forall a b. (a, b) -> a
fst [(Positional b, ExprValue)]
rs) m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In return at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
      ([b], String) -> m ([b], String)
forall (m :: * -> *) a. Monad m => a -> m a
return (((Positional b, ExprValue) -> b)
-> [(Positional b, ExprValue)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map ([b] -> b
forall a. [a] -> a
head ([b] -> b)
-> ((Positional b, ExprValue) -> [b])
-> (Positional b, ExprValue)
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positional b -> [b]
forall a. Positional a -> [a]
pValues (Positional b -> [b])
-> ((Positional b, ExprValue) -> Positional b)
-> (Positional b, ExprValue)
-> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Positional b, ExprValue) -> Positional b
forall a b. (a, b) -> a
fst) [(Positional b, ExprValue)]
rs, String
"ArgTuple(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((Positional b, ExprValue) -> String)
-> [(Positional b, ExprValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ExprValue -> String
useAsUnwrapped (ExprValue -> String)
-> ((Positional b, ExprValue) -> ExprValue)
-> (Positional b, ExprValue)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Positional b, ExprValue) -> ExprValue
forall a b. (a, b) -> b
snd) [(Positional b, ExprValue)]
rs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
    checkArity :: (a, Positional a) -> m ()
checkArity (a
_,Positional [a
_]) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkArity (a
i,Positional [a]
ts)  =
      String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Return position " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ts) String -> String -> String
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
      r -> ParamFilters -> ValueType -> ValueType -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> ParamFilters -> ValueType -> ValueType -> m ()
checkValueAssignment r
r ParamFilters
fa ValueType
t1 ValueType
t0 m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In argument " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f)

guessParamsFromArgs :: (Ord c, Show c, CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) ->
  Positional ValueType -> m (Positional GeneralInstance)
guessParamsFromArgs :: 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 <- ScopedFunction c -> m ParamFilters
forall (m :: * -> *) c.
CollectErrorsM m =>
ScopedFunction c -> m ParamFilters
getFunctionFilterMap ScopedFunction c
f
  [PatternMatch ValueType]
args <- (ValueType -> ValueType -> m (PatternMatch ValueType))
-> ExpressionType -> ExpressionType -> m [PatternMatch ValueType]
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 -> PatternMatch ValueType -> m (PatternMatch ValueType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PatternMatch ValueType -> m (PatternMatch ValueType))
-> PatternMatch ValueType -> m (PatternMatch ValueType)
forall a b. (a -> b) -> a -> b
$ Variance -> ValueType -> ValueType -> PatternMatch ValueType
forall a. Variance -> a -> a -> PatternMatch a
PatternMatch Variance
Covariant ValueType
t1 ValueType
t2) ExpressionType
ts ((PassedValue c -> ValueType)
-> Positional (PassedValue c) -> ExpressionType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType (Positional (PassedValue c) -> ExpressionType)
-> Positional (PassedValue c) -> ExpressionType
forall a b. (a -> b) -> a -> b
$ ScopedFunction c -> Positional (PassedValue c)
forall c. ScopedFunction c -> Positional (PassedValue c)
sfArgs ScopedFunction c
f)
  ParamValues
pa <- ([(ParamName, GeneralInstance)] -> ParamValues)
-> m [(ParamName, GeneralInstance)] -> m ParamValues
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ParamName, GeneralInstance)] -> ParamValues
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(ParamName, GeneralInstance)] -> m ParamValues)
-> m [(ParamName, GeneralInstance)] -> m ParamValues
forall a b. (a -> b) -> a -> b
$ (ParamName
 -> InstanceOrInferred c -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> Positional (InstanceOrInferred c)
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> InstanceOrInferred c -> m (ParamName, GeneralInstance)
forall (m :: * -> *) c.
Monad m =>
ParamName -> InstanceOrInferred c -> m (ParamName, GeneralInstance)
toInstance ((ValueParam c -> ParamName)
-> Positional (ValueParam c) -> Positional ParamName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam (Positional (ValueParam c) -> Positional ParamName)
-> Positional (ValueParam c) -> Positional ParamName
forall a b. (a -> b) -> a -> b
$ ScopedFunction c -> Positional (ValueParam c)
forall c. ScopedFunction c -> Positional (ValueParam c)
sfParams ScopedFunction c
f) Positional (InstanceOrInferred c)
ps
  MergeTree InferredTypeGuess
gs <- r
-> ParamFilters
-> ParamValues
-> [PatternMatch ValueType]
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ParamValues
-> [PatternMatch ValueType]
-> m (MergeTree InferredTypeGuess)
inferParamTypes r
r ParamFilters
fa ParamValues
pa [PatternMatch ValueType]
args
  [InferredTypeGuess]
gs' <- r
-> ParamFilters
-> ParamFilters
-> ParamValues
-> MergeTree InferredTypeGuess
-> m [InferredTypeGuess]
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> ParamFilters
-> ParamFilters
-> ParamValues
-> MergeTree InferredTypeGuess
-> m [InferredTypeGuess]
mergeInferredTypes r
r ParamFilters
fa ParamFilters
fm ParamValues
pa MergeTree InferredTypeGuess
gs
  let pa3 :: ParamValues
pa3 = [InferredTypeGuess] -> ParamValues
guessesAsParams [InferredTypeGuess]
gs' ParamValues -> ParamValues -> ParamValues
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` ParamValues
pa
  ([GeneralInstance] -> Positional GeneralInstance)
-> m [GeneralInstance] -> m (Positional GeneralInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GeneralInstance] -> Positional GeneralInstance
forall a. [a] -> Positional a
Positional (m [GeneralInstance] -> m (Positional GeneralInstance))
-> m [GeneralInstance] -> m (Positional GeneralInstance)
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> m GeneralInstance)
-> [ValueParam c] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (ParamValues -> ValueParam c -> m GeneralInstance
forall (m :: * -> *) a a.
(ErrorContextM m, Show a) =>
Map ParamName a -> ValueParam a -> m a
subPosition ParamValues
pa3) (Positional (ValueParam c) -> [ValueParam c]
forall a. Positional a -> [a]
pValues (Positional (ValueParam c) -> [ValueParam c])
-> Positional (ValueParam c) -> [ValueParam c]
forall a b. (a -> b) -> a -> b
$ ScopedFunction c -> Positional (ValueParam c)
forall c. ScopedFunction c -> Positional (ValueParam c)
sfParams ScopedFunction c
f) where
    subPosition :: Map ParamName a -> ValueParam a -> m a
subPosition Map ParamName a
pa2 ValueParam a
p =
      case (ValueParam a -> ParamName
forall c. ValueParam c -> ParamName
vpParam ValueParam a
p) ParamName -> Map ParamName a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map ParamName a
pa2 of
           Just a
t  -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t
           Maybe a
Nothing -> String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Something went wrong inferring " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      ParamName -> String
forall a. Show a => a -> String
show (ValueParam a -> ParamName
forall c. ValueParam c -> ParamName
vpParam ValueParam a
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace (ValueParam a -> [a]
forall c. ValueParam c -> [c]
vpContext ValueParam a
p)
    toInstance :: ParamName -> InstanceOrInferred c -> m (ParamName, GeneralInstance)
toInstance ParamName
p1 (AssignedInstance [c]
_ GeneralInstance
t) = (ParamName, GeneralInstance) -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
p1,GeneralInstance
t)
    toInstance ParamName
p1 (InferredInstance [c]
_)   = (ParamName, GeneralInstance) -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
p1,TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
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 :: CategoryMap c
-> ExprMap c -> Expression c -> m (CompiledData [String])
compileMainProcedure CategoryMap c
tm ExprMap c
em Expression c
e = do
  ProcedureContext c
ctx <- CategoryMap c -> ExprMap c -> m (ProcedureContext c)
forall (m :: * -> *) c.
CollectErrorsM m =>
CategoryMap c -> ExprMap c -> m (ProcedureContext c)
getMainContext CategoryMap c
tm ExprMap c
em
  CompilerState (ProcedureContext c) m ()
-> ProcedureContext c -> m (CompiledData [String])
forall c (m :: * -> *) s a b.
CompilerContext c m s a =>
CompilerState a m b -> a -> m (CompiledData s)
runDataCompiler CompilerState (ProcedureContext c) m ()
compiler ProcedureContext c
ctx where
    procedure :: Procedure c
procedure = [c] -> [Statement c] -> Procedure c
forall c. [c] -> [Statement c] -> Procedure c
Procedure [] [[c] -> Expression c -> Statement c
forall c. [c] -> Expression c -> Statement c
IgnoreValues [] Expression c
e]
    compiler :: CompilerState (ProcedureContext c) m ()
compiler = do
      ProcedureContext c
ctx0 <- CompilerState (ProcedureContext c) m (ProcedureContext c)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m a
getCleanContext
      ProcedureContext c
-> Procedure c
-> CompilerState (ProcedureContext c) m (ProcedureContext c)
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 CompilerState (ProcedureContext c) m (ProcedureContext c)
-> (ProcedureContext c -> CompilerState (ProcedureContext c) m ())
-> CompilerState (ProcedureContext c) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcedureContext c -> CompilerState (ProcedureContext c) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put

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

selectTestFromArgv1 :: CollectErrorsM m => [FunctionName] -> m ([String],CompiledData [String])
selectTestFromArgv1 :: [FunctionName] -> m ([String], CompiledData [String])
selectTestFromArgv1 [FunctionName]
fs = ([String], CompiledData [String])
-> m ([String], CompiledData [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
includes,CompiledData [String]
allCode) where
  allCode :: CompiledData [String]
allCode = [CompiledData [String]] -> CompiledData [String]
forall a. Monoid a => [a] -> a
mconcat [
      CompiledData [String]
initMap,
      CompiledData [String]
selectFromMap
    ]
  initMap :: CompiledData [String]
initMap = [String] -> CompiledData [String]
onlyCodes ([String] -> CompiledData [String])
-> [String] -> CompiledData [String]
forall a b. (a -> b) -> a -> b
$ [
      String
"const std::unordered_map<std::string, ReturnTuple(*)()> tests{"
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (FunctionName -> String) -> [FunctionName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (FunctionName -> String) -> FunctionName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctionName -> String
testEntry) [FunctionName]
fs [String] -> [String] -> [String]
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
"{ \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\", &" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
testFunctionName FunctionName
f String -> String -> String
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 :: SymbolScope -> CompilerState a m String
autoScope SymbolScope
s = do
  SymbolScope
s1 <- CompilerState a m SymbolScope
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m SymbolScope
csCurrentScope
  String -> CompilerState a m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> CompilerState a m String)
-> String -> CompilerState a m String
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 = ([Set CategoryName] -> Set CategoryName)
-> ([Set CategoryName] -> Set CategoryName)
-> (T GeneralInstance -> Set CategoryName)
-> GeneralInstance
-> Set CategoryName
forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree [Set CategoryName] -> Set CategoryName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set CategoryName] -> Set CategoryName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions T GeneralInstance -> Set CategoryName
TypeInstanceOrParam -> Set CategoryName
getAll where
  getAll :: TypeInstanceOrParam -> Set CategoryName
getAll (JustTypeInstance (TypeInstance CategoryName
t Positional GeneralInstance
ps)) =
    CategoryName
t CategoryName -> Set CategoryName -> Set CategoryName
forall a. Ord a => a -> Set a -> Set a
`Set.insert` ([Set CategoryName] -> Set CategoryName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set CategoryName] -> Set CategoryName)
-> [Set CategoryName] -> Set CategoryName
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> Set CategoryName)
-> [GeneralInstance] -> [Set CategoryName]
forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> Set CategoryName
categoriesFromTypes ([GeneralInstance] -> [Set CategoryName])
-> [GeneralInstance] -> [Set CategoryName]
forall a b. (a -> b) -> a -> b
$ Positional GeneralInstance -> [GeneralInstance]
forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps)
  getAll TypeInstanceOrParam
_ = Set CategoryName
forall a. Set a
Set.empty

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

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

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

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

expandGeneralInstance :: (CollectErrorsM m, CompilerContext c m s a) =>
  GeneralInstance -> CompilerState a m String
expandGeneralInstance :: GeneralInstance -> CompilerState a m String
expandGeneralInstance GeneralInstance
t
  | GeneralInstance
t GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
== GeneralInstance
forall a. Bounded a => a
minBound = String -> CompilerState a m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> CompilerState a m String)
-> String -> CompilerState a m String
forall a b. (a -> b) -> a -> b
$ String
allGetter String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"()"
  | GeneralInstance
t GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
== GeneralInstance
forall a. Bounded a => a
maxBound = String -> CompilerState a m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> CompilerState a m String)
-> String -> CompilerState a m String
forall a b. (a -> b) -> a -> b
$ String
anyGetter String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"()"
expandGeneralInstance GeneralInstance
t = ([CompilerState a m String] -> CompilerState a m String)
-> ([CompilerState a m String] -> CompilerState a m String)
-> (T GeneralInstance -> CompilerState a m String)
-> GeneralInstance
-> CompilerState a m String
forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree [CompilerState a m String] -> CompilerState a m String
forall (m :: * -> *). Monad m => [m String] -> m String
getAny [CompilerState a m String] -> CompilerState a m String
forall (m :: * -> *). Monad m => [m String] -> m String
getAll T GeneralInstance -> CompilerState a m String
forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
TypeInstanceOrParam -> StateT a m String
getSingle GeneralInstance
t where
  getAny :: [m String] -> m String
getAny [m String]
ts = [m String] -> m String
forall (m :: * -> *). Monad m => [m String] -> m String
combine [m String]
ts m String -> (String -> m String) -> m String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> (String -> String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
unionGetter String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  getAll :: [m String] -> m String
getAll [m String]
ts = [m String] -> m String
forall (m :: * -> *). Monad m => [m String] -> m String
combine [m String]
ts m String -> (String -> m String) -> m String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> (String -> String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
intersectGetter String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  getSingle :: TypeInstanceOrParam -> StateT a m String
getSingle (JustTypeInstance (TypeInstance CategoryName
t2 Positional GeneralInstance
ps)) = do
    [String]
ps' <- [StateT a m String] -> StateT a m [String]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([StateT a m String] -> StateT a m [String])
-> [StateT a m String] -> StateT a m [String]
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> StateT a m String)
-> [GeneralInstance] -> [StateT a m String]
forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> StateT a m String
forall (m :: * -> *) c s a.
(CollectErrorsM m, CompilerContext c m s a) =>
GeneralInstance -> CompilerState a m String
expandGeneralInstance ([GeneralInstance] -> [StateT a m String])
-> [GeneralInstance] -> [StateT a m String]
forall a b. (a -> b) -> a -> b
$ Positional GeneralInstance -> [GeneralInstance]
forall a. Positional a -> [a]
pValues Positional GeneralInstance
ps
    String -> StateT a m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> StateT a m String) -> String -> StateT a m String
forall a b. (a -> b) -> a -> b
$ CategoryName -> String
typeGetter CategoryName
t2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(T_get(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
ps' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))"
  getSingle (JustParamName Bool
_ ParamName
p)  = do
    SymbolScope
s <- ParamName -> CompilerState a m SymbolScope
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
ParamName -> CompilerState a m SymbolScope
csGetParamScope ParamName
p
    String
scoped <- SymbolScope -> StateT a m String
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
SymbolScope -> CompilerState a m String
autoScope SymbolScope
s
    String -> StateT a m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> StateT a m String) -> String -> StateT a m String
forall a b. (a -> b) -> a -> b
$ String
scoped String -> String -> String
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' <- [m String] -> m [String]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m String]
ps
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"(L_get<S<const " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">>(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
ps' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))"

doImplicitReturn :: (CollectErrorsM m, Ord c, Show c, CompilerContext c m [String] a) =>
  [c] -> CompilerState a m ()
doImplicitReturn :: [c] -> CompilerState a m ()
doImplicitReturn [c]
c = do
  Bool
named <- CompilerState a m Bool
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsNamedReturns
  [c] -> Maybe ExpressionType -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> Maybe ExpressionType -> CompilerState a m ()
csRegisterReturn [c]
c Maybe ExpressionType
forall a. Maybe a
Nothing
  (CleanupBlock [String]
ss [UsedVariable c]
_ JumpType
_ Set CategoryName
req) <- JumpType -> CompilerState a m (CleanupBlock c [String])
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
JumpType -> CompilerState a m (CleanupBlock c s)
csGetCleanup JumpType
JumpReturn
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired Set CategoryName
req
  [c] -> JumpType -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpReturn
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String]
ss
  if Bool -> Bool
not Bool
named
     then [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"return ReturnTuple(0);"]
     else do
       CompilerState a m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
CompilerState a m ()
getPrimNamedReturns
       [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"return returns;"]
  where

autoPositionalCleanup :: (CollectErrorsM m, CompilerContext c m [String] a) =>
  [c] -> ExprValue -> CompilerState a m ()
autoPositionalCleanup :: [c] -> ExprValue -> CompilerState a m ()
autoPositionalCleanup [c]
c ExprValue
e = do
  Bool
named <- CompilerState a m Bool
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m Bool
csIsNamedReturns
  (CleanupBlock [String]
ss [UsedVariable c]
_ JumpType
_ Set CategoryName
req) <- JumpType -> CompilerState a m (CleanupBlock c [String])
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
JumpType -> CompilerState a m (CleanupBlock c s)
csGetCleanup JumpType
JumpReturn
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired Set CategoryName
req
  [c] -> JumpType -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
[c] -> JumpType -> CompilerState a m ()
csSetJumpType [c]
c JumpType
JumpReturn
  if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ss
     then [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsReturns ExprValue
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"]
     else do
       if Bool
named
          then do
            [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"returns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsReturns ExprValue
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"]
            CompilerState a m ()
forall (m :: * -> *) c a.
(CollectErrorsM m, CompilerContext c m [String] a) =>
CompilerState a m ()
setPrimNamedReturns
            [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String]
ss
            [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"return returns;"]
          else do
            [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String
"{",String
"ReturnTuple returns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsReturns ExprValue
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"]
            [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String]
ss
            [String] -> CompilerState a m ()
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 :: CompilerState a m ()
setPrimNamedReturns = do
  [ReturnVariable]
vars <- CompilerState a m [ReturnVariable]
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m [ReturnVariable]
csPrimNamedReturns
  [CompilerState a m ()] -> CompilerState a m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([CompilerState a m ()] -> CompilerState a m ())
-> [CompilerState a m ()] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (ReturnVariable -> CompilerState a m ())
-> [ReturnVariable] -> [CompilerState a m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite ([String] -> CompilerState a m ())
-> (ReturnVariable -> [String])
-> ReturnVariable
-> CompilerState a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (String -> [String])
-> (ReturnVariable -> String) -> ReturnVariable -> [String]
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueType -> ExprValue -> String
writeStoredVariable ValueType
t (Int -> ExprValue
forall a. Show a => a -> ExprValue
position Int
i) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    position :: a -> ExprValue
position a
i = String -> ExprValue
WrappedSingle (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ String
"returns.At(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

getPrimNamedReturns ::  (CollectErrorsM m, CompilerContext c m [String] a) =>
  CompilerState a m ()
getPrimNamedReturns :: CompilerState a m ()
getPrimNamedReturns = do
  [ReturnVariable]
vars <- CompilerState a m [ReturnVariable]
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
CompilerState a m [ReturnVariable]
csPrimNamedReturns
  [CompilerState a m ()] -> CompilerState a m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([CompilerState a m ()] -> CompilerState a m ())
-> [CompilerState a m ()] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (ReturnVariable -> CompilerState a m ())
-> [ReturnVariable] -> [CompilerState a m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite ([String] -> CompilerState a m ())
-> (ReturnVariable -> [String])
-> ReturnVariable
-> CompilerState a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (String -> [String])
-> (ReturnVariable -> String) -> ReturnVariable -> [String]
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(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExprValue -> String
useAsUnwrapped (Bool -> ValueType -> String -> ExprValue
readStoredVariable Bool
False ValueType
t (String -> ExprValue) -> String -> ExprValue
forall a b. (a -> b) -> a -> b
$ VariableName -> String
variableName VariableName
n) String -> String -> String
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 :: [c] -> JumpType -> a -> CompilerState a m ()
autoInsertCleanup [c]
c JumpType
j a
ctx = do
  (CleanupBlock [String]
ss [UsedVariable c]
vs JumpType
jump Set CategoryName
req) <- m (CleanupBlock c [String]) -> StateT a m (CleanupBlock c [String])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (CleanupBlock c [String])
 -> StateT a m (CleanupBlock c [String]))
-> m (CleanupBlock c [String])
-> StateT a m (CleanupBlock c [String])
forall a b. (a -> b) -> a -> b
$ a -> JumpType -> m (CleanupBlock c [String])
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> JumpType -> m (CleanupBlock c s)
ccGetCleanup a
ctx JumpType
j
  m () -> CompilerState a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (a -> [UsedVariable c] -> m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> [UsedVariable c] -> m ()
ccCheckVariableInit a
ctx ([UsedVariable c] -> m ()) -> [UsedVariable c] -> m ()
forall a b. (a -> b) -> a -> b
$ [UsedVariable c] -> [UsedVariable c]
forall a. Eq a => [a] -> [a]
nub [UsedVariable c]
vs) CompilerState a m () -> String -> CompilerState a m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
    String
"In inlining of cleanup block after statement at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c
  let vs2 :: [UsedVariable c]
vs2 = (UsedVariable c -> UsedVariable c)
-> [UsedVariable c] -> [UsedVariable c]
forall a b. (a -> b) -> [a] -> [b]
map (\(UsedVariable [c]
c0 VariableName
v) -> [c] -> VariableName -> UsedVariable c
forall c. [c] -> VariableName -> UsedVariable c
UsedVariable ([c]
c [c] -> [c] -> [c]
forall a. [a] -> [a] -> [a]
++ [c]
c0) VariableName
v) [UsedVariable c]
vs
  -- This is needed in case a cleanup is inlined within another cleanup, e.g.,
  -- e.g., if the latter has a break statement.
  [CompilerState a m ()] -> CompilerState a m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([CompilerState a m ()] -> CompilerState a m ())
-> [CompilerState a m ()] -> CompilerState a m ()
forall a b. (a -> b) -> a -> b
$ (UsedVariable c -> CompilerState a m ())
-> [UsedVariable c] -> [CompilerState a m ()]
forall a b. (a -> b) -> [a] -> [b]
map UsedVariable c -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
UsedVariable c -> CompilerState a m ()
csAddUsed ([UsedVariable c] -> [CompilerState a m ()])
-> [UsedVariable c] -> [CompilerState a m ()]
forall a b. (a -> b) -> a -> b
$ [UsedVariable c]
vs2
  [String] -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
s -> CompilerState a m ()
csWrite [String]
ss
  Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired Set CategoryName
req
  [c] -> JumpType -> CompilerState a m ()
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 :: a -> CompilerState a m ()
inheritRequired a
ctx = m (Set CategoryName) -> StateT a m (Set CategoryName)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (a -> m (Set CategoryName)
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
a -> m (Set CategoryName)
ccGetRequired a
ctx) StateT a m (Set CategoryName)
-> (Set CategoryName -> CompilerState a m ())
-> CompilerState a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Set CategoryName -> CompilerState a m ()
forall c (m :: * -> *) s a.
CompilerContext c m s a =>
Set CategoryName -> CompilerState a m ()
csAddRequired

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

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

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