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

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

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

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

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

{-# LANGUAGE Safe #-}
{-# LANGUAGE TypeFamilies #-}

module Types.TypeCategory (
  AnyCategory(..),
  CallArgLabel(..),
  CategoryMap(..),
  CategoryResolver(..),
  FunctionName(..),
  FunctionVisibility(..),
  Namespace(..),
  ParamFilter(..),
  PassedValue(..),
  PatternMatch(..),
  PragmaCategory(..),
  ScopedFunction(..),
  SymbolScope(..),
  ValueDefine(..),
  ValueParam(..),
  ValueRefine(..),
  checkCategoryInstances,
  checkConnectedTypes,
  checkConnectionCycles,
  checkFunctionCallVisibility,
  checkParamVariances,
  declareAllTypes, -- TODO: Remove?
  emptyCategoryMap,
  flattenAllConnections,
  formatFullContext,
  formatFullContextBrace,
  getCategory,
  getCategoryContext,
  getCategoryDefines,
  getCategoryDeps,
  getCategoryFilterMap,
  getCategoryFilters,
  getCategoryFunctions,
  getCategoryName,
  getCategoryNamespace,
  getCategoryParamMap,
  getCategoryParamSet,
  getCategoryParams,
  getCategoryPragmas,
  getCategoryRefines,
  getConcreteCategory,
  getFilterMap,
  getFunctionFilterMap,
  getInstanceCategory,
  getValueCategory,
  guessesFromFilters,
  includeNewTypes,
  inferParamTypes,
  instanceFromCategory,
  isCategoryImmutable,
  isInstanceInterface,
  isNoNamespace,
  isPrivateNamespace,
  isPublicNamespace,
  isStaticNamespace,
  isValueConcrete,
  isValueInterface,
  matchesCallArgLabel,
  mergeDefines,
  mergeFunctions,
  mergeInferredTypes,
  mergeRefines,
  noDuplicateDefines,
  noDuplicateRefines,
  parsedToFunctionType,
  partitionByScope,
  prependCategoryPragmaContext,
  replaceSelfFunction,
  setCategoryNamespace,
  singleFromCategory,
  toCategoryMap,
  topoSortCategories,
  uncheckedSubFunction,
  validateCategoryFunction,
) where

import Control.Arrow (second)
import Control.Monad ((>=>),foldM,when)
import Data.List (group,intercalate,nub,nubBy,sort)
import qualified Data.Map as Map
import qualified Data.Set as Set

import Base.CompilerError
import Base.GeneralType
import Base.MergeTree
import Base.Mergeable
import Base.Positional
import Types.Function
import Types.TypeInstance
import Types.Variance


data AnyCategory c =
  ValueInterface {
    forall c. AnyCategory c -> [c]
viContext :: [c],
    forall c. AnyCategory c -> Namespace
viNamespace :: Namespace,
    forall c. AnyCategory c -> CategoryName
viName :: CategoryName,
    forall c. AnyCategory c -> [PragmaCategory c]
viPragmas :: [PragmaCategory c],
    forall c. AnyCategory c -> [ValueParam c]
viParams :: [ValueParam c],
    forall c. AnyCategory c -> [ValueRefine c]
viRefines :: [ValueRefine c],
    forall c. AnyCategory c -> [ScopedFunction c]
viFunctions :: [ScopedFunction c]
  } |
  InstanceInterface {
    forall c. AnyCategory c -> [c]
iiContext :: [c],
    forall c. AnyCategory c -> Namespace
iiNamespace :: Namespace,
    forall c. AnyCategory c -> CategoryName
iiName :: CategoryName,
    forall c. AnyCategory c -> [PragmaCategory c]
iiPragmas :: [PragmaCategory c],
    forall c. AnyCategory c -> [ValueParam c]
iiParams :: [ValueParam c],
    forall c. AnyCategory c -> [ScopedFunction c]
iiFunctions :: [ScopedFunction c]
  } |
  ValueConcrete {
    forall c. AnyCategory c -> [c]
vcContext :: [c],
    forall c. AnyCategory c -> Namespace
vcNamespace :: Namespace,
    forall c. AnyCategory c -> CategoryName
vcName :: CategoryName,
    forall c. AnyCategory c -> [PragmaCategory c]
vcPragmas :: [PragmaCategory c],
    forall c. AnyCategory c -> [FunctionVisibility c]
vcVisibility :: [FunctionVisibility c],
    forall c. AnyCategory c -> [ValueParam c]
vcParams :: [ValueParam c],
    forall c. AnyCategory c -> [ValueRefine c]
vcRefines :: [ValueRefine c],
    forall c. AnyCategory c -> [ValueDefine c]
vcDefines :: [ValueDefine c],
    forall c. AnyCategory c -> [ParamFilter c]
vcParamFilter :: [ParamFilter c],
    forall c. AnyCategory c -> [ScopedFunction c]
vcFunctions :: [ScopedFunction c]
  }

data PragmaCategory c =
  CategoryImmutable {
    forall c. PragmaCategory c -> [c]
ciContext :: [c]
  }

instance Show c => Show (PragmaCategory c) where
  show :: PragmaCategory c -> String
show (CategoryImmutable [c]
c) = String
"immutable /*" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [c]
c forall a. [a] -> [a] -> [a]
++ String
"*/"

isCategoryImmutable :: PragmaCategory c -> Bool
isCategoryImmutable :: forall c. PragmaCategory c -> Bool
isCategoryImmutable (CategoryImmutable [c]
_) = Bool
True

prependCategoryPragmaContext :: [c] -> PragmaCategory c -> PragmaCategory c
prependCategoryPragmaContext :: forall c. [c] -> PragmaCategory c -> PragmaCategory c
prependCategoryPragmaContext [c]
c (CategoryImmutable [c]
c2) = forall c. [c] -> PragmaCategory c
CategoryImmutable ([c]
cforall a. [a] -> [a] -> [a]
++[c]
c2)

formatFullContext :: Show a => [a] -> String
formatFullContext :: forall a. Show a => [a] -> String
formatFullContext [a]
cs = forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [a]
cs)

formatFullContextBrace :: Show a => [a] -> String
formatFullContextBrace :: forall a. Show a => [a] -> String
formatFullContextBrace [] = String
""
formatFullContextBrace [a]
cs = String
" [" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [a]
cs) forall a. [a] -> [a] -> [a]
++ String
"]"

instance Show c => Show (AnyCategory c) where
  show :: AnyCategory c -> String
show = forall c. Show c => AnyCategory c -> String
format where
    format :: AnyCategory c -> String
format (ValueInterface [c]
cs Namespace
ns CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ValueRefine c]
rs [ScopedFunction c]
fs) =
      String
"@value interface " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n forall a. [a] -> [a] -> [a]
++ forall {t :: * -> *} {c}. Foldable t => t (ValueParam c) -> String
formatParams [ValueParam c]
ps forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespace Namespace
ns forall a. [a] -> [a] -> [a]
++ String
" { " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatContext [c]
cs forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
      (forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" forall a b. (a -> b) -> a -> b
$
         forall a b. (a -> b) -> [a] -> [b]
map (\PragmaCategory c
p -> String
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PragmaCategory c
p) [PragmaCategory c]
pg forall a. [a] -> [a] -> [a]
++
         forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> String
"  " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => ValueRefine a -> String
formatRefine ValueRefine c
r) [ValueRefine c]
rs forall a. [a] -> [a] -> [a]
++
         forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> forall {c}. Show c => ScopedFunction c -> String
formatInterfaceFunc ScopedFunction c
f) [ScopedFunction c]
fs) forall a. [a] -> [a] -> [a]
++
      String
"\n}\n"
    format (InstanceInterface [c]
cs Namespace
ns CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ScopedFunction c]
fs) =
      String
"@type interface " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n forall a. [a] -> [a] -> [a]
++ forall {t :: * -> *} {c}. Foldable t => t (ValueParam c) -> String
formatParams [ValueParam c]
ps forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespace Namespace
ns forall a. [a] -> [a] -> [a]
++ String
" { " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatContext [c]
cs forall a. [a] -> [a] -> [a]
++
      (forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" forall a b. (a -> b) -> a -> b
$
         forall a b. (a -> b) -> [a] -> [b]
map (\PragmaCategory c
p -> String
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PragmaCategory c
p) [PragmaCategory c]
pg forall a. [a] -> [a] -> [a]
++
         forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> forall {c}. Show c => ScopedFunction c -> String
formatInterfaceFunc ScopedFunction c
f) [ScopedFunction c]
fs) forall a. [a] -> [a] -> [a]
++
      String
"\n}\n"
    format (ValueConcrete [c]
cs Namespace
ns CategoryName
n [PragmaCategory c]
pg [FunctionVisibility c]
_ [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs) =
      String
"concrete " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n forall a. [a] -> [a] -> [a]
++ forall {t :: * -> *} {c}. Foldable t => t (ValueParam c) -> String
formatParams [ValueParam c]
ps forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespace Namespace
ns forall a. [a] -> [a] -> [a]
++ String
" { " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatContext [c]
cs forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
      (forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" forall a b. (a -> b) -> a -> b
$
         forall a b. (a -> b) -> [a] -> [b]
map (\PragmaCategory c
p -> String
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PragmaCategory c
p) [PragmaCategory c]
pg forall a. [a] -> [a] -> [a]
++
         forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> String
"  " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => ValueRefine a -> String
formatRefine ValueRefine c
r) [ValueRefine c]
rs forall a. [a] -> [a] -> [a]
++
         forall a b. (a -> b) -> [a] -> [b]
map (\ValueDefine c
d -> String
"  " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => ValueDefine a -> String
formatDefine ValueDefine c
d) [ValueDefine c]
ds forall a. [a] -> [a] -> [a]
++
         forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
v -> String
"  " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => ParamFilter a -> String
formatValue ParamFilter c
v) [ParamFilter c]
vs forall a. [a] -> [a] -> [a]
++
         forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> forall {c}. Show c => ScopedFunction c -> String
formatConcreteFunc ScopedFunction c
f) [ScopedFunction c]
fs) forall a. [a] -> [a] -> [a]
++
      String
"\n}\n"
    namespace :: Namespace -> String
namespace Namespace
ns
      | Namespace -> Bool
isStaticNamespace Namespace
ns = String
" /*" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Namespace
ns forall a. [a] -> [a] -> [a]
++ String
"*/"
      | Bool
otherwise = String
""
    formatContext :: [a] -> String
formatContext [a]
cs = String
"/*" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [a]
cs forall a. [a] -> [a] -> [a]
++ String
"*/"
    formatParams :: t (ValueParam c) -> String
formatParams t (ValueParam c)
ps = let ([String]
con,[String]
inv,[String]
cov) = (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {c}.
ValueParam c
-> ([String], [String], [String]) -> ([String], [String], [String])
partitionParam ([],[],[]) t (ValueParam c)
ps) in
      String
"<" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
con forall a. [a] -> [a] -> [a]
++ String
"|" forall a. [a] -> [a] -> [a]
++
             forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
inv forall a. [a] -> [a] -> [a]
++ String
"|" forall a. [a] -> [a] -> [a]
++
             forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
cov forall a. [a] -> [a] -> [a]
++ String
">"
    partitionParam :: ValueParam c
-> ([String], [String], [String]) -> ([String], [String], [String])
partitionParam (ValueParam [c]
_ ParamName
p Variance
Contravariant) ([String]
con,[String]
inv,[String]
cov) = ((forall a. Show a => a -> String
show ParamName
p)forall a. a -> [a] -> [a]
:[String]
con,[String]
inv,[String]
cov)
    partitionParam (ValueParam [c]
_ ParamName
p Variance
Invariant)     ([String]
con,[String]
inv,[String]
cov) = ([String]
con,(forall a. Show a => a -> String
show ParamName
p)forall a. a -> [a] -> [a]
:[String]
inv,[String]
cov)
    partitionParam (ValueParam [c]
_ ParamName
p Variance
Covariant)     ([String]
con,[String]
inv,[String]
cov) = ([String]
con,[String]
inv,(forall a. Show a => a -> String
show ParamName
p)forall a. a -> [a] -> [a]
:[String]
cov)
    formatRefine :: ValueRefine a -> String
formatRefine ValueRefine a
r = String
"refines " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ValueRefine c -> TypeInstance
vrType ValueRefine a
r) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatContext (forall c. ValueRefine c -> [c]
vrContext ValueRefine a
r)
    formatDefine :: ValueDefine a -> String
formatDefine ValueDefine a
d = String
"defines " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine a
d) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatContext (forall c. ValueDefine c -> [c]
vdContext ValueDefine a
d)
    formatValue :: ParamFilter a -> String
formatValue ParamFilter a
v = forall a. Show a => a -> String
show (forall c. ParamFilter c -> ParamName
pfParam ParamFilter a
v) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter a
v) forall a. [a] -> [a] -> [a]
++
                    String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatContext (forall c. ParamFilter c -> [c]
pfContext ParamFilter a
v)
    formatInterfaceFunc :: ScopedFunction c -> String
formatInterfaceFunc ScopedFunction c
f = forall c. Show c => String -> String -> ScopedFunction c -> String
showFunctionInContext String
"" String
"  " ScopedFunction c
f
    formatConcreteFunc :: ScopedFunction c -> String
formatConcreteFunc ScopedFunction c
f = forall c. Show c => String -> String -> ScopedFunction c -> String
showFunctionInContext (forall a. Show a => a -> String
show (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f) forall a. [a] -> [a] -> [a]
++ String
" ") String
"  " ScopedFunction c
f

getCategoryName :: AnyCategory c -> CategoryName
getCategoryName :: forall c. AnyCategory c -> CategoryName
getCategoryName (ValueInterface [c]
_ Namespace
_ CategoryName
n [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ScopedFunction c]
_)      = CategoryName
n
getCategoryName (InstanceInterface [c]
_ Namespace
_ CategoryName
n [PragmaCategory c]
_ [ValueParam c]
_ [ScopedFunction c]
_)     = CategoryName
n
getCategoryName (ValueConcrete [c]
_ Namespace
_ CategoryName
n [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = CategoryName
n

getCategoryContext :: AnyCategory c -> [c]
getCategoryContext :: forall c. AnyCategory c -> [c]
getCategoryContext (ValueInterface [c]
c Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ScopedFunction c]
_)      = [c]
c
getCategoryContext (InstanceInterface [c]
c Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ScopedFunction c]
_)     = [c]
c
getCategoryContext (ValueConcrete [c]
c Namespace
_ CategoryName
_ [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [c]
c

getCategoryNamespace :: AnyCategory c -> Namespace
getCategoryNamespace :: forall c. AnyCategory c -> Namespace
getCategoryNamespace (ValueInterface [c]
_ Namespace
ns CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ScopedFunction c]
_)      = Namespace
ns
getCategoryNamespace (InstanceInterface [c]
_ Namespace
ns CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ScopedFunction c]
_)     = Namespace
ns
getCategoryNamespace (ValueConcrete [c]
_ Namespace
ns CategoryName
_ [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = Namespace
ns

getCategoryPragmas :: AnyCategory c -> [PragmaCategory c]
getCategoryPragmas :: forall c. AnyCategory c -> [PragmaCategory c]
getCategoryPragmas (ValueInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
pg [ValueParam c]
_ [ValueRefine c]
_ [ScopedFunction c]
_)      = [PragmaCategory c]
pg
getCategoryPragmas (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
pg [ValueParam c]
_ [ScopedFunction c]
_)     = [PragmaCategory c]
pg
getCategoryPragmas (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
pg [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [PragmaCategory c]
pg

setCategoryNamespace :: Namespace -> AnyCategory c -> AnyCategory c
setCategoryNamespace :: forall c. Namespace -> AnyCategory c -> AnyCategory c
setCategoryNamespace Namespace
ns (ValueInterface [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ValueRefine c]
rs [ScopedFunction c]
fs)        = (forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ScopedFunction c]
-> AnyCategory c
ValueInterface [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ValueRefine c]
rs [ScopedFunction c]
fs)
setCategoryNamespace Namespace
ns (InstanceInterface [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ScopedFunction c]
fs)        = (forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ScopedFunction c]
-> AnyCategory c
InstanceInterface [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ScopedFunction c]
fs)
setCategoryNamespace Namespace
ns (ValueConcrete [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
pg [FunctionVisibility c]
fv [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs) = (forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [FunctionVisibility c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueConcrete [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [FunctionVisibility c]
fv [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs)

getCategoryVisibilities :: AnyCategory c -> [FunctionVisibility c]
getCategoryVisibilities :: forall c. AnyCategory c -> [FunctionVisibility c]
getCategoryVisibilities (ValueInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ScopedFunction c]
_)       = []
getCategoryVisibilities (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ScopedFunction c]
_)      = []
getCategoryVisibilities (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [FunctionVisibility c]
fv [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [FunctionVisibility c]
fv

getCategoryParams :: AnyCategory c -> [ValueParam c]
getCategoryParams :: forall c. AnyCategory c -> [ValueParam c]
getCategoryParams (ValueInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
ps [ValueRefine c]
_ [ScopedFunction c]
_)      = [ValueParam c]
ps
getCategoryParams (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
ps [ScopedFunction c]
_)     = [ValueParam c]
ps
getCategoryParams (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
ps [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [ValueParam c]
ps

getCategoryRefines :: AnyCategory c -> [ValueRefine c]
getCategoryRefines :: forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines (ValueInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
rs [ScopedFunction c]
_)      = [ValueRefine c]
rs
getCategoryRefines (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ScopedFunction c]
_)      = []
getCategoryRefines (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
rs [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [ValueRefine c]
rs

getCategoryDefines :: AnyCategory c -> [ValueDefine c]
getCategoryDefines :: forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines (ValueInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ScopedFunction c]
_)       = []
getCategoryDefines (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ScopedFunction c]
_)      = []
getCategoryDefines (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
ds [ParamFilter c]
_ [ScopedFunction c]
_) = [ValueDefine c]
ds

getCategoryFilters :: AnyCategory c -> [ParamFilter c]
getCategoryFilters :: forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters (ValueInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ScopedFunction c]
_)       = []
getCategoryFilters (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ScopedFunction c]
_)      = []
getCategoryFilters (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
vs [ScopedFunction c]
_) = [ParamFilter c]
vs

getCategoryFunctions :: AnyCategory c -> [ScopedFunction c]
getCategoryFunctions :: forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions (ValueInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ScopedFunction c]
fs)      = [ScopedFunction c]
fs
getCategoryFunctions (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ScopedFunction c]
fs)     = [ScopedFunction c]
fs
getCategoryFunctions (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
fs) = [ScopedFunction c]
fs

singleFromCategory :: AnyCategory c -> TypeInstance
singleFromCategory :: forall c. AnyCategory c -> TypeInstance
singleFromCategory AnyCategory c
t = CategoryName -> InstanceParams -> TypeInstance
TypeInstance CategoryName
n (forall a. [a] -> Positional a
Positional [GeneralType TypeInstanceOrParam]
ps) where
  n :: CategoryName
n = forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t
  ps :: [GeneralType TypeInstanceOrParam]
ps = forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ValueParam c -> ParamName
vpParam) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t

instanceFromCategory :: AnyCategory c -> GeneralInstance
instanceFromCategory :: forall c. AnyCategory c -> GeneralType TypeInstanceOrParam
instanceFromCategory = forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstance -> TypeInstanceOrParam
JustTypeInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. AnyCategory c -> TypeInstance
singleFromCategory

getCategoryDeps :: AnyCategory c -> Set.Set CategoryName
getCategoryDeps :: forall c. AnyCategory c -> Set CategoryName
getCategoryDeps AnyCategory c
t = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) forall a b. (a -> b) -> a -> b
$ [CategoryName]
refines forall a. [a] -> [a] -> [a]
++ [CategoryName]
defines forall a. [a] -> [a] -> [a]
++ [CategoryName]
filters forall a. [a] -> [a] -> [a]
++ [CategoryName]
functions where
  refines :: [CategoryName]
refines = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstance -> TypeInstanceOrParam
JustTypeInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ValueRefine c -> TypeInstance
vrType) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t
  defines :: [CategoryName]
defines = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (DefinesInstance -> [CategoryName]
fromDefine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ValueDefine c -> DefinesInstance
vdType) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t
  filters :: [CategoryName]
filters = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (TypeFilter -> [CategoryName]
fromFilter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ParamFilter c -> TypeFilter
pfFilter) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t
  functions :: [CategoryName]
functions = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {c}. ScopedFunction c -> [CategoryName]
fromFunction forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
t
  fromInstance :: GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance = forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat TypeInstanceOrParam -> [CategoryName]
fromSingle
  fromSingle :: TypeInstanceOrParam -> [CategoryName]
fromSingle (JustTypeInstance (TypeInstance CategoryName
n InstanceParams
ps)) = CategoryName
nforall a. a -> [a] -> [a]
:(forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues InstanceParams
ps)
  fromSingle TypeInstanceOrParam
_ = []
  fromDefine :: DefinesInstance -> [CategoryName]
fromDefine (DefinesInstance CategoryName
n InstanceParams
ps) = CategoryName
nforall a. a -> [a] -> [a]
:(forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues InstanceParams
ps)
  fromFilter :: TypeFilter -> [CategoryName]
fromFilter (TypeFilter FilterDirection
_ GeneralType TypeInstanceOrParam
t2)  = GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance GeneralType TypeInstanceOrParam
t2
  fromFilter (DefinesFilter DefinesInstance
t2) = DefinesInstance -> [CategoryName]
fromDefine DefinesInstance
t2
  fromFilter TypeFilter
ImmutableFilter = []
  fromType :: ValueType -> [CategoryName]
fromType (ValueType StorageType
_ GeneralType TypeInstanceOrParam
t2) = GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance GeneralType TypeInstanceOrParam
t2
  fromFunction :: ScopedFunction c -> [CategoryName]
fromFunction ScopedFunction c
f = [CategoryName]
args forall a. [a] -> [a] -> [a]
++ [CategoryName]
returns forall a. [a] -> [a] -> [a]
++ [CategoryName]
filters2 where
    args :: [CategoryName]
args = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> [CategoryName]
fromType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PassedValue c -> ValueType
pvType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f
    returns :: [CategoryName]
returns = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> [CategoryName]
fromType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PassedValue c -> ValueType
pvType) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall c. ScopedFunction c -> Positional (PassedValue c)
sfReturns ScopedFunction c
f
    filters2 :: [CategoryName]
filters2 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (TypeFilter -> [CategoryName]
fromFilter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ParamFilter c -> TypeFilter
pfFilter) forall a b. (a -> b) -> a -> b
$ forall c. ScopedFunction c -> [ParamFilter c]
sfFilters ScopedFunction c
f

isValueInterface :: AnyCategory c -> Bool
isValueInterface :: forall c. AnyCategory c -> Bool
isValueInterface (ValueInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ScopedFunction c]
_) = Bool
True
isValueInterface AnyCategory c
_ = Bool
False

isInstanceInterface :: AnyCategory c -> Bool
isInstanceInterface :: forall c. AnyCategory c -> Bool
isInstanceInterface (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [ValueParam c]
_ [ScopedFunction c]
_) = Bool
True
isInstanceInterface AnyCategory c
_ = Bool
False

isValueConcrete :: AnyCategory c -> Bool
isValueConcrete :: forall c. AnyCategory c -> Bool
isValueConcrete (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = Bool
True
isValueConcrete AnyCategory c
_ = Bool
False

data Namespace =
  StaticNamespace {
    Namespace -> String
snName :: String
  } |
  NoNamespace |
  PublicNamespace |
  PrivateNamespace
  deriving (Namespace -> Namespace -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c== :: Namespace -> Namespace -> Bool
Eq,Eq Namespace
Namespace -> Namespace -> Bool
Namespace -> Namespace -> Ordering
Namespace -> Namespace -> Namespace
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Namespace -> Namespace -> Namespace
$cmin :: Namespace -> Namespace -> Namespace
max :: Namespace -> Namespace -> Namespace
$cmax :: Namespace -> Namespace -> Namespace
>= :: Namespace -> Namespace -> Bool
$c>= :: Namespace -> Namespace -> Bool
> :: Namespace -> Namespace -> Bool
$c> :: Namespace -> Namespace -> Bool
<= :: Namespace -> Namespace -> Bool
$c<= :: Namespace -> Namespace -> Bool
< :: Namespace -> Namespace -> Bool
$c< :: Namespace -> Namespace -> Bool
compare :: Namespace -> Namespace -> Ordering
$ccompare :: Namespace -> Namespace -> Ordering
Ord)

instance Show Namespace where
  show :: Namespace -> String
show (StaticNamespace String
n) = String
n
  show Namespace
_                   = String
""

isStaticNamespace :: Namespace -> Bool
isStaticNamespace :: Namespace -> Bool
isStaticNamespace (StaticNamespace String
_) = Bool
True
isStaticNamespace Namespace
_                   = Bool
False

isNoNamespace :: Namespace -> Bool
isNoNamespace :: Namespace -> Bool
isNoNamespace Namespace
NoNamespace = Bool
True
isNoNamespace Namespace
_           = Bool
False

isPublicNamespace :: Namespace -> Bool
isPublicNamespace :: Namespace -> Bool
isPublicNamespace Namespace
PublicNamespace = Bool
True
isPublicNamespace Namespace
_                = Bool
False

isPrivateNamespace :: Namespace -> Bool
isPrivateNamespace :: Namespace -> Bool
isPrivateNamespace Namespace
PrivateNamespace = Bool
True
isPrivateNamespace Namespace
_                = Bool
False

data ValueRefine c =
  ValueRefine {
    forall c. ValueRefine c -> [c]
vrContext :: [c],
    forall c. ValueRefine c -> TypeInstance
vrType :: TypeInstance
  }

instance Show c => Show (ValueRefine c) where
  show :: ValueRefine c -> String
show (ValueRefine [c]
c TypeInstance
t) = forall a. Show a => a -> String
show TypeInstance
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

data ValueDefine c =
  ValueDefine {
    forall c. ValueDefine c -> [c]
vdContext :: [c],
    forall c. ValueDefine c -> DefinesInstance
vdType :: DefinesInstance
  }

instance Show c => Show (ValueDefine c) where
  show :: ValueDefine c -> String
show (ValueDefine [c]
c DefinesInstance
t) = forall a. Show a => a -> String
show DefinesInstance
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

data ValueParam c =
  ValueParam {
    forall c. ValueParam c -> [c]
vpContext :: [c],
    forall c. ValueParam c -> ParamName
vpParam :: ParamName,
    forall c. ValueParam c -> Variance
vpVariance :: Variance
  }

instance Show c => Show (ValueParam c) where
  show :: ValueParam c -> String
show (ValueParam [c]
c ParamName
t Variance
v) = forall a. Show a => a -> String
show ParamName
t forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Variance
v forall a. [a] -> [a] -> [a]
++ String
")" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

data ParamFilter c =
  ParamFilter {
    forall c. ParamFilter c -> [c]
pfContext :: [c],
    forall c. ParamFilter c -> ParamName
pfParam :: ParamName,
    forall c. ParamFilter c -> TypeFilter
pfFilter :: TypeFilter
  }

instance Show c => Show (ParamFilter c) where
  show :: ParamFilter c -> String
show (ParamFilter [c]
c ParamName
n TypeFilter
f) = forall a. Show a => a -> String
show ParamName
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeFilter
f forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

newtype CategoryResolver c =
  CategoryResolver {
    forall c. CategoryResolver c -> CategoryMap c
crCategories :: CategoryMap c
  }

instance Show c => TypeResolver (CategoryResolver c) where
    trRefines :: forall (m :: * -> *).
CollectErrorsM m =>
CategoryResolver c
-> TypeInstance -> CategoryName -> m InstanceParams
trRefines (CategoryResolver CategoryMap c
tm) ta :: TypeInstance
ta@(TypeInstance CategoryName
n1 InstanceParams
ps1) CategoryName
n2
      | CategoryName
n1 forall a. Eq a => a -> a -> Bool
== CategoryName
n2 = do
        ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
tm ([],CategoryName
n1)
        forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t) InstanceParams
ps1
        forall (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
ps1
      | Bool
otherwise = do
        let self :: GeneralType TypeInstanceOrParam
self = forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
ta
        ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
tm ([],CategoryName
n1)
        let params :: [ParamName]
params = forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
        Map ParamName (GeneralType TypeInstanceOrParam)
assigned <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall a. [a] -> Positional a
Positional [ParamName]
params) InstanceParams
ps1
        let pa :: Map CategoryName InstanceParams
pa = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\TypeInstance
r -> (TypeInstance -> CategoryName
tiName TypeInstance
r,TypeInstance -> InstanceParams
tiParams TypeInstance
r)) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueRefine c -> TypeInstance
vrType forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t
        InstanceParams
ps2 <- case CategoryName
n2 forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName InstanceParams
pa of
                    (Just InstanceParams
x) -> forall (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
x
                    Maybe InstanceParams
_ -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n1 forall a. [a] -> [a] -> [a]
++ String
" does not refine " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n2
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
subAllParams Map ParamName (GeneralType TypeInstanceOrParam)
assigned forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *).
CollectErrorsM m =>
GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
replaceSelfInstance GeneralType TypeInstanceOrParam
self) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues InstanceParams
ps2
    trDefines :: forall (m :: * -> *).
CollectErrorsM m =>
CategoryResolver c
-> TypeInstance -> CategoryName -> m InstanceParams
trDefines (CategoryResolver CategoryMap c
tm) ta :: TypeInstance
ta@(TypeInstance CategoryName
n1 InstanceParams
ps1) CategoryName
n2 = do
      let self :: GeneralType TypeInstanceOrParam
self = forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
ta
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
tm ([],CategoryName
n1)
      let params :: [ParamName]
params = forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
      Map ParamName (GeneralType TypeInstanceOrParam)
assigned <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall a. [a] -> Positional a
Positional [ParamName]
params) InstanceParams
ps1
      let pa :: Map CategoryName InstanceParams
pa = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\DefinesInstance
r -> (DefinesInstance -> CategoryName
diName DefinesInstance
r,DefinesInstance -> InstanceParams
diParams DefinesInstance
r)) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueDefine c -> DefinesInstance
vdType forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t
      InstanceParams
ps2 <- case CategoryName
n2 forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName InstanceParams
pa of
                  (Just InstanceParams
x) -> forall (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
x
                  Maybe InstanceParams
_ -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n1 forall a. [a] -> [a] -> [a]
++ String
" does not define " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n2
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
subAllParams Map ParamName (GeneralType TypeInstanceOrParam)
assigned forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *).
CollectErrorsM m =>
GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
replaceSelfInstance GeneralType TypeInstanceOrParam
self) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues InstanceParams
ps2
    trVariance :: forall (m :: * -> *).
CollectErrorsM m =>
CategoryResolver c -> CategoryName -> m InstanceVariances
trVariance (CategoryResolver CategoryMap c
tm) CategoryName
n = do
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([],CategoryName
n)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> Variance
vpVariance forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
    trTypeFilters :: forall (m :: * -> *).
CollectErrorsM m =>
CategoryResolver c -> TypeInstance -> m InstanceFilters
trTypeFilters (CategoryResolver CategoryMap c
tm) (TypeInstance CategoryName
n InstanceParams
ps) = do
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
tm ([],CategoryName
n)
      forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> InstanceParams -> m InstanceFilters
checkFilters AnyCategory c
t InstanceParams
ps
    trDefinesFilters :: forall (m :: * -> *).
CollectErrorsM m =>
CategoryResolver c -> DefinesInstance -> m InstanceFilters
trDefinesFilters (CategoryResolver CategoryMap c
tm) (DefinesInstance CategoryName
n InstanceParams
ps) = do
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getInstanceCategory CategoryMap c
tm ([],CategoryName
n)
      forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> InstanceParams -> m InstanceFilters
checkFilters AnyCategory c
t InstanceParams
ps
    trConcrete :: forall (m :: * -> *).
CollectErrorsM m =>
CategoryResolver c -> CategoryName -> m Bool
trConcrete (CategoryResolver CategoryMap c
tm) CategoryName
n = do
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([],CategoryName
n)
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t)
    trImmutable :: forall (m :: * -> *).
CollectErrorsM m =>
CategoryResolver c -> CategoryName -> m Bool
trImmutable (CategoryResolver CategoryMap c
tm) CategoryName
n = do
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([],CategoryName
n)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall c. PragmaCategory c -> Bool
isCategoryImmutable (forall c. AnyCategory c -> [PragmaCategory c]
getCategoryPragmas AnyCategory c
t)

data SymbolScope =
  LocalScope |
  CategoryScope |
  TypeScope |
  ValueScope
  deriving (SymbolScope -> SymbolScope -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SymbolScope -> SymbolScope -> Bool
$c/= :: SymbolScope -> SymbolScope -> Bool
== :: SymbolScope -> SymbolScope -> Bool
$c== :: SymbolScope -> SymbolScope -> Bool
Eq,Eq SymbolScope
SymbolScope -> SymbolScope -> Bool
SymbolScope -> SymbolScope -> Ordering
SymbolScope -> SymbolScope -> SymbolScope
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SymbolScope -> SymbolScope -> SymbolScope
$cmin :: SymbolScope -> SymbolScope -> SymbolScope
max :: SymbolScope -> SymbolScope -> SymbolScope
$cmax :: SymbolScope -> SymbolScope -> SymbolScope
>= :: SymbolScope -> SymbolScope -> Bool
$c>= :: SymbolScope -> SymbolScope -> Bool
> :: SymbolScope -> SymbolScope -> Bool
$c> :: SymbolScope -> SymbolScope -> Bool
<= :: SymbolScope -> SymbolScope -> Bool
$c<= :: SymbolScope -> SymbolScope -> Bool
< :: SymbolScope -> SymbolScope -> Bool
$c< :: SymbolScope -> SymbolScope -> Bool
compare :: SymbolScope -> SymbolScope -> Ordering
$ccompare :: SymbolScope -> SymbolScope -> Ordering
Ord)

instance Show SymbolScope where
  show :: SymbolScope -> String
show SymbolScope
CategoryScope = String
"@category"
  show SymbolScope
TypeScope     = String
"@type"
  show SymbolScope
ValueScope    = String
"@value"
  show SymbolScope
LocalScope    = String
"@local"

partitionByScope :: (a -> SymbolScope) -> [a] -> ([a],[a],[a])
partitionByScope :: forall a. (a -> SymbolScope) -> [a] -> ([a], [a], [a])
partitionByScope a -> SymbolScope
f = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> ([a], [a], [a]) -> ([a], [a], [a])
bin forall {a} {a} {a}. ([a], [a], [a])
empty where
  empty :: ([a], [a], [a])
empty = ([],[],[])
  bin :: a -> ([a], [a], [a]) -> ([a], [a], [a])
bin a
x ([a]
cs,[a]
ts,[a]
vs)
    | a -> SymbolScope
f a
x forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope = (a
xforall a. a -> [a] -> [a]
:[a]
cs,[a]
ts,[a]
vs)
    | a -> SymbolScope
f a
x forall a. Eq a => a -> a -> Bool
== SymbolScope
TypeScope     = ([a]
cs,a
xforall a. a -> [a] -> [a]
:[a]
ts,[a]
vs)
    | a -> SymbolScope
f a
x forall a. Eq a => a -> a -> Bool
== SymbolScope
ValueScope    = ([a]
cs,[a]
ts,a
xforall a. a -> [a] -> [a]
:[a]
vs)
    | Bool
otherwise = ([a]
cs,[a]
ts,[a]
vs)

checkFilters :: CollectErrorsM m =>
  AnyCategory c -> Positional GeneralInstance -> m (Positional [TypeFilter])
checkFilters :: forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> InstanceParams -> m InstanceFilters
checkFilters AnyCategory c
t InstanceParams
ps = do
  Map ParamName (GeneralType TypeInstanceOrParam)
assigned <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf GeneralType TypeInstanceOrParam
selfType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) forall a b. (a -> b) -> a -> b
$ forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall a. [a] -> Positional a
Positional [ParamName]
params) InstanceParams
ps
  [(ParamName, TypeFilter)]
fs <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {a}.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> (a, TypeFilter) -> m (a, TypeFilter)
subSingleFilter Map ParamName (GeneralType TypeInstanceOrParam)
assigned forall b c a. (b -> c) -> (a -> b) -> a -> c
. \ParamFilter c
f -> (forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f,forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter c
f)) [ParamFilter c]
allFilters
  let fa :: Map ParamName [TypeFilter]
fa = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a. a -> [a] -> [a]
:[])) [(ParamName, TypeFilter)]
fs
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {k} {m :: * -> *} {a}.
(Ord k, Monad m) =>
Map k [a] -> k -> m [a]
assignFilter Map ParamName [TypeFilter]
fa) [ParamName]
params where
    params :: [ParamName]
params = forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
    allFilters :: [ParamFilter c]
allFilters = forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall c. [c] -> ParamName -> TypeFilter -> ParamFilter c
ParamFilter (forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t) ParamName
ParamSelf) (forall c. AnyCategory c -> [TypeFilter]
getSelfFilters AnyCategory c
t)
    subSingleFilter :: Map ParamName (GeneralType TypeInstanceOrParam)
-> (a, TypeFilter) -> m (a, TypeFilter)
subSingleFilter Map ParamName (GeneralType TypeInstanceOrParam)
pa (a
n,(TypeFilter FilterDirection
v GeneralType TypeInstanceOrParam
t2)) = do
      GeneralType TypeInstanceOrParam
t3<- forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
uncheckedSubInstance (forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa) GeneralType TypeInstanceOrParam
t2
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
n,(FilterDirection -> GeneralType TypeInstanceOrParam -> TypeFilter
TypeFilter FilterDirection
v GeneralType TypeInstanceOrParam
t3))
    subSingleFilter Map ParamName (GeneralType TypeInstanceOrParam)
pa (a
n,(DefinesFilter (DefinesInstance CategoryName
n2 InstanceParams
ps2))) = do
      [GeneralType TypeInstanceOrParam]
ps3 <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
uncheckedSubInstance forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa) (forall a. Positional a -> [a]
pValues InstanceParams
ps2)
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
n,(DefinesInstance -> TypeFilter
DefinesFilter (CategoryName -> InstanceParams -> DefinesInstance
DefinesInstance CategoryName
n2 (forall a. [a] -> Positional a
Positional [GeneralType TypeInstanceOrParam]
ps3))))
    subSingleFilter Map ParamName (GeneralType TypeInstanceOrParam)
_ f :: (a, TypeFilter)
f@(a
_,TypeFilter
ImmutableFilter) = forall (m :: * -> *) a. Monad m => a -> m a
return (a, TypeFilter)
f
    assignFilter :: Map k [a] -> k -> m [a]
assignFilter Map k [a]
fa k
n =
      case k
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map k [a]
fa of
            (Just [a]
x) -> forall (m :: * -> *) a. Monad m => a -> m a
return [a]
x
            Maybe [a]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []

getSelfFilters :: AnyCategory c -> [TypeFilter]
getSelfFilters :: forall c. AnyCategory c -> [TypeFilter]
getSelfFilters AnyCategory c
t = [TypeFilter]
selfFilters where
  params :: [ParamName]
params = forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
  selfParams :: InstanceParams
selfParams = forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False) [ParamName]
params
  selfFilters :: [TypeFilter]
selfFilters
    | forall c. AnyCategory c -> Bool
isInstanceInterface AnyCategory c
t = [
        DefinesInstance -> TypeFilter
DefinesFilter forall a b. (a -> b) -> a -> b
$ CategoryName -> InstanceParams -> DefinesInstance
DefinesInstance (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) InstanceParams
selfParams
      ] forall a. [a] -> [a] -> [a]
++ [TypeFilter]
inheritedFilters
    | Bool
otherwise = [
        FilterDirection -> GeneralType TypeInstanceOrParam -> TypeFilter
TypeFilter FilterDirection
FilterRequires forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance forall a b. (a -> b) -> a -> b
$ CategoryName -> InstanceParams -> TypeInstance
TypeInstance (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) InstanceParams
selfParams
      ] forall a. [a] -> [a] -> [a]
++ [TypeFilter]
inheritedFilters
  inheritedFilters :: [TypeFilter]
inheritedFilters = forall a b. (a -> b) -> [a] -> [b]
map (DefinesInstance -> TypeFilter
DefinesFilter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ValueDefine c -> DefinesInstance
vdType) (forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t) forall a. [a] -> [a] -> [a]
++
                     forall a b. (a -> b) -> [a] -> [b]
map (FilterDirection -> GeneralType TypeInstanceOrParam -> TypeFilter
TypeFilter FilterDirection
FilterRequires forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstance -> TypeInstanceOrParam
JustTypeInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ValueRefine c -> TypeInstance
vrType) (forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t)

subAllParams :: CollectErrorsM m =>
  ParamValues -> GeneralInstance -> m GeneralInstance
subAllParams :: forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
subAllParams Map ParamName (GeneralType TypeInstanceOrParam)
pa = forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
uncheckedSubInstance (forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa)

data CategoryMap c =
  CategoryMap {
    forall c. CategoryMap c -> Map CategoryName [c]
cmKnown :: Map.Map CategoryName [c],
    forall c. CategoryMap c -> Map CategoryName (AnyCategory c)
cmAvailable :: Map.Map CategoryName (AnyCategory c)
  }

emptyCategoryMap :: CategoryMap c
emptyCategoryMap :: forall c. CategoryMap c
emptyCategoryMap = forall c. [(CategoryName, AnyCategory c)] -> CategoryMap c
toCategoryMap []

toCategoryMap :: [(CategoryName,AnyCategory c)] -> CategoryMap c
toCategoryMap :: forall c. [(CategoryName, AnyCategory c)] -> CategoryMap c
toCategoryMap = forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap forall k a. Map k a
Map.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

getCategory :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c)
getCategory :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory (CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) ([c]
c,CategoryName
n) = Maybe (AnyCategory c) -> Maybe [c] -> m ([c], AnyCategory c)
handle (CategoryName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName (AnyCategory c)
tm) (CategoryName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName [c]
km) where
  handle :: Maybe (AnyCategory c) -> Maybe [c] -> m ([c], AnyCategory c)
handle (Just AnyCategory c
t) Maybe [c]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c,AnyCategory c
t)
  handle Maybe (AnyCategory c)
_ (Just [c]
c2) = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c2 forall a. [a] -> [a] -> [a]
++
                                        String
" not visible here" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  handle Maybe (AnyCategory c)
_ Maybe [c]
_ = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n forall a. [a] -> [a] -> [a]
++ String
" not found" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

getValueCategory :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c)
getValueCategory :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
tm ([c]
c,CategoryName
n) = do
  ([c]
c2,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([c]
c,CategoryName
n)
  if forall c. AnyCategory c -> Bool
isValueInterface AnyCategory c
t Bool -> Bool -> Bool
|| forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t
     then forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,AnyCategory c
t)
     else forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n forall a. [a] -> [a] -> [a]
++
                           String
" cannot be used as a value" forall a. [a] -> [a] -> [a]
++
                           forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

getInstanceCategory :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c)
getInstanceCategory :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getInstanceCategory CategoryMap c
tm ([c]
c,CategoryName
n) = do
  ([c]
c2,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([c]
c,CategoryName
n)
  if forall c. AnyCategory c -> Bool
isInstanceInterface AnyCategory c
t
     then forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,AnyCategory c
t)
     else forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n forall a. [a] -> [a] -> [a]
++
                           String
" cannot be used as a type interface" forall a. [a] -> [a] -> [a]
++
                           forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

getConcreteCategory :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c)
getConcreteCategory :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getConcreteCategory CategoryMap c
tm ([c]
c,CategoryName
n) = do
  ([c]
c2,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([c]
c,CategoryName
n)
  if forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t
     then forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,AnyCategory c
t)
     else forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n forall a. [a] -> [a] -> [a]
++
                           String
" cannot be used as concrete" forall a. [a] -> [a] -> [a]
++
                           forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

includeNewTypes :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes CategoryMap c
tm0 [AnyCategory c]
ts = do
  forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkConnectionCycles CategoryMap c
tm0 [AnyCategory c]
ts
  forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkConnectedTypes CategoryMap c
tm0 [AnyCategory c]
ts
  forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkParamVariances CategoryMap c
tm0 [AnyCategory c]
ts
  [AnyCategory c]
ts2 <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
topoSortCategories CategoryMap c
tm0 [AnyCategory c]
ts
  [AnyCategory c]
ts3 <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
flattenAllConnections CategoryMap c
tm0 [AnyCategory c]
ts2
  forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkCategoryInstances CategoryMap c
tm0 [AnyCategory c]
ts3
  forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes CategoryMap c
tm0 [AnyCategory c]
ts3

declareAllTypes :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes CategoryMap c
tm0 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\AnyCategory c
t m (CategoryMap c)
tm -> m (CategoryMap c)
tm forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {c}.
(ErrorContextM m, Show c) =>
AnyCategory c -> CategoryMap c -> m (CategoryMap c)
update AnyCategory c
t) (forall (m :: * -> *) a. Monad m => a -> m a
return CategoryMap c
tm0) where
  update :: AnyCategory c -> CategoryMap c -> m (CategoryMap c)
update AnyCategory c
t (CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) =
    case forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName (AnyCategory c)
tm of
        (Just AnyCategory c
t2) -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) forall a. [a] -> [a] -> [a]
++
                                      forall a. Show a => [a] -> String
formatFullContextBrace (forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t) forall a. [a] -> [a] -> [a]
++
                                      String
" has already been declared" forall a. [a] -> [a] -> [a]
++
                                      forall a. Show a => [a] -> String
formatFullContextBrace (forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t2)
        Maybe (AnyCategory c)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) AnyCategory c
t Map CategoryName (AnyCategory c)
tm

getFilterMap :: CollectErrorsM m => [ValueParam c] -> [ParamFilter c] -> m ParamFilters
getFilterMap :: forall (m :: * -> *) c.
CollectErrorsM m =>
[ValueParam c] -> [ParamFilter c] -> m (Map ParamName [TypeFilter])
getFilterMap [ValueParam c]
ps [ParamFilter c]
fs = do
  [ParamFilter c]
mirrored <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ParamFilter c -> m [ParamFilter c]
maybeMirror [ParamFilter c]
fs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {c}.
[ParamFilter c]
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
getFilters [ParamFilter c]
mirrored forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Set a -> [a]
Set.toList Set ParamName
pa) (forall a. a -> [a]
repeat []) where
    pa :: Set ParamName
pa = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam [ValueParam c]
ps
    maybeMirror :: ParamFilter c -> m [ParamFilter c]
maybeMirror fa :: ParamFilter c
fa@(ParamFilter [c]
c ParamName
p1 (TypeFilter FilterDirection
d GeneralType TypeInstanceOrParam
p2)) = do
      Maybe TypeInstanceOrParam
p <- forall (m :: * -> *) a. CollectErrorsM m => m a -> m (Maybe a)
tryCompilerM forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf GeneralType TypeInstanceOrParam
p2
      case Maybe TypeInstanceOrParam
p of
          Just (JustParamName Bool
_ ParamName
p') ->
            if ParamName
p' forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ParamName
pa
               then forall (m :: * -> *) a. Monad m => a -> m a
return [ParamFilter c
fa,(forall c. [c] -> ParamName -> TypeFilter -> ParamFilter c
ParamFilter [c]
c ParamName
p' (FilterDirection -> GeneralType TypeInstanceOrParam -> TypeFilter
TypeFilter (FilterDirection -> FilterDirection
flipFilter FilterDirection
d) (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False ParamName
p1))))]
               else forall (m :: * -> *) a. Monad m => a -> m a
return [ParamFilter c
fa]
          Maybe TypeInstanceOrParam
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [ParamFilter c
fa]
    maybeMirror ParamFilter c
fa = forall (m :: * -> *) a. Monad m => a -> m a
return [ParamFilter c
fa]
    getFilters :: [ParamFilter c]
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
getFilters [ParamFilter c]
fs2 [(ParamName, [TypeFilter])]
pa0 = let fs' :: [(ParamName, TypeFilter)]
fs' = forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
f -> (forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f,forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter c
f)) [ParamFilter c]
fs2 in
                             forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a. a -> [a] -> [a]
:[])) [(ParamName, TypeFilter)]
fs' forall a. [a] -> [a] -> [a]
++ [(ParamName, [TypeFilter])]
pa0

getCategoryFilterMap :: CollectErrorsM m => AnyCategory c -> m ParamFilters
getCategoryFilterMap :: forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Map ParamName [TypeFilter])
getCategoryFilterMap AnyCategory c
t = do
  Map ParamName [TypeFilter]
defaultMap <- forall (m :: * -> *) c.
CollectErrorsM m =>
[ValueParam c] -> [ParamFilter c] -> m (Map ParamName [TypeFilter])
getFilterMap (forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t) (forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf (forall c. AnyCategory c -> [TypeFilter]
getSelfFilters AnyCategory c
t) Map ParamName [TypeFilter]
defaultMap

getCategoryParamSet :: CollectErrorsM m => AnyCategory c -> m (Set.Set ParamName)
getCategoryParamSet :: forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Set ParamName)
getCategoryParamSet = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ParamName
ParamSelf] forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. AnyCategory c -> [ValueParam c]
getCategoryParams

-- TODO: Use this where it's needed in this file.
getFunctionFilterMap :: CollectErrorsM m => ScopedFunction c -> m ParamFilters
getFunctionFilterMap :: forall (m :: * -> *) c.
CollectErrorsM m =>
ScopedFunction c -> m (Map ParamName [TypeFilter])
getFunctionFilterMap ScopedFunction c
f = forall (m :: * -> *) c.
CollectErrorsM m =>
[ValueParam c] -> [ParamFilter c] -> m (Map ParamName [TypeFilter])
getFilterMap (forall a. Positional a -> [a]
pValues forall a b. (a -> b) -> a -> b
$ forall c. ScopedFunction c -> Positional (ValueParam c)
sfParams ScopedFunction c
f) (forall c. ScopedFunction c -> [ParamFilter c]
sfFilters ScopedFunction c
f)

getCategoryParamMap :: AnyCategory c -> ParamValues
getCategoryParamMap :: forall c.
AnyCategory c -> Map ParamName (GeneralType TypeInstanceOrParam)
getCategoryParamMap AnyCategory c
t = let ps :: [ParamName]
ps = forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t in
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [ParamName]
ps (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False) [ParamName]
ps) forall a. [a] -> [a] -> [a]
++ [(ParamName
ParamSelf,GeneralType TypeInstanceOrParam
selfType)]

disallowBoundedParams :: CollectErrorsM m => ParamFilters -> m ()
disallowBoundedParams :: forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName [TypeFilter] -> m ()
disallowBoundedParams = forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall {t :: * -> *} {f :: * -> *} {a}.
(Foldable t, Show a, CollectErrorsM f) =>
(a, t TypeFilter) -> f ()
checkBounds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList where
  checkBounds :: (a, t TypeFilter) -> f ()
checkBounds (a
p,t TypeFilter
fs) = do
    let (GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
ub) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeFilter
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
splitBounds (forall a. Bounded a => a
minBound,forall a. Bounded a => a
maxBound) t TypeFilter
fs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralType TypeInstanceOrParam
lb forall a. Eq a => a -> a -> Bool
/= forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& GeneralType TypeInstanceOrParam
ub forall a. Eq a => a -> a -> Bool
/= forall a. Bounded a => a
maxBound) forall a b. (a -> b) -> a -> b
$
      String
"Param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
p forall a. [a] -> [a] -> [a]
++ String
" cannot have both lower and upper bounds" forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
!!>
        forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ [
            forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Lower bound: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
lb,
            forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Upper bound: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
ub
          ]
  splitBounds :: TypeFilter
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
splitBounds (TypeFilter FilterDirection
FilterRequires GeneralType TypeInstanceOrParam
t) (GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
ub) = (GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
tforall a. Mergeable a => a -> a -> a
<&&>GeneralType TypeInstanceOrParam
ub)
  splitBounds (TypeFilter FilterDirection
FilterAllows   GeneralType TypeInstanceOrParam
t) (GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
ub) = (GeneralType TypeInstanceOrParam
tforall a. Mergeable a => a -> a -> a
<||>GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
ub)
  splitBounds TypeFilter
_ (GeneralType TypeInstanceOrParam, GeneralType TypeInstanceOrParam)
bs = (GeneralType TypeInstanceOrParam, GeneralType TypeInstanceOrParam)
bs

checkConnectedTypes :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkConnectedTypes :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkConnectedTypes CategoryMap c
cm0 [AnyCategory c]
ts = do
  CategoryMap c
cm <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes CategoryMap c
cm0 [AnyCategory c]
ts
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {c}.
(CollectErrorsM m, Show c) =>
CategoryMap c -> AnyCategory c -> m ()
checkSingle CategoryMap c
cm) [AnyCategory c]
ts)
  where
    checkSingle :: CategoryMap c -> AnyCategory c -> m ()
checkSingle CategoryMap c
cm (ValueInterface [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
rs [ScopedFunction c]
_) = do
      let ts2 :: [([c], CategoryName)]
ts2 = forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName forall a b. (a -> b) -> a -> b
$ forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) [ValueRefine c]
rs
      [([c], AnyCategory c)]
is <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
cm) [([c], CategoryName)]
ts2
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {a} {a} {a} {c}.
(ErrorContextM m, Show a, Show a, Show a) =>
[a] -> a -> ([a], AnyCategory c) -> m ()
valueRefinesInstanceError [c]
c CategoryName
n) [([c], AnyCategory c)]
is)
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {a} {a} {a} {c}.
(ErrorContextM m, Show a, Show a, Show a) =>
[a] -> a -> ([a], AnyCategory c) -> m ()
valueRefinesConcreteError [c]
c CategoryName
n) [([c], AnyCategory c)]
is)
    checkSingle CategoryMap c
cm (ValueConcrete [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
_ [ScopedFunction c]
_) = do
      let ts2 :: [([c], CategoryName)]
ts2 = forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName forall a b. (a -> b) -> a -> b
$ forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) [ValueRefine c]
rs
      let ts3 :: [([c], CategoryName)]
ts3 = forall a b. (a -> b) -> [a] -> [b]
map (\ValueDefine c
d -> (forall c. ValueDefine c -> [c]
vdContext ValueDefine c
d,DefinesInstance -> CategoryName
diName forall a b. (a -> b) -> a -> b
$ forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine c
d)) [ValueDefine c]
ds
      [([c], AnyCategory c)]
is1 <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
cm) [([c], CategoryName)]
ts2
      [([c], AnyCategory c)]
is2 <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
cm) [([c], CategoryName)]
ts3
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {a} {a} {a} {c}.
(ErrorContextM m, Show a, Show a, Show a) =>
[a] -> a -> ([a], AnyCategory c) -> m ()
concreteRefinesInstanceError [c]
c CategoryName
n) [([c], AnyCategory c)]
is1)
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {a} {a} {a} {c}.
(ErrorContextM m, Show a, Show a, Show a) =>
[a] -> a -> ([a], AnyCategory c) -> m ()
concreteDefinesValueError [c]
c CategoryName
n) [([c], AnyCategory c)]
is2)
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {a} {a} {a} {c}.
(ErrorContextM m, Show a, Show a, Show a) =>
[a] -> a -> ([a], AnyCategory c) -> m ()
concreteRefinesConcreteError [c]
c CategoryName
n) [([c], AnyCategory c)]
is1)
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {a} {a} {a} {c}.
(ErrorContextM m, Show a, Show a, Show a) =>
[a] -> a -> ([a], AnyCategory c) -> m ()
concreteDefinesConcreteError [c]
c CategoryName
n) [([c], AnyCategory c)]
is2)
    checkSingle CategoryMap c
_ AnyCategory c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    valueRefinesInstanceError :: [a] -> a -> ([a], AnyCategory c) -> m ()
valueRefinesInstanceError [a]
c a
n ([a]
c2,AnyCategory c
t)
      | forall c. AnyCategory c -> Bool
isInstanceInterface AnyCategory c
t =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Value interface " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine type interface " forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => a -> String
show (forall c. AnyCategory c -> CategoryName
iiName AnyCategory c
t) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    valueRefinesConcreteError :: [a] -> a -> ([a], AnyCategory c) -> m ()
valueRefinesConcreteError [a]
c a
n ([a]
c2,AnyCategory c
t)
      | forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Value interface " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine concrete type " forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => a -> String
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    concreteRefinesInstanceError :: [a] -> a -> ([a], AnyCategory c) -> m ()
concreteRefinesInstanceError [a]
c a
n ([a]
c2,AnyCategory c
t)
      | forall c. AnyCategory c -> Bool
isInstanceInterface AnyCategory c
t =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Concrete type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine instance interface " forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => a -> String
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2 forall a. [a] -> [a] -> [a]
++
                         String
" => use defines instead"
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    concreteDefinesValueError :: [a] -> a -> ([a], AnyCategory c) -> m ()
concreteDefinesValueError [a]
c a
n ([a]
c2,AnyCategory c
t)
      | forall c. AnyCategory c -> Bool
isValueInterface AnyCategory c
t =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Concrete type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++
                         String
" cannot define value interface " forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => a -> String
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2 forall a. [a] -> [a] -> [a]
++
                         String
" => use refines instead"
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    concreteRefinesConcreteError :: [a] -> a -> ([a], AnyCategory c) -> m ()
concreteRefinesConcreteError [a]
c a
n ([a]
c2,AnyCategory c
t)
      | forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Concrete type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine concrete type " forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => a -> String
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    concreteDefinesConcreteError :: [a] -> a -> ([a], AnyCategory c) -> m ()
concreteDefinesConcreteError [a]
c a
n ([a]
c2,AnyCategory c
t)
      | forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Concrete type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++
                         String
" cannot define concrete type " forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => a -> String
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkConnectionCycles :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkConnectionCycles :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkConnectionCycles (CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm0) [AnyCategory c]
ts = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map ([CategoryName] -> AnyCategory c -> m ()
checker []) [AnyCategory c]
ts) where
  tm :: Map CategoryName (AnyCategory c)
tm = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map CategoryName (AnyCategory c)
tm0 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall c. AnyCategory c -> CategoryName
getCategoryName [AnyCategory c]
ts) [AnyCategory c]
ts
  cm :: CategoryMap c
cm = forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm
  checker :: [CategoryName] -> AnyCategory c -> m ()
checker [CategoryName]
us (ValueInterface [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
_ [ValueParam c]
_ [ValueRefine c]
rs [ScopedFunction c]
_) = do
    forall {f :: * -> *} {a} {a}.
(Ord a, ErrorContextM f, Show a, Show a) =>
a -> [a] -> [a] -> f ()
failIfCycle CategoryName
n [c]
c [CategoryName]
us
    let ts2 :: [([c], CategoryName)]
ts2 = forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName forall a b. (a -> b) -> a -> b
$ forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) [ValueRefine c]
rs
    [([c], AnyCategory c)]
is <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
cm) [([c], CategoryName)]
ts2
    forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map ([CategoryName] -> AnyCategory c -> m ()
checker ([CategoryName]
us forall a. [a] -> [a] -> [a]
++ [CategoryName
n]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([c], AnyCategory c)]
is)
  checker [CategoryName]
us (ValueConcrete [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
_ [FunctionVisibility c]
_ [ValueParam c]
_ [ValueRefine c]
rs [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = do
    forall {f :: * -> *} {a} {a}.
(Ord a, ErrorContextM f, Show a, Show a) =>
a -> [a] -> [a] -> f ()
failIfCycle CategoryName
n [c]
c [CategoryName]
us
    let ts2 :: [([c], CategoryName)]
ts2 = forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName forall a b. (a -> b) -> a -> b
$ forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) [ValueRefine c]
rs
    [([c], AnyCategory c)]
is <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
cm) [([c], CategoryName)]
ts2
    forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map ([CategoryName] -> AnyCategory c -> m ()
checker ([CategoryName]
us forall a. [a] -> [a] -> [a]
++ [CategoryName
n]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([c], AnyCategory c)]
is)
  checker [CategoryName]
_ AnyCategory c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  failIfCycle :: a -> [a] -> [a] -> f ()
failIfCycle a
n [a]
c [a]
us =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
n forall a. Ord a => a -> Set a -> Bool
`Set.member` (forall a. Ord a => [a] -> Set a
Set.fromList [a]
us)) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++
                       String
" refers back to itself: " forall a. [a] -> [a] -> [a]
++
                       forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show ([a]
us forall a. [a] -> [a] -> [a]
++ [a
n]))

checkParamVariances :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkParamVariances :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkParamVariances CategoryMap c
cm0 [AnyCategory c]
ts = do
  CategoryMap c
cm <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes CategoryMap c
cm0 [AnyCategory c]
ts
  let r :: CategoryResolver c
r = forall c. CategoryMap c -> CategoryResolver c
CategoryResolver CategoryMap c
cm
  forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {c} {r}.
(Show c, CollectErrorsM m, TypeResolver r) =>
r -> AnyCategory c -> m ()
checkCategory CategoryResolver c
r) [AnyCategory c]
ts
  forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall {m :: * -> *} {c}.
(Show c, CollectErrorsM m) =>
AnyCategory c -> m ()
checkBounds [AnyCategory c]
ts
  where
    categoryContext :: AnyCategory a -> String
categoryContext AnyCategory a
t =
      String
"In " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory a
t) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace (forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory a
t)
    checkBounds :: AnyCategory c -> m ()
checkBounds AnyCategory c
t = forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory c
t forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> (forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Map ParamName [TypeFilter])
getCategoryFilterMap AnyCategory c
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName [TypeFilter] -> m ()
disallowBoundedParams)
    checkCategory :: r -> AnyCategory c -> m ()
checkCategory r
r t :: AnyCategory c
t@(ValueInterface [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
_ [ValueParam c]
ps [ValueRefine c]
rs [ScopedFunction c]
_) = forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory c
t forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      forall {m :: * -> *} {a} {a} {c}.
(Show a, Show a, CollectErrorsM m) =>
[a] -> a -> [ValueParam c] -> m ()
noDuplicates [c]
c CategoryName
n [ValueParam c]
ps
      let vm :: Map ParamName Variance
vm = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ValueParam c
p -> (forall c. ValueParam c -> ParamName
vpParam ValueParam c
p,forall c. ValueParam c -> Variance
vpVariance ValueParam c
p)) [ValueParam c]
ps
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Map ParamName Variance -> ValueRefine a -> m ()
checkRefine r
r Map ParamName Variance
vm) [ValueRefine c]
rs)
    checkCategory r
r t :: AnyCategory c
t@(ValueConcrete [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
_ [FunctionVisibility c]
fv [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
_ [ScopedFunction c]
_) = forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory c
t forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      forall {m :: * -> *} {a} {a} {c}.
(Show a, Show a, CollectErrorsM m) =>
[a] -> a -> [ValueParam c] -> m ()
noDuplicates [c]
c CategoryName
n [ValueParam c]
ps
      let vm :: Map ParamName Variance
vm = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ValueParam c
p -> (forall c. ValueParam c -> ParamName
vpParam ValueParam c
p,forall c. ValueParam c -> Variance
vpVariance ValueParam c
p)) [ValueParam c]
ps
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Map ParamName Variance -> ValueRefine a -> m ()
checkRefine r
r Map ParamName Variance
vm) [ValueRefine c]
rs)
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Map ParamName Variance -> ValueDefine a -> m ()
checkDefine r
r Map ParamName Variance
vm) [ValueDefine c]
ds)
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Map ParamName Variance -> FunctionVisibility a -> m ()
checkVisibility r
r Map ParamName Variance
vm) [FunctionVisibility c]
fv)
    checkCategory r
_ t :: AnyCategory c
t@(InstanceInterface [c]
c Namespace
_ CategoryName
n [PragmaCategory c]
_ [ValueParam c]
ps [ScopedFunction c]
_) = forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory c
t forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      forall {m :: * -> *} {a} {a} {c}.
(Show a, Show a, CollectErrorsM m) =>
[a] -> a -> [ValueParam c] -> m ()
noDuplicates [c]
c CategoryName
n [ValueParam c]
ps
    noDuplicates :: [a] -> a -> [ValueParam c] -> m ()
noDuplicates [a]
c a
n [ValueParam c]
ps = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map [ParamName] -> m ()
checkCount forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [[a]]
group forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam [ValueParam c]
ps) where
      checkCount :: [ParamName] -> m ()
checkCount xa :: [ParamName]
xa@(ParamName
x:ParamName
_:[ParamName]
_) =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
x forall a. [a] -> [a] -> [a]
++ String
" occurs " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ParamName]
xa) forall a. [a] -> [a] -> [a]
++
                         String
" times in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
      checkCount [ParamName]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkRefine :: r -> Map ParamName Variance -> ValueRefine a -> m ()
checkRefine r
r Map ParamName Variance
vm (ValueRefine [a]
c TypeInstance
t) =
      forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName Variance
-> Variance
-> GeneralType TypeInstanceOrParam
-> m ()
validateInstanceVariance r
r Map ParamName Variance
vm Variance
Covariant (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeInstance
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    checkDefine :: r -> Map ParamName Variance -> ValueDefine a -> m ()
checkDefine r
r Map ParamName Variance
vm (ValueDefine [a]
c DefinesInstance
t) =
      forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName Variance -> Variance -> DefinesInstance -> m ()
validateDefinesVariance r
r Map ParamName Variance
vm Variance
Covariant DefinesInstance
t forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DefinesInstance
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    checkVisibility :: r -> Map ParamName Variance -> FunctionVisibility a -> m ()
checkVisibility r
_ Map ParamName Variance
_ FunctionVisibility a
FunctionVisibilityDefault = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkVisibility r
r Map ParamName Variance
vm (FunctionVisibility [a]
_ [([a], GeneralType TypeInstanceOrParam)]
ts2) =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r
-> Map ParamName Variance
-> ([a], GeneralType TypeInstanceOrParam)
-> m ()
checkVisibilitySingle r
r Map ParamName Variance
vm) [([a], GeneralType TypeInstanceOrParam)]
ts2)
    checkVisibilitySingle :: r
-> Map ParamName Variance
-> ([a], GeneralType TypeInstanceOrParam)
-> m ()
checkVisibilitySingle r
r Map ParamName Variance
vm ([a]
c,GeneralType TypeInstanceOrParam
t) =
      forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName Variance
-> Variance
-> GeneralType TypeInstanceOrParam
-> m ()
validateInstanceVariance r
r Map ParamName Variance
vm Variance
Covariant GeneralType TypeInstanceOrParam
t forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In visibility " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c

checkCategoryInstances :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkCategoryInstances :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkCategoryInstances CategoryMap c
cm0 [AnyCategory c]
ts = do
  CategoryMap c
cm <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes CategoryMap c
cm0 [AnyCategory c]
ts
  let r :: CategoryResolver c
r = forall c. CategoryMap c -> CategoryResolver c
CategoryResolver CategoryMap c
cm
  forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {c} {r}.
(CollectErrorsM m, Show c, TypeResolver r) =>
r -> AnyCategory c -> m ()
checkSingle CategoryResolver c
r) [AnyCategory c]
ts
  where
    checkSingle :: r -> AnyCategory c -> m ()
checkSingle r
r AnyCategory c
t = do
      Set ParamName
pa <- forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Set ParamName)
getCategoryParamSet AnyCategory c
t
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {f :: * -> *} {a}.
(ErrorContextM f, Show a) =>
Set ParamName -> ParamFilter a -> f ()
checkFilterParam Set ParamName
pa)  (forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t)
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Set ParamName -> ValueRefine a -> m ()
checkRefine r
r Set ParamName
pa)     (forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t)
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Set ParamName -> ValueDefine a -> m ()
checkDefine r
r Set ParamName
pa)     (forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t)
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Set ParamName -> ParamFilter a -> m ()
checkFilter r
r Set ParamName
pa)     (forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t)
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Set ParamName -> FunctionVisibility a -> m ()
checkVisibility r
r Set ParamName
pa) (forall c. AnyCategory c -> [FunctionVisibility c]
getCategoryVisibilities AnyCategory c
t)
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r -> AnyCategory c -> ScopedFunction c -> m ()
validateCategoryFunction r
r AnyCategory c
t) (forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
t)
    checkVisibility :: r -> Set ParamName -> FunctionVisibility a -> m ()
checkVisibility r
r Set ParamName
fm (FunctionVisibility [a]
c [([a], GeneralType TypeInstanceOrParam)]
ts2) =
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r
-> Set ParamName -> ([a], GeneralType TypeInstanceOrParam) -> m ()
checkVisibilitySingle r
r Set ParamName
fm) [([a], GeneralType TypeInstanceOrParam)]
ts2 forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In visibility at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [a]
c
    checkVisibility r
_ Set ParamName
_ FunctionVisibility a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkVisibilitySingle :: r
-> Set ParamName -> ([a], GeneralType TypeInstanceOrParam) -> m ()
checkVisibilitySingle r
r Set ParamName
fm ([a]
c,GeneralType TypeInstanceOrParam
t) =
      forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> GeneralType TypeInstanceOrParam -> m ()
validateGeneralInstance r
r Set ParamName
fm GeneralType TypeInstanceOrParam
t forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    checkFilterParam :: Set ParamName -> ParamFilter a -> f ()
checkFilterParam Set ParamName
pa (ParamFilter [a]
c ParamName
n TypeFilter
_) =
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ParamName
n forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ParamName
pa) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++ String
" not found"
    checkRefine :: r -> Set ParamName -> ValueRefine a -> m ()
checkRefine r
r Set ParamName
fm (ValueRefine [a]
c TypeInstance
t) =
      forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> TypeInstance -> m ()
validateTypeInstance r
r Set ParamName
fm TypeInstance
t forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeInstance
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    checkDefine :: r -> Set ParamName -> ValueDefine a -> m ()
checkDefine r
r Set ParamName
fm (ValueDefine [a]
c DefinesInstance
t) =
      forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> DefinesInstance -> m ()
validateDefinesInstance r
r Set ParamName
fm DefinesInstance
t forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DefinesInstance
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    checkFilter :: r -> Set ParamName -> ParamFilter a -> m ()
checkFilter r
r Set ParamName
fm (ParamFilter [a]
c ParamName
n TypeFilter
f) =
      forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> TypeFilter -> m ()
validateTypeFilter r
r Set ParamName
fm TypeFilter
f forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeFilter
f forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [a]
c

validateCategoryFunction :: (Show c, CollectErrorsM m, TypeResolver r) =>
  r -> AnyCategory c -> ScopedFunction c -> m ()
validateCategoryFunction :: forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r -> AnyCategory c -> ScopedFunction c -> m ()
validateCategoryFunction r
r AnyCategory c
t ScopedFunction c
f = do
  Set ParamName
pa <- forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Set ParamName)
getCategoryParamSet AnyCategory c
t
  let vm :: Map ParamName Variance
vm = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ValueParam c
p -> (forall c. ValueParam c -> ParamName
vpParam ValueParam c
p,forall c. ValueParam c -> Variance
vpVariance ValueParam c
p)) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
  String
message forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
    FunctionType
funcType <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f
    case forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f of
         SymbolScope
CategoryScope -> forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Set ParamName -> Map ParamName Variance -> FunctionType -> m ()
validatateFunctionType r
r forall a. Set a
Set.empty forall k a. Map k a
Map.empty FunctionType
funcType
         SymbolScope
TypeScope     -> forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Set ParamName -> Map ParamName Variance -> FunctionType -> m ()
validatateFunctionType r
r Set ParamName
pa Map ParamName Variance
vm FunctionType
funcType
         SymbolScope
ValueScope    -> forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Set ParamName -> Map ParamName Variance -> FunctionType -> m ()
validatateFunctionType r
r Set ParamName
pa Map ParamName Variance
vm FunctionType
funcType
         SymbolScope
_             -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *) c.
CollectErrorsM m =>
ScopedFunction c -> m (Map ParamName [TypeFilter])
getFunctionFilterMap ScopedFunction c
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName [TypeFilter] -> m ()
disallowBoundedParams
    forall {m :: * -> *} {c}.
(ErrorContextM m, Show c) =>
SymbolScope -> FunctionVisibility c -> m ()
checkVis (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f) (forall c. ScopedFunction c -> FunctionVisibility c
sfVisibility ScopedFunction c
f) where
      checkVis :: SymbolScope -> FunctionVisibility c -> m ()
checkVis SymbolScope
CategoryScope va :: FunctionVisibility c
va@(FunctionVisibility [c]
_ [([c], GeneralType TypeInstanceOrParam)]
_) =
        forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Category functions must not have restricted visibility: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionVisibility c
va
      checkVis SymbolScope
_ FunctionVisibility c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      message :: String
message
        | forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t forall a. Eq a => a -> a -> Bool
== forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f = String
"In function:\n---\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScopedFunction c
f forall a. [a] -> [a] -> [a]
++ String
"\n---\n"
        | Bool
otherwise = String
"In function inherited from " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f) forall a. [a] -> [a] -> [a]
++
                      forall a. Show a => [a] -> String
formatFullContextBrace (forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t) forall a. [a] -> [a] -> [a]
++ String
":\n---\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScopedFunction c
f forall a. [a] -> [a] -> [a]
++ String
"\n---\n"

topoSortCategories :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
topoSortCategories :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
topoSortCategories CategoryMap c
cm0 [AnyCategory c]
ts = do
  CategoryMap c
cm <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes CategoryMap c
cm0 [AnyCategory c]
ts
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {c}.
(CollectErrorsM m, Show c) =>
CategoryMap c
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update CategoryMap c
cm (forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall c. CategoryMap c -> Map CategoryName (AnyCategory c)
cmAvailable CategoryMap c
cm0) [AnyCategory c]
ts
  where
    update :: CategoryMap c
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update CategoryMap c
cm Set CategoryName
ta (AnyCategory c
t:[AnyCategory c]
ts2) = do
      if forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CategoryName
ta
         then CategoryMap c
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update CategoryMap c
cm Set CategoryName
ta [AnyCategory c]
ts2
         else do
           [([c], AnyCategory c)]
refines <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (\ValueRefine c
r -> forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
cm (forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName forall a b. (a -> b) -> a -> b
$ forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t
           [([c], AnyCategory c)]
defines <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (\ValueDefine c
d -> forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
cm (forall c. ValueDefine c -> [c]
vdContext ValueDefine c
d,DefinesInstance -> CategoryName
diName forall a b. (a -> b) -> a -> b
$ forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine c
d)) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t
           ([AnyCategory c]
ts3,Set CategoryName
ta2) <- CategoryMap c
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update CategoryMap c
cm (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set CategoryName
ta) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ [([c], AnyCategory c)]
refines forall a. [a] -> [a] -> [a]
++ [([c], AnyCategory c)]
defines)
           ([AnyCategory c]
ts4,Set CategoryName
ta3) <- CategoryMap c
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update CategoryMap c
cm Set CategoryName
ta2 [AnyCategory c]
ts2
           forall (m :: * -> *) a. Monad m => a -> m a
return ([AnyCategory c]
ts3 forall a. [a] -> [a] -> [a]
++ [AnyCategory c
t] forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
ts4,Set CategoryName
ta3)
    update CategoryMap c
_ Set CategoryName
ta [AnyCategory c]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ([],Set CategoryName
ta)

mergeRefines :: (CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> [ValueRefine c] -> m [ValueRefine c]
mergeRefines :: forall (m :: * -> *) r c.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> m [ValueRefine c]
mergeRefines r
r Map ParamName [TypeFilter]
f = forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> a -> m b) -> [a] -> m [a]
mergeObjectsM ValueRefine c -> ValueRefine c -> m ()
check where
  check :: ValueRefine c -> ValueRefine c -> m ()
check (ValueRefine [c]
_ t1 :: TypeInstance
t1@(TypeInstance CategoryName
n1 InstanceParams
_)) (ValueRefine [c]
_ t2 :: TypeInstance
t2@(TypeInstance CategoryName
n2 InstanceParams
_))
    | CategoryName
n1 forall a. Eq a => a -> a -> Bool
/= CategoryName
n2 = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show TypeInstance
t1 forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeInstance
t2 forall a. [a] -> [a] -> [a]
++ String
" are incompatible"
    | Bool
otherwise =
      forall (m :: * -> *).
CollectErrorsM m =>
m (MergeTree InferredTypeGuess) -> m ()
noInferredTypes forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
Covariant
                        (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance forall a b. (a -> b) -> a -> b
$ TypeInstance
t1)
                        (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance forall a b. (a -> b) -> a -> b
$ TypeInstance
t2)

mergeDefines :: (CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> [ValueDefine c] -> m [ValueDefine c]
mergeDefines :: forall (m :: * -> *) r c.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> [ValueDefine c]
-> m [ValueDefine c]
mergeDefines r
r Map ParamName [TypeFilter]
f = forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> a -> m b) -> [a] -> m [a]
mergeObjectsM ValueDefine c -> ValueDefine c -> m ()
check where
  check :: ValueDefine c -> ValueDefine c -> m ()
check (ValueDefine [c]
_ t1 :: DefinesInstance
t1@(DefinesInstance CategoryName
n1 InstanceParams
_)) (ValueDefine [c]
_ t2 :: DefinesInstance
t2@(DefinesInstance CategoryName
n2 InstanceParams
_))
    | CategoryName
n1 forall a. Eq a => a -> a -> Bool
/= CategoryName
n2 = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show DefinesInstance
t1 forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DefinesInstance
t2 forall a. [a] -> [a] -> [a]
++ String
" are incompatible"
    | Bool
otherwise = forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> DefinesInstance
-> DefinesInstance
-> m (MergeTree InferredTypeGuess)
checkDefinesMatch r
r Map ParamName [TypeFilter]
f DefinesInstance
t2 DefinesInstance
t1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

noDuplicateRefines :: (Show c, CollectErrorsM m) =>
  [c] -> CategoryName -> [ValueRefine c] -> m ()
noDuplicateRefines :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
[c] -> CategoryName -> [ValueRefine c] -> m ()
noDuplicateRefines [c]
c CategoryName
n [ValueRefine c]
rs = do
  let names :: [(CategoryName, ValueRefine c)]
names = forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (TypeInstance -> CategoryName
tiName forall a b. (a -> b) -> a -> b
$ forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r,ValueRefine c
r)) [ValueRefine c]
rs
  forall c a (m :: * -> *).
(Show c, Show a, CollectErrorsM m) =>
[c] -> CategoryName -> [(CategoryName, a)] -> m ()
noDuplicateCategories [c]
c CategoryName
n [(CategoryName, ValueRefine c)]
names

noDuplicateDefines :: (Show c, CollectErrorsM m) =>
  [c] -> CategoryName -> [ValueDefine c] -> m ()
noDuplicateDefines :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
[c] -> CategoryName -> [ValueDefine c] -> m ()
noDuplicateDefines [c]
c CategoryName
n [ValueDefine c]
ds = do
  let names :: [(CategoryName, ValueDefine c)]
names = forall a b. (a -> b) -> [a] -> [b]
map (\ValueDefine c
d -> (DefinesInstance -> CategoryName
diName forall a b. (a -> b) -> a -> b
$ forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine c
d,ValueDefine c
d)) [ValueDefine c]
ds
  forall c a (m :: * -> *).
(Show c, Show a, CollectErrorsM m) =>
[c] -> CategoryName -> [(CategoryName, a)] -> m ()
noDuplicateCategories [c]
c CategoryName
n [(CategoryName, ValueDefine c)]
names

noDuplicateCategories :: (Show c, Show a, CollectErrorsM m) =>
  [c] -> CategoryName -> [(CategoryName,a)] -> m ()
noDuplicateCategories :: forall c a (m :: * -> *).
(Show c, Show a, CollectErrorsM m) =>
[c] -> CategoryName -> [(CategoryName, a)] -> m ()
noDuplicateCategories [c]
c CategoryName
n [(CategoryName, a)]
ns = do
  let byName :: Map CategoryName [a]
byName = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a. a -> [a] -> [a]
:[])) [(CategoryName, a)]
ns
  forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (CategoryName, [a]) -> m ()
checkCount forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map CategoryName [a]
byName where
    checkCount :: (CategoryName, [a]) -> m ()
checkCount (CategoryName
_,[a
_]) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkCount (CategoryName
n2,[a]
xs) =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show CategoryName
n2 forall a. [a] -> [a] -> [a]
++ String
" occurs " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) forall a. [a] -> [a] -> [a]
++
                       String
" times in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall a. [a] -> [a] -> [a]
++ String
":\n---\n" forall a. [a] -> [a] -> [a]
++
                       forall a. [a] -> [[a]] -> [a]
intercalate String
"\n---\n" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [a]
xs)

flattenAllConnections :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
flattenAllConnections :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
flattenAllConnections (CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm0) [AnyCategory c]
ts = do
  -- We need to process all refines before type-checking can be done.
  Map CategoryName (AnyCategory c)
tm1 <- forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AnyCategory c
-> m (Map CategoryName (AnyCategory c))
-> m (Map CategoryName (AnyCategory c))
preMerge (forall (m :: * -> *) a. Monad m => a -> m a
return Map CategoryName (AnyCategory c)
tm0) (forall a. [a] -> [a]
reverse [AnyCategory c]
ts)
  let r :: CategoryResolver c
r = forall c. CategoryMap c -> CategoryResolver c
CategoryResolver (forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm1)
  ([AnyCategory c]
ts',Map CategoryName (AnyCategory c)
_) <- forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CategoryResolver c
-> AnyCategory c
-> m ([AnyCategory c], Map CategoryName (AnyCategory c))
-> m ([AnyCategory c], Map CategoryName (AnyCategory c))
update CategoryResolver c
r) (forall (m :: * -> *) a. Monad m => a -> m a
return ([],Map CategoryName (AnyCategory c)
tm0)) (forall a. [a] -> [a]
reverse [AnyCategory c]
ts)
  forall (m :: * -> *) a. Monad m => a -> m a
return [AnyCategory c]
ts'
  where
    preMerge :: AnyCategory c
-> m (Map CategoryName (AnyCategory c))
-> m (Map CategoryName (AnyCategory c))
preMerge AnyCategory c
t m (Map CategoryName (AnyCategory c))
u = do
      Map CategoryName (AnyCategory c)
tm <- m (Map CategoryName (AnyCategory c))
u
      AnyCategory c
t' <- Map CategoryName (AnyCategory c)
-> AnyCategory c -> m (AnyCategory c)
preMergeSingle Map CategoryName (AnyCategory c)
tm AnyCategory c
t
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t') AnyCategory c
t' Map CategoryName (AnyCategory c)
tm
    preMergeSingle :: Map CategoryName (AnyCategory c)
-> AnyCategory c -> m (AnyCategory c)
preMergeSingle Map CategoryName (AnyCategory c)
tm (ValueInterface [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ValueRefine c]
rs [ScopedFunction c]
fs) = do
      [ValueRefine c]
rs' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map CategoryName (AnyCategory c)
-> ValueRefine c -> m [ValueRefine c]
getRefines Map CategoryName (AnyCategory c)
tm) [ValueRefine c]
rs
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ScopedFunction c]
-> AnyCategory c
ValueInterface [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ValueRefine c]
rs' [ScopedFunction c]
fs
    preMergeSingle Map CategoryName (AnyCategory c)
tm (ValueConcrete [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [FunctionVisibility c]
fv [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs) = do
      [ValueRefine c]
rs' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map CategoryName (AnyCategory c)
-> ValueRefine c -> m [ValueRefine c]
getRefines Map CategoryName (AnyCategory c)
tm) [ValueRefine c]
rs
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [FunctionVisibility c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueConcrete [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [FunctionVisibility c]
fv [ValueParam c]
ps [ValueRefine c]
rs' [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs
    preMergeSingle Map CategoryName (AnyCategory c)
_ AnyCategory c
t = forall (m :: * -> *) a. Monad m => a -> m a
return AnyCategory c
t
    update :: CategoryResolver c
-> AnyCategory c
-> m ([AnyCategory c], Map CategoryName (AnyCategory c))
-> m ([AnyCategory c], Map CategoryName (AnyCategory c))
update CategoryResolver c
r AnyCategory c
t m ([AnyCategory c], Map CategoryName (AnyCategory c))
u = do
      ([AnyCategory c]
ts2,Map CategoryName (AnyCategory c)
tm) <- m ([AnyCategory c], Map CategoryName (AnyCategory c))
u
      AnyCategory c
t' <- CategoryResolver c
-> Map CategoryName (AnyCategory c)
-> AnyCategory c
-> m (AnyCategory c)
updateSingle CategoryResolver c
r Map CategoryName (AnyCategory c)
tm AnyCategory c
t forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
              String
"In category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) forall a. [a] -> [a] -> [a]
++
                forall a. Show a => [a] -> String
formatFullContextBrace (forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t)
      forall (m :: * -> *) a. Monad m => a -> m a
return ([AnyCategory c]
ts2 forall a. [a] -> [a] -> [a]
++ [AnyCategory c
t'],forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t') AnyCategory c
t' Map CategoryName (AnyCategory c)
tm)
    updateSingle :: CategoryResolver c
-> Map CategoryName (AnyCategory c)
-> AnyCategory c
-> m (AnyCategory c)
updateSingle CategoryResolver c
r Map CategoryName (AnyCategory c)
tm t :: AnyCategory c
t@(ValueInterface [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ValueRefine c]
rs [ScopedFunction c]
fs) = do
      Map ParamName [TypeFilter]
fm <- forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Map ParamName [TypeFilter])
getCategoryFilterMap AnyCategory c
t
      let pm :: Map ParamName (GeneralType TypeInstanceOrParam)
pm = forall c.
AnyCategory c -> Map ParamName (GeneralType TypeInstanceOrParam)
getCategoryParamMap AnyCategory c
t
      [ValueRefine c]
rs' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map CategoryName (AnyCategory c)
-> ValueRefine c -> m [ValueRefine c]
getRefines Map CategoryName (AnyCategory c)
tm) [ValueRefine c]
rs
      [ValueRefine c]
rs'' <- forall (m :: * -> *) r c.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> m [ValueRefine c]
mergeRefines CategoryResolver c
r Map ParamName [TypeFilter]
fm [ValueRefine c]
rs'
      forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
[c] -> CategoryName -> [ValueRefine c] -> m ()
noDuplicateRefines [c]
c CategoryName
n [ValueRefine c]
rs''
      forall {m :: * -> *} {r} {c} {c}.
(CollectErrorsM m, TypeResolver r, Show c, Show c) =>
r
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueRefine c]
-> m ()
checkMerged CategoryResolver c
r Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueRefine c]
rs''
      [PragmaCategory c]
pg2 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map CategoryName (AnyCategory c)
-> ValueRefine c -> m [PragmaCategory c]
getRefinesPragmas Map CategoryName (AnyCategory c)
tm) [ValueRefine c]
rs
      -- Only merge from direct parents.
      [ScopedFunction c]
fs' <- forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r
-> CategoryMap c
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions CategoryResolver c
r (forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) Map ParamName (GeneralType TypeInstanceOrParam)
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [] [ScopedFunction c]
fs
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ScopedFunction c]
-> AnyCategory c
ValueInterface [c]
c Namespace
ns CategoryName
n ([PragmaCategory c]
pgforall a. [a] -> [a] -> [a]
++[PragmaCategory c]
pg2) [ValueParam c]
ps [ValueRefine c]
rs'' [ScopedFunction c]
fs'
    -- TODO: Remove duplication below and/or have separate tests.
    updateSingle CategoryResolver c
r Map CategoryName (AnyCategory c)
tm t :: AnyCategory c
t@(ValueConcrete [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [FunctionVisibility c]
fv [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs) = do
      Map ParamName [TypeFilter]
fm <- forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Map ParamName [TypeFilter])
getCategoryFilterMap AnyCategory c
t
      let pm :: Map ParamName (GeneralType TypeInstanceOrParam)
pm = forall c.
AnyCategory c -> Map ParamName (GeneralType TypeInstanceOrParam)
getCategoryParamMap AnyCategory c
t
      [ValueRefine c]
rs' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map CategoryName (AnyCategory c)
-> ValueRefine c -> m [ValueRefine c]
getRefines Map CategoryName (AnyCategory c)
tm) [ValueRefine c]
rs
      [ValueRefine c]
rs'' <- forall (m :: * -> *) r c.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> m [ValueRefine c]
mergeRefines CategoryResolver c
r Map ParamName [TypeFilter]
fm [ValueRefine c]
rs'
      forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
[c] -> CategoryName -> [ValueRefine c] -> m ()
noDuplicateRefines [c]
c CategoryName
n [ValueRefine c]
rs''
      forall {m :: * -> *} {r} {c} {c}.
(CollectErrorsM m, TypeResolver r, Show c, Show c) =>
r
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueRefine c]
-> m ()
checkMerged CategoryResolver c
r Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueRefine c]
rs''
      [ValueDefine c]
ds' <- forall (m :: * -> *) r c.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> [ValueDefine c]
-> m [ValueDefine c]
mergeDefines CategoryResolver c
r Map ParamName [TypeFilter]
fm [ValueDefine c]
ds
      forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
[c] -> CategoryName -> [ValueDefine c] -> m ()
noDuplicateDefines [c]
c CategoryName
n [ValueDefine c]
ds'
      [PragmaCategory c]
pg2 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map CategoryName (AnyCategory c)
-> ValueRefine c -> m [PragmaCategory c]
getRefinesPragmas Map CategoryName (AnyCategory c)
tm) [ValueRefine c]
rs
      [PragmaCategory c]
pg3 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map CategoryName (AnyCategory c)
-> ValueDefine c -> m [PragmaCategory c]
getDefinesPragmas Map CategoryName (AnyCategory c)
tm) [ValueDefine c]
ds
      -- Only merge from direct parents.
      [ScopedFunction c]
fs' <- forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r
-> CategoryMap c
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions CategoryResolver c
r (forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) Map ParamName (GeneralType TypeInstanceOrParam)
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueDefine c]
ds [ScopedFunction c]
fs
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [FunctionVisibility c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueConcrete [c]
c Namespace
ns CategoryName
n ([PragmaCategory c]
pgforall a. [a] -> [a] -> [a]
++[PragmaCategory c]
pg2forall a. [a] -> [a] -> [a]
++[PragmaCategory c]
pg3) [FunctionVisibility c]
fv [ValueParam c]
ps [ValueRefine c]
rs'' [ValueDefine c]
ds' [ParamFilter c]
vs [ScopedFunction c]
fs'
    updateSingle CategoryResolver c
_ Map CategoryName (AnyCategory c)
_ AnyCategory c
t = forall (m :: * -> *) a. Monad m => a -> m a
return AnyCategory c
t
    getRefines :: Map CategoryName (AnyCategory c)
-> ValueRefine c -> m [ValueRefine c]
getRefines Map CategoryName (AnyCategory c)
tm ra :: ValueRefine c
ra@(ValueRefine [c]
c t :: TypeInstance
t@(TypeInstance CategoryName
n InstanceParams
_)) = do
      ([c]
_,AnyCategory c
v) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory (forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) ([c]
c,CategoryName
n)
      let refines :: [ValueRefine c]
refines = forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
v
      Map ParamName (GeneralType TypeInstanceOrParam)
pa <- Map CategoryName (AnyCategory c)
-> [c]
-> TypeInstance
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
assignParams Map CategoryName (AnyCategory c)
tm [c]
c TypeInstance
t
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValueRefine c
raforall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {c}.
CollectErrorsM m =>
[c]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> ValueRefine c
-> m (ValueRefine c)
subAll [c]
c Map ParamName (GeneralType TypeInstanceOrParam)
pa) [ValueRefine c]
refines
    subAll :: [c]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> ValueRefine c
-> m (ValueRefine c)
subAll [c]
c Map ParamName (GeneralType TypeInstanceOrParam)
pa (ValueRefine [c]
c1 TypeInstance
t1) = do
      TypeInstance
t2 <- forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> TypeInstance -> m TypeInstance
uncheckedSubSingle (forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa) TypeInstance
t1
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> TypeInstance -> ValueRefine c
ValueRefine ([c]
c forall a. [a] -> [a] -> [a]
++ [c]
c1) TypeInstance
t2
    assignParams :: Map CategoryName (AnyCategory c)
-> [c]
-> TypeInstance
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
assignParams Map CategoryName (AnyCategory c)
tm [c]
c (TypeInstance CategoryName
n InstanceParams
ps) = do
      ([c]
_,AnyCategory c
v) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory (forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) ([c]
c,CategoryName
n)
      let ns :: [ParamName]
ns = forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
v
      [(ParamName, GeneralType TypeInstanceOrParam)]
paired <- forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall a. [a] -> Positional a
Positional [ParamName]
ns) InstanceParams
ps
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf GeneralType TypeInstanceOrParam
selfType forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ParamName, GeneralType TypeInstanceOrParam)]
paired
    checkMerged :: r
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueRefine c]
-> m ()
checkMerged r
r Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueRefine c]
rs2 = do
      let rm :: Map CategoryName (ValueRefine c)
rm = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
t -> (TypeInstance -> CategoryName
tiName forall a b. (a -> b) -> a -> b
$ forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
t,ValueRefine c
t)) [ValueRefine c]
rs
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (\ValueRefine c
t -> forall {m :: * -> *} {r} {c} {c}.
(CollectErrorsM m, TypeResolver r, Show c, Show c) =>
r
-> Map ParamName [TypeFilter]
-> Maybe (ValueRefine c)
-> ValueRefine c
-> m ()
checkConvert r
r Map ParamName [TypeFilter]
fm (TypeInstance -> CategoryName
tiName (forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
t) forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName (ValueRefine c)
rm) ValueRefine c
t) [ValueRefine c]
rs2
    checkConvert :: r
-> Map ParamName [TypeFilter]
-> Maybe (ValueRefine c)
-> ValueRefine c
-> m ()
checkConvert r
r Map ParamName [TypeFilter]
fm (Just ta1 :: ValueRefine c
ta1@(ValueRefine [c]
_ TypeInstance
t1)) ta2 :: ValueRefine c
ta2@(ValueRefine [c]
_ TypeInstance
t2) = do
      forall (m :: * -> *).
CollectErrorsM m =>
m (MergeTree InferredTypeGuess) -> m ()
noInferredTypes forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
fm Variance
Covariant
                        (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t1)
                        (forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t2) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!!
                          String
"Cannot refine " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueRefine c
ta1 forall a. [a] -> [a] -> [a]
++ String
" from inherited " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueRefine c
ta2
      forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkConvert r
_ Map ParamName [TypeFilter]
_ Maybe (ValueRefine c)
_ ValueRefine c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    getRefinesPragmas :: Map CategoryName (AnyCategory c)
-> ValueRefine c -> m [PragmaCategory c]
getRefinesPragmas Map CategoryName (AnyCategory c)
tm ValueRefine c
rf = do
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory (forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) (forall c. ValueRefine c -> [c]
vrContext ValueRefine c
rf,TypeInstance -> CategoryName
tiName forall a b. (a -> b) -> a -> b
$ forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
rf)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c. [c] -> PragmaCategory c -> PragmaCategory c
prependCategoryPragmaContext forall a b. (a -> b) -> a -> b
$ forall c. ValueRefine c -> [c]
vrContext ValueRefine c
rf) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [PragmaCategory c]
getCategoryPragmas AnyCategory c
t
    getDefinesPragmas :: Map CategoryName (AnyCategory c)
-> ValueDefine c -> m [PragmaCategory c]
getDefinesPragmas Map CategoryName (AnyCategory c)
tm ValueDefine c
df = do
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory (forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) (forall c. ValueDefine c -> [c]
vdContext ValueDefine c
df,DefinesInstance -> CategoryName
diName forall a b. (a -> b) -> a -> b
$ forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine c
df)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c. [c] -> PragmaCategory c -> PragmaCategory c
prependCategoryPragmaContext forall a b. (a -> b) -> a -> b
$ forall c. ValueDefine c -> [c]
vdContext ValueDefine c
df) forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [PragmaCategory c]
getCategoryPragmas AnyCategory c
t

mergeFunctions :: (Show c, CollectErrorsM m, TypeResolver r) =>
  r -> CategoryMap c -> ParamValues -> ParamFilters -> [ValueRefine c] ->
  [ValueDefine c] -> [ScopedFunction c] -> m [ScopedFunction c]
mergeFunctions :: forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r
-> CategoryMap c
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions r
r CategoryMap c
cm Map ParamName (GeneralType TypeInstanceOrParam)
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueDefine c]
ds [ScopedFunction c]
fs = do
  [ScopedFunction c]
inheritValue <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ValueRefine c -> m [ScopedFunction c]
getRefinesFuncs [ValueRefine c]
rs
  [ScopedFunction c]
inheritType  <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ValueDefine c -> m [ScopedFunction c]
getDefinesFuncs [ValueDefine c]
ds
  let inheritByName :: Map FunctionName [ScopedFunction c]
inheritByName  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy forall c. ScopedFunction c -> ScopedFunction c -> Bool
sameFunction) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f,[ScopedFunction c
f])) forall a b. (a -> b) -> a -> b
$ [ScopedFunction c]
inheritValue forall a. [a] -> [a] -> [a]
++ [ScopedFunction c]
inheritType
  let explicitByName :: Map FunctionName [ScopedFunction c]
explicitByName = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f,[ScopedFunction c
f])) [ScopedFunction c]
fs
  let allNames :: [FunctionName]
allNames = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.union (forall k a. Map k a -> Set k
Map.keysSet Map FunctionName [ScopedFunction c]
inheritByName) (forall k a. Map k a -> Set k
Map.keysSet Map FunctionName [ScopedFunction c]
explicitByName)
  forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map FunctionName [ScopedFunction c]
-> Map FunctionName [ScopedFunction c]
-> FunctionName
-> m (ScopedFunction c)
mergeByName Map FunctionName [ScopedFunction c]
inheritByName Map FunctionName [ScopedFunction c]
explicitByName) [FunctionName]
allNames where
    getRefinesFuncs :: ValueRefine c -> m [ScopedFunction c]
getRefinesFuncs (ValueRefine [c]
c (TypeInstance CategoryName
n InstanceParams
ts2)) = do
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
cm ([c]
c,CategoryName
n)
      let ps :: [ParamName]
ps = forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
      let fs2 :: [ScopedFunction c]
fs2 = forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
t
      [(ParamName, GeneralType TypeInstanceOrParam)]
paired <- forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall a. [a] -> Positional a
Positional [ParamName]
ps) InstanceParams
ts2
      let assigned :: Map ParamName (GeneralType TypeInstanceOrParam)
assigned = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ (ParamName
ParamSelf,GeneralType TypeInstanceOrParam
selfType)forall a. a -> [a] -> [a]
:[(ParamName, GeneralType TypeInstanceOrParam)]
paired
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName (GeneralType TypeInstanceOrParam)
assigned) [ScopedFunction c]
fs2
    getDefinesFuncs :: ValueDefine c -> m [ScopedFunction c]
getDefinesFuncs (ValueDefine [c]
c (DefinesInstance CategoryName
n InstanceParams
ts2)) = do
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getInstanceCategory CategoryMap c
cm ([c]
c,CategoryName
n)
      let ps :: [ParamName]
ps = forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
      let fs2 :: [ScopedFunction c]
fs2 = forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
t
      [(ParamName, GeneralType TypeInstanceOrParam)]
paired <- forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair (forall a. [a] -> Positional a
Positional [ParamName]
ps) InstanceParams
ts2
      let assigned :: Map ParamName (GeneralType TypeInstanceOrParam)
assigned = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ (ParamName
ParamSelf,GeneralType TypeInstanceOrParam
selfType)forall a. a -> [a] -> [a]
:[(ParamName, GeneralType TypeInstanceOrParam)]
paired
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName (GeneralType TypeInstanceOrParam)
assigned) [ScopedFunction c]
fs2
    mergeByName :: Map FunctionName [ScopedFunction c]
-> Map FunctionName [ScopedFunction c]
-> FunctionName
-> m (ScopedFunction c)
mergeByName Map FunctionName [ScopedFunction c]
im Map FunctionName [ScopedFunction c]
em FunctionName
n =
      FunctionName
-> Maybe [ScopedFunction c]
-> Maybe [ScopedFunction c]
-> m (ScopedFunction c)
tryMerge FunctionName
n (FunctionName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map FunctionName [ScopedFunction c]
im) (FunctionName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map FunctionName [ScopedFunction c]
em)
    -- Inherited without an override.
    tryMerge :: FunctionName
-> Maybe [ScopedFunction c]
-> Maybe [ScopedFunction c]
-> m (ScopedFunction c)
tryMerge FunctionName
n (Just [ScopedFunction c]
is) Maybe [ScopedFunction c]
Nothing
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [ScopedFunction c]
is forall a. Eq a => a -> a -> Bool
== Int
1 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [ScopedFunction c]
is
      | Bool
otherwise = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" is inherited " forall a. [a] -> [a] -> [a]
++
                                     forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ScopedFunction c]
is) forall a. [a] -> [a] -> [a]
++ String
" times:\n---\n" forall a. [a] -> [a] -> [a]
++
                                     forall a. [a] -> [[a]] -> [a]
intercalate String
"\n---\n" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [ScopedFunction c]
is)
    -- Not inherited.
    tryMerge FunctionName
n Maybe [ScopedFunction c]
Nothing Maybe [ScopedFunction c]
es = FunctionName
-> Maybe [ScopedFunction c]
-> Maybe [ScopedFunction c]
-> m (ScopedFunction c)
tryMerge FunctionName
n (forall a. a -> Maybe a
Just []) Maybe [ScopedFunction c]
es
    -- Explicit override, possibly inherited.
    tryMerge FunctionName
n (Just [ScopedFunction c]
is) (Just [ScopedFunction c]
es)
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [ScopedFunction c]
es forall a. Eq a => a -> a -> Bool
/= Int
1 = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++ String
" is declared " forall a. [a] -> [a] -> [a]
++
                                          forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ScopedFunction c]
es) forall a. [a] -> [a] -> [a]
++ String
" times:\n---\n" forall a. [a] -> [a] -> [a]
++
                                          forall a. [a] -> [[a]] -> [a]
intercalate String
"\n---\n" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [ScopedFunction c]
es)
      | Bool
otherwise = do
        let ff :: ScopedFunction c
ff@(ScopedFunction [c]
c FunctionName
n2 CategoryName
t SymbolScope
s FunctionVisibility c
v Positional (PassedValue c, Maybe (CallArgLabel c))
as Positional (PassedValue c)
rs2 Positional (ValueParam c)
ps [ParamFilter c]
fa [ScopedFunction c]
ms) = forall a. [a] -> a
head [ScopedFunction c]
es
        forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (ScopedFunction c -> ScopedFunction c -> m ()
checkMerge ScopedFunction c
ff) [ScopedFunction c]
is
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> FunctionName
-> CategoryName
-> SymbolScope
-> FunctionVisibility c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
ScopedFunction [c]
c FunctionName
n2 CategoryName
t SymbolScope
s FunctionVisibility c
v Positional (PassedValue c, Maybe (CallArgLabel c))
as Positional (PassedValue c)
rs2 Positional (ValueParam c)
ps [ParamFilter c]
fa ([ScopedFunction c]
ms forall a. [a] -> [a] -> [a]
++ [ScopedFunction c]
is)
        where
          checkMerge :: ScopedFunction c -> ScopedFunction c -> m ()
checkMerge ScopedFunction c
f1 ScopedFunction c
f2
            | forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f1 forall a. Eq a => a -> a -> Bool
/= forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f2 =
              forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Cannot merge " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f2) forall a. [a] -> [a] -> [a]
++ String
" with " forall a. [a] -> [a] -> [a]
++
                               forall a. Show a => a -> String
show (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f1) forall a. [a] -> [a] -> [a]
++ String
" in function merge:\n---\n" forall a. [a] -> [a] -> [a]
++
                               forall a. Show a => a -> String
show ScopedFunction c
f2 forall a. [a] -> [a] -> [a]
++ String
"\n  ->\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScopedFunction c
f1
            | Bool
otherwise =
              String
"In function merge:\n---\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScopedFunction c
f2 forall a. [a] -> [a] -> [a]
++ String
"\n  ->\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScopedFunction c
f1 forall a. [a] -> [a] -> [a]
++ String
"\n---\n" forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
                forall {m :: * -> *} {a} {c}.
(ErrorContextM m, Show a, Show c) =>
FunctionVisibility c -> a -> m ()
checkMergeVis (forall c. ScopedFunction c -> FunctionVisibility c
sfVisibility ScopedFunction c
f1) (forall c. ScopedFunction c -> FunctionVisibility c
sfVisibility ScopedFunction c
f2)
                FunctionType
f1' <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f1
                FunctionType
f2' <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f2
                case forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f1 of
                     SymbolScope
CategoryScope -> forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> FunctionType
-> FunctionType
-> m ()
checkFunctionConvert r
r forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty FunctionType
f2' FunctionType
f1'
                     SymbolScope
_             -> forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> FunctionType
-> FunctionType
-> m ()
checkFunctionConvert r
r Map ParamName [TypeFilter]
fm Map ParamName (GeneralType TypeInstanceOrParam)
pm FunctionType
f2' FunctionType
f1'
                forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ forall {m :: * -> *} {c} {c} {c} {c}.
(ErrorContextM m, Show c, Show c, Show c, Show c) =>
(PassedValue c, Maybe (CallArgLabel c))
-> (PassedValue c, Maybe (CallArgLabel c)) -> m ()
checkArgNames (forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f1) (forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f2)
          checkMergeVis :: FunctionVisibility c -> a -> m ()
checkMergeVis FunctionVisibility c
FunctionVisibilityDefault a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
          checkMergeVis FunctionVisibility c
v1 a
v2 =
            forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Cannot supersede " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
v2 forall a. [a] -> [a] -> [a]
++ String
" with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionVisibility c
v1
          checkArgNames :: (PassedValue c, Maybe (CallArgLabel c))
-> (PassedValue c, Maybe (CallArgLabel c)) -> m ()
checkArgNames (PassedValue c
_,Maybe (CallArgLabel c)
n1) (PassedValue c
_,Maybe (CallArgLabel c)
n2)
            | forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. CallArgLabel c -> String
calName Maybe (CallArgLabel c)
n1 forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. CallArgLabel c -> String
calName Maybe (CallArgLabel c)
n2 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
          checkArgNames (PassedValue c, Maybe (CallArgLabel c))
t1 (PassedValue c, Maybe (CallArgLabel c))
t2 =
            forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected arg label from " forall a. [a] -> [a] -> [a]
++ forall {c} {a}.
(Show c, Show a) =>
(PassedValue c, Maybe a) -> String
showArgName (PassedValue c, Maybe (CallArgLabel c))
t2 forall a. [a] -> [a] -> [a]
++
                            String
" to match " forall a. [a] -> [a] -> [a]
++ forall {c} {a}.
(Show c, Show a) =>
(PassedValue c, Maybe a) -> String
showArgName (PassedValue c, Maybe (CallArgLabel c))
t1
          showArgName :: (PassedValue c, Maybe a) -> String
showArgName (PassedValue c
t',Maybe a
Nothing) = forall a. Show a => a -> String
show PassedValue c
t'
          showArgName (PassedValue c
t',Just a
n') = forall a. Show a => a -> String
show (forall c. PassedValue c -> ValueType
pvType PassedValue c
t') forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n'

data FunctionName =
  FunctionName {
    FunctionName -> String
fnName :: String
  } |
  BuiltinPresent |
  BuiltinReduce |
  BuiltinRequire |
  BuiltinStrong |
  BuiltinIdentify |
  BuiltinTypename
  deriving (FunctionName -> FunctionName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FunctionName -> FunctionName -> Bool
$c/= :: FunctionName -> FunctionName -> Bool
== :: FunctionName -> FunctionName -> Bool
$c== :: FunctionName -> FunctionName -> Bool
Eq,Eq FunctionName
FunctionName -> FunctionName -> Bool
FunctionName -> FunctionName -> Ordering
FunctionName -> FunctionName -> FunctionName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FunctionName -> FunctionName -> FunctionName
$cmin :: FunctionName -> FunctionName -> FunctionName
max :: FunctionName -> FunctionName -> FunctionName
$cmax :: FunctionName -> FunctionName -> FunctionName
>= :: FunctionName -> FunctionName -> Bool
$c>= :: FunctionName -> FunctionName -> Bool
> :: FunctionName -> FunctionName -> Bool
$c> :: FunctionName -> FunctionName -> Bool
<= :: FunctionName -> FunctionName -> Bool
$c<= :: FunctionName -> FunctionName -> Bool
< :: FunctionName -> FunctionName -> Bool
$c< :: FunctionName -> FunctionName -> Bool
compare :: FunctionName -> FunctionName -> Ordering
$ccompare :: FunctionName -> FunctionName -> Ordering
Ord)

instance Show FunctionName where
  show :: FunctionName -> String
show (FunctionName String
n) = String
n
  show FunctionName
BuiltinPresent  = String
"present"
  show FunctionName
BuiltinReduce   = String
"reduce"
  show FunctionName
BuiltinRequire  = String
"require"
  show FunctionName
BuiltinStrong   = String
"strong"
  show FunctionName
BuiltinIdentify = String
"identify"
  show FunctionName
BuiltinTypename = String
"typename"

data CallArgLabel c =
  CallArgLabel {
    forall c. CallArgLabel c -> [c]
calContext :: [c],
    forall c. CallArgLabel c -> String
calName ::String
  }
  deriving (CallArgLabel c -> CallArgLabel c -> Bool
forall c. Eq c => CallArgLabel c -> CallArgLabel c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallArgLabel c -> CallArgLabel c -> Bool
$c/= :: forall c. Eq c => CallArgLabel c -> CallArgLabel c -> Bool
== :: CallArgLabel c -> CallArgLabel c -> Bool
$c== :: forall c. Eq c => CallArgLabel c -> CallArgLabel c -> Bool
Eq,CallArgLabel c -> CallArgLabel c -> Bool
CallArgLabel c -> CallArgLabel c -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {c}. Ord c => Eq (CallArgLabel c)
forall c. Ord c => CallArgLabel c -> CallArgLabel c -> Bool
forall c. Ord c => CallArgLabel c -> CallArgLabel c -> Ordering
forall c.
Ord c =>
CallArgLabel c -> CallArgLabel c -> CallArgLabel c
min :: CallArgLabel c -> CallArgLabel c -> CallArgLabel c
$cmin :: forall c.
Ord c =>
CallArgLabel c -> CallArgLabel c -> CallArgLabel c
max :: CallArgLabel c -> CallArgLabel c -> CallArgLabel c
$cmax :: forall c.
Ord c =>
CallArgLabel c -> CallArgLabel c -> CallArgLabel c
>= :: CallArgLabel c -> CallArgLabel c -> Bool
$c>= :: forall c. Ord c => CallArgLabel c -> CallArgLabel c -> Bool
> :: CallArgLabel c -> CallArgLabel c -> Bool
$c> :: forall c. Ord c => CallArgLabel c -> CallArgLabel c -> Bool
<= :: CallArgLabel c -> CallArgLabel c -> Bool
$c<= :: forall c. Ord c => CallArgLabel c -> CallArgLabel c -> Bool
< :: CallArgLabel c -> CallArgLabel c -> Bool
$c< :: forall c. Ord c => CallArgLabel c -> CallArgLabel c -> Bool
compare :: CallArgLabel c -> CallArgLabel c -> Ordering
$ccompare :: forall c. Ord c => CallArgLabel c -> CallArgLabel c -> Ordering
Ord)

instance Show c => Show (CallArgLabel c) where
  show :: CallArgLabel c -> String
show (CallArgLabel [c]
c String
n) = String
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

matchesCallArgLabel :: CallArgLabel c -> String -> Bool
matchesCallArgLabel :: forall c. CallArgLabel c -> String -> Bool
matchesCallArgLabel (CallArgLabel [c]
_ String
n1) String
n2 = forall a. [a] -> [a]
init String
n1 forall a. Eq a => a -> a -> Bool
== String
n2

data FunctionVisibility c =
  FunctionVisibility {
    forall c. FunctionVisibility c -> [c]
fvContext :: [c],
    forall c.
FunctionVisibility c -> [([c], GeneralType TypeInstanceOrParam)]
fvTypes :: [([c],GeneralInstance)]
  } |
  FunctionVisibilityDefault
  deriving (FunctionVisibility c -> FunctionVisibility c -> Bool
forall c.
Eq c =>
FunctionVisibility c -> FunctionVisibility c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FunctionVisibility c -> FunctionVisibility c -> Bool
$c/= :: forall c.
Eq c =>
FunctionVisibility c -> FunctionVisibility c -> Bool
== :: FunctionVisibility c -> FunctionVisibility c -> Bool
$c== :: forall c.
Eq c =>
FunctionVisibility c -> FunctionVisibility c -> Bool
Eq)

instance Show c => Show (FunctionVisibility c) where
  show :: FunctionVisibility c -> String
show FunctionVisibility c
FunctionVisibilityDefault = String
"visibility _"
  show (FunctionVisibility [c]
c [([c], GeneralType TypeInstanceOrParam)]
ts) = String
"visibility " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([c], GeneralType TypeInstanceOrParam)]
ts) forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

data ScopedFunction c =
  ScopedFunction {
    forall c. ScopedFunction c -> [c]
sfContext :: [c],
    forall c. ScopedFunction c -> FunctionName
sfName :: FunctionName,
    forall c. ScopedFunction c -> CategoryName
sfType :: CategoryName,
    forall c. ScopedFunction c -> SymbolScope
sfScope :: SymbolScope,
    forall c. ScopedFunction c -> FunctionVisibility c
sfVisibility :: FunctionVisibility c,
    forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs :: Positional (PassedValue c, Maybe (CallArgLabel c)),
    forall c. ScopedFunction c -> Positional (PassedValue c)
sfReturns :: Positional (PassedValue c),
    forall c. ScopedFunction c -> Positional (ValueParam c)
sfParams :: Positional (ValueParam c),
    forall c. ScopedFunction c -> [ParamFilter c]
sfFilters :: [ParamFilter c],
    forall c. ScopedFunction c -> [ScopedFunction c]
sfMerges :: [ScopedFunction c]
  }

instance Show c => Show (ScopedFunction c) where
  show :: ScopedFunction c -> String
show ScopedFunction c
f = forall c. Show c => String -> String -> ScopedFunction c -> String
showFunctionInContext (forall a. Show a => a -> String
show (forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f) forall a. [a] -> [a] -> [a]
++ String
" ") String
"" ScopedFunction c
f

sameFunction :: ScopedFunction c -> ScopedFunction c -> Bool
sameFunction :: forall c. ScopedFunction c -> ScopedFunction c -> Bool
sameFunction (ScopedFunction [c]
_ FunctionName
n1 CategoryName
t1 SymbolScope
s1 FunctionVisibility c
_ Positional (PassedValue c, Maybe (CallArgLabel c))
_ Positional (PassedValue c)
_ Positional (ValueParam c)
_ [ParamFilter c]
_ [ScopedFunction c]
_) (ScopedFunction [c]
_ FunctionName
n2 CategoryName
t2 SymbolScope
s2 FunctionVisibility c
_ Positional (PassedValue c, Maybe (CallArgLabel c))
_ Positional (PassedValue c)
_ Positional (ValueParam c)
_ [ParamFilter c]
_ [ScopedFunction c]
_) =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. a -> a
id [FunctionName
n1 forall a. Eq a => a -> a -> Bool
== FunctionName
n2, CategoryName
t1 forall a. Eq a => a -> a -> Bool
== CategoryName
t2, SymbolScope
s1 forall a. Eq a => a -> a -> Bool
== SymbolScope
s2]

showFunctionInContext :: Show c => String -> String -> ScopedFunction c -> String
showFunctionInContext :: forall c. Show c => String -> String -> ScopedFunction c -> String
showFunctionInContext String
s String
indent (ScopedFunction [c]
cs FunctionName
n CategoryName
t SymbolScope
_ FunctionVisibility c
_ Positional (PassedValue c, Maybe (CallArgLabel c))
as Positional (PassedValue c)
rs Positional (ValueParam c)
ps [ParamFilter c]
fa [ScopedFunction c]
ms) =
  String
indent forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"/*" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CategoryName
t forall a. [a] -> [a] -> [a]
++ String
"*/ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++
  forall {c}. [ValueParam c] -> String
showParams (forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatContext [c]
cs forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
v -> String
indent forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => ParamFilter a -> String
formatValue ParamFilter c
v forall a. [a] -> [a] -> [a]
++ String
"\n") [ParamFilter c]
fa) forall a. [a] -> [a] -> [a]
++
  String
indent forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map forall {c} {c}. (PassedValue c, Maybe (CallArgLabel c)) -> String
showArg forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c, Maybe (CallArgLabel c))
as) forall a. [a] -> [a] -> [a]
++ String
") -> " forall a. [a] -> [a] -> [a]
++
  String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PassedValue c -> ValueType
pvType) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs) forall a. [a] -> [a] -> [a]
++ String
")" forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => Set a -> String
showMerges (forall {c}. [ScopedFunction c] -> Set CategoryName
flatten [ScopedFunction c]
ms)
  where
    showArg :: (PassedValue c, Maybe (CallArgLabel c)) -> String
showArg (PassedValue c
a,Maybe (CallArgLabel c)
Nothing) = forall a. Show a => a -> String
show (forall c. PassedValue c -> ValueType
pvType PassedValue c
a)
    showArg (PassedValue c
a,Just CallArgLabel c
n2) = forall a. Show a => a -> String
show (forall c. PassedValue c -> ValueType
pvType PassedValue c
a) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. CallArgLabel c -> String
calName CallArgLabel c
n2)
    showParams :: [ValueParam c] -> String
showParams [] = String
""
    showParams [ValueParam c]
ps2 = String
"<" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ValueParam c -> ParamName
vpParam) [ValueParam c]
ps2) forall a. [a] -> [a] -> [a]
++ String
">"
    formatContext :: [a] -> String
formatContext [a]
cs2 = String
"/*" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContext [a]
cs2 forall a. [a] -> [a] -> [a]
++ String
"*/"
    formatValue :: ParamFilter a -> String
formatValue ParamFilter a
v = String
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ParamFilter c -> ParamName
pfParam ParamFilter a
v) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter a
v) forall a. [a] -> [a] -> [a]
++
                    String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatContext (forall c. ParamFilter c -> [c]
pfContext ParamFilter a
v)
    flatten :: [ScopedFunction c] -> Set CategoryName
flatten [] = forall a. Set a
Set.empty
    flatten [ScopedFunction c]
ms2 = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ScopedFunction c -> CategoryName
sfType [ScopedFunction c]
ms2)forall a. a -> [a] -> [a]
:(forall a b. (a -> b) -> [a] -> [b]
map ([ScopedFunction c] -> Set CategoryName
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ScopedFunction c -> [ScopedFunction c]
sfMerges) [ScopedFunction c]
ms2)
    showMerges :: Set a -> String
showMerges Set a
ms2
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Set a -> [a]
Set.toList Set a
ms2) = String
" /*not merged*/"
      | Bool
otherwise = String
" /*merged from: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set a
ms2) forall a. [a] -> [a] -> [a]
++ String
"*/"

data PassedValue c =
  PassedValue {
    forall c. PassedValue c -> [c]
pvContext :: [c],
    forall c. PassedValue c -> ValueType
pvType :: ValueType
  }

instance Show c => Show (PassedValue c) where
  show :: PassedValue c -> String
show (PassedValue [c]
c ValueType
t) = forall a. Show a => a -> String
show ValueType
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

parsedToFunctionType :: (Show c, CollectErrorsM m) =>
  ScopedFunction c -> m FunctionType
parsedToFunctionType :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType (ScopedFunction [c]
c FunctionName
n CategoryName
_ SymbolScope
_ FunctionVisibility c
_ Positional (PassedValue c, Maybe (CallArgLabel c))
as Positional (PassedValue c)
rs Positional (ValueParam c)
ps [ParamFilter c]
fa [ScopedFunction c]
_) = do
  let as' :: Positional ValueType
as' = forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c. PassedValue c -> ValueType
pvType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c, Maybe (CallArgLabel c))
as
  let rs' :: Positional ValueType
rs' = forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. PassedValue c -> ValueType
pvType forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs
  let ps' :: Positional ParamName
ps' = forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps
  forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ ParamFilter c -> m ()
checkFilter [ParamFilter c]
fa
  let fm :: Map ParamName [TypeFilter]
fm = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
f -> (forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f,[forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter c
f])) [ParamFilter c]
fa
  let fa' :: InstanceFilters
fa' = forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {k} {a}. Ord k => Map k [a] -> k -> [a]
getFilters Map ParamName [TypeFilter]
fm) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional ParamName
ps'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Positional ValueType
-> Positional ValueType
-> Positional ParamName
-> InstanceFilters
-> FunctionType
FunctionType Positional ValueType
as' Positional ValueType
rs' Positional ParamName
ps' InstanceFilters
fa'
  where
    pa :: Set ParamName
pa = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps
    checkFilter :: ParamFilter c -> m ()
checkFilter ParamFilter c
f =
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ (forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ParamName
pa) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Filtered param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f) forall a. [a] -> [a] -> [a]
++
                       String
" is not defined for function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FunctionName
n forall a. [a] -> [a] -> [a]
++
                       forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
    getFilters :: Map k [a] -> k -> [a]
getFilters Map k [a]
fm2 k
n2 =
      case k
n2 forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map k [a]
fm2 of
           (Just [a]
fs) -> [a]
fs
           Maybe [a]
_ -> []

uncheckedSubFunction :: (Show c, CollectErrorsM m) =>
  ParamValues -> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction = forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GeneralType TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
fixTypeParams

unfixedSubFunction :: (Show c, CollectErrorsM m) =>
  ParamValues -> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName (GeneralType TypeInstanceOrParam)
pa ff :: ScopedFunction c
ff@(ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s FunctionVisibility c
v Positional (PassedValue c, Maybe (CallArgLabel c))
as Positional (PassedValue c)
rs Positional (ValueParam c)
ps [ParamFilter c]
fa [ScopedFunction c]
ms) =
  String
"In function:\n---\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScopedFunction c
ff forall a. [a] -> [a] -> [a]
++ String
"\n---\n" forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
    let unresolved :: Map ParamName (GeneralType TypeInstanceOrParam)
unresolved = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ParamName
n2 -> (ParamName
n2,forall a. (Eq a, Ord a) => a -> GeneralType a
singleType forall a b. (a -> b) -> a -> b
$ Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False ParamName
n2)) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. ValueParam c -> ParamName
vpParam forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps
    let pa' :: Map ParamName (GeneralType TypeInstanceOrParam)
pa' = Map ParamName (GeneralType TypeInstanceOrParam)
pa forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map ParamName (GeneralType TypeInstanceOrParam)
unresolved
    Positional (PassedValue c, Maybe (CallArgLabel c))
as' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {c} {b}.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> (PassedValue c, b) -> m (PassedValue c, b)
subPassedNamed Map ParamName (GeneralType TypeInstanceOrParam)
pa') forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c, Maybe (CallArgLabel c))
as
    Positional (PassedValue c)
rs' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {c}.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> PassedValue c -> m (PassedValue c)
subPassed Map ParamName (GeneralType TypeInstanceOrParam)
pa') forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs
    [ParamFilter c]
fa' <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {c}.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamFilter c -> m (ParamFilter c)
subFilter Map ParamName (GeneralType TypeInstanceOrParam)
pa') [ParamFilter c]
fa
    [ScopedFunction c]
ms' <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction Map ParamName (GeneralType TypeInstanceOrParam)
pa) [ScopedFunction c]
ms
    FunctionVisibility c
v' <- forall {m :: * -> *} {c}.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> FunctionVisibility c -> m (FunctionVisibility c)
subVisibility Map ParamName (GeneralType TypeInstanceOrParam)
pa' FunctionVisibility c
v
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall c.
[c]
-> FunctionName
-> CategoryName
-> SymbolScope
-> FunctionVisibility c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s FunctionVisibility c
v' Positional (PassedValue c, Maybe (CallArgLabel c))
as' Positional (PassedValue c)
rs' Positional (ValueParam c)
ps [ParamFilter c]
fa' [ScopedFunction c]
ms')
    where
      subPassedNamed :: Map ParamName (GeneralType TypeInstanceOrParam)
-> (PassedValue c, b) -> m (PassedValue c, b)
subPassedNamed Map ParamName (GeneralType TypeInstanceOrParam)
pa2 (PassedValue c
a,b
n2) = do
        PassedValue c
a2 <- forall {m :: * -> *} {c}.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> PassedValue c -> m (PassedValue c)
subPassed Map ParamName (GeneralType TypeInstanceOrParam)
pa2 PassedValue c
a
        forall (m :: * -> *) a. Monad m => a -> m a
return (PassedValue c
a2,b
n2)
      subPassed :: Map ParamName (GeneralType TypeInstanceOrParam)
-> PassedValue c -> m (PassedValue c)
subPassed Map ParamName (GeneralType TypeInstanceOrParam)
pa2 (PassedValue [c]
c2 ValueType
t2) = do
        ValueType
t' <- forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> ValueType -> m ValueType
uncheckedSubValueType (forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa2) ValueType
t2
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> ValueType -> PassedValue c
PassedValue [c]
c2 ValueType
t'
      subFilter :: Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamFilter c -> m (ParamFilter c)
subFilter Map ParamName (GeneralType TypeInstanceOrParam)
pa2 (ParamFilter [c]
c2 ParamName
n2 TypeFilter
f) = do
        TypeFilter
f' <- forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> TypeFilter -> m TypeFilter
uncheckedSubFilter (forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa2) TypeFilter
f
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> ParamName -> TypeFilter -> ParamFilter c
ParamFilter [c]
c2 ParamName
n2 TypeFilter
f'
      subVisibility :: Map ParamName (GeneralType TypeInstanceOrParam)
-> FunctionVisibility c -> m (FunctionVisibility c)
subVisibility Map ParamName (GeneralType TypeInstanceOrParam)
_ FunctionVisibility c
FunctionVisibilityDefault = forall (m :: * -> *) a. Monad m => a -> m a
return forall c. FunctionVisibility c
FunctionVisibilityDefault
      subVisibility Map ParamName (GeneralType TypeInstanceOrParam)
pa2 (FunctionVisibility [c]
c2 [([c], GeneralType TypeInstanceOrParam)]
ts) = do
        [([c], GeneralType TypeInstanceOrParam)]
ts' <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {a}.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> (a, GeneralType TypeInstanceOrParam)
-> m (a, GeneralType TypeInstanceOrParam)
subVisibilitySingle Map ParamName (GeneralType TypeInstanceOrParam)
pa2) [([c], GeneralType TypeInstanceOrParam)]
ts
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> [([c], GeneralType TypeInstanceOrParam)] -> FunctionVisibility c
FunctionVisibility [c]
c2 [([c], GeneralType TypeInstanceOrParam)]
ts'
      subVisibilitySingle :: Map ParamName (GeneralType TypeInstanceOrParam)
-> (a, GeneralType TypeInstanceOrParam)
-> m (a, GeneralType TypeInstanceOrParam)
subVisibilitySingle Map ParamName (GeneralType TypeInstanceOrParam)
pa2 (a
c2,GeneralType TypeInstanceOrParam
t2) = do
        GeneralType TypeInstanceOrParam
t2' <- forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
uncheckedSubInstance (forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa2) GeneralType TypeInstanceOrParam
t2
        forall (m :: * -> *) a. Monad m => a -> m a
return (a
c2,GeneralType TypeInstanceOrParam
t2')

replaceSelfFunction :: (Show c, CollectErrorsM m) =>
  GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
GeneralType TypeInstanceOrParam
-> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction GeneralType TypeInstanceOrParam
self ff :: ScopedFunction c
ff@(ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s FunctionVisibility c
v Positional (PassedValue c, Maybe (CallArgLabel c))
as Positional (PassedValue c)
rs Positional (ValueParam c)
ps [ParamFilter c]
fa [ScopedFunction c]
ms) =
  String
"In function:\n---\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScopedFunction c
ff forall a. [a] -> [a] -> [a]
++ String
"\n---\n" forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
    Positional (PassedValue c, Maybe (CallArgLabel c))
as' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (PassedValue c, Maybe (CallArgLabel c))
-> m (PassedValue c, Maybe (CallArgLabel c))
subPassedNamed forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c, Maybe (CallArgLabel c))
as
    Positional (PassedValue c)
rs' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM PassedValue c -> m (PassedValue c)
subPassed forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs
    [ParamFilter c]
fa' <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ParamFilter c -> m (ParamFilter c)
subFilter [ParamFilter c]
fa
    [ScopedFunction c]
ms' <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
GeneralType TypeInstanceOrParam
-> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction GeneralType TypeInstanceOrParam
self) [ScopedFunction c]
ms
    FunctionVisibility c
v' <- FunctionVisibility c -> m (FunctionVisibility c)
subVisibility FunctionVisibility c
v
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall c.
[c]
-> FunctionName
-> CategoryName
-> SymbolScope
-> FunctionVisibility c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s FunctionVisibility c
v' Positional (PassedValue c, Maybe (CallArgLabel c))
as' Positional (PassedValue c)
rs' Positional (ValueParam c)
ps [ParamFilter c]
fa' [ScopedFunction c]
ms')
    where
      subPassedNamed :: (PassedValue c, Maybe (CallArgLabel c))
-> m (PassedValue c, Maybe (CallArgLabel c))
subPassedNamed (PassedValue c
a,Maybe (CallArgLabel c)
n2) = do
        PassedValue c
a2 <- PassedValue c -> m (PassedValue c)
subPassed PassedValue c
a
        forall (m :: * -> *) a. Monad m => a -> m a
return (PassedValue c
a2,Maybe (CallArgLabel c)
n2)
      subPassed :: PassedValue c -> m (PassedValue c)
subPassed (PassedValue [c]
c2 ValueType
t2) = do
        ValueType
t' <- forall (m :: * -> *).
CollectErrorsM m =>
GeneralType TypeInstanceOrParam -> ValueType -> m ValueType
replaceSelfValueType GeneralType TypeInstanceOrParam
self ValueType
t2
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> ValueType -> PassedValue c
PassedValue [c]
c2 ValueType
t'
      subFilter :: ParamFilter c -> m (ParamFilter c)
subFilter (ParamFilter [c]
c2 ParamName
n2 TypeFilter
f) = do
        TypeFilter
f' <- forall (m :: * -> *).
CollectErrorsM m =>
GeneralType TypeInstanceOrParam -> TypeFilter -> m TypeFilter
replaceSelfFilter GeneralType TypeInstanceOrParam
self TypeFilter
f
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> ParamName -> TypeFilter -> ParamFilter c
ParamFilter [c]
c2 ParamName
n2 TypeFilter
f'
      subVisibility :: FunctionVisibility c -> m (FunctionVisibility c)
subVisibility FunctionVisibility c
FunctionVisibilityDefault = forall (m :: * -> *) a. Monad m => a -> m a
return forall c. FunctionVisibility c
FunctionVisibilityDefault
      subVisibility (FunctionVisibility [c]
c2 [([c], GeneralType TypeInstanceOrParam)]
ts) = do
        [([c], GeneralType TypeInstanceOrParam)]
ts' <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ([c], GeneralType TypeInstanceOrParam)
-> m ([c], GeneralType TypeInstanceOrParam)
subVisibilitySingle [([c], GeneralType TypeInstanceOrParam)]
ts
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> [([c], GeneralType TypeInstanceOrParam)] -> FunctionVisibility c
FunctionVisibility [c]
c2 [([c], GeneralType TypeInstanceOrParam)]
ts'
      subVisibilitySingle :: ([c], GeneralType TypeInstanceOrParam)
-> m ([c], GeneralType TypeInstanceOrParam)
subVisibilitySingle ([c]
c2,GeneralType TypeInstanceOrParam
t2) = do
        GeneralType TypeInstanceOrParam
t2' <- forall (m :: * -> *).
CollectErrorsM m =>
GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
replaceSelfInstance GeneralType TypeInstanceOrParam
self GeneralType TypeInstanceOrParam
t2
        forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,GeneralType TypeInstanceOrParam
t2')

checkFunctionCallVisibility :: (Show c, CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> ScopedFunction c -> GeneralInstance -> m ()
checkFunctionCallVisibility :: forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> ScopedFunction c
-> GeneralType TypeInstanceOrParam
-> m ()
checkFunctionCallVisibility r
r Map ParamName [TypeFilter]
fs ScopedFunction c
f = FunctionVisibility c -> GeneralType TypeInstanceOrParam -> m ()
check (forall c. ScopedFunction c -> FunctionVisibility c
sfVisibility ScopedFunction c
f) where
  check :: FunctionVisibility c -> GeneralType TypeInstanceOrParam -> m ()
check FunctionVisibility c
FunctionVisibilityDefault GeneralType TypeInstanceOrParam
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  check (FunctionVisibility [c]
_ [([c], GeneralType TypeInstanceOrParam)]
ts) GeneralType TypeInstanceOrParam
t0 = String
"Cannot call " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) forall a. [a] -> [a] -> [a]
++ String
" in context of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
t0 forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
!!>
    forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectFirstM_ (forall a b. (a -> b) -> [a] -> [b]
map (GeneralType TypeInstanceOrParam
-> ([c], GeneralType TypeInstanceOrParam)
-> m (MergeTree InferredTypeGuess)
checkSingle GeneralType TypeInstanceOrParam
t0) [([c], GeneralType TypeInstanceOrParam)]
ts)
  checkSingle :: GeneralType TypeInstanceOrParam
-> ([c], GeneralType TypeInstanceOrParam)
-> m (MergeTree InferredTypeGuess)
checkSingle GeneralType TypeInstanceOrParam
t0 ([c]
c,GeneralType TypeInstanceOrParam
t) = String
"In visibility " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
t forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
formatFullContextBrace [c]
c forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??>
    forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
fs Variance
Covariant GeneralType TypeInstanceOrParam
t0 GeneralType TypeInstanceOrParam
t

data PatternMatch =
  TypePattern {
    PatternMatch -> Variance
tpVariance :: Variance,
    PatternMatch -> ValueType
tpData :: ValueType,
    PatternMatch -> ValueType
tpPattern :: ValueType
  } |
  DefinesPattern {
    PatternMatch -> TypeInstance
dpData :: TypeInstance,
    PatternMatch -> DefinesInstance
dpPattern :: DefinesInstance
  }

instance Show PatternMatch where
  show :: PatternMatch -> String
show (TypePattern Variance
Covariant     ValueType
l ValueType
r) = forall a. Show a => a -> String
show ValueType
l forall a. [a] -> [a] -> [a]
++ String
" -> "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
r
  show (TypePattern Variance
Contravariant ValueType
l ValueType
r) = forall a. Show a => a -> String
show ValueType
l forall a. [a] -> [a] -> [a]
++ String
" <- "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
r
  show (TypePattern Variance
Invariant     ValueType
l ValueType
r) = forall a. Show a => a -> String
show ValueType
l forall a. [a] -> [a] -> [a]
++ String
" <-> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ValueType
r
  show (DefinesPattern TypeInstance
l DefinesInstance
r) = forall a. Show a => a -> String
show TypeInstance
l forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DefinesInstance
r

inferParamTypes :: (CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> ParamValues -> [PatternMatch] ->
  m (MergeTree InferredTypeGuess)
inferParamTypes :: forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> [PatternMatch]
-> m (MergeTree InferredTypeGuess)
inferParamTypes r
r Map ParamName [TypeFilter]
f Map ParamName (GeneralType TypeInstanceOrParam)
ps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a (f :: * -> *). (Mergeable a, Foldable f) => f a -> a
mergeAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM PatternMatch -> m (MergeTree InferredTypeGuess)
single where
  single :: PatternMatch -> m (MergeTree InferredTypeGuess)
single (TypePattern Variance
v ValueType
t1 ValueType
t2) = do
    ValueType
t2' <- forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> ValueType -> m ValueType
uncheckedSubValueType (forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
ps) ValueType
t2
    forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> ValueType
-> ValueType
-> m (MergeTree InferredTypeGuess)
checkValueTypeMatch r
r Map ParamName [TypeFilter]
f Variance
v ValueType
t1 ValueType
t2'
  single (DefinesPattern TypeInstance
t1 (DefinesInstance CategoryName
n InstanceParams
ps2)) = do
    InstanceParams
ps3 <- forall r (m :: * -> *).
(TypeResolver r, CollectErrorsM m) =>
r -> TypeInstance -> CategoryName -> m InstanceParams
trDefines r
r TypeInstance
t1 CategoryName
n
    InstanceParams
ps2' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Positional a
Positional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
uncheckedSubInstance (forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
ps)) forall a b. (a -> b) -> a -> b
$ forall a. Positional a -> [a]
pValues InstanceParams
ps2
    forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> DefinesInstance
-> DefinesInstance
-> m (MergeTree InferredTypeGuess)
checkDefinesMatch r
r Map ParamName [TypeFilter]
f (CategoryName -> InstanceParams -> DefinesInstance
DefinesInstance CategoryName
n InstanceParams
ps3) (CategoryName -> InstanceParams -> DefinesInstance
DefinesInstance CategoryName
n InstanceParams
ps2')

data GuessRange a =
  GuessRange {
    forall a. GuessRange a -> Maybe a
grLower :: Maybe a,
    forall a. GuessRange a -> Maybe a
grUpper :: Maybe a
  }
  deriving (GuessRange a -> GuessRange a -> Bool
forall a. Eq a => GuessRange a -> GuessRange a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GuessRange a -> GuessRange a -> Bool
$c/= :: forall a. Eq a => GuessRange a -> GuessRange a -> Bool
== :: GuessRange a -> GuessRange a -> Bool
$c== :: forall a. Eq a => GuessRange a -> GuessRange a -> Bool
Eq,GuessRange a -> GuessRange a -> Bool
GuessRange a -> GuessRange a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (GuessRange a)
forall a. Ord a => GuessRange a -> GuessRange a -> Bool
forall a. Ord a => GuessRange a -> GuessRange a -> Ordering
forall a. Ord a => GuessRange a -> GuessRange a -> GuessRange a
min :: GuessRange a -> GuessRange a -> GuessRange a
$cmin :: forall a. Ord a => GuessRange a -> GuessRange a -> GuessRange a
max :: GuessRange a -> GuessRange a -> GuessRange a
$cmax :: forall a. Ord a => GuessRange a -> GuessRange a -> GuessRange a
>= :: GuessRange a -> GuessRange a -> Bool
$c>= :: forall a. Ord a => GuessRange a -> GuessRange a -> Bool
> :: GuessRange a -> GuessRange a -> Bool
$c> :: forall a. Ord a => GuessRange a -> GuessRange a -> Bool
<= :: GuessRange a -> GuessRange a -> Bool
$c<= :: forall a. Ord a => GuessRange a -> GuessRange a -> Bool
< :: GuessRange a -> GuessRange a -> Bool
$c< :: forall a. Ord a => GuessRange a -> GuessRange a -> Bool
compare :: GuessRange a -> GuessRange a -> Ordering
$ccompare :: forall a. Ord a => GuessRange a -> GuessRange a -> Ordering
Ord)

instance Show a => Show (GuessRange a) where
  show :: GuessRange a -> String
show (GuessRange Maybe a
Nothing   Maybe a
Nothing)   = String
"literally anything is possible"
  show (GuessRange Maybe a
Nothing   (Just a
hi)) = String
"something at or below " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
hi
  show (GuessRange (Just a
lo) Maybe a
Nothing)   = String
"something at or above " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
lo
  show (GuessRange (Just a
lo) (Just a
hi)) = String
"something between " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
lo forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
hi

data GuessUnion =
  GuessUnion {
    GuessUnion -> [GuessRange (GeneralType TypeInstanceOrParam)]
guGuesses :: [GuessRange GeneralInstance]
  }

guessesFromFilters :: CollectErrorsM m =>
  ParamFilters -> ValueType -> ValueType -> m [PatternMatch]
guessesFromFilters :: forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName [TypeFilter]
-> ValueType -> ValueType -> m [PatternMatch]
guessesFromFilters Map ParamName [TypeFilter]
fm (ValueType StorageType
_ GeneralType TypeInstanceOrParam
t1) (ValueType StorageType
_ GeneralType TypeInstanceOrParam
t2) = m (Maybe TypeInstanceOrParam)
tryParam forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TypeInstanceOrParam -> m [PatternMatch]
fromFilters where
  tryParam :: m (Maybe TypeInstanceOrParam)
tryParam = forall (m :: * -> *) a. CollectErrorsM m => m a -> m (Maybe a)
tryCompilerM forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf GeneralType TypeInstanceOrParam
t2
  fromFilters :: Maybe TypeInstanceOrParam -> m [PatternMatch]
fromFilters (Just (JustParamName Bool
_ ParamName
n)) =
    case ParamName
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map ParamName [TypeFilter]
fm of
         Just [TypeFilter]
fs -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM TypeFilter -> m [PatternMatch]
toGuess [TypeFilter]
fs
         Maybe [TypeFilter]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
  fromFilters Maybe TypeInstanceOrParam
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
  toGuess :: TypeFilter -> m [PatternMatch]
toGuess (TypeFilter FilterDirection
FilterRequires GeneralType TypeInstanceOrParam
t3) =
    forall (m :: * -> *) a. Monad m => a -> m a
return [Variance -> ValueType -> ValueType -> PatternMatch
TypePattern Variance
Covariant (StorageType -> GeneralType TypeInstanceOrParam -> ValueType
ValueType StorageType
RequiredValue GeneralType TypeInstanceOrParam
t1) (StorageType -> GeneralType TypeInstanceOrParam -> ValueType
ValueType StorageType
RequiredValue GeneralType TypeInstanceOrParam
t3)]
  toGuess (TypeFilter FilterDirection
FilterAllows GeneralType TypeInstanceOrParam
t3) =
    forall (m :: * -> *) a. Monad m => a -> m a
return [Variance -> ValueType -> ValueType -> PatternMatch
TypePattern Variance
Contravariant (StorageType -> GeneralType TypeInstanceOrParam -> ValueType
ValueType StorageType
RequiredValue GeneralType TypeInstanceOrParam
t1) (StorageType -> GeneralType TypeInstanceOrParam -> ValueType
ValueType StorageType
RequiredValue GeneralType TypeInstanceOrParam
t3)]
  toGuess (DefinesFilter DefinesInstance
t3) = do
    Maybe TypeInstanceOrParam
maybeInstance <- forall (m :: * -> *) a. CollectErrorsM m => m a -> m (Maybe a)
tryCompilerM forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf GeneralType TypeInstanceOrParam
t1
    case Maybe TypeInstanceOrParam
maybeInstance of
         Just (JustTypeInstance TypeInstance
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return [TypeInstance -> DefinesInstance -> PatternMatch
DefinesPattern TypeInstance
t DefinesInstance
t3]
         Maybe TypeInstanceOrParam
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
  toGuess TypeFilter
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []

mergeInferredTypes :: (CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> ParamFilters -> ParamValues -> MergeTree InferredTypeGuess -> m ParamValues
mergeInferredTypes :: forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName [TypeFilter]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> MergeTree InferredTypeGuess
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
mergeInferredTypes r
_ Map ParamName [TypeFilter]
_ Map ParamName [TypeFilter]
ff Map ParamName (GeneralType TypeInstanceOrParam)
_ MergeTree InferredTypeGuess
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall k a. Map k a -> [(k, a)]
Map.toList Map ParamName [TypeFilter]
ff) = forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. Map k a
Map.empty
mergeInferredTypes r
r Map ParamName [TypeFilter]
f Map ParamName [TypeFilter]
ff Map ParamName (GeneralType TypeInstanceOrParam)
ps MergeTree InferredTypeGuess
gs0 = do
  let gs0' :: Map ParamName (MergeTree InferredTypeGuess)
gs0' = MergeTree InferredTypeGuess
-> Map ParamName (MergeTree InferredTypeGuess)
mapTypeGuesses MergeTree InferredTypeGuess
gs0
  [(ParamName, [GuessRange (GeneralType TypeInstanceOrParam)])]
gs1 <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (\(ParamName
i,MergeTree InferredTypeGuess
is) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) ParamName
i) forall a b. (a -> b) -> a -> b
$ (MergeTree InferredTypeGuess
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
reduce forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [GuessRange (GeneralType TypeInstanceOrParam)]
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
simplifyUnion) MergeTree InferredTypeGuess
is) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map ParamName (MergeTree InferredTypeGuess)
gs0'
  [[(ParamName, GeneralType TypeInstanceOrParam)]]
gs2 <- [(ParamName, [GuessRange (GeneralType TypeInstanceOrParam)])]
-> m [[(ParamName, GeneralType TypeInstanceOrParam)]]
filterGuesses [(ParamName, [GuessRange (GeneralType TypeInstanceOrParam)])]
gs1
  [[(ParamName, GeneralType TypeInstanceOrParam)]]
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
takeBest [[(ParamName, GeneralType TypeInstanceOrParam)]]
gs2 where
    reduce :: MergeTree InferredTypeGuess
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
reduce MergeTree InferredTypeGuess
is = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GuessUnion -> [GuessRange (GeneralType TypeInstanceOrParam)]
guGuesses forall a b. (a -> b) -> a -> b
$ forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree [m GuessUnion] -> m GuessUnion
anyOp [m GuessUnion] -> m GuessUnion
allOp forall {m :: * -> *}. Monad m => InferredTypeGuess -> m GuessUnion
leafOp MergeTree InferredTypeGuess
is
    leafOp :: InferredTypeGuess -> m GuessUnion
leafOp (InferredTypeGuess ParamName
_ GeneralType TypeInstanceOrParam
t Variance
Covariant)     = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [GuessRange (GeneralType TypeInstanceOrParam)] -> GuessUnion
GuessUnion [forall a. Maybe a -> Maybe a -> GuessRange a
GuessRange (forall a. a -> Maybe a
Just GeneralType TypeInstanceOrParam
t) forall a. Maybe a
Nothing]
    leafOp (InferredTypeGuess ParamName
_ GeneralType TypeInstanceOrParam
t Variance
Contravariant) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [GuessRange (GeneralType TypeInstanceOrParam)] -> GuessUnion
GuessUnion [forall a. Maybe a -> Maybe a -> GuessRange a
GuessRange forall a. Maybe a
Nothing  (forall a. a -> Maybe a
Just GeneralType TypeInstanceOrParam
t)]
    leafOp (InferredTypeGuess ParamName
_ GeneralType TypeInstanceOrParam
t Variance
_)             = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [GuessRange (GeneralType TypeInstanceOrParam)] -> GuessUnion
GuessUnion [forall a. Maybe a -> Maybe a -> GuessRange a
GuessRange (forall a. a -> Maybe a
Just GeneralType TypeInstanceOrParam
t) (forall a. a -> Maybe a
Just GeneralType TypeInstanceOrParam
t)]
    anyOp :: [m GuessUnion] -> m GuessUnion
anyOp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([GuessRange (GeneralType TypeInstanceOrParam)] -> GuessUnion
GuessUnion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map GuessUnion -> [GuessRange (GeneralType TypeInstanceOrParam)]
guGuesses) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAllM
    allOp :: [m GuessUnion] -> m GuessUnion
allOp = forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAllM forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [GuessUnion] -> m GuessUnion
prodAll
    prodAll :: [GuessUnion] -> m GuessUnion
prodAll [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [GuessRange (GeneralType TypeInstanceOrParam)] -> GuessUnion
GuessUnion []
    prodAll [GuessUnion [GuessRange (GeneralType TypeInstanceOrParam)]
gs] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [GuessRange (GeneralType TypeInstanceOrParam)] -> GuessUnion
GuessUnion forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [GuessRange (GeneralType TypeInstanceOrParam)]
gs
    prodAll ((GuessUnion [GuessRange (GeneralType TypeInstanceOrParam)]
g1):(GuessUnion [GuessRange (GeneralType TypeInstanceOrParam)]
g2):[GuessUnion]
gs) = do
      [GuessRange (GeneralType TypeInstanceOrParam)]
g <- [GuessRange (GeneralType TypeInstanceOrParam)]
g1 [GuessRange (GeneralType TypeInstanceOrParam)]
-> [GuessRange (GeneralType TypeInstanceOrParam)]
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
`guessProd` [GuessRange (GeneralType TypeInstanceOrParam)]
g2
      [GuessUnion] -> m GuessUnion
prodAll ([GuessRange (GeneralType TypeInstanceOrParam)] -> GuessUnion
GuessUnion [GuessRange (GeneralType TypeInstanceOrParam)]
gforall a. a -> [a] -> [a]
:[GuessUnion]
gs)
    guessProd :: [GuessRange (GeneralType TypeInstanceOrParam)]
-> [GuessRange (GeneralType TypeInstanceOrParam)]
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
guessProd [GuessRange (GeneralType TypeInstanceOrParam)]
xs [GuessRange (GeneralType TypeInstanceOrParam)]
ys = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAllM forall a b. (a -> b) -> a -> b
$ do
      GuessRange (GeneralType TypeInstanceOrParam)
x <- forall a. Eq a => [a] -> [a]
nub [GuessRange (GeneralType TypeInstanceOrParam)]
xs
      GuessRange (GeneralType TypeInstanceOrParam)
y <- forall a. Eq a => [a] -> [a]
nub [GuessRange (GeneralType TypeInstanceOrParam)]
ys
      [GuessRange (GeneralType TypeInstanceOrParam)
x GuessRange (GeneralType TypeInstanceOrParam)
-> GuessRange (GeneralType TypeInstanceOrParam)
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
`guessIntersect` GuessRange (GeneralType TypeInstanceOrParam)
y]
    guessIntersect :: GuessRange (GeneralType TypeInstanceOrParam)
-> GuessRange (GeneralType TypeInstanceOrParam)
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
guessIntersect (GuessRange Maybe (GeneralType TypeInstanceOrParam)
loX Maybe (GeneralType TypeInstanceOrParam)
hiX) (GuessRange Maybe (GeneralType TypeInstanceOrParam)
loY Maybe (GeneralType TypeInstanceOrParam)
hiY) = do
      Bool
q1 <- Maybe (GeneralType TypeInstanceOrParam)
loX Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam) -> m Bool
`convertsTo` Maybe (GeneralType TypeInstanceOrParam)
hiY
      Bool
q2 <- Maybe (GeneralType TypeInstanceOrParam)
loY Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam) -> m Bool
`convertsTo` Maybe (GeneralType TypeInstanceOrParam)
hiX
      if Bool
q1 Bool -> Bool -> Bool
&& Bool
q2
         then do
           Maybe (GeneralType TypeInstanceOrParam)
loZ <- Variance
-> Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam)
-> m (Maybe (GeneralType TypeInstanceOrParam))
tryMerge Variance
Covariant     Maybe (GeneralType TypeInstanceOrParam)
loX Maybe (GeneralType TypeInstanceOrParam)
loY
           Maybe (GeneralType TypeInstanceOrParam)
hiZ <- Variance
-> Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam)
-> m (Maybe (GeneralType TypeInstanceOrParam))
tryMerge Variance
Contravariant Maybe (GeneralType TypeInstanceOrParam)
hiX Maybe (GeneralType TypeInstanceOrParam)
hiY
           forall (m :: * -> *) a. Monad m => a -> m a
return [forall a. Maybe a -> Maybe a -> GuessRange a
GuessRange Maybe (GeneralType TypeInstanceOrParam)
loZ Maybe (GeneralType TypeInstanceOrParam)
hiZ]
         else forall (m :: * -> *) a. Monad m => a -> m a
return []
    convertsTo :: Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam) -> m Bool
convertsTo Maybe (GeneralType TypeInstanceOrParam)
Nothing Maybe (GeneralType TypeInstanceOrParam)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    convertsTo Maybe (GeneralType TypeInstanceOrParam)
_ Maybe (GeneralType TypeInstanceOrParam)
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    convertsTo (Just GeneralType TypeInstanceOrParam
t1) (Just GeneralType TypeInstanceOrParam
t2) = forall (m :: * -> *) a. CollectErrorsM m => m a -> m Bool
isCompilerSuccessM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
Covariant GeneralType TypeInstanceOrParam
t1 GeneralType TypeInstanceOrParam
t2
    tryMerge :: Variance
-> Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam)
-> m (Maybe (GeneralType TypeInstanceOrParam))
tryMerge Variance
_ Maybe (GeneralType TypeInstanceOrParam)
Nothing Maybe (GeneralType TypeInstanceOrParam)
t2 = forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (GeneralType TypeInstanceOrParam)
t2
    tryMerge Variance
_ Maybe (GeneralType TypeInstanceOrParam)
t1 Maybe (GeneralType TypeInstanceOrParam)
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (GeneralType TypeInstanceOrParam)
t1
    tryMerge Variance
v (Just GeneralType TypeInstanceOrParam
t1) (Just GeneralType TypeInstanceOrParam
t2) = forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM [
        forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
v GeneralType TypeInstanceOrParam
t1 GeneralType TypeInstanceOrParam
t2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just GeneralType TypeInstanceOrParam
t2),
        forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
v GeneralType TypeInstanceOrParam
t2 GeneralType TypeInstanceOrParam
t1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just GeneralType TypeInstanceOrParam
t1),
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Variance
v of
                      Variance
Covariant     -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). (Mergeable a, Foldable f) => f a -> a
mergeAny [GeneralType TypeInstanceOrParam
t1,GeneralType TypeInstanceOrParam
t2]
                      Variance
Contravariant -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). (Mergeable a, Foldable f) => f a -> a
mergeAll [GeneralType TypeInstanceOrParam
t1,GeneralType TypeInstanceOrParam
t2]
                      Variance
_ -> forall a. HasCallStack => a
undefined
      ]
    simplifyUnion :: [GuessRange (GeneralType TypeInstanceOrParam)]
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
simplifyUnion [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    simplifyUnion (GuessRange (GeneralType TypeInstanceOrParam)
g:[GuessRange (GeneralType TypeInstanceOrParam)]
gs) = do
      Maybe [GuessRange (GeneralType TypeInstanceOrParam)]
ga <- [GuessRange (GeneralType TypeInstanceOrParam)]
-> GuessRange (GeneralType TypeInstanceOrParam)
-> [GuessRange (GeneralType TypeInstanceOrParam)]
-> m (Maybe [GuessRange (GeneralType TypeInstanceOrParam)])
tryRangeUnion [] GuessRange (GeneralType TypeInstanceOrParam)
g [GuessRange (GeneralType TypeInstanceOrParam)]
gs
      case Maybe [GuessRange (GeneralType TypeInstanceOrParam)]
ga of
           Just [GuessRange (GeneralType TypeInstanceOrParam)]
gs2 -> [GuessRange (GeneralType TypeInstanceOrParam)]
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
simplifyUnion [GuessRange (GeneralType TypeInstanceOrParam)]
gs2
           Maybe [GuessRange (GeneralType TypeInstanceOrParam)]
Nothing -> do
             [GuessRange (GeneralType TypeInstanceOrParam)]
gs2 <- [GuessRange (GeneralType TypeInstanceOrParam)]
-> m [GuessRange (GeneralType TypeInstanceOrParam)]
simplifyUnion [GuessRange (GeneralType TypeInstanceOrParam)]
gs
             forall (m :: * -> *) a. Monad m => a -> m a
return (GuessRange (GeneralType TypeInstanceOrParam)
gforall a. a -> [a] -> [a]
:[GuessRange (GeneralType TypeInstanceOrParam)]
gs2)
    -- Returns Just a new list if there was a merge, and Nothing otherwise.
    tryRangeUnion :: [GuessRange (GeneralType TypeInstanceOrParam)]
-> GuessRange (GeneralType TypeInstanceOrParam)
-> [GuessRange (GeneralType TypeInstanceOrParam)]
-> m (Maybe [GuessRange (GeneralType TypeInstanceOrParam)])
tryRangeUnion [GuessRange (GeneralType TypeInstanceOrParam)]
ms g1 :: GuessRange (GeneralType TypeInstanceOrParam)
g1@(GuessRange Maybe (GeneralType TypeInstanceOrParam)
loX Maybe (GeneralType TypeInstanceOrParam)
hiX) (g2 :: GuessRange (GeneralType TypeInstanceOrParam)
g2@(GuessRange Maybe (GeneralType TypeInstanceOrParam)
loY Maybe (GeneralType TypeInstanceOrParam)
hiY):[GuessRange (GeneralType TypeInstanceOrParam)]
gs) = do
      Bool
l1 <- Maybe (GeneralType TypeInstanceOrParam)
loX Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam) -> m Bool
`convertsTo` Maybe (GeneralType TypeInstanceOrParam)
loY
      Bool
l2 <- Maybe (GeneralType TypeInstanceOrParam)
loY Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam) -> m Bool
`convertsTo` Maybe (GeneralType TypeInstanceOrParam)
loX
      let loZ :: Maybe (Maybe (GeneralType TypeInstanceOrParam))
loZ = case (Bool
l1,Bool
l2) of
                     (Bool
True,Bool
_) -> forall a. a -> Maybe a
Just Maybe (GeneralType TypeInstanceOrParam)
loX
                     (Bool
_,Bool
True) -> forall a. a -> Maybe a
Just Maybe (GeneralType TypeInstanceOrParam)
loY
                     (Bool, Bool)
_ -> forall a. Maybe a
Nothing
      Bool
h1 <- Maybe (GeneralType TypeInstanceOrParam)
hiX Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam) -> m Bool
`convertsTo` Maybe (GeneralType TypeInstanceOrParam)
hiY
      Bool
h2 <- Maybe (GeneralType TypeInstanceOrParam)
hiY Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam) -> m Bool
`convertsTo` Maybe (GeneralType TypeInstanceOrParam)
hiX
      let hiZ :: Maybe (Maybe (GeneralType TypeInstanceOrParam))
hiZ = case (Bool
h1,Bool
h2) of
                     (Bool
True,Bool
_) -> forall a. a -> Maybe a
Just Maybe (GeneralType TypeInstanceOrParam)
hiY
                     (Bool
_,Bool
True) -> forall a. a -> Maybe a
Just Maybe (GeneralType TypeInstanceOrParam)
hiX
                     (Bool, Bool)
_ -> forall a. Maybe a
Nothing
      case (Maybe (Maybe (GeneralType TypeInstanceOrParam))
loZ,Maybe (Maybe (GeneralType TypeInstanceOrParam))
hiZ) of
           (Just Maybe (GeneralType TypeInstanceOrParam)
lo,Just Maybe (GeneralType TypeInstanceOrParam)
hi) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [GuessRange (GeneralType TypeInstanceOrParam)]
ms forall a. [a] -> [a] -> [a]
++ [forall a. Maybe a -> Maybe a -> GuessRange a
GuessRange Maybe (GeneralType TypeInstanceOrParam)
lo Maybe (GeneralType TypeInstanceOrParam)
hi] forall a. [a] -> [a] -> [a]
++ [GuessRange (GeneralType TypeInstanceOrParam)]
gs
           (Maybe (Maybe (GeneralType TypeInstanceOrParam)),
 Maybe (Maybe (GeneralType TypeInstanceOrParam)))
_                 -> [GuessRange (GeneralType TypeInstanceOrParam)]
-> GuessRange (GeneralType TypeInstanceOrParam)
-> [GuessRange (GeneralType TypeInstanceOrParam)]
-> m (Maybe [GuessRange (GeneralType TypeInstanceOrParam)])
tryRangeUnion ([GuessRange (GeneralType TypeInstanceOrParam)]
ms forall a. [a] -> [a] -> [a]
++ [GuessRange (GeneralType TypeInstanceOrParam)
g2]) GuessRange (GeneralType TypeInstanceOrParam)
g1 [GuessRange (GeneralType TypeInstanceOrParam)]
gs
    tryRangeUnion [GuessRange (GeneralType TypeInstanceOrParam)]
_ GuessRange (GeneralType TypeInstanceOrParam)
_ [GuessRange (GeneralType TypeInstanceOrParam)]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    takeBest :: [[(ParamName, GeneralType TypeInstanceOrParam)]]
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
takeBest [[(ParamName, GeneralType TypeInstanceOrParam)]
gs] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ParamName, GeneralType TypeInstanceOrParam)]
gs
    takeBest [] = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM String
genericError
    takeBest [[(ParamName, GeneralType TypeInstanceOrParam)]]
gs = String
"Unable to merge alternative param guesses" forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
!!> do
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall {m :: * -> *} {a} {a} {a} {a}.
(CollectErrorsM m, Show a, Show a, Show a) =>
(a, [(a, a)]) -> m a
showAmbiguous (forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1..] :: [Int]) [[(ParamName, GeneralType TypeInstanceOrParam)]]
gs)
      forall (m :: * -> *) a. CollectErrorsM m => m a
emptyErrorM
    showAmbiguous :: (a, [(a, a)]) -> m a
showAmbiguous (a
n,[(a, a)]
gs) = String
"Param guess set " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
!!>
      (forall (m :: * -> *) a. CollectErrorsM m => [String] -> m a
mapErrorsM forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(a
i,a
t) -> String
"Guess for param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
t) [(a, a)]
gs)
    filterGuesses :: [(ParamName, [GuessRange (GeneralType TypeInstanceOrParam)])]
-> m [[(ParamName, GeneralType TypeInstanceOrParam)]]
filterGuesses [(ParamName, [GuessRange (GeneralType TypeInstanceOrParam)])]
gs = do
      [[(ParamName, GeneralType TypeInstanceOrParam)]]
gs' <- forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (ParamName, [GuessRange (GeneralType TypeInstanceOrParam)])
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
extractGuesses [(ParamName, [GuessRange (GeneralType TypeInstanceOrParam)])]
gs
      let mult :: [[(ParamName, GeneralType TypeInstanceOrParam)]]
mult = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[(ParamName, GeneralType TypeInstanceOrParam)]
xs [(ParamName, GeneralType TypeInstanceOrParam)]
ys -> [[(ParamName, GeneralType TypeInstanceOrParam)]
xsforall a. [a] -> [a] -> [a]
++[(ParamName, GeneralType TypeInstanceOrParam)
y] | (ParamName, GeneralType TypeInstanceOrParam)
y <- [(ParamName, GeneralType TypeInstanceOrParam)]
ys]) [] [[(ParamName, GeneralType TypeInstanceOrParam)]]
gs'
      let gs2 :: [m [(ParamName, GeneralType TypeInstanceOrParam)]]
gs2 = forall a b. (a -> b) -> [a] -> [b]
map [(ParamName, GeneralType TypeInstanceOrParam)]
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
filterGuess [[(ParamName, GeneralType TypeInstanceOrParam)]]
mult
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectFirstM_ [m [(ParamName, GeneralType TypeInstanceOrParam)]]
gs2 forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!! String
genericError
      forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAnyM [m [(ParamName, GeneralType TypeInstanceOrParam)]]
gs2
    genericError :: String
genericError = String
"No guesses available for params " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map ParamName [TypeFilter]
ff)
    filterGuess :: [(ParamName, GeneralType TypeInstanceOrParam)]
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
filterGuess [(ParamName, GeneralType TypeInstanceOrParam)]
gs = [(ParamName, GeneralType TypeInstanceOrParam)] -> m ()
checkSubFilters [(ParamName, GeneralType TypeInstanceOrParam)]
gs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [(ParamName, GeneralType TypeInstanceOrParam)]
gs
    extractGuesses :: (ParamName, [GuessRange (GeneralType TypeInstanceOrParam)])
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
extractGuesses (ParamName
i,[GuessRange (GeneralType TypeInstanceOrParam)]
is) = do
      let is2 :: [m (ParamName, GeneralType TypeInstanceOrParam)]
is2 = forall a b. (a -> b) -> [a] -> [b]
map (ParamName
-> GuessRange (GeneralType TypeInstanceOrParam)
-> m (ParamName, GeneralType TypeInstanceOrParam)
extractSingle ParamName
i) [GuessRange (GeneralType TypeInstanceOrParam)]
is
      -- resetBackgroundM prevents duplicate messages.
      forall (m :: * -> *) a. ErrorContextM m => m a -> m a
resetBackgroundM forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectFirstM_ [m (ParamName, GeneralType TypeInstanceOrParam)]
is2 forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!! String
"No feasible guesses for param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
i
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAnyM [m (ParamName, GeneralType TypeInstanceOrParam)]
is2
    extractSingle :: ParamName
-> GuessRange (GeneralType TypeInstanceOrParam)
-> m (ParamName, GeneralType TypeInstanceOrParam)
extractSingle ParamName
i (GuessRange (Just GeneralType TypeInstanceOrParam
lo) Maybe (GeneralType TypeInstanceOrParam)
Nothing) = forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
i,GeneralType TypeInstanceOrParam
lo)
    extractSingle ParamName
i (GuessRange Maybe (GeneralType TypeInstanceOrParam)
Nothing (Just GeneralType TypeInstanceOrParam
hi)) = forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
i,GeneralType TypeInstanceOrParam
hi)
    extractSingle ParamName
i g :: GuessRange (GeneralType TypeInstanceOrParam)
g@(GuessRange (Just GeneralType TypeInstanceOrParam
lo) (Just GeneralType TypeInstanceOrParam
hi)) = do
      Bool
p <- (forall a. a -> Maybe a
Just GeneralType TypeInstanceOrParam
hi) Maybe (GeneralType TypeInstanceOrParam)
-> Maybe (GeneralType TypeInstanceOrParam) -> m Bool
`convertsTo` (forall a. a -> Maybe a
Just GeneralType TypeInstanceOrParam
lo)
      if Bool
p
         then forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
i,GeneralType TypeInstanceOrParam
lo)
         else do
           forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerBackgroundM forall a b. (a -> b) -> a -> b
$ String
"Arbitrarily using lower bound " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
lo forall a. [a] -> [a] -> [a]
++
                                 String
" for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
i forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GuessRange (GeneralType TypeInstanceOrParam)
g forall a. [a] -> [a] -> [a]
++ String
")"
           forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName
i,GeneralType TypeInstanceOrParam
lo)
    extractSingle ParamName
i g :: GuessRange (GeneralType TypeInstanceOrParam)
g@(GuessRange Maybe (GeneralType TypeInstanceOrParam)
Nothing Maybe (GeneralType TypeInstanceOrParam)
Nothing) =
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Ambiguous guess for param " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParamName
i forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GuessRange (GeneralType TypeInstanceOrParam)
g
    checkSubFilters :: [(ParamName, GeneralType TypeInstanceOrParam)] -> m ()
checkSubFilters [(ParamName, GeneralType TypeInstanceOrParam)]
gs = String
"In validation of inference guess: " forall a. [a] -> [a] -> [a]
++ [(ParamName, GeneralType TypeInstanceOrParam)] -> String
describeGuess [(ParamName, GeneralType TypeInstanceOrParam)]
gs forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      let ps' :: Map ParamName (GeneralType TypeInstanceOrParam)
ps' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert) Map ParamName (GeneralType TypeInstanceOrParam)
ps [(ParamName, GeneralType TypeInstanceOrParam)]
gs
      Map ParamName [TypeFilter]
ff' <- forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> Map ParamName [TypeFilter] -> m (Map ParamName [TypeFilter])
uncheckedSubFilters (forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
ps') Map ParamName [TypeFilter]
ff
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (Map ParamName [TypeFilter]
-> (ParamName, GeneralType TypeInstanceOrParam) -> m ()
validateSingleParam Map ParamName [TypeFilter]
ff') [(ParamName, GeneralType TypeInstanceOrParam)]
gs
    validateSingleParam :: Map ParamName [TypeFilter]
-> (ParamName, GeneralType TypeInstanceOrParam) -> m ()
validateSingleParam Map ParamName [TypeFilter]
ff2 (ParamName
i,GeneralType TypeInstanceOrParam
t) = do
      [TypeFilter]
fs <- Map ParamName [TypeFilter]
ff2 forall (m :: * -> *).
ErrorContextM m =>
Map ParamName [TypeFilter] -> ParamName -> m [TypeFilter]
`filterLookup` ParamName
i
      forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> GeneralType TypeInstanceOrParam
-> [TypeFilter]
-> m ()
validateAssignment r
r Map ParamName [TypeFilter]
f GeneralType TypeInstanceOrParam
t [TypeFilter]
fs
    describeGuess :: [(ParamName, GeneralType TypeInstanceOrParam)] -> String
describeGuess = forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(ParamName
i,GeneralType TypeInstanceOrParam
t) -> forall a. Show a => a -> String
show ParamName
i forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
t)