{- -----------------------------------------------------------------------------
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 /*" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContext [c]
c String -> ShowS
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) = [c] -> PragmaCategory c
forall c. [c] -> PragmaCategory c
CategoryImmutable ([c]
c[c] -> [c] -> [c]
forall a. [a] -> [a] -> [a]
++[c]
c2)

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

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

instance Show c => Show (AnyCategory c) where
  show :: AnyCategory c -> String
show = AnyCategory c -> String
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [ValueParam c] -> String
forall {t :: * -> *} {c}. Foldable t => t (ValueParam c) -> String
formatParams [ValueParam c]
ps String -> ShowS
forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespace Namespace
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" { " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatContext [c]
cs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
      (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
         (PragmaCategory c -> String) -> [PragmaCategory c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\PragmaCategory c
p -> String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PragmaCategory c -> String
forall a. Show a => a -> String
show PragmaCategory c
p) [PragmaCategory c]
pg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
         (ValueRefine c -> String) -> [ValueRefine c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueRefine c -> String
forall {a}. Show a => ValueRefine a -> String
formatRefine ValueRefine c
r) [ValueRefine c]
rs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
         (ScopedFunction c -> String) -> [ScopedFunction c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> ScopedFunction c -> String
forall {c}. Show c => ScopedFunction c -> String
formatInterfaceFunc ScopedFunction c
f) [ScopedFunction c]
fs) String -> ShowS
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [ValueParam c] -> String
forall {t :: * -> *} {c}. Foldable t => t (ValueParam c) -> String
formatParams [ValueParam c]
ps String -> ShowS
forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespace Namespace
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" { " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatContext [c]
cs String -> ShowS
forall a. [a] -> [a] -> [a]
++
      (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
         (PragmaCategory c -> String) -> [PragmaCategory c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\PragmaCategory c
p -> String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PragmaCategory c -> String
forall a. Show a => a -> String
show PragmaCategory c
p) [PragmaCategory c]
pg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
         (ScopedFunction c -> String) -> [ScopedFunction c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> ScopedFunction c -> String
forall {c}. Show c => ScopedFunction c -> String
formatInterfaceFunc ScopedFunction c
f) [ScopedFunction c]
fs) String -> ShowS
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [ValueParam c] -> String
forall {t :: * -> *} {c}. Foldable t => t (ValueParam c) -> String
formatParams [ValueParam c]
ps String -> ShowS
forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespace Namespace
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" { " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatContext [c]
cs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
      (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
         (PragmaCategory c -> String) -> [PragmaCategory c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\PragmaCategory c
p -> String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PragmaCategory c -> String
forall a. Show a => a -> String
show PragmaCategory c
p) [PragmaCategory c]
pg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
         (ValueRefine c -> String) -> [ValueRefine c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueRefine c -> String
forall {a}. Show a => ValueRefine a -> String
formatRefine ValueRefine c
r) [ValueRefine c]
rs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
         (ValueDefine c -> String) -> [ValueDefine c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueDefine c
d -> String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueDefine c -> String
forall {a}. Show a => ValueDefine a -> String
formatDefine ValueDefine c
d) [ValueDefine c]
ds [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
         (ParamFilter c -> String) -> [ParamFilter c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
v -> String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParamFilter c -> String
forall {a}. Show a => ParamFilter a -> String
formatValue ParamFilter c
v) [ParamFilter c]
vs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
         (ScopedFunction c -> String) -> [ScopedFunction c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> ScopedFunction c -> String
forall {c}. Show c => ScopedFunction c -> String
formatConcreteFunc ScopedFunction c
f) [ScopedFunction c]
fs) String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String
"\n}\n"
    namespace :: Namespace -> String
namespace Namespace
ns
      | Namespace -> Bool
isStaticNamespace Namespace
ns = String
" /*" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Namespace -> String
forall a. Show a => a -> String
show Namespace
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"*/"
      | Bool
otherwise = String
""
    formatContext :: [a] -> String
formatContext [a]
cs = String
"/*" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContext [a]
cs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"*/"
    formatParams :: t (ValueParam c) -> String
formatParams t (ValueParam c)
ps = let ([String]
con,[String]
inv,[String]
cov) = ((ValueParam c
 -> ([String], [String], [String])
 -> ([String], [String], [String]))
-> ([String], [String], [String])
-> t (ValueParam c)
-> ([String], [String], [String])
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ValueParam c
-> ([String], [String], [String]) -> ([String], [String], [String])
forall {c}.
ValueParam c
-> ([String], [String], [String]) -> ([String], [String], [String])
partitionParam ([],[],[]) t (ValueParam c)
ps) in
      String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
con String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|" String -> ShowS
forall a. [a] -> [a] -> [a]
++
             String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
inv String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|" String -> ShowS
forall a. [a] -> [a] -> [a]
++
             String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
cov String -> ShowS
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) = ((ParamName -> String
forall a. Show a => a -> String
show ParamName
p)String -> [String] -> [String]
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,(ParamName -> String
forall a. Show a => a -> String
show ParamName
p)String -> [String] -> [String]
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,(ParamName -> String
forall a. Show a => a -> String
show ParamName
p)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
cov)
    formatRefine :: ValueRefine a -> String
formatRefine ValueRefine a
r = String
"refines " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeInstance -> String
forall a. Show a => a -> String
show (ValueRefine a -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine a
r) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatContext (ValueRefine a -> [a]
forall c. ValueRefine c -> [c]
vrContext ValueRefine a
r)
    formatDefine :: ValueDefine a -> String
formatDefine ValueDefine a
d = String
"defines " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DefinesInstance -> String
forall a. Show a => a -> String
show (ValueDefine a -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine a
d) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatContext (ValueDefine a -> [a]
forall c. ValueDefine c -> [c]
vdContext ValueDefine a
d)
    formatValue :: ParamFilter a -> String
formatValue ParamFilter a
v = ParamName -> String
forall a. Show a => a -> String
show (ParamFilter a -> ParamName
forall c. ParamFilter c -> ParamName
pfParam ParamFilter a
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeFilter -> String
forall a. Show a => a -> String
show (ParamFilter a -> TypeFilter
forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter a
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatContext (ParamFilter a -> [a]
forall c. ParamFilter c -> [c]
pfContext ParamFilter a
v)
    formatInterfaceFunc :: ScopedFunction c -> String
formatInterfaceFunc ScopedFunction c
f = String -> String -> ScopedFunction c -> String
forall c. Show c => String -> String -> ScopedFunction c -> String
showFunctionInContext String
"" String
"  " ScopedFunction c
f
    formatConcreteFunc :: ScopedFunction c -> String
formatConcreteFunc ScopedFunction c
f = String -> String -> ScopedFunction c -> String
forall c. Show c => String -> String -> ScopedFunction c -> String
showFunctionInContext (SymbolScope -> String
forall a. Show a => a -> String
show (ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f) String -> ShowS
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)        = ([c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ScopedFunction c]
-> AnyCategory c
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)        = ([c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ScopedFunction c]
-> AnyCategory c
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) = ([c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [FunctionVisibility c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
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 ([GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional [GeneralInstance]
ps) where
  n :: CategoryName
n = AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t
  ps :: [GeneralInstance]
ps = (ValueParam c -> GeneralInstance)
-> [ValueParam c] -> [GeneralInstance]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> (ValueParam c -> TypeInstanceOrParam)
-> ValueParam c
-> GeneralInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
True (ParamName -> TypeInstanceOrParam)
-> (ValueParam c -> ParamName)
-> ValueParam c
-> TypeInstanceOrParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam) ([ValueParam c] -> [GeneralInstance])
-> [ValueParam c] -> [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t

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

getCategoryDeps :: AnyCategory c -> Set.Set CategoryName
getCategoryDeps :: forall c. AnyCategory c -> Set CategoryName
getCategoryDeps AnyCategory c
t = [CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList ([CategoryName] -> Set CategoryName)
-> [CategoryName] -> Set CategoryName
forall a b. (a -> b) -> a -> b
$ (CategoryName -> Bool) -> [CategoryName] -> [CategoryName]
forall a. (a -> Bool) -> [a] -> [a]
filter (CategoryName -> CategoryName -> Bool
forall a. Eq a => a -> a -> Bool
/= AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) ([CategoryName] -> [CategoryName])
-> [CategoryName] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ [CategoryName]
refines [CategoryName] -> [CategoryName] -> [CategoryName]
forall a. [a] -> [a] -> [a]
++ [CategoryName]
defines [CategoryName] -> [CategoryName] -> [CategoryName]
forall a. [a] -> [a] -> [a]
++ [CategoryName]
filters [CategoryName] -> [CategoryName] -> [CategoryName]
forall a. [a] -> [a] -> [a]
++ [CategoryName]
functions where
  refines :: [CategoryName]
refines = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> [CategoryName])
-> [ValueRefine c] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map (GeneralInstance -> [CategoryName]
fromInstance (GeneralInstance -> [CategoryName])
-> (ValueRefine c -> GeneralInstance)
-> ValueRefine c
-> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> (ValueRefine c -> TypeInstanceOrParam)
-> ValueRefine c
-> GeneralInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> (ValueRefine c -> TypeInstance)
-> ValueRefine c
-> TypeInstanceOrParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType) ([ValueRefine c] -> [[CategoryName]])
-> [ValueRefine c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueRefine c]
forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t
  defines :: [CategoryName]
defines = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (ValueDefine c -> [CategoryName])
-> [ValueDefine c] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map (DefinesInstance -> [CategoryName]
fromDefine (DefinesInstance -> [CategoryName])
-> (ValueDefine c -> DefinesInstance)
-> ValueDefine c
-> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType) ([ValueDefine c] -> [[CategoryName]])
-> [ValueDefine c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueDefine c]
forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t
  filters :: [CategoryName]
filters = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (ParamFilter c -> [CategoryName])
-> [ParamFilter c] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map (TypeFilter -> [CategoryName]
fromFilter (TypeFilter -> [CategoryName])
-> (ParamFilter c -> TypeFilter) -> ParamFilter c -> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamFilter c -> TypeFilter
forall c. ParamFilter c -> TypeFilter
pfFilter) ([ParamFilter c] -> [[CategoryName]])
-> [ParamFilter c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ParamFilter c]
forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t
  functions :: [CategoryName]
functions = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (ScopedFunction c -> [CategoryName])
-> [ScopedFunction c] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map ScopedFunction c -> [CategoryName]
forall {c}. ScopedFunction c -> [CategoryName]
fromFunction ([ScopedFunction c] -> [[CategoryName]])
-> [ScopedFunction c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ScopedFunction c]
forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
t
  fromInstance :: GeneralInstance -> [CategoryName]
fromInstance = ([[CategoryName]] -> [CategoryName])
-> ([[CategoryName]] -> [CategoryName])
-> (T GeneralInstance -> [CategoryName])
-> GeneralInstance
-> [CategoryName]
forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat T GeneralInstance -> [CategoryName]
TypeInstanceOrParam -> [CategoryName]
fromSingle
  fromSingle :: TypeInstanceOrParam -> [CategoryName]
fromSingle (JustTypeInstance (TypeInstance CategoryName
n InstanceParams
ps)) = CategoryName
nCategoryName -> [CategoryName] -> [CategoryName]
forall a. a -> [a] -> [a]
:([[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> [CategoryName])
-> [GeneralInstance] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> [CategoryName]
fromInstance ([GeneralInstance] -> [[CategoryName]])
-> [GeneralInstance] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralInstance]
forall a. Positional a -> [a]
pValues InstanceParams
ps)
  fromSingle TypeInstanceOrParam
_ = []
  fromDefine :: DefinesInstance -> [CategoryName]
fromDefine (DefinesInstance CategoryName
n InstanceParams
ps) = CategoryName
nCategoryName -> [CategoryName] -> [CategoryName]
forall a. a -> [a] -> [a]
:([[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> [CategoryName])
-> [GeneralInstance] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> [CategoryName]
fromInstance ([GeneralInstance] -> [[CategoryName]])
-> [GeneralInstance] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralInstance]
forall a. Positional a -> [a]
pValues InstanceParams
ps)
  fromFilter :: TypeFilter -> [CategoryName]
fromFilter (TypeFilter FilterDirection
_ GeneralInstance
t2)  = GeneralInstance -> [CategoryName]
fromInstance GeneralInstance
t2
  fromFilter (DefinesFilter DefinesInstance
t2) = DefinesInstance -> [CategoryName]
fromDefine DefinesInstance
t2
  fromFilter TypeFilter
ImmutableFilter = []
  fromType :: ValueType -> [CategoryName]
fromType (ValueType StorageType
_ GeneralInstance
t2) = GeneralInstance -> [CategoryName]
fromInstance GeneralInstance
t2
  fromFunction :: ScopedFunction c -> [CategoryName]
fromFunction ScopedFunction c
f = [CategoryName]
args [CategoryName] -> [CategoryName] -> [CategoryName]
forall a. [a] -> [a] -> [a]
++ [CategoryName]
returns [CategoryName] -> [CategoryName] -> [CategoryName]
forall a. [a] -> [a] -> [a]
++ [CategoryName]
filters2 where
    args :: [CategoryName]
args = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ ((PassedValue c, Maybe (CallArgLabel c)) -> [CategoryName])
-> [(PassedValue c, Maybe (CallArgLabel c))] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> [CategoryName]
fromType (ValueType -> [CategoryName])
-> ((PassedValue c, Maybe (CallArgLabel c)) -> ValueType)
-> (PassedValue c, Maybe (CallArgLabel c))
-> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType (PassedValue c -> ValueType)
-> ((PassedValue c, Maybe (CallArgLabel c)) -> PassedValue c)
-> (PassedValue c, Maybe (CallArgLabel c))
-> ValueType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PassedValue c, Maybe (CallArgLabel c)) -> PassedValue c
forall a b. (a, b) -> a
fst) ([(PassedValue c, Maybe (CallArgLabel c))] -> [[CategoryName]])
-> [(PassedValue c, Maybe (CallArgLabel c))] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c, Maybe (CallArgLabel c))
-> [(PassedValue c, Maybe (CallArgLabel c))]
forall a. Positional a -> [a]
pValues (Positional (PassedValue c, Maybe (CallArgLabel c))
 -> [(PassedValue c, Maybe (CallArgLabel c))])
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> [(PassedValue c, Maybe (CallArgLabel c))]
forall a b. (a -> b) -> a -> b
$ ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f
    returns :: [CategoryName]
returns = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (PassedValue c -> [CategoryName])
-> [PassedValue c] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> [CategoryName]
fromType (ValueType -> [CategoryName])
-> (PassedValue c -> ValueType) -> PassedValue c -> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType) ([PassedValue c] -> [[CategoryName]])
-> [PassedValue c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c) -> [PassedValue c]
forall a. Positional a -> [a]
pValues (Positional (PassedValue c) -> [PassedValue c])
-> Positional (PassedValue c) -> [PassedValue c]
forall a b. (a -> b) -> a -> b
$ ScopedFunction c -> Positional (PassedValue c)
forall c. ScopedFunction c -> Positional (PassedValue c)
sfReturns ScopedFunction c
f
    filters2 :: [CategoryName]
filters2 = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (ParamFilter c -> [CategoryName])
-> [ParamFilter c] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map (TypeFilter -> [CategoryName]
fromFilter (TypeFilter -> [CategoryName])
-> (ParamFilter c -> TypeFilter) -> ParamFilter c -> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamFilter c -> TypeFilter
forall c. ParamFilter c -> TypeFilter
pfFilter) ([ParamFilter c] -> [[CategoryName]])
-> [ParamFilter c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ ScopedFunction c -> [ParamFilter c]
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
(Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool) -> Eq Namespace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
/= :: Namespace -> Namespace -> Bool
Eq,Eq Namespace
Eq Namespace =>
(Namespace -> Namespace -> Ordering)
-> (Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Namespace)
-> (Namespace -> Namespace -> Namespace)
-> Ord 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
$ccompare :: Namespace -> Namespace -> Ordering
compare :: Namespace -> Namespace -> Ordering
$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
>= :: Namespace -> Namespace -> Bool
$cmax :: Namespace -> Namespace -> Namespace
max :: Namespace -> Namespace -> Namespace
$cmin :: Namespace -> Namespace -> Namespace
min :: Namespace -> Namespace -> Namespace
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) = TypeInstance -> String
forall a. Show a => a -> String
show TypeInstance
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
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) = DefinesInstance -> String
forall a. Show a => a -> String
show DefinesInstance
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
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) = ParamName -> String
forall a. Show a => a -> String
show ParamName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Variance -> String
forall a. Show a => a -> String
show Variance
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
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) = ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeFilter -> String
forall a. Show a => a -> String
show TypeFilter
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
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 CategoryName -> CategoryName -> Bool
forall a. Eq a => a -> a -> Bool
== CategoryName
n2 = do
        ([c]
_,AnyCategory c
t) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
tm ([],CategoryName
n1)
        (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName -> InstanceParams -> m ()
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional ([ParamName] -> Positional ParamName)
-> [ParamName] -> Positional ParamName
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t) InstanceParams
ps1
        InstanceParams -> m InstanceParams
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
ps1
      | Bool
otherwise = do
        let self :: GeneralInstance
self = TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
ta
        ([c]
_,AnyCategory c
t) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
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 = (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
        Map ParamName GeneralInstance
assigned <- ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(ParamName, GeneralInstance)]
 -> m (Map ParamName GeneralInstance))
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> a -> b
$ (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
params) InstanceParams
ps1
        let pa :: Map CategoryName InstanceParams
pa = [(CategoryName, InstanceParams)] -> Map CategoryName InstanceParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CategoryName, InstanceParams)]
 -> Map CategoryName InstanceParams)
-> [(CategoryName, InstanceParams)]
-> Map CategoryName InstanceParams
forall a b. (a -> b) -> a -> b
$ (TypeInstance -> (CategoryName, InstanceParams))
-> [TypeInstance] -> [(CategoryName, InstanceParams)]
forall a b. (a -> b) -> [a] -> [b]
map (\TypeInstance
r -> (TypeInstance -> CategoryName
tiName TypeInstance
r,TypeInstance -> InstanceParams
tiParams TypeInstance
r)) ([TypeInstance] -> [(CategoryName, InstanceParams)])
-> [TypeInstance] -> [(CategoryName, InstanceParams)]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> TypeInstance)
-> [ValueRefine c] -> [TypeInstance]
forall a b. (a -> b) -> [a] -> [b]
map ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ([ValueRefine c] -> [TypeInstance])
-> [ValueRefine c] -> [TypeInstance]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueRefine c]
forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t
        InstanceParams
ps2 <- case CategoryName
n2 CategoryName
-> Map CategoryName InstanceParams -> Maybe InstanceParams
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName InstanceParams
pa of
                    (Just InstanceParams
x) -> InstanceParams -> m InstanceParams
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
x
                    Maybe InstanceParams
_ -> String -> m InstanceParams
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m InstanceParams) -> String -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ String
"Category " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not refine " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n2
        ([GeneralInstance] -> InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional (m [GeneralInstance] -> m InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> m GeneralInstance)
-> [GeneralInstance] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName GeneralInstance
-> GeneralInstance -> m GeneralInstance
subAllParams Map ParamName GeneralInstance
assigned (GeneralInstance -> m GeneralInstance)
-> (GeneralInstance -> m GeneralInstance)
-> GeneralInstance
-> m GeneralInstance
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GeneralInstance -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self) ([GeneralInstance] -> m [GeneralInstance])
-> [GeneralInstance] -> m [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralInstance]
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 :: GeneralInstance
self = TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
ta
      ([c]
_,AnyCategory c
t) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
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 = (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
      Map ParamName GeneralInstance
assigned <- ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(ParamName, GeneralInstance)]
 -> m (Map ParamName GeneralInstance))
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> a -> b
$ (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
params) InstanceParams
ps1
      let pa :: Map CategoryName InstanceParams
pa = [(CategoryName, InstanceParams)] -> Map CategoryName InstanceParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CategoryName, InstanceParams)]
 -> Map CategoryName InstanceParams)
-> [(CategoryName, InstanceParams)]
-> Map CategoryName InstanceParams
forall a b. (a -> b) -> a -> b
$ (DefinesInstance -> (CategoryName, InstanceParams))
-> [DefinesInstance] -> [(CategoryName, InstanceParams)]
forall a b. (a -> b) -> [a] -> [b]
map (\DefinesInstance
r -> (DefinesInstance -> CategoryName
diName DefinesInstance
r,DefinesInstance -> InstanceParams
diParams DefinesInstance
r)) ([DefinesInstance] -> [(CategoryName, InstanceParams)])
-> [DefinesInstance] -> [(CategoryName, InstanceParams)]
forall a b. (a -> b) -> a -> b
$ (ValueDefine c -> DefinesInstance)
-> [ValueDefine c] -> [DefinesInstance]
forall a b. (a -> b) -> [a] -> [b]
map ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType ([ValueDefine c] -> [DefinesInstance])
-> [ValueDefine c] -> [DefinesInstance]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueDefine c]
forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t
      InstanceParams
ps2 <- case CategoryName
n2 CategoryName
-> Map CategoryName InstanceParams -> Maybe InstanceParams
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName InstanceParams
pa of
                  (Just InstanceParams
x) -> InstanceParams -> m InstanceParams
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
x
                  Maybe InstanceParams
_ -> String -> m InstanceParams
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m InstanceParams) -> String -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ String
"Category " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not define " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n2
      ([GeneralInstance] -> InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional (m [GeneralInstance] -> m InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> m GeneralInstance)
-> [GeneralInstance] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName GeneralInstance
-> GeneralInstance -> m GeneralInstance
subAllParams Map ParamName GeneralInstance
assigned (GeneralInstance -> m GeneralInstance)
-> (GeneralInstance -> m GeneralInstance)
-> GeneralInstance
-> m GeneralInstance
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GeneralInstance -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self) ([GeneralInstance] -> m [GeneralInstance])
-> [GeneralInstance] -> m [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralInstance]
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([],CategoryName
n)
      InstanceVariances -> m InstanceVariances
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstanceVariances -> m InstanceVariances)
-> InstanceVariances -> m InstanceVariances
forall a b. (a -> b) -> a -> b
$ [Variance] -> InstanceVariances
forall a. [a] -> Positional a
Positional ([Variance] -> InstanceVariances)
-> [Variance] -> InstanceVariances
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> Variance) -> [ValueParam c] -> [Variance]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> Variance
forall c. ValueParam c -> Variance
vpVariance ([ValueParam c] -> [Variance]) -> [ValueParam c] -> [Variance]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
tm ([],CategoryName
n)
      AnyCategory c -> InstanceParams -> m InstanceFilters
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getInstanceCategory CategoryMap c
tm ([],CategoryName
n)
      AnyCategory c -> InstanceParams -> m InstanceFilters
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([],CategoryName
n)
      Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyCategory c -> Bool
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([],CategoryName
n)
      Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (PragmaCategory c -> Bool) -> [PragmaCategory c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PragmaCategory c -> Bool
forall c. PragmaCategory c -> Bool
isCategoryImmutable (AnyCategory c -> [PragmaCategory c]
forall c. AnyCategory c -> [PragmaCategory c]
getCategoryPragmas AnyCategory c
t)

data SymbolScope =
  LocalScope |
  CategoryScope |
  TypeScope |
  ValueScope
  deriving (SymbolScope -> SymbolScope -> Bool
(SymbolScope -> SymbolScope -> Bool)
-> (SymbolScope -> SymbolScope -> Bool) -> Eq SymbolScope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SymbolScope -> SymbolScope -> Bool
== :: SymbolScope -> SymbolScope -> Bool
$c/= :: SymbolScope -> SymbolScope -> Bool
/= :: SymbolScope -> SymbolScope -> Bool
Eq,Eq SymbolScope
Eq SymbolScope =>
(SymbolScope -> SymbolScope -> Ordering)
-> (SymbolScope -> SymbolScope -> Bool)
-> (SymbolScope -> SymbolScope -> Bool)
-> (SymbolScope -> SymbolScope -> Bool)
-> (SymbolScope -> SymbolScope -> Bool)
-> (SymbolScope -> SymbolScope -> SymbolScope)
-> (SymbolScope -> SymbolScope -> SymbolScope)
-> Ord 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
$ccompare :: SymbolScope -> SymbolScope -> Ordering
compare :: SymbolScope -> SymbolScope -> Ordering
$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
>= :: SymbolScope -> SymbolScope -> Bool
$cmax :: SymbolScope -> SymbolScope -> SymbolScope
max :: SymbolScope -> SymbolScope -> SymbolScope
$cmin :: SymbolScope -> SymbolScope -> SymbolScope
min :: SymbolScope -> SymbolScope -> SymbolScope
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 = (a -> ([a], [a], [a]) -> ([a], [a], [a]))
-> ([a], [a], [a]) -> [a] -> ([a], [a], [a])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> ([a], [a], [a]) -> ([a], [a], [a])
bin ([a], [a], [a])
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 SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
CategoryScope = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
cs,[a]
ts,[a]
vs)
    | a -> SymbolScope
f a
x SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
TypeScope     = ([a]
cs,a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ts,[a]
vs)
    | a -> SymbolScope
f a
x SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolScope
ValueScope    = ([a]
cs,[a]
ts,a
xa -> [a] -> [a]
forall 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 GeneralInstance
assigned <- ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParamName
-> GeneralInstance
-> Map ParamName GeneralInstance
-> Map ParamName GeneralInstance
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf GeneralInstance
selfType (Map ParamName GeneralInstance -> Map ParamName GeneralInstance)
-> ([(ParamName, GeneralInstance)]
    -> Map ParamName GeneralInstance)
-> [(ParamName, GeneralInstance)]
-> Map ParamName GeneralInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) (m [(ParamName, GeneralInstance)]
 -> m (Map ParamName GeneralInstance))
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> a -> b
$ (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
params) InstanceParams
ps
  [(ParamName, TypeFilter)]
fs <- (ParamFilter c -> m (ParamName, TypeFilter))
-> [ParamFilter c] -> m [(ParamName, TypeFilter)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> (ParamName, TypeFilter) -> m (ParamName, TypeFilter)
forall {m :: * -> *} {a}.
CollectErrorsM m =>
Map ParamName GeneralInstance
-> (a, TypeFilter) -> m (a, TypeFilter)
subSingleFilter Map ParamName GeneralInstance
assigned ((ParamName, TypeFilter) -> m (ParamName, TypeFilter))
-> (ParamFilter c -> (ParamName, TypeFilter))
-> ParamFilter c
-> m (ParamName, TypeFilter)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \ParamFilter c
f -> (ParamFilter c -> ParamName
forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f,ParamFilter c -> TypeFilter
forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter c
f)) [ParamFilter c]
allFilters
  let fa :: Map ParamName [TypeFilter]
fa = ([TypeFilter] -> [TypeFilter] -> [TypeFilter])
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
(++) ([(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter])
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall a b. (a -> b) -> a -> b
$ ((ParamName, TypeFilter) -> (ParamName, [TypeFilter]))
-> [(ParamName, TypeFilter)] -> [(ParamName, [TypeFilter])]
forall a b. (a -> b) -> [a] -> [b]
map ((TypeFilter -> [TypeFilter])
-> (ParamName, TypeFilter) -> (ParamName, [TypeFilter])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (TypeFilter -> [TypeFilter] -> [TypeFilter]
forall a. a -> [a] -> [a]
:[])) [(ParamName, TypeFilter)]
fs
  ([[TypeFilter]] -> InstanceFilters)
-> m [[TypeFilter]] -> m InstanceFilters
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[TypeFilter]] -> InstanceFilters
forall a. [a] -> Positional a
Positional (m [[TypeFilter]] -> m InstanceFilters)
-> m [[TypeFilter]] -> m InstanceFilters
forall a b. (a -> b) -> a -> b
$ (ParamName -> m [TypeFilter]) -> [ParamName] -> m [[TypeFilter]]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName [TypeFilter] -> ParamName -> m [TypeFilter]
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 = (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
    allFilters :: [ParamFilter c]
allFilters = AnyCategory c -> [ParamFilter c]
forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t [ParamFilter c] -> [ParamFilter c] -> [ParamFilter c]
forall a. [a] -> [a] -> [a]
++ (TypeFilter -> ParamFilter c) -> [TypeFilter] -> [ParamFilter c]
forall a b. (a -> b) -> [a] -> [b]
map ([c] -> ParamName -> TypeFilter -> ParamFilter c
forall c. [c] -> ParamName -> TypeFilter -> ParamFilter c
ParamFilter (AnyCategory c -> [c]
forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t) ParamName
ParamSelf) (AnyCategory c -> [TypeFilter]
forall c. AnyCategory c -> [TypeFilter]
getSelfFilters AnyCategory c
t)
    subSingleFilter :: Map ParamName GeneralInstance
-> (a, TypeFilter) -> m (a, TypeFilter)
subSingleFilter Map ParamName GeneralInstance
pa (a
n,(TypeFilter FilterDirection
v GeneralInstance
t2)) = do
      GeneralInstance
t3<- (ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
uncheckedSubInstance (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
pa) GeneralInstance
t2
      (a, TypeFilter) -> m (a, TypeFilter)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
n,(FilterDirection -> GeneralInstance -> TypeFilter
TypeFilter FilterDirection
v GeneralInstance
t3))
    subSingleFilter Map ParamName GeneralInstance
pa (a
n,(DefinesFilter (DefinesInstance CategoryName
n2 InstanceParams
ps2))) = do
      [GeneralInstance]
ps3 <- (GeneralInstance -> m GeneralInstance)
-> [GeneralInstance] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ((ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
uncheckedSubInstance ((ParamName -> m GeneralInstance)
 -> GeneralInstance -> m GeneralInstance)
-> (ParamName -> m GeneralInstance)
-> GeneralInstance
-> m GeneralInstance
forall a b. (a -> b) -> a -> b
$ Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
pa) (InstanceParams -> [GeneralInstance]
forall a. Positional a -> [a]
pValues InstanceParams
ps2)
      (a, TypeFilter) -> m (a, TypeFilter)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
n,(DefinesInstance -> TypeFilter
DefinesFilter (CategoryName -> InstanceParams -> DefinesInstance
DefinesInstance CategoryName
n2 ([GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional [GeneralInstance]
ps3))))
    subSingleFilter Map ParamName GeneralInstance
_ f :: (a, TypeFilter)
f@(a
_,TypeFilter
ImmutableFilter) = (a, TypeFilter) -> m (a, TypeFilter)
forall a. a -> m a
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 k -> Map k [a] -> Maybe [a]
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map k [a]
fa of
            (Just [a]
x) -> [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
x
            Maybe [a]
_ -> [a] -> m [a]
forall a. a -> m 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 = (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
  selfParams :: InstanceParams
selfParams = [GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional ([GeneralInstance] -> InstanceParams)
-> [GeneralInstance] -> InstanceParams
forall a b. (a -> b) -> a -> b
$ (ParamName -> GeneralInstance) -> [ParamName] -> [GeneralInstance]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> (ParamName -> TypeInstanceOrParam)
-> ParamName
-> GeneralInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False) [ParamName]
params
  selfFilters :: [TypeFilter]
selfFilters
    | AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isInstanceInterface AnyCategory c
t = [
        DefinesInstance -> TypeFilter
DefinesFilter (DefinesInstance -> TypeFilter) -> DefinesInstance -> TypeFilter
forall a b. (a -> b) -> a -> b
$ CategoryName -> InstanceParams -> DefinesInstance
DefinesInstance (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) InstanceParams
selfParams
      ] [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
++ [TypeFilter]
inheritedFilters
    | Bool
otherwise = [
        FilterDirection -> GeneralInstance -> TypeFilter
TypeFilter FilterDirection
FilterRequires (GeneralInstance -> TypeFilter) -> GeneralInstance -> TypeFilter
forall a b. (a -> b) -> a -> b
$ TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> TypeInstance -> TypeInstanceOrParam
forall a b. (a -> b) -> a -> b
$ CategoryName -> InstanceParams -> TypeInstance
TypeInstance (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) InstanceParams
selfParams
      ] [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
++ [TypeFilter]
inheritedFilters
  inheritedFilters :: [TypeFilter]
inheritedFilters = (ValueDefine c -> TypeFilter) -> [ValueDefine c] -> [TypeFilter]
forall a b. (a -> b) -> [a] -> [b]
map (DefinesInstance -> TypeFilter
DefinesFilter (DefinesInstance -> TypeFilter)
-> (ValueDefine c -> DefinesInstance)
-> ValueDefine c
-> TypeFilter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType) (AnyCategory c -> [ValueDefine c]
forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t) [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
++
                     (ValueRefine c -> TypeFilter) -> [ValueRefine c] -> [TypeFilter]
forall a b. (a -> b) -> [a] -> [b]
map (FilterDirection -> GeneralInstance -> TypeFilter
TypeFilter FilterDirection
FilterRequires (GeneralInstance -> TypeFilter)
-> (ValueRefine c -> GeneralInstance)
-> ValueRefine c
-> TypeFilter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> (ValueRefine c -> TypeInstanceOrParam)
-> ValueRefine c
-> GeneralInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> (ValueRefine c -> TypeInstance)
-> ValueRefine c
-> TypeInstanceOrParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType) (AnyCategory c -> [ValueRefine c]
forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t)

subAllParams :: CollectErrorsM m =>
  ParamValues -> GeneralInstance -> m GeneralInstance
subAllParams :: forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName GeneralInstance
-> GeneralInstance -> m GeneralInstance
subAllParams Map ParamName GeneralInstance
pa = (ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
uncheckedSubInstance (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
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 = [(CategoryName, AnyCategory c)] -> CategoryMap c
forall c. [(CategoryName, AnyCategory c)] -> CategoryMap c
toCategoryMap []

toCategoryMap :: [(CategoryName,AnyCategory c)] -> CategoryMap c
toCategoryMap :: forall c. [(CategoryName, AnyCategory c)] -> CategoryMap c
toCategoryMap = Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
forall k a. Map k a
Map.empty (Map CategoryName (AnyCategory c) -> CategoryMap c)
-> ([(CategoryName, AnyCategory c)]
    -> Map CategoryName (AnyCategory c))
-> [(CategoryName, AnyCategory c)]
-> CategoryMap c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CategoryName, AnyCategory c)] -> Map CategoryName (AnyCategory 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 CategoryName
-> Map CategoryName (AnyCategory c) -> Maybe (AnyCategory c)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName (AnyCategory c)
tm) (CategoryName
n CategoryName -> Map CategoryName [c] -> Maybe [c]
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]
_ = ([c], AnyCategory c) -> m ([c], AnyCategory c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c,AnyCategory c
t)
  handle Maybe (AnyCategory c)
_ (Just [c]
c2) = String -> m ([c], AnyCategory c)
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ([c], AnyCategory c))
-> String -> m ([c], AnyCategory c)
forall a b. (a -> b) -> a -> b
$ String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c2 String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                        String
" not visible here" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c
  handle Maybe (AnyCategory c)
_ Maybe [c]
_ = String -> m ([c], AnyCategory c)
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ([c], AnyCategory c))
-> String -> m ([c], AnyCategory c)
forall a b. (a -> b) -> a -> b
$ String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not found" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([c]
c,CategoryName
n)
  if AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isValueInterface AnyCategory c
t Bool -> Bool -> Bool
|| AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t
     then ([c], AnyCategory c) -> m ([c], AnyCategory c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,AnyCategory c
t)
     else String -> m ([c], AnyCategory c)
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ([c], AnyCategory c))
-> String -> m ([c], AnyCategory c)
forall a b. (a -> b) -> a -> b
$ String
"Category " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++
                           String
" cannot be used as a value" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                           [c] -> String
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([c]
c,CategoryName
n)
  if AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isInstanceInterface AnyCategory c
t
     then ([c], AnyCategory c) -> m ([c], AnyCategory c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,AnyCategory c
t)
     else String -> m ([c], AnyCategory c)
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ([c], AnyCategory c))
-> String -> m ([c], AnyCategory c)
forall a b. (a -> b) -> a -> b
$ String
"Category " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++
                           String
" cannot be used as a type interface" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                           [c] -> String
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([c]
c,CategoryName
n)
  if AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t
     then ([c], AnyCategory c) -> m ([c], AnyCategory c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,AnyCategory c
t)
     else String -> m ([c], AnyCategory c)
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ([c], AnyCategory c))
-> String -> m ([c], AnyCategory c)
forall a b. (a -> b) -> a -> b
$ String
"Category " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++
                           String
" cannot be used as concrete" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                           [c] -> String
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
  CategoryMap c -> [AnyCategory c] -> m ()
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkConnectionCycles CategoryMap c
tm0 [AnyCategory c]
ts
  CategoryMap c -> [AnyCategory c] -> m ()
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkConnectedTypes CategoryMap c
tm0 [AnyCategory c]
ts
  CategoryMap c -> [AnyCategory c] -> m ()
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkParamVariances CategoryMap c
tm0 [AnyCategory c]
ts
  [AnyCategory c]
ts2 <- CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
topoSortCategories CategoryMap c
tm0 [AnyCategory c]
ts
  [AnyCategory c]
ts3 <- CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
flattenAllConnections CategoryMap c
tm0 [AnyCategory c]
ts2
  CategoryMap c -> [AnyCategory c] -> m ()
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m ()
checkCategoryInstances CategoryMap c
tm0 [AnyCategory c]
ts3
  CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
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 = (AnyCategory c -> m (CategoryMap c) -> m (CategoryMap c))
-> m (CategoryMap c) -> [AnyCategory c] -> m (CategoryMap c)
forall a b. (a -> b -> b) -> b -> [a] -> b
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 m (CategoryMap c)
-> (CategoryMap c -> m (CategoryMap c)) -> m (CategoryMap c)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AnyCategory c -> CategoryMap c -> m (CategoryMap c)
forall {m :: * -> *} {c}.
(ErrorContextM m, Show c) =>
AnyCategory c -> CategoryMap c -> m (CategoryMap c)
update AnyCategory c
t) (CategoryMap c -> m (CategoryMap c)
forall a. a -> m a
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 AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t CategoryName
-> Map CategoryName (AnyCategory c) -> Maybe (AnyCategory c)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName (AnyCategory c)
tm of
        (Just AnyCategory c
t2) -> String -> m (CategoryMap c)
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m (CategoryMap c)) -> String -> m (CategoryMap c)
forall a b. (a -> b) -> a -> b
$ String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                      [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace (AnyCategory c -> [c]
forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                      String
" has already been declared" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                      [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace (AnyCategory c -> [c]
forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t2)
        Maybe (AnyCategory c)
_ -> CategoryMap c -> m (CategoryMap c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CategoryMap c -> m (CategoryMap c))
-> CategoryMap c -> m (CategoryMap c)
forall a b. (a -> b) -> a -> b
$ Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km (Map CategoryName (AnyCategory c) -> CategoryMap c)
-> Map CategoryName (AnyCategory c) -> CategoryMap c
forall a b. (a -> b) -> a -> b
$ CategoryName
-> AnyCategory c
-> Map CategoryName (AnyCategory c)
-> Map CategoryName (AnyCategory c)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AnyCategory c -> CategoryName
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 <- ([[ParamFilter c]] -> [ParamFilter c])
-> m [[ParamFilter c]] -> m [ParamFilter c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ParamFilter c]] -> [ParamFilter c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[ParamFilter c]] -> m [ParamFilter c])
-> m [[ParamFilter c]] -> m [ParamFilter c]
forall a b. (a -> b) -> a -> b
$ (ParamFilter c -> m [ParamFilter c])
-> [ParamFilter c] -> m [[ParamFilter c]]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ParamFilter c -> m [ParamFilter c]
maybeMirror [ParamFilter c]
fs
  Map ParamName [TypeFilter] -> m (Map ParamName [TypeFilter])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ParamName [TypeFilter] -> m (Map ParamName [TypeFilter]))
-> Map ParamName [TypeFilter] -> m (Map ParamName [TypeFilter])
forall a b. (a -> b) -> a -> b
$ [ParamFilter c]
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall {c}.
[ParamFilter c]
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
getFilters [ParamFilter c]
mirrored ([(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter])
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall a b. (a -> b) -> a -> b
$ [ParamName] -> [[TypeFilter]] -> [(ParamName, [TypeFilter])]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set ParamName -> [ParamName]
forall a. Set a -> [a]
Set.toList Set ParamName
pa) ([TypeFilter] -> [[TypeFilter]]
forall a. a -> [a]
repeat []) where
    pa :: Set ParamName
pa = [ParamName] -> Set ParamName
forall a. Ord a => [a] -> Set a
Set.fromList ([ParamName] -> Set ParamName) -> [ParamName] -> Set ParamName
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam [ValueParam c]
ps
    maybeMirror :: ParamFilter c -> m [ParamFilter c]
maybeMirror fa :: ParamFilter c
fa@(ParamFilter [c]
c ParamName
p1 (TypeFilter FilterDirection
d GeneralInstance
p2)) = do
      Maybe TypeInstanceOrParam
p <- m TypeInstanceOrParam -> m (Maybe TypeInstanceOrParam)
forall (m :: * -> *) a. CollectErrorsM m => m a -> m (Maybe a)
tryCompilerM (m TypeInstanceOrParam -> m (Maybe TypeInstanceOrParam))
-> m TypeInstanceOrParam -> m (Maybe TypeInstanceOrParam)
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> m (T GeneralInstance)
forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf GeneralInstance
p2
      case Maybe TypeInstanceOrParam
p of
          Just (JustParamName Bool
_ ParamName
p') ->
            if ParamName
p' ParamName -> Set ParamName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ParamName
pa
               then [ParamFilter c] -> m [ParamFilter c]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ParamFilter c
fa,([c] -> ParamName -> TypeFilter -> ParamFilter c
forall c. [c] -> ParamName -> TypeFilter -> ParamFilter c
ParamFilter [c]
c ParamName
p' (FilterDirection -> GeneralInstance -> TypeFilter
TypeFilter (FilterDirection -> FilterDirection
flipFilter FilterDirection
d) (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False ParamName
p1))))]
               else [ParamFilter c] -> m [ParamFilter c]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ParamFilter c
fa]
          Maybe TypeInstanceOrParam
_ -> [ParamFilter c] -> m [ParamFilter c]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ParamFilter c
fa]
    maybeMirror ParamFilter c
fa = [ParamFilter c] -> m [ParamFilter c]
forall a. a -> m a
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' = (ParamFilter c -> (ParamName, TypeFilter))
-> [ParamFilter c] -> [(ParamName, TypeFilter)]
forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
f -> (ParamFilter c -> ParamName
forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f,ParamFilter c -> TypeFilter
forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter c
f)) [ParamFilter c]
fs2 in
                             ([TypeFilter] -> [TypeFilter] -> [TypeFilter])
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
(++) ([(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter])
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall a b. (a -> b) -> a -> b
$ ((ParamName, TypeFilter) -> (ParamName, [TypeFilter]))
-> [(ParamName, TypeFilter)] -> [(ParamName, [TypeFilter])]
forall a b. (a -> b) -> [a] -> [b]
map ((TypeFilter -> [TypeFilter])
-> (ParamName, TypeFilter) -> (ParamName, [TypeFilter])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (TypeFilter -> [TypeFilter] -> [TypeFilter]
forall a. a -> [a] -> [a]
:[])) [(ParamName, TypeFilter)]
fs' [(ParamName, [TypeFilter])]
-> [(ParamName, [TypeFilter])] -> [(ParamName, [TypeFilter])]
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 <- [ValueParam c] -> [ParamFilter c] -> m (Map ParamName [TypeFilter])
forall (m :: * -> *) c.
CollectErrorsM m =>
[ValueParam c] -> [ParamFilter c] -> m (Map ParamName [TypeFilter])
getFilterMap (AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t) (AnyCategory c -> [ParamFilter c]
forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t)
  Map ParamName [TypeFilter] -> m (Map ParamName [TypeFilter])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ParamName [TypeFilter] -> m (Map ParamName [TypeFilter]))
-> Map ParamName [TypeFilter] -> m (Map ParamName [TypeFilter])
forall a b. (a -> b) -> a -> b
$ ParamName
-> [TypeFilter]
-> Map ParamName [TypeFilter]
-> Map ParamName [TypeFilter]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf (AnyCategory c -> [TypeFilter]
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 = Set ParamName -> m (Set ParamName)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set ParamName -> m (Set ParamName))
-> (AnyCategory c -> Set ParamName)
-> AnyCategory c
-> m (Set ParamName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParamName] -> Set ParamName
forall a. Ord a => [a] -> Set a
Set.fromList ([ParamName] -> Set ParamName)
-> (AnyCategory c -> [ParamName]) -> AnyCategory c -> Set ParamName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ParamName
ParamSelf] [ParamName] -> [ParamName] -> [ParamName]
forall a. [a] -> [a] -> [a]
++) ([ParamName] -> [ParamName])
-> (AnyCategory c -> [ParamName]) -> AnyCategory c -> [ParamName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName])
-> (AnyCategory c -> [ValueParam c])
-> AnyCategory c
-> [ParamName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyCategory c -> [ValueParam 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 = [ValueParam c] -> [ParamFilter c] -> m (Map ParamName [TypeFilter])
forall (m :: * -> *) c.
CollectErrorsM m =>
[ValueParam c] -> [ParamFilter c] -> m (Map ParamName [TypeFilter])
getFilterMap (Positional (ValueParam c) -> [ValueParam c]
forall a. Positional a -> [a]
pValues (Positional (ValueParam c) -> [ValueParam c])
-> Positional (ValueParam c) -> [ValueParam c]
forall a b. (a -> b) -> a -> b
$ ScopedFunction c -> Positional (ValueParam c)
forall c. ScopedFunction c -> Positional (ValueParam c)
sfParams ScopedFunction c
f) (ScopedFunction c -> [ParamFilter c]
forall c. ScopedFunction c -> [ParamFilter c]
sfFilters ScopedFunction c
f)

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

disallowBoundedParams :: CollectErrorsM m => ParamFilters -> m ()
disallowBoundedParams :: forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName [TypeFilter] -> m ()
disallowBoundedParams = ((ParamName, [TypeFilter]) -> m ())
-> [(ParamName, [TypeFilter])] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (ParamName, [TypeFilter]) -> m ()
forall {t :: * -> *} {f :: * -> *} {a}.
(Foldable t, Show a, CollectErrorsM f) =>
(a, t TypeFilter) -> f ()
checkBounds ([(ParamName, [TypeFilter])] -> m ())
-> (Map ParamName [TypeFilter] -> [(ParamName, [TypeFilter])])
-> Map ParamName [TypeFilter]
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ParamName [TypeFilter] -> [(ParamName, [TypeFilter])]
forall k a. Map k a -> [(k, a)]
Map.toList where
  checkBounds :: (a, t TypeFilter) -> f ()
checkBounds (a
p,t TypeFilter
fs) = do
    let (GeneralInstance
lb,GeneralInstance
ub) = (TypeFilter
 -> (GeneralInstance, GeneralInstance)
 -> (GeneralInstance, GeneralInstance))
-> (GeneralInstance, GeneralInstance)
-> t TypeFilter
-> (GeneralInstance, GeneralInstance)
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeFilter
-> (GeneralInstance, GeneralInstance)
-> (GeneralInstance, GeneralInstance)
splitBounds (GeneralInstance
forall a. Bounded a => a
minBound,GeneralInstance
forall a. Bounded a => a
maxBound) t TypeFilter
fs
    Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralInstance
lb GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
/= GeneralInstance
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& GeneralInstance
ub GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
/= GeneralInstance
forall a. Bounded a => a
maxBound) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
      String
"Param " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" cannot have both lower and upper bounds" String -> f () -> f ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
!!>
        [f Any] -> f ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ [
            String -> f Any
forall a. String -> f a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> f Any) -> String -> f Any
forall a b. (a -> b) -> a -> b
$ String
"Lower bound: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
lb,
            String -> f Any
forall a. String -> f a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> f Any) -> String -> f Any
forall a b. (a -> b) -> a -> b
$ String
"Upper bound: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
ub
          ]
  splitBounds :: TypeFilter
-> (GeneralInstance, GeneralInstance)
-> (GeneralInstance, GeneralInstance)
splitBounds (TypeFilter FilterDirection
FilterRequires GeneralInstance
t) (GeneralInstance
lb,GeneralInstance
ub) = (GeneralInstance
lb,GeneralInstance
tGeneralInstance -> GeneralInstance -> GeneralInstance
forall a. Mergeable a => a -> a -> a
<&&>GeneralInstance
ub)
  splitBounds (TypeFilter FilterDirection
FilterAllows   GeneralInstance
t) (GeneralInstance
lb,GeneralInstance
ub) = (GeneralInstance
tGeneralInstance -> GeneralInstance -> GeneralInstance
forall a. Mergeable a => a -> a -> a
<||>GeneralInstance
lb,GeneralInstance
ub)
  splitBounds TypeFilter
_ (GeneralInstance, GeneralInstance)
bs = (GeneralInstance, GeneralInstance)
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 <- CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes CategoryMap c
cm0 [AnyCategory c]
ts
  [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((AnyCategory c -> m ()) -> [AnyCategory c] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (CategoryMap c -> AnyCategory c -> m ()
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 = (ValueRefine c -> ([c], CategoryName))
-> [ValueRefine c] -> [([c], CategoryName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (ValueRefine c -> [c]
forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName (TypeInstance -> CategoryName) -> TypeInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) [ValueRefine c]
rs
      [([c], AnyCategory c)]
is <- (([c], CategoryName) -> m ([c], AnyCategory c))
-> [([c], CategoryName)] -> m [([c], AnyCategory c)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
cm) [([c], CategoryName)]
ts2
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((([c], AnyCategory c) -> m ()) -> [([c], AnyCategory c)] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([c] -> CategoryName -> ([c], AnyCategory c) -> m ()
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)
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((([c], AnyCategory c) -> m ()) -> [([c], AnyCategory c)] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([c] -> CategoryName -> ([c], AnyCategory c) -> m ()
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 = (ValueRefine c -> ([c], CategoryName))
-> [ValueRefine c] -> [([c], CategoryName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (ValueRefine c -> [c]
forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName (TypeInstance -> CategoryName) -> TypeInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) [ValueRefine c]
rs
      let ts3 :: [([c], CategoryName)]
ts3 = (ValueDefine c -> ([c], CategoryName))
-> [ValueDefine c] -> [([c], CategoryName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueDefine c
d -> (ValueDefine c -> [c]
forall c. ValueDefine c -> [c]
vdContext ValueDefine c
d,DefinesInstance -> CategoryName
diName (DefinesInstance -> CategoryName)
-> DefinesInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine c
d)) [ValueDefine c]
ds
      [([c], AnyCategory c)]
is1 <- (([c], CategoryName) -> m ([c], AnyCategory c))
-> [([c], CategoryName)] -> m [([c], AnyCategory c)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
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 <- (([c], CategoryName) -> m ([c], AnyCategory c))
-> [([c], CategoryName)] -> m [([c], AnyCategory c)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
cm) [([c], CategoryName)]
ts3
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((([c], AnyCategory c) -> m ()) -> [([c], AnyCategory c)] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([c] -> CategoryName -> ([c], AnyCategory c) -> m ()
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)
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((([c], AnyCategory c) -> m ()) -> [([c], AnyCategory c)] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([c] -> CategoryName -> ([c], AnyCategory c) -> m ()
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)
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((([c], AnyCategory c) -> m ()) -> [([c], AnyCategory c)] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([c] -> CategoryName -> ([c], AnyCategory c) -> m ()
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)
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((([c], AnyCategory c) -> m ()) -> [([c], AnyCategory c)] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([c] -> CategoryName -> ([c], AnyCategory c) -> m ()
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
_ = () -> m ()
forall a. a -> m a
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)
      | AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isInstanceInterface AnyCategory c
t =
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Value interface " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine type interface " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         CategoryName -> String
forall a. Show a => a -> String
show (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
iiName AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
      | Bool
otherwise = () -> m ()
forall a. a -> m a
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)
      | AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t =
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Value interface " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine concrete type " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         CategoryName -> String
forall a. Show a => a -> String
show (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
      | Bool
otherwise = () -> m ()
forall a. a -> m a
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)
      | AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isInstanceInterface AnyCategory c
t =
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Concrete type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine instance interface " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         CategoryName -> String
forall a. Show a => a -> String
show (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2 String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" => use defines instead"
      | Bool
otherwise = () -> m ()
forall a. a -> m a
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)
      | AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isValueInterface AnyCategory c
t =
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Concrete type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" cannot define value interface " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         CategoryName -> String
forall a. Show a => a -> String
show (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2 String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" => use refines instead"
      | Bool
otherwise = () -> m ()
forall a. a -> m a
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)
      | AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t =
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Concrete type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine concrete type " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         CategoryName -> String
forall a. Show a => a -> String
show (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
      | Bool
otherwise = () -> m ()
forall a. a -> m a
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)
      | AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t =
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Concrete type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" cannot define concrete type " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         CategoryName -> String
forall a. Show a => a -> String
show (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2
      | Bool
otherwise = () -> m ()
forall a. a -> m a
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 = [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((AnyCategory c -> m ()) -> [AnyCategory c] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([CategoryName] -> AnyCategory c -> m ()
checker []) [AnyCategory c]
ts) where
  tm :: Map CategoryName (AnyCategory c)
tm = Map CategoryName (AnyCategory c)
-> Map CategoryName (AnyCategory c)
-> Map CategoryName (AnyCategory c)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map CategoryName (AnyCategory c)
tm0 (Map CategoryName (AnyCategory c)
 -> Map CategoryName (AnyCategory c))
-> Map CategoryName (AnyCategory c)
-> Map CategoryName (AnyCategory c)
forall a b. (a -> b) -> a -> b
$ [(CategoryName, AnyCategory c)] -> Map CategoryName (AnyCategory c)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CategoryName, AnyCategory c)]
 -> Map CategoryName (AnyCategory c))
-> [(CategoryName, AnyCategory c)]
-> Map CategoryName (AnyCategory c)
forall a b. (a -> b) -> a -> b
$ [CategoryName]
-> [AnyCategory c] -> [(CategoryName, AnyCategory c)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((AnyCategory c -> CategoryName)
-> [AnyCategory c] -> [CategoryName]
forall a b. (a -> b) -> [a] -> [b]
map AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName [AnyCategory c]
ts) [AnyCategory c]
ts
  cm :: CategoryMap c
cm = Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
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
    CategoryName -> [c] -> [CategoryName] -> m ()
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 = (ValueRefine c -> ([c], CategoryName))
-> [ValueRefine c] -> [([c], CategoryName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (ValueRefine c -> [c]
forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName (TypeInstance -> CategoryName) -> TypeInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) [ValueRefine c]
rs
    [([c], AnyCategory c)]
is <- (([c], CategoryName) -> m ([c], AnyCategory c))
-> [([c], CategoryName)] -> m [([c], AnyCategory c)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
cm) [([c], CategoryName)]
ts2
    [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((([c], AnyCategory c) -> m ()) -> [([c], AnyCategory c)] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([CategoryName] -> AnyCategory c -> m ()
checker ([CategoryName]
us [CategoryName] -> [CategoryName] -> [CategoryName]
forall a. [a] -> [a] -> [a]
++ [CategoryName
n]) (AnyCategory c -> m ())
-> (([c], AnyCategory c) -> AnyCategory c)
-> ([c], AnyCategory c)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([c], AnyCategory c) -> AnyCategory 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
    CategoryName -> [c] -> [CategoryName] -> m ()
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 = (ValueRefine c -> ([c], CategoryName))
-> [ValueRefine c] -> [([c], CategoryName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (ValueRefine c -> [c]
forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName (TypeInstance -> CategoryName) -> TypeInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) [ValueRefine c]
rs
    [([c], AnyCategory c)]
is <- (([c], CategoryName) -> m ([c], AnyCategory c))
-> [([c], CategoryName)] -> m [([c], AnyCategory c)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
cm) [([c], CategoryName)]
ts2
    [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((([c], AnyCategory c) -> m ()) -> [([c], AnyCategory c)] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([CategoryName] -> AnyCategory c -> m ()
checker ([CategoryName]
us [CategoryName] -> [CategoryName] -> [CategoryName]
forall a. [a] -> [a] -> [a]
++ [CategoryName
n]) (AnyCategory c -> m ())
-> (([c], AnyCategory c) -> AnyCategory c)
-> ([c], AnyCategory c)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([c], AnyCategory c) -> AnyCategory c
forall a b. (a, b) -> b
snd) [([c], AnyCategory c)]
is)
  checker [CategoryName]
_ AnyCategory c
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  failIfCycle :: a -> [a] -> [a] -> f ()
failIfCycle a
n [a]
c [a]
us =
    Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
n a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
us)) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
      String -> f ()
forall a. String -> f a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> f ()) -> String -> f ()
forall a b. (a -> b) -> a -> b
$ String
"Category " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" refers back to itself: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show ([a]
us [a] -> [a] -> [a]
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 <- CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
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 = CategoryMap c -> CategoryResolver c
forall c. CategoryMap c -> CategoryResolver c
CategoryResolver CategoryMap c
cm
  (AnyCategory c -> m ()) -> [AnyCategory c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (CategoryResolver c -> AnyCategory c -> m ()
forall {m :: * -> *} {c} {r}.
(Show c, CollectErrorsM m, TypeResolver r) =>
r -> AnyCategory c -> m ()
checkCategory CategoryResolver c
r) [AnyCategory c]
ts
  (AnyCategory c -> m ()) -> [AnyCategory c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ AnyCategory c -> m ()
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show (AnyCategory a -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory a
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace (AnyCategory a -> [a]
forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory a
t)
    checkBounds :: AnyCategory c -> m ()
checkBounds AnyCategory c
t = AnyCategory c -> String
forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory c
t String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> (AnyCategory c -> m (Map ParamName [TypeFilter])
forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Map ParamName [TypeFilter])
getCategoryFilterMap AnyCategory c
t m (Map ParamName [TypeFilter])
-> (Map ParamName [TypeFilter] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map ParamName [TypeFilter] -> m ()
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]
_) = AnyCategory c -> String
forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory c
t String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      [c] -> CategoryName -> [ValueParam c] -> m ()
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 = [(ParamName, Variance)] -> Map ParamName Variance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, Variance)] -> Map ParamName Variance)
-> [(ParamName, Variance)] -> Map ParamName Variance
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> (ParamName, Variance))
-> [ValueParam c] -> [(ParamName, Variance)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueParam c
p -> (ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ValueParam c
p,ValueParam c -> Variance
forall c. ValueParam c -> Variance
vpVariance ValueParam c
p)) [ValueParam c]
ps
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((ValueRefine c -> m ()) -> [ValueRefine c] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (r -> Map ParamName Variance -> ValueRefine c -> m ()
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]
_) = AnyCategory c -> String
forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory c
t String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      [c] -> CategoryName -> [ValueParam c] -> m ()
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 = [(ParamName, Variance)] -> Map ParamName Variance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, Variance)] -> Map ParamName Variance)
-> [(ParamName, Variance)] -> Map ParamName Variance
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> (ParamName, Variance))
-> [ValueParam c] -> [(ParamName, Variance)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueParam c
p -> (ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ValueParam c
p,ValueParam c -> Variance
forall c. ValueParam c -> Variance
vpVariance ValueParam c
p)) [ValueParam c]
ps
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((ValueRefine c -> m ()) -> [ValueRefine c] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (r -> Map ParamName Variance -> ValueRefine c -> m ()
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)
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((ValueDefine c -> m ()) -> [ValueDefine c] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (r -> Map ParamName Variance -> ValueDefine c -> m ()
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)
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((FunctionVisibility c -> m ()) -> [FunctionVisibility c] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (r -> Map ParamName Variance -> FunctionVisibility c -> m ()
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]
_) = AnyCategory c -> String
forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory c
t String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      [c] -> CategoryName -> [ValueParam c] -> m ()
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 = [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ (([ParamName] -> m ()) -> [[ParamName]] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map [ParamName] -> m ()
checkCount ([[ParamName]] -> [m ()]) -> [[ParamName]] -> [m ()]
forall a b. (a -> b) -> a -> b
$ [ParamName] -> [[ParamName]]
forall a. Eq a => [a] -> [[a]]
group ([ParamName] -> [[ParamName]]) -> [ParamName] -> [[ParamName]]
forall a b. (a -> b) -> a -> b
$ [ParamName] -> [ParamName]
forall a. Ord a => [a] -> [a]
sort ([ParamName] -> [ParamName]) -> [ParamName] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam [ValueParam c]
ps) where
      checkCount :: [ParamName] -> m ()
checkCount xa :: [ParamName]
xa@(ParamName
x:ParamName
_:[ParamName]
_) =
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Param " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" occurs " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([ParamName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ParamName]
xa) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" times in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
      checkCount [ParamName]
_ = () -> m ()
forall a. a -> m a
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) =
      r -> Map ParamName Variance -> Variance -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName Variance -> Variance -> GeneralInstance -> m ()
validateInstanceVariance r
r Map ParamName Variance
vm Variance
Covariant (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t) m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeInstance -> String
forall a. Show a => a -> String
show TypeInstance
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
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) =
      r -> Map ParamName Variance -> Variance -> DefinesInstance -> m ()
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 m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DefinesInstance -> String
forall a. Show a => a -> String
show DefinesInstance
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
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 = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkVisibility r
r Map ParamName Variance
vm (FunctionVisibility [a]
_ [([a], GeneralInstance)]
ts2) =
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((([a], GeneralInstance) -> m ())
-> [([a], GeneralInstance)] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (r -> Map ParamName Variance -> ([a], GeneralInstance) -> m ()
forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Map ParamName Variance -> ([a], GeneralInstance) -> m ()
checkVisibilitySingle r
r Map ParamName Variance
vm) [([a], GeneralInstance)]
ts2)
    checkVisibilitySingle :: r -> Map ParamName Variance -> ([a], GeneralInstance) -> m ()
checkVisibilitySingle r
r Map ParamName Variance
vm ([a]
c,GeneralInstance
t) =
      r -> Map ParamName Variance -> Variance -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName Variance -> Variance -> GeneralInstance -> m ()
validateInstanceVariance r
r Map ParamName Variance
vm Variance
Covariant GeneralInstance
t m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In visibility " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
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 <- CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
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 = CategoryMap c -> CategoryResolver c
forall c. CategoryMap c -> CategoryResolver c
CategoryResolver CategoryMap c
cm
  (AnyCategory c -> m ()) -> [AnyCategory c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (CategoryResolver c -> AnyCategory c -> m ()
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 <- AnyCategory c -> m (Set ParamName)
forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Set ParamName)
getCategoryParamSet AnyCategory c
t
      (ParamFilter c -> m ()) -> [ParamFilter c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (Set ParamName -> ParamFilter c -> m ()
forall {f :: * -> *} {a}.
(ErrorContextM f, Show a) =>
Set ParamName -> ParamFilter a -> f ()
checkFilterParam Set ParamName
pa)  (AnyCategory c -> [ParamFilter c]
forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t)
      (ValueRefine c -> m ()) -> [ValueRefine c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (r -> Set ParamName -> ValueRefine c -> m ()
forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Set ParamName -> ValueRefine a -> m ()
checkRefine r
r Set ParamName
pa)     (AnyCategory c -> [ValueRefine c]
forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t)
      (ValueDefine c -> m ()) -> [ValueDefine c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (r -> Set ParamName -> ValueDefine c -> m ()
forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Set ParamName -> ValueDefine a -> m ()
checkDefine r
r Set ParamName
pa)     (AnyCategory c -> [ValueDefine c]
forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t)
      (ParamFilter c -> m ()) -> [ParamFilter c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (r -> Set ParamName -> ParamFilter c -> m ()
forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Set ParamName -> ParamFilter a -> m ()
checkFilter r
r Set ParamName
pa)     (AnyCategory c -> [ParamFilter c]
forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t)
      (FunctionVisibility c -> m ()) -> [FunctionVisibility c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (r -> Set ParamName -> FunctionVisibility c -> m ()
forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Set ParamName -> FunctionVisibility a -> m ()
checkVisibility r
r Set ParamName
pa) (AnyCategory c -> [FunctionVisibility c]
forall c. AnyCategory c -> [FunctionVisibility c]
getCategoryVisibilities AnyCategory c
t)
      (ScopedFunction c -> m ()) -> [ScopedFunction c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (r -> AnyCategory c -> ScopedFunction c -> m ()
forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r -> AnyCategory c -> ScopedFunction c -> m ()
validateCategoryFunction r
r AnyCategory c
t) (AnyCategory c -> [ScopedFunction c]
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], GeneralInstance)]
ts2) =
      (([a], GeneralInstance) -> m ())
-> [([a], GeneralInstance)] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (r -> Set ParamName -> ([a], GeneralInstance) -> m ()
forall {m :: * -> *} {r} {a}.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Set ParamName -> ([a], GeneralInstance) -> m ()
checkVisibilitySingle r
r Set ParamName
fm) [([a], GeneralInstance)]
ts2 m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In visibility at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContext [a]
c
    checkVisibility r
_ Set ParamName
_ FunctionVisibility a
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkVisibilitySingle :: r -> Set ParamName -> ([a], GeneralInstance) -> m ()
checkVisibilitySingle r
r Set ParamName
fm ([a]
c,GeneralInstance
t) =
      r -> Set ParamName -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> GeneralInstance -> m ()
validateGeneralInstance r
r Set ParamName
fm GeneralInstance
t m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
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
_) =
      Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ParamName
n ParamName -> Set ParamName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ParamName
pa) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
        String -> f ()
forall a. String -> f a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> f ()) -> String -> f ()
forall a b. (a -> b) -> a -> b
$ String
"Param " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> ShowS
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) =
      r -> Set ParamName -> TypeInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> TypeInstance -> m ()
validateTypeInstance r
r Set ParamName
fm TypeInstance
t m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeInstance -> String
forall a. Show a => a -> String
show TypeInstance
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
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) =
      r -> Set ParamName -> DefinesInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> DefinesInstance -> m ()
validateDefinesInstance r
r Set ParamName
fm DefinesInstance
t m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DefinesInstance -> String
forall a. Show a => a -> String
show DefinesInstance
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
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) =
      r -> Set ParamName -> TypeFilter -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Set ParamName -> TypeFilter -> m ()
validateTypeFilter r
r Set ParamName
fm TypeFilter
f m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeFilter -> String
forall a. Show a => a -> String
show TypeFilter
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
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 <- AnyCategory c -> m (Set ParamName)
forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Set ParamName)
getCategoryParamSet AnyCategory c
t
  let vm :: Map ParamName Variance
vm = [(ParamName, Variance)] -> Map ParamName Variance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, Variance)] -> Map ParamName Variance)
-> [(ParamName, Variance)] -> Map ParamName Variance
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> (ParamName, Variance))
-> [ValueParam c] -> [(ParamName, Variance)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueParam c
p -> (ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ValueParam c
p,ValueParam c -> Variance
forall c. ValueParam c -> Variance
vpVariance ValueParam c
p)) ([ValueParam c] -> [(ParamName, Variance)])
-> [ValueParam c] -> [(ParamName, Variance)]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
  String
message String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
    FunctionType
funcType <- ScopedFunction c -> m FunctionType
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f
    case ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f of
         SymbolScope
CategoryScope -> r
-> Set ParamName -> Map ParamName Variance -> FunctionType -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Set ParamName -> Map ParamName Variance -> FunctionType -> m ()
validatateFunctionType r
r Set ParamName
forall a. Set a
Set.empty Map ParamName Variance
forall k a. Map k a
Map.empty FunctionType
funcType
         SymbolScope
TypeScope     -> r
-> Set ParamName -> Map ParamName Variance -> FunctionType -> m ()
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    -> r
-> Set ParamName -> Map ParamName Variance -> FunctionType -> m ()
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
_             -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ScopedFunction c -> m (Map ParamName [TypeFilter])
forall (m :: * -> *) c.
CollectErrorsM m =>
ScopedFunction c -> m (Map ParamName [TypeFilter])
getFunctionFilterMap ScopedFunction c
f m (Map ParamName [TypeFilter])
-> (Map ParamName [TypeFilter] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map ParamName [TypeFilter] -> m ()
forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName [TypeFilter] -> m ()
disallowBoundedParams
    SymbolScope -> FunctionVisibility c -> m ()
forall {m :: * -> *} {c}.
(ErrorContextM m, Show c) =>
SymbolScope -> FunctionVisibility c -> m ()
checkVis (ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f) (ScopedFunction c -> FunctionVisibility c
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], GeneralInstance)]
_) =
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Category functions must not have restricted visibility: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctionVisibility c -> String
forall a. Show a => a -> String
show FunctionVisibility c
va
      checkVis SymbolScope
_ FunctionVisibility c
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      message :: String
message
        | AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t CategoryName -> CategoryName -> Bool
forall a. Eq a => a -> a -> Bool
== ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f = String
"In function:\n---\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n---\n"
        | Bool
otherwise = String
"In function inherited from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show (ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                      [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace (AnyCategory c -> [c]
forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n---\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f String -> ShowS
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 <- CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes CategoryMap c
cm0 [AnyCategory c]
ts
  (([AnyCategory c], Set CategoryName) -> [AnyCategory c])
-> m ([AnyCategory c], Set CategoryName) -> m [AnyCategory c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([AnyCategory c], Set CategoryName) -> [AnyCategory c]
forall a b. (a, b) -> a
fst (m ([AnyCategory c], Set CategoryName) -> m [AnyCategory c])
-> m ([AnyCategory c], Set CategoryName) -> m [AnyCategory c]
forall a b. (a -> b) -> a -> b
$ CategoryMap c
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
forall {m :: * -> *} {c}.
(CollectErrorsM m, Show c) =>
CategoryMap c
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update CategoryMap c
cm (Map CategoryName (AnyCategory c) -> Set CategoryName
forall k a. Map k a -> Set k
Map.keysSet (Map CategoryName (AnyCategory c) -> Set CategoryName)
-> Map CategoryName (AnyCategory c) -> Set CategoryName
forall a b. (a -> b) -> a -> b
$ CategoryMap c -> Map CategoryName (AnyCategory c)
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 AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t CategoryName -> Set CategoryName -> Bool
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 <- (ValueRefine c -> m ([c], AnyCategory c))
-> [ValueRefine c] -> m [([c], AnyCategory c)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (\ValueRefine c
r -> CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
cm (ValueRefine c -> [c]
forall c. ValueRefine c -> [c]
vrContext ValueRefine c
r,TypeInstance -> CategoryName
tiName (TypeInstance -> CategoryName) -> TypeInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r)) ([ValueRefine c] -> m [([c], AnyCategory c)])
-> [ValueRefine c] -> m [([c], AnyCategory c)]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueRefine c]
forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t
           [([c], AnyCategory c)]
defines <- (ValueDefine c -> m ([c], AnyCategory c))
-> [ValueDefine c] -> m [([c], AnyCategory c)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (\ValueDefine c
d -> CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
cm (ValueDefine c -> [c]
forall c. ValueDefine c -> [c]
vdContext ValueDefine c
d,DefinesInstance -> CategoryName
diName (DefinesInstance -> CategoryName)
-> DefinesInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine c
d)) ([ValueDefine c] -> m [([c], AnyCategory c)])
-> [ValueDefine c] -> m [([c], AnyCategory c)]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueDefine c]
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 (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t CategoryName -> Set CategoryName -> Set CategoryName
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set CategoryName
ta) ((([c], AnyCategory c) -> AnyCategory c)
-> [([c], AnyCategory c)] -> [AnyCategory c]
forall a b. (a -> b) -> [a] -> [b]
map ([c], AnyCategory c) -> AnyCategory c
forall a b. (a, b) -> b
snd ([([c], AnyCategory c)] -> [AnyCategory c])
-> [([c], AnyCategory c)] -> [AnyCategory c]
forall a b. (a -> b) -> a -> b
$ [([c], AnyCategory c)]
refines [([c], AnyCategory c)]
-> [([c], AnyCategory c)] -> [([c], AnyCategory c)]
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
           ([AnyCategory c], Set CategoryName)
-> m ([AnyCategory c], Set CategoryName)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AnyCategory c]
ts3 [AnyCategory c] -> [AnyCategory c] -> [AnyCategory c]
forall a. [a] -> [a] -> [a]
++ [AnyCategory c
t] [AnyCategory c] -> [AnyCategory c] -> [AnyCategory c]
forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
ts4,Set CategoryName
ta3)
    update CategoryMap c
_ Set CategoryName
ta [AnyCategory c]
_ = ([AnyCategory c], Set CategoryName)
-> m ([AnyCategory c], Set CategoryName)
forall a. a -> m a
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 = (ValueRefine c -> ValueRefine c -> m ())
-> [ValueRefine c] -> m [ValueRefine c]
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 CategoryName -> CategoryName -> Bool
forall a. Eq a => a -> a -> Bool
/= CategoryName
n2 = String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ TypeInstance -> String
forall a. Show a => a -> String
show TypeInstance
t1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeInstance -> String
forall a. Show a => a -> String
show TypeInstance
t2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" are incompatible"
    | Bool
otherwise =
      m (MergeTree InferredTypeGuess) -> m ()
forall (m :: * -> *).
CollectErrorsM m =>
m (MergeTree InferredTypeGuess) -> m ()
noInferredTypes (m (MergeTree InferredTypeGuess) -> m ())
-> m (MergeTree InferredTypeGuess) -> m ()
forall a b. (a -> b) -> a -> b
$ r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
Covariant
                        (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> TypeInstance -> TypeInstanceOrParam
forall a b. (a -> b) -> a -> b
$ TypeInstance
t1)
                        (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> TypeInstance -> TypeInstanceOrParam
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 = (ValueDefine c -> ValueDefine c -> m ())
-> [ValueDefine c] -> m [ValueDefine c]
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 CategoryName -> CategoryName -> Bool
forall a. Eq a => a -> a -> Bool
/= CategoryName
n2 = String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ DefinesInstance -> String
forall a. Show a => a -> String
show DefinesInstance
t1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DefinesInstance -> String
forall a. Show a => a -> String
show DefinesInstance
t2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" are incompatible"
    | Bool
otherwise = r
-> Map ParamName [TypeFilter]
-> DefinesInstance
-> DefinesInstance
-> m (MergeTree InferredTypeGuess)
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 m (MergeTree InferredTypeGuess) -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
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 = (ValueRefine c -> (CategoryName, ValueRefine c))
-> [ValueRefine c] -> [(CategoryName, ValueRefine c)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> (TypeInstance -> CategoryName
tiName (TypeInstance -> CategoryName) -> TypeInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
r,ValueRefine c
r)) [ValueRefine c]
rs
  [c] -> CategoryName -> [(CategoryName, ValueRefine c)] -> m ()
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 = (ValueDefine c -> (CategoryName, ValueDefine c))
-> [ValueDefine c] -> [(CategoryName, ValueDefine c)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueDefine c
d -> (DefinesInstance -> CategoryName
diName (DefinesInstance -> CategoryName)
-> DefinesInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine c
d,ValueDefine c
d)) [ValueDefine c]
ds
  [c] -> CategoryName -> [(CategoryName, ValueDefine c)] -> m ()
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 = ([a] -> [a] -> [a])
-> [(CategoryName, [a])] -> Map CategoryName [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([(CategoryName, [a])] -> Map CategoryName [a])
-> [(CategoryName, [a])] -> Map CategoryName [a]
forall a b. (a -> b) -> a -> b
$ ((CategoryName, a) -> (CategoryName, [a]))
-> [(CategoryName, a)] -> [(CategoryName, [a])]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> [a]) -> (CategoryName, a) -> (CategoryName, [a])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])) [(CategoryName, a)]
ns
  ((CategoryName, [a]) -> m ()) -> [(CategoryName, [a])] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (CategoryName, [a]) -> m ()
checkCount ([(CategoryName, [a])] -> m ()) -> [(CategoryName, [a])] -> m ()
forall a b. (a -> b) -> a -> b
$ Map CategoryName [a] -> [(CategoryName, [a])]
forall k a. Map k a -> [(k, a)]
Map.toList Map CategoryName [a]
byName where
    checkCount :: (CategoryName, [a]) -> m ()
checkCount (CategoryName
_,[a
_]) = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkCount (CategoryName
n2,[a]
xs) =
      String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" occurs " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" times in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n---\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n---\n" ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
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 <- (AnyCategory c
 -> m (Map CategoryName (AnyCategory c))
 -> m (Map CategoryName (AnyCategory c)))
-> m (Map CategoryName (AnyCategory c))
-> [AnyCategory c]
-> m (Map CategoryName (AnyCategory c))
forall a b. (a -> b -> b) -> b -> [a] -> b
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 (Map CategoryName (AnyCategory c)
-> m (Map CategoryName (AnyCategory c))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Map CategoryName (AnyCategory c)
tm0) ([AnyCategory c] -> [AnyCategory c]
forall a. [a] -> [a]
reverse [AnyCategory c]
ts)
  let r :: CategoryResolver c
r = CategoryMap c -> CategoryResolver c
forall c. CategoryMap c -> CategoryResolver c
CategoryResolver (Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
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)
_) <- (AnyCategory c
 -> m ([AnyCategory c], Map CategoryName (AnyCategory c))
 -> m ([AnyCategory c], Map CategoryName (AnyCategory c)))
-> m ([AnyCategory c], Map CategoryName (AnyCategory c))
-> [AnyCategory c]
-> m ([AnyCategory c], Map CategoryName (AnyCategory c))
forall a b. (a -> b -> b) -> b -> [a] -> b
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) (([AnyCategory c], Map CategoryName (AnyCategory c))
-> m ([AnyCategory c], Map CategoryName (AnyCategory c))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Map CategoryName (AnyCategory c)
tm0)) ([AnyCategory c] -> [AnyCategory c]
forall a. [a] -> [a]
reverse [AnyCategory c]
ts)
  [AnyCategory c] -> m [AnyCategory c]
forall a. a -> m a
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
      Map CategoryName (AnyCategory c)
-> m (Map CategoryName (AnyCategory c))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map CategoryName (AnyCategory c)
 -> m (Map CategoryName (AnyCategory c)))
-> Map CategoryName (AnyCategory c)
-> m (Map CategoryName (AnyCategory c))
forall a b. (a -> b) -> a -> b
$ CategoryName
-> AnyCategory c
-> Map CategoryName (AnyCategory c)
-> Map CategoryName (AnyCategory c)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AnyCategory c -> CategoryName
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' <- ([[ValueRefine c]] -> [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ValueRefine c]] -> [ValueRefine c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[ValueRefine c]] -> m [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> m [ValueRefine c])
-> [ValueRefine c] -> m [[ValueRefine c]]
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
      AnyCategory c -> m (AnyCategory c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyCategory c -> m (AnyCategory c))
-> AnyCategory c -> m (AnyCategory c)
forall a b. (a -> b) -> a -> b
$ [c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ScopedFunction c]
-> AnyCategory c
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' <- ([[ValueRefine c]] -> [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ValueRefine c]] -> [ValueRefine c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[ValueRefine c]] -> m [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> m [ValueRefine c])
-> [ValueRefine c] -> m [[ValueRefine c]]
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
      AnyCategory c -> m (AnyCategory c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyCategory c -> m (AnyCategory c))
-> AnyCategory c -> m (AnyCategory c)
forall a b. (a -> b) -> a -> b
$ [c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [FunctionVisibility c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
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 = AnyCategory c -> m (AnyCategory c)
forall a. a -> m a
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 m (AnyCategory c) -> String -> m (AnyCategory c)
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
              String
"In category " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace (AnyCategory c -> [c]
forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t)
      ([AnyCategory c], Map CategoryName (AnyCategory c))
-> m ([AnyCategory c], Map CategoryName (AnyCategory c))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AnyCategory c]
ts2 [AnyCategory c] -> [AnyCategory c] -> [AnyCategory c]
forall a. [a] -> [a] -> [a]
++ [AnyCategory c
t'],CategoryName
-> AnyCategory c
-> Map CategoryName (AnyCategory c)
-> Map CategoryName (AnyCategory c)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AnyCategory c -> CategoryName
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 <- AnyCategory c -> m (Map ParamName [TypeFilter])
forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Map ParamName [TypeFilter])
getCategoryFilterMap AnyCategory c
t
      let pm :: Map ParamName GeneralInstance
pm = AnyCategory c -> Map ParamName GeneralInstance
forall c. AnyCategory c -> Map ParamName GeneralInstance
getCategoryParamMap AnyCategory c
t
      [ValueRefine c]
rs' <- ([[ValueRefine c]] -> [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ValueRefine c]] -> [ValueRefine c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[ValueRefine c]] -> m [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> m [ValueRefine c])
-> [ValueRefine c] -> m [[ValueRefine c]]
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'' <- CategoryResolver c
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> m [ValueRefine c]
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'
      [c] -> CategoryName -> [ValueRefine c] -> m ()
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
[c] -> CategoryName -> [ValueRefine c] -> m ()
noDuplicateRefines [c]
c CategoryName
n [ValueRefine c]
rs''
      CategoryResolver c
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueRefine c]
-> m ()
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 <- ([[PragmaCategory c]] -> [PragmaCategory c])
-> m [[PragmaCategory c]] -> m [PragmaCategory c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[PragmaCategory c]] -> [PragmaCategory c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[PragmaCategory c]] -> m [PragmaCategory c])
-> m [[PragmaCategory c]] -> m [PragmaCategory c]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> m [PragmaCategory c])
-> [ValueRefine c] -> m [[PragmaCategory c]]
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' <- CategoryResolver c
-> CategoryMap c
-> Map ParamName GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r
-> CategoryMap c
-> Map ParamName GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions CategoryResolver c
r (Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) Map ParamName GeneralInstance
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [] [ScopedFunction c]
fs
      AnyCategory c -> m (AnyCategory c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyCategory c -> m (AnyCategory c))
-> AnyCategory c -> m (AnyCategory c)
forall a b. (a -> b) -> a -> b
$ [c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ScopedFunction c]
-> AnyCategory c
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[PragmaCategory c] -> [PragmaCategory c] -> [PragmaCategory c]
forall 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 <- AnyCategory c -> m (Map ParamName [TypeFilter])
forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Map ParamName [TypeFilter])
getCategoryFilterMap AnyCategory c
t
      let pm :: Map ParamName GeneralInstance
pm = AnyCategory c -> Map ParamName GeneralInstance
forall c. AnyCategory c -> Map ParamName GeneralInstance
getCategoryParamMap AnyCategory c
t
      [ValueRefine c]
rs' <- ([[ValueRefine c]] -> [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ValueRefine c]] -> [ValueRefine c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[ValueRefine c]] -> m [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> m [ValueRefine c])
-> [ValueRefine c] -> m [[ValueRefine c]]
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'' <- CategoryResolver c
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> m [ValueRefine c]
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'
      [c] -> CategoryName -> [ValueRefine c] -> m ()
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
[c] -> CategoryName -> [ValueRefine c] -> m ()
noDuplicateRefines [c]
c CategoryName
n [ValueRefine c]
rs''
      CategoryResolver c
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueRefine c]
-> m ()
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' <- CategoryResolver c
-> Map ParamName [TypeFilter]
-> [ValueDefine c]
-> m [ValueDefine c]
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
      [c] -> CategoryName -> [ValueDefine c] -> m ()
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
[c] -> CategoryName -> [ValueDefine c] -> m ()
noDuplicateDefines [c]
c CategoryName
n [ValueDefine c]
ds'
      [PragmaCategory c]
pg2 <- ([[PragmaCategory c]] -> [PragmaCategory c])
-> m [[PragmaCategory c]] -> m [PragmaCategory c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[PragmaCategory c]] -> [PragmaCategory c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[PragmaCategory c]] -> m [PragmaCategory c])
-> m [[PragmaCategory c]] -> m [PragmaCategory c]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> m [PragmaCategory c])
-> [ValueRefine c] -> m [[PragmaCategory c]]
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 <- ([[PragmaCategory c]] -> [PragmaCategory c])
-> m [[PragmaCategory c]] -> m [PragmaCategory c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[PragmaCategory c]] -> [PragmaCategory c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[PragmaCategory c]] -> m [PragmaCategory c])
-> m [[PragmaCategory c]] -> m [PragmaCategory c]
forall a b. (a -> b) -> a -> b
$ (ValueDefine c -> m [PragmaCategory c])
-> [ValueDefine c] -> m [[PragmaCategory c]]
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' <- CategoryResolver c
-> CategoryMap c
-> Map ParamName GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r
-> CategoryMap c
-> Map ParamName GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions CategoryResolver c
r (Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) Map ParamName GeneralInstance
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueDefine c]
ds [ScopedFunction c]
fs
      AnyCategory c -> m (AnyCategory c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyCategory c -> m (AnyCategory c))
-> AnyCategory c -> m (AnyCategory c)
forall a b. (a -> b) -> a -> b
$ [c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [FunctionVisibility c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
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[PragmaCategory c] -> [PragmaCategory c] -> [PragmaCategory c]
forall a. [a] -> [a] -> [a]
++[PragmaCategory c]
pg2[PragmaCategory c] -> [PragmaCategory c] -> [PragmaCategory c]
forall 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 = AnyCategory c -> m (AnyCategory c)
forall a. a -> m a
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory (Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
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 = AnyCategory c -> [ValueRefine c]
forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
v
      Map ParamName GeneralInstance
pa <- Map CategoryName (AnyCategory c)
-> [c] -> TypeInstance -> m (Map ParamName GeneralInstance)
assignParams Map CategoryName (AnyCategory c)
tm [c]
c TypeInstance
t
      ([ValueRefine c] -> [ValueRefine c])
-> m [ValueRefine c] -> m [ValueRefine c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValueRefine c
raValueRefine c -> [ValueRefine c] -> [ValueRefine c]
forall a. a -> [a] -> [a]
:) (m [ValueRefine c] -> m [ValueRefine c])
-> m [ValueRefine c] -> m [ValueRefine c]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> m (ValueRefine c))
-> [ValueRefine c] -> m [ValueRefine c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ([c]
-> Map ParamName GeneralInstance
-> ValueRefine c
-> m (ValueRefine c)
forall {m :: * -> *} {c}.
CollectErrorsM m =>
[c]
-> Map ParamName GeneralInstance
-> ValueRefine c
-> m (ValueRefine c)
subAll [c]
c Map ParamName GeneralInstance
pa) [ValueRefine c]
refines
    subAll :: [c]
-> Map ParamName GeneralInstance
-> ValueRefine c
-> m (ValueRefine c)
subAll [c]
c Map ParamName GeneralInstance
pa (ValueRefine [c]
c1 TypeInstance
t1) = do
      TypeInstance
t2 <- (ParamName -> m GeneralInstance) -> TypeInstance -> m TypeInstance
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance) -> TypeInstance -> m TypeInstance
uncheckedSubSingle (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
pa) TypeInstance
t1
      ValueRefine c -> m (ValueRefine c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValueRefine c -> m (ValueRefine c))
-> ValueRefine c -> m (ValueRefine c)
forall a b. (a -> b) -> a -> b
$ [c] -> TypeInstance -> ValueRefine c
forall c. [c] -> TypeInstance -> ValueRefine c
ValueRefine ([c]
c [c] -> [c] -> [c]
forall a. [a] -> [a] -> [a]
++ [c]
c1) TypeInstance
t2
    assignParams :: Map CategoryName (AnyCategory c)
-> [c] -> TypeInstance -> m (Map ParamName GeneralInstance)
assignParams Map CategoryName (AnyCategory c)
tm [c]
c (TypeInstance CategoryName
n InstanceParams
ps) = do
      ([c]
_,AnyCategory c
v) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory (Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
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 = (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
v
      [(ParamName, GeneralInstance)]
paired <- (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
ns) InstanceParams
ps
      Map ParamName GeneralInstance -> m (Map ParamName GeneralInstance)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ParamName GeneralInstance
 -> m (Map ParamName GeneralInstance))
-> Map ParamName GeneralInstance
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> a -> b
$ ParamName
-> GeneralInstance
-> Map ParamName GeneralInstance
-> Map ParamName GeneralInstance
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf GeneralInstance
selfType (Map ParamName GeneralInstance -> Map ParamName GeneralInstance)
-> Map ParamName GeneralInstance -> Map ParamName GeneralInstance
forall a b. (a -> b) -> a -> b
$ [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ParamName, GeneralInstance)]
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 = [(CategoryName, ValueRefine c)] -> Map CategoryName (ValueRefine c)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CategoryName, ValueRefine c)]
 -> Map CategoryName (ValueRefine c))
-> [(CategoryName, ValueRefine c)]
-> Map CategoryName (ValueRefine c)
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> (CategoryName, ValueRefine c))
-> [ValueRefine c] -> [(CategoryName, ValueRefine c)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
t -> (TypeInstance -> CategoryName
tiName (TypeInstance -> CategoryName) -> TypeInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
t,ValueRefine c
t)) [ValueRefine c]
rs
      (ValueRefine c -> m ()) -> [ValueRefine c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (\ValueRefine c
t -> r
-> Map ParamName [TypeFilter]
-> Maybe (ValueRefine c)
-> ValueRefine c
-> m ()
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 (ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
t) CategoryName
-> Map CategoryName (ValueRefine c) -> Maybe (ValueRefine c)
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
      m (MergeTree InferredTypeGuess) -> m ()
forall (m :: * -> *).
CollectErrorsM m =>
m (MergeTree InferredTypeGuess) -> m ()
noInferredTypes (m (MergeTree InferredTypeGuess) -> m ())
-> m (MergeTree InferredTypeGuess) -> m ()
forall a b. (a -> b) -> a -> b
$ r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
fm Variance
Covariant
                        (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t1)
                        (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t2) m (MergeTree InferredTypeGuess)
-> String -> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!!
                          String
"Cannot refine " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueRefine c -> String
forall a. Show a => a -> String
show ValueRefine c
ta1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" from inherited " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueRefine c -> String
forall a. Show a => a -> String
show ValueRefine c
ta2
      () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkConvert r
_ Map ParamName [TypeFilter]
_ Maybe (ValueRefine c)
_ ValueRefine c
_ = () -> m ()
forall a. a -> m a
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory (Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) (ValueRefine c -> [c]
forall c. ValueRefine c -> [c]
vrContext ValueRefine c
rf,TypeInstance -> CategoryName
tiName (TypeInstance -> CategoryName) -> TypeInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
rf)
      [PragmaCategory c] -> m [PragmaCategory c]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PragmaCategory c] -> m [PragmaCategory c])
-> [PragmaCategory c] -> m [PragmaCategory c]
forall a b. (a -> b) -> a -> b
$ (PragmaCategory c -> PragmaCategory c)
-> [PragmaCategory c] -> [PragmaCategory c]
forall a b. (a -> b) -> [a] -> [b]
map ([c] -> PragmaCategory c -> PragmaCategory c
forall c. [c] -> PragmaCategory c -> PragmaCategory c
prependCategoryPragmaContext ([c] -> PragmaCategory c -> PragmaCategory c)
-> [c] -> PragmaCategory c -> PragmaCategory c
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> [c]
forall c. ValueRefine c -> [c]
vrContext ValueRefine c
rf) ([PragmaCategory c] -> [PragmaCategory c])
-> [PragmaCategory c] -> [PragmaCategory c]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [PragmaCategory c]
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory (Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
forall c.
Map CategoryName [c]
-> Map CategoryName (AnyCategory c) -> CategoryMap c
CategoryMap Map CategoryName [c]
km Map CategoryName (AnyCategory c)
tm) (ValueDefine c -> [c]
forall c. ValueDefine c -> [c]
vdContext ValueDefine c
df,DefinesInstance -> CategoryName
diName (DefinesInstance -> CategoryName)
-> DefinesInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType ValueDefine c
df)
      [PragmaCategory c] -> m [PragmaCategory c]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PragmaCategory c] -> m [PragmaCategory c])
-> [PragmaCategory c] -> m [PragmaCategory c]
forall a b. (a -> b) -> a -> b
$ (PragmaCategory c -> PragmaCategory c)
-> [PragmaCategory c] -> [PragmaCategory c]
forall a b. (a -> b) -> [a] -> [b]
map ([c] -> PragmaCategory c -> PragmaCategory c
forall c. [c] -> PragmaCategory c -> PragmaCategory c
prependCategoryPragmaContext ([c] -> PragmaCategory c -> PragmaCategory c)
-> [c] -> PragmaCategory c -> PragmaCategory c
forall a b. (a -> b) -> a -> b
$ ValueDefine c -> [c]
forall c. ValueDefine c -> [c]
vdContext ValueDefine c
df) ([PragmaCategory c] -> [PragmaCategory c])
-> [PragmaCategory c] -> [PragmaCategory c]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [PragmaCategory c]
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 GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions r
r CategoryMap c
cm Map ParamName GeneralInstance
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueDefine c]
ds [ScopedFunction c]
fs = do
  [ScopedFunction c]
inheritValue <- ([[ScopedFunction c]] -> [ScopedFunction c])
-> m [[ScopedFunction c]] -> m [ScopedFunction c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ScopedFunction c]] -> [ScopedFunction c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[ScopedFunction c]] -> m [ScopedFunction c])
-> m [[ScopedFunction c]] -> m [ScopedFunction c]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> m [ScopedFunction c])
-> [ValueRefine c] -> m [[ScopedFunction c]]
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  <- ([[ScopedFunction c]] -> [ScopedFunction c])
-> m [[ScopedFunction c]] -> m [ScopedFunction c]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ScopedFunction c]] -> [ScopedFunction c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[ScopedFunction c]] -> m [ScopedFunction c])
-> m [[ScopedFunction c]] -> m [ScopedFunction c]
forall a b. (a -> b) -> a -> b
$ (ValueDefine c -> m [ScopedFunction c])
-> [ValueDefine c] -> m [[ScopedFunction c]]
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  = ([ScopedFunction c] -> [ScopedFunction c])
-> Map FunctionName [ScopedFunction c]
-> Map FunctionName [ScopedFunction c]
forall a b. (a -> b) -> Map FunctionName a -> Map FunctionName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ScopedFunction c -> ScopedFunction c -> Bool)
-> [ScopedFunction c] -> [ScopedFunction c]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ScopedFunction c -> ScopedFunction c -> Bool
forall c. ScopedFunction c -> ScopedFunction c -> Bool
sameFunction) (Map FunctionName [ScopedFunction c]
 -> Map FunctionName [ScopedFunction c])
-> Map FunctionName [ScopedFunction c]
-> Map FunctionName [ScopedFunction c]
forall a b. (a -> b) -> a -> b
$ ([ScopedFunction c] -> [ScopedFunction c] -> [ScopedFunction c])
-> [(FunctionName, [ScopedFunction c])]
-> Map FunctionName [ScopedFunction c]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [ScopedFunction c] -> [ScopedFunction c] -> [ScopedFunction c]
forall a. [a] -> [a] -> [a]
(++) ([(FunctionName, [ScopedFunction c])]
 -> Map FunctionName [ScopedFunction c])
-> [(FunctionName, [ScopedFunction c])]
-> Map FunctionName [ScopedFunction c]
forall a b. (a -> b) -> a -> b
$ (ScopedFunction c -> (FunctionName, [ScopedFunction c]))
-> [ScopedFunction c] -> [(FunctionName, [ScopedFunction c])]
forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f,[ScopedFunction c
f])) ([ScopedFunction c] -> [(FunctionName, [ScopedFunction c])])
-> [ScopedFunction c] -> [(FunctionName, [ScopedFunction c])]
forall a b. (a -> b) -> a -> b
$ [ScopedFunction c]
inheritValue [ScopedFunction c] -> [ScopedFunction c] -> [ScopedFunction c]
forall a. [a] -> [a] -> [a]
++ [ScopedFunction c]
inheritType
  let explicitByName :: Map FunctionName [ScopedFunction c]
explicitByName = ([ScopedFunction c] -> [ScopedFunction c] -> [ScopedFunction c])
-> [(FunctionName, [ScopedFunction c])]
-> Map FunctionName [ScopedFunction c]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [ScopedFunction c] -> [ScopedFunction c] -> [ScopedFunction c]
forall a. [a] -> [a] -> [a]
(++) ([(FunctionName, [ScopedFunction c])]
 -> Map FunctionName [ScopedFunction c])
-> [(FunctionName, [ScopedFunction c])]
-> Map FunctionName [ScopedFunction c]
forall a b. (a -> b) -> a -> b
$ (ScopedFunction c -> (FunctionName, [ScopedFunction c]))
-> [ScopedFunction c] -> [(FunctionName, [ScopedFunction c])]
forall a b. (a -> b) -> [a] -> [b]
map (\ScopedFunction c
f -> (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f,[ScopedFunction c
f])) [ScopedFunction c]
fs
  let allNames :: [FunctionName]
allNames = Set FunctionName -> [FunctionName]
forall a. Set a -> [a]
Set.toList (Set FunctionName -> [FunctionName])
-> Set FunctionName -> [FunctionName]
forall a b. (a -> b) -> a -> b
$ Set FunctionName -> Set FunctionName -> Set FunctionName
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Map FunctionName [ScopedFunction c] -> Set FunctionName
forall k a. Map k a -> Set k
Map.keysSet Map FunctionName [ScopedFunction c]
inheritByName) (Map FunctionName [ScopedFunction c] -> Set FunctionName
forall k a. Map k a -> Set k
Map.keysSet Map FunctionName [ScopedFunction c]
explicitByName)
  (FunctionName -> m (ScopedFunction c))
-> [FunctionName] -> m [ScopedFunction c]
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) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
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 = (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
      let fs2 :: [ScopedFunction c]
fs2 = AnyCategory c -> [ScopedFunction c]
forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
t
      [(ParamName, GeneralInstance)]
paired <- (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
ps) InstanceParams
ts2
      let assigned :: Map ParamName GeneralInstance
assigned = [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall a b. (a -> b) -> a -> b
$ (ParamName
ParamSelf,GeneralInstance
selfType)(ParamName, GeneralInstance)
-> [(ParamName, GeneralInstance)] -> [(ParamName, GeneralInstance)]
forall a. a -> [a] -> [a]
:[(ParamName, GeneralInstance)]
paired
      (ScopedFunction c -> m (ScopedFunction c))
-> [ScopedFunction c] -> m [ScopedFunction c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName GeneralInstance
assigned) [ScopedFunction c]
fs2
    getDefinesFuncs :: ValueDefine c -> m [ScopedFunction c]
getDefinesFuncs (ValueDefine [c]
c (DefinesInstance CategoryName
n InstanceParams
ts2)) = do
      ([c]
_,AnyCategory c
t) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
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 = (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
      let fs2 :: [ScopedFunction c]
fs2 = AnyCategory c -> [ScopedFunction c]
forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
t
      [(ParamName, GeneralInstance)]
paired <- (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
ps) InstanceParams
ts2
      let assigned :: Map ParamName GeneralInstance
assigned = [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall a b. (a -> b) -> a -> b
$ (ParamName
ParamSelf,GeneralInstance
selfType)(ParamName, GeneralInstance)
-> [(ParamName, GeneralInstance)] -> [(ParamName, GeneralInstance)]
forall a. a -> [a] -> [a]
:[(ParamName, GeneralInstance)]
paired
      (ScopedFunction c -> m (ScopedFunction c))
-> [ScopedFunction c] -> m [ScopedFunction c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName GeneralInstance
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 FunctionName
-> Map FunctionName [ScopedFunction c] -> Maybe [ScopedFunction c]
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map FunctionName [ScopedFunction c]
im) (FunctionName
n FunctionName
-> Map FunctionName [ScopedFunction c] -> Maybe [ScopedFunction c]
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
      | [ScopedFunction c] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ScopedFunction c]
is Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = ScopedFunction c -> m (ScopedFunction c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopedFunction c -> m (ScopedFunction c))
-> ScopedFunction c -> m (ScopedFunction c)
forall a b. (a -> b) -> a -> b
$ [ScopedFunction c] -> ScopedFunction c
forall a. HasCallStack => [a] -> a
head [ScopedFunction c]
is
      | Bool
otherwise = String -> m (ScopedFunction c)
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m (ScopedFunction c)) -> String -> m (ScopedFunction c)
forall a b. (a -> b) -> a -> b
$ String
"Function " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is inherited " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                     Int -> String
forall a. Show a => a -> String
show ([ScopedFunction c] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ScopedFunction c]
is) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" times:\n---\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                     String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n---\n" ((ScopedFunction c -> String) -> [ScopedFunction c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ScopedFunction c -> String
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 ([ScopedFunction c] -> Maybe [ScopedFunction c]
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)
      | [ScopedFunction c] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ScopedFunction c]
es Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 = String -> m (ScopedFunction c)
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m (ScopedFunction c)) -> String -> m (ScopedFunction c)
forall a b. (a -> b) -> a -> b
$ String
"Function " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is declared " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                          Int -> String
forall a. Show a => a -> String
show ([ScopedFunction c] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ScopedFunction c]
es) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" times:\n---\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                          String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n---\n" ((ScopedFunction c -> String) -> [ScopedFunction c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ScopedFunction c -> String
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) = [ScopedFunction c] -> ScopedFunction c
forall a. HasCallStack => [a] -> a
head [ScopedFunction c]
es
        (ScopedFunction c -> m ()) -> [ScopedFunction c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (ScopedFunction c -> ScopedFunction c -> m ()
checkMerge ScopedFunction c
ff) [ScopedFunction c]
is
        ScopedFunction c -> m (ScopedFunction c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopedFunction c -> m (ScopedFunction c))
-> ScopedFunction c -> m (ScopedFunction c)
forall a b. (a -> b) -> a -> b
$ [c]
-> FunctionName
-> CategoryName
-> SymbolScope
-> FunctionVisibility c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
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 [ScopedFunction c] -> [ScopedFunction c] -> [ScopedFunction c]
forall a. [a] -> [a] -> [a]
++ [ScopedFunction c]
is)
        where
          checkMerge :: ScopedFunction c -> ScopedFunction c -> m ()
checkMerge ScopedFunction c
f1 ScopedFunction c
f2
            | ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f1 SymbolScope -> SymbolScope -> Bool
forall a. Eq a => a -> a -> Bool
/= ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f2 =
              String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot merge " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymbolScope -> String
forall a. Show a => a -> String
show (ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f2) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                               SymbolScope -> String
forall a. Show a => a -> String
show (ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in function merge:\n---\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                               ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n  ->\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f1
            | Bool
otherwise =
              String
"In function merge:\n---\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n  ->\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n---\n" String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
                FunctionVisibility c -> FunctionVisibility c -> m ()
forall {m :: * -> *} {a} {c}.
(ErrorContextM m, Show a, Show c) =>
FunctionVisibility c -> a -> m ()
checkMergeVis (ScopedFunction c -> FunctionVisibility c
forall c. ScopedFunction c -> FunctionVisibility c
sfVisibility ScopedFunction c
f1) (ScopedFunction c -> FunctionVisibility c
forall c. ScopedFunction c -> FunctionVisibility c
sfVisibility ScopedFunction c
f2)
                FunctionType
f1' <- ScopedFunction c -> m FunctionType
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f1
                FunctionType
f2' <- ScopedFunction c -> m FunctionType
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
ScopedFunction c -> m FunctionType
parsedToFunctionType ScopedFunction c
f2
                case ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f1 of
                     SymbolScope
CategoryScope -> r
-> Map ParamName [TypeFilter]
-> Map ParamName GeneralInstance
-> FunctionType
-> FunctionType
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName GeneralInstance
-> FunctionType
-> FunctionType
-> m ()
checkFunctionConvert r
r Map ParamName [TypeFilter]
forall k a. Map k a
Map.empty Map ParamName GeneralInstance
forall k a. Map k a
Map.empty FunctionType
f2' FunctionType
f1'
                     SymbolScope
_             -> r
-> Map ParamName [TypeFilter]
-> Map ParamName GeneralInstance
-> FunctionType
-> FunctionType
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName GeneralInstance
-> FunctionType
-> FunctionType
-> m ()
checkFunctionConvert r
r Map ParamName [TypeFilter]
fm Map ParamName GeneralInstance
pm FunctionType
f2' FunctionType
f1'
                ((PassedValue c, Maybe (CallArgLabel c))
 -> (PassedValue c, Maybe (CallArgLabel c)) -> m ())
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> m ()
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ (PassedValue c, Maybe (CallArgLabel c))
-> (PassedValue c, Maybe (CallArgLabel c)) -> m ()
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 (ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f1) (ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
forall c.
ScopedFunction c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
sfArgs ScopedFunction c
f2)
          checkMergeVis :: FunctionVisibility c -> a -> m ()
checkMergeVis FunctionVisibility c
FunctionVisibilityDefault a
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          checkMergeVis FunctionVisibility c
v1 a
v2 =
            String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot supersede " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctionVisibility c -> String
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)
            | (CallArgLabel c -> String)
-> Maybe (CallArgLabel c) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CallArgLabel c -> String
forall c. CallArgLabel c -> String
calName Maybe (CallArgLabel c)
n1 Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== (CallArgLabel c -> String)
-> Maybe (CallArgLabel c) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CallArgLabel c -> String
forall c. CallArgLabel c -> String
calName Maybe (CallArgLabel c)
n2 = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          checkArgNames (PassedValue c, Maybe (CallArgLabel c))
t1 (PassedValue c, Maybe (CallArgLabel c))
t2 =
            String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Expected arg label from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (PassedValue c, Maybe (CallArgLabel c)) -> String
forall {c} {a}.
(Show c, Show a) =>
(PassedValue c, Maybe a) -> String
showArgName (PassedValue c, Maybe (CallArgLabel c))
t2 String -> ShowS
forall a. [a] -> [a] -> [a]
++
                            String
" to match " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (PassedValue c, Maybe (CallArgLabel c)) -> String
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) = PassedValue c -> String
forall a. Show a => a -> String
show PassedValue c
t'
          showArgName (PassedValue c
t',Just a
n') = ValueType -> String
forall a. Show a => a -> String
show (PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType PassedValue c
t') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
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
(FunctionName -> FunctionName -> Bool)
-> (FunctionName -> FunctionName -> Bool) -> Eq FunctionName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FunctionName -> FunctionName -> Bool
== :: FunctionName -> FunctionName -> Bool
$c/= :: FunctionName -> FunctionName -> Bool
/= :: FunctionName -> FunctionName -> Bool
Eq,Eq FunctionName
Eq FunctionName =>
(FunctionName -> FunctionName -> Ordering)
-> (FunctionName -> FunctionName -> Bool)
-> (FunctionName -> FunctionName -> Bool)
-> (FunctionName -> FunctionName -> Bool)
-> (FunctionName -> FunctionName -> Bool)
-> (FunctionName -> FunctionName -> FunctionName)
-> (FunctionName -> FunctionName -> FunctionName)
-> Ord 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
$ccompare :: FunctionName -> FunctionName -> Ordering
compare :: FunctionName -> FunctionName -> Ordering
$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
>= :: FunctionName -> FunctionName -> Bool
$cmax :: FunctionName -> FunctionName -> FunctionName
max :: FunctionName -> FunctionName -> FunctionName
$cmin :: FunctionName -> FunctionName -> FunctionName
min :: FunctionName -> FunctionName -> FunctionName
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
(CallArgLabel c -> CallArgLabel c -> Bool)
-> (CallArgLabel c -> CallArgLabel c -> Bool)
-> Eq (CallArgLabel c)
forall c. Eq c => CallArgLabel c -> CallArgLabel c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: CallArgLabel c -> CallArgLabel c -> Bool
Eq,Eq (CallArgLabel c)
Eq (CallArgLabel c) =>
(CallArgLabel c -> CallArgLabel c -> Ordering)
-> (CallArgLabel c -> CallArgLabel c -> Bool)
-> (CallArgLabel c -> CallArgLabel c -> Bool)
-> (CallArgLabel c -> CallArgLabel c -> Bool)
-> (CallArgLabel c -> CallArgLabel c -> Bool)
-> (CallArgLabel c -> CallArgLabel c -> CallArgLabel c)
-> (CallArgLabel c -> CallArgLabel c -> CallArgLabel c)
-> Ord (CallArgLabel c)
CallArgLabel c -> CallArgLabel c -> Bool
CallArgLabel c -> CallArgLabel c -> Ordering
CallArgLabel c -> CallArgLabel c -> CallArgLabel c
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
$ccompare :: forall c. Ord c => CallArgLabel c -> CallArgLabel c -> Ordering
compare :: CallArgLabel c -> CallArgLabel c -> Ordering
$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
>= :: CallArgLabel c -> CallArgLabel c -> Bool
$cmax :: forall c.
Ord c =>
CallArgLabel c -> CallArgLabel c -> CallArgLabel c
max :: CallArgLabel c -> CallArgLabel c -> CallArgLabel c
$cmin :: forall c.
Ord c =>
CallArgLabel c -> CallArgLabel c -> CallArgLabel c
min :: CallArgLabel c -> CallArgLabel c -> CallArgLabel c
Ord)

instance Show c => Show (CallArgLabel c) where
  show :: CallArgLabel c -> String
show (CallArgLabel [c]
c String
n) = String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
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 = ShowS
forall a. HasCallStack => [a] -> [a]
init String
n1 String -> String -> Bool
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], GeneralInstance)]
fvTypes :: [([c],GeneralInstance)]
  } |
  FunctionVisibilityDefault
  deriving (FunctionVisibility c -> FunctionVisibility c -> Bool
(FunctionVisibility c -> FunctionVisibility c -> Bool)
-> (FunctionVisibility c -> FunctionVisibility c -> Bool)
-> Eq (FunctionVisibility c)
forall c.
Eq c =>
FunctionVisibility c -> FunctionVisibility c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: 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], GeneralInstance)]
ts) = String
"visibility " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((([c], GeneralInstance) -> String)
-> [([c], GeneralInstance)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (GeneralInstance -> String
forall a. Show a => a -> String
show (GeneralInstance -> String)
-> (([c], GeneralInstance) -> GeneralInstance)
-> ([c], GeneralInstance)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([c], GeneralInstance) -> GeneralInstance
forall a b. (a, b) -> b
snd) [([c], GeneralInstance)]
ts) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
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 = String -> String -> ScopedFunction c -> String
forall c. Show c => String -> String -> ScopedFunction c -> String
showFunctionInContext (SymbolScope -> String
forall a. Show a => a -> String
show (ScopedFunction c -> SymbolScope
forall c. ScopedFunction c -> SymbolScope
sfScope ScopedFunction c
f) String -> ShowS
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]
_) =
  (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Bool -> Bool
forall a. a -> a
id [FunctionName
n1 FunctionName -> FunctionName -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionName
n2, CategoryName
t1 CategoryName -> CategoryName -> Bool
forall a. Eq a => a -> a -> Bool
== CategoryName
t2, SymbolScope
s1 SymbolScope -> SymbolScope -> Bool
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/*" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"*/ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++
  [ValueParam c] -> String
forall {c}. [ValueParam c] -> String
showParams (Positional (ValueParam c) -> [ValueParam c]
forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatContext [c]
cs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ParamFilter c -> String) -> [ParamFilter c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
v -> String
indent String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParamFilter c -> String
forall {a}. Show a => ParamFilter a -> String
formatValue ParamFilter c
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n") [ParamFilter c]
fa) String -> ShowS
forall a. [a] -> [a] -> [a]
++
  String
indent String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (((PassedValue c, Maybe (CallArgLabel c)) -> String)
-> [(PassedValue c, Maybe (CallArgLabel c))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PassedValue c, Maybe (CallArgLabel c)) -> String
forall {c} {c}. (PassedValue c, Maybe (CallArgLabel c)) -> String
showArg ([(PassedValue c, Maybe (CallArgLabel c))] -> [String])
-> [(PassedValue c, Maybe (CallArgLabel c))] -> [String]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c, Maybe (CallArgLabel c))
-> [(PassedValue c, Maybe (CallArgLabel c))]
forall a. Positional a -> [a]
pValues Positional (PassedValue c, Maybe (CallArgLabel c))
as) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++
  String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((PassedValue c -> String) -> [PassedValue c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> String
forall a. Show a => a -> String
show (ValueType -> String)
-> (PassedValue c -> ValueType) -> PassedValue c -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType) ([PassedValue c] -> [String]) -> [PassedValue c] -> [String]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c) -> [PassedValue c]
forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set CategoryName -> String
forall {a}. Show a => Set a -> String
showMerges ([ScopedFunction c] -> Set CategoryName
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) = ValueType -> String
forall a. Show a => a -> String
show (PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType PassedValue c
a)
    showArg (PassedValue c
a,Just CallArgLabel c
n2) = ValueType -> String
forall a. Show a => a -> String
show (PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType PassedValue c
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (CallArgLabel c -> String
forall c. CallArgLabel c -> String
calName CallArgLabel c
n2)
    showParams :: [ValueParam c] -> String
showParams [] = String
""
    showParams [ValueParam c]
ps2 = String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((ValueParam c -> String) -> [ValueParam c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ParamName -> String
forall a. Show a => a -> String
show (ParamName -> String)
-> (ValueParam c -> ParamName) -> ValueParam c -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam) [ValueParam c]
ps2) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
    formatContext :: [a] -> String
formatContext [a]
cs2 = String
"/*" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContext [a]
cs2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"*/"
    formatValue :: ParamFilter a -> String
formatValue ParamFilter a
v = String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show (ParamFilter a -> ParamName
forall c. ParamFilter c -> ParamName
pfParam ParamFilter a
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeFilter -> String
forall a. Show a => a -> String
show (ParamFilter a -> TypeFilter
forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter a
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatContext (ParamFilter a -> [a]
forall c. ParamFilter c -> [c]
pfContext ParamFilter a
v)
    flatten :: [ScopedFunction c] -> Set CategoryName
flatten [] = Set CategoryName
forall a. Set a
Set.empty
    flatten [ScopedFunction c]
ms2 = [Set CategoryName] -> Set CategoryName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set CategoryName] -> Set CategoryName)
-> [Set CategoryName] -> Set CategoryName
forall a b. (a -> b) -> a -> b
$ ([CategoryName] -> Set CategoryName
forall a. Ord a => [a] -> Set a
Set.fromList ([CategoryName] -> Set CategoryName)
-> [CategoryName] -> Set CategoryName
forall a b. (a -> b) -> a -> b
$ (ScopedFunction c -> CategoryName)
-> [ScopedFunction c] -> [CategoryName]
forall a b. (a -> b) -> [a] -> [b]
map ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType [ScopedFunction c]
ms2)Set CategoryName -> [Set CategoryName] -> [Set CategoryName]
forall a. a -> [a] -> [a]
:((ScopedFunction c -> Set CategoryName)
-> [ScopedFunction c] -> [Set CategoryName]
forall a b. (a -> b) -> [a] -> [b]
map ([ScopedFunction c] -> Set CategoryName
flatten ([ScopedFunction c] -> Set CategoryName)
-> (ScopedFunction c -> [ScopedFunction c])
-> ScopedFunction c
-> Set CategoryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopedFunction c -> [ScopedFunction c]
forall c. ScopedFunction c -> [ScopedFunction c]
sfMerges) [ScopedFunction c]
ms2)
    showMerges :: Set a -> String
showMerges Set a
ms2
      | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
ms2) = String
" /*not merged*/"
      | Bool
otherwise = String
" /*merged from: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show ([a] -> [String]) -> [a] -> [String]
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
ms2) String -> ShowS
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) = ValueType -> String
forall a. Show a => a -> String
show ValueType
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
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' = [ValueType] -> Positional ValueType
forall a. [a] -> Positional a
Positional ([ValueType] -> Positional ValueType)
-> [ValueType] -> Positional ValueType
forall a b. (a -> b) -> a -> b
$ ((PassedValue c, Maybe (CallArgLabel c)) -> ValueType)
-> [(PassedValue c, Maybe (CallArgLabel c))] -> [ValueType]
forall a b. (a -> b) -> [a] -> [b]
map (PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType (PassedValue c -> ValueType)
-> ((PassedValue c, Maybe (CallArgLabel c)) -> PassedValue c)
-> (PassedValue c, Maybe (CallArgLabel c))
-> ValueType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PassedValue c, Maybe (CallArgLabel c)) -> PassedValue c
forall a b. (a, b) -> a
fst) ([(PassedValue c, Maybe (CallArgLabel c))] -> [ValueType])
-> [(PassedValue c, Maybe (CallArgLabel c))] -> [ValueType]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c, Maybe (CallArgLabel c))
-> [(PassedValue c, Maybe (CallArgLabel c))]
forall a. Positional a -> [a]
pValues Positional (PassedValue c, Maybe (CallArgLabel c))
as
  let rs' :: Positional ValueType
rs' = [ValueType] -> Positional ValueType
forall a. [a] -> Positional a
Positional ([ValueType] -> Positional ValueType)
-> [ValueType] -> Positional ValueType
forall a b. (a -> b) -> a -> b
$ (PassedValue c -> ValueType) -> [PassedValue c] -> [ValueType]
forall a b. (a -> b) -> [a] -> [b]
map PassedValue c -> ValueType
forall c. PassedValue c -> ValueType
pvType ([PassedValue c] -> [ValueType]) -> [PassedValue c] -> [ValueType]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c) -> [PassedValue c]
forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs
  let ps' :: Positional ParamName
ps' = [ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional ([ParamName] -> Positional ParamName)
-> [ParamName] -> Positional ParamName
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ Positional (ValueParam c) -> [ValueParam c]
forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps
  (ParamFilter c -> m ()) -> [ParamFilter c] -> m ()
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 = ([TypeFilter] -> [TypeFilter] -> [TypeFilter])
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
(++) ([(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter])
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall a b. (a -> b) -> a -> b
$ (ParamFilter c -> (ParamName, [TypeFilter]))
-> [ParamFilter c] -> [(ParamName, [TypeFilter])]
forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
f -> (ParamFilter c -> ParamName
forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f,[ParamFilter c -> TypeFilter
forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter c
f])) [ParamFilter c]
fa
  let fa' :: InstanceFilters
fa' = [[TypeFilter]] -> InstanceFilters
forall a. [a] -> Positional a
Positional ([[TypeFilter]] -> InstanceFilters)
-> [[TypeFilter]] -> InstanceFilters
forall a b. (a -> b) -> a -> b
$ (ParamName -> [TypeFilter]) -> [ParamName] -> [[TypeFilter]]
forall a b. (a -> b) -> [a] -> [b]
map (Map ParamName [TypeFilter] -> ParamName -> [TypeFilter]
forall {k} {a}. Ord k => Map k [a] -> k -> [a]
getFilters Map ParamName [TypeFilter]
fm) ([ParamName] -> [[TypeFilter]]) -> [ParamName] -> [[TypeFilter]]
forall a b. (a -> b) -> a -> b
$ Positional ParamName -> [ParamName]
forall a. Positional a -> [a]
pValues Positional ParamName
ps'
  FunctionType -> m FunctionType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunctionType -> m FunctionType) -> FunctionType -> m FunctionType
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 = [ParamName] -> Set ParamName
forall a. Ord a => [a] -> Set a
Set.fromList ([ParamName] -> Set ParamName) -> [ParamName] -> Set ParamName
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ Positional (ValueParam c) -> [ValueParam c]
forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps
    checkFilter :: ParamFilter c -> m ()
checkFilter ParamFilter c
f =
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (ParamFilter c -> ParamName
forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f) ParamName -> Set ParamName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ParamName
pa) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Filtered param " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show (ParamFilter c -> ParamName
forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" is not defined for function " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       [c] -> String
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 k -> Map k [a] -> Maybe [a]
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 GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction = Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction (Map ParamName GeneralInstance
 -> ScopedFunction c -> m (ScopedFunction c))
-> (Map ParamName GeneralInstance -> Map ParamName GeneralInstance)
-> Map ParamName GeneralInstance
-> ScopedFunction c
-> m (ScopedFunction c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GeneralInstance -> GeneralInstance)
-> Map ParamName GeneralInstance -> Map ParamName GeneralInstance
forall a b. (a -> b) -> Map ParamName a -> Map ParamName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GeneralInstance -> GeneralInstance
fixTypeParams

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

replaceSelfFunction :: (Show c, CollectErrorsM m) =>
  GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction :: forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction GeneralInstance
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" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
ff String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n---\n" String -> m (ScopedFunction c) -> m (ScopedFunction c)
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
    Positional (PassedValue c, Maybe (CallArgLabel c))
as' <- ([(PassedValue c, Maybe (CallArgLabel c))]
 -> Positional (PassedValue c, Maybe (CallArgLabel c)))
-> m [(PassedValue c, Maybe (CallArgLabel c))]
-> m (Positional (PassedValue c, Maybe (CallArgLabel c)))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(PassedValue c, Maybe (CallArgLabel c))]
-> Positional (PassedValue c, Maybe (CallArgLabel c))
forall a. [a] -> Positional a
Positional (m [(PassedValue c, Maybe (CallArgLabel c))]
 -> m (Positional (PassedValue c, Maybe (CallArgLabel c))))
-> m [(PassedValue c, Maybe (CallArgLabel c))]
-> m (Positional (PassedValue c, Maybe (CallArgLabel c)))
forall a b. (a -> b) -> a -> b
$ ((PassedValue c, Maybe (CallArgLabel c))
 -> m (PassedValue c, Maybe (CallArgLabel c)))
-> [(PassedValue c, Maybe (CallArgLabel c))]
-> m [(PassedValue c, Maybe (CallArgLabel c))]
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 ([(PassedValue c, Maybe (CallArgLabel c))]
 -> m [(PassedValue c, Maybe (CallArgLabel c))])
-> [(PassedValue c, Maybe (CallArgLabel c))]
-> m [(PassedValue c, Maybe (CallArgLabel c))]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c, Maybe (CallArgLabel c))
-> [(PassedValue c, Maybe (CallArgLabel c))]
forall a. Positional a -> [a]
pValues Positional (PassedValue c, Maybe (CallArgLabel c))
as
    Positional (PassedValue c)
rs' <- ([PassedValue c] -> Positional (PassedValue c))
-> m [PassedValue c] -> m (Positional (PassedValue c))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PassedValue c] -> Positional (PassedValue c)
forall a. [a] -> Positional a
Positional (m [PassedValue c] -> m (Positional (PassedValue c)))
-> m [PassedValue c] -> m (Positional (PassedValue c))
forall a b. (a -> b) -> a -> b
$ (PassedValue c -> m (PassedValue c))
-> [PassedValue c] -> m [PassedValue c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM PassedValue c -> m (PassedValue c)
subPassed ([PassedValue c] -> m [PassedValue c])
-> [PassedValue c] -> m [PassedValue c]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c) -> [PassedValue c]
forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs
    [ParamFilter c]
fa' <- (ParamFilter c -> m (ParamFilter c))
-> [ParamFilter c] -> m [ParamFilter c]
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' <- (ScopedFunction c -> m (ScopedFunction c))
-> [ScopedFunction c] -> m [ScopedFunction c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction GeneralInstance
self) [ScopedFunction c]
ms
    FunctionVisibility c
v' <- FunctionVisibility c -> m (FunctionVisibility c)
subVisibility FunctionVisibility c
v
    ScopedFunction c -> m (ScopedFunction c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopedFunction c -> m (ScopedFunction c))
-> ScopedFunction c -> m (ScopedFunction c)
forall a b. (a -> b) -> a -> b
$ ([c]
-> FunctionName
-> CategoryName
-> SymbolScope
-> FunctionVisibility c
-> Positional (PassedValue c, Maybe (CallArgLabel c))
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
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
        (PassedValue c, Maybe (CallArgLabel c))
-> m (PassedValue c, Maybe (CallArgLabel c))
forall a. a -> m 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' <- GeneralInstance -> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> ValueType -> m ValueType
replaceSelfValueType GeneralInstance
self ValueType
t2
        PassedValue c -> m (PassedValue c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PassedValue c -> m (PassedValue c))
-> PassedValue c -> m (PassedValue c)
forall a b. (a -> b) -> a -> b
$ [c] -> ValueType -> PassedValue c
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' <- GeneralInstance -> TypeFilter -> m TypeFilter
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> TypeFilter -> m TypeFilter
replaceSelfFilter GeneralInstance
self TypeFilter
f
        ParamFilter c -> m (ParamFilter c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParamFilter c -> m (ParamFilter c))
-> ParamFilter c -> m (ParamFilter c)
forall a b. (a -> b) -> a -> b
$ [c] -> ParamName -> TypeFilter -> ParamFilter c
forall c. [c] -> ParamName -> TypeFilter -> ParamFilter c
ParamFilter [c]
c2 ParamName
n2 TypeFilter
f'
      subVisibility :: FunctionVisibility c -> m (FunctionVisibility c)
subVisibility FunctionVisibility c
FunctionVisibilityDefault = FunctionVisibility c -> m (FunctionVisibility c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return FunctionVisibility c
forall c. FunctionVisibility c
FunctionVisibilityDefault
      subVisibility (FunctionVisibility [c]
c2 [([c], GeneralInstance)]
ts) = do
        [([c], GeneralInstance)]
ts' <- (([c], GeneralInstance) -> m ([c], GeneralInstance))
-> [([c], GeneralInstance)] -> m [([c], GeneralInstance)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ([c], GeneralInstance) -> m ([c], GeneralInstance)
subVisibilitySingle [([c], GeneralInstance)]
ts
        FunctionVisibility c -> m (FunctionVisibility c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunctionVisibility c -> m (FunctionVisibility c))
-> FunctionVisibility c -> m (FunctionVisibility c)
forall a b. (a -> b) -> a -> b
$ [c] -> [([c], GeneralInstance)] -> FunctionVisibility c
forall c. [c] -> [([c], GeneralInstance)] -> FunctionVisibility c
FunctionVisibility [c]
c2 [([c], GeneralInstance)]
ts'
      subVisibilitySingle :: ([c], GeneralInstance) -> m ([c], GeneralInstance)
subVisibilitySingle ([c]
c2,GeneralInstance
t2) = do
        GeneralInstance
t2' <- GeneralInstance -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> GeneralInstance -> m GeneralInstance
replaceSelfInstance GeneralInstance
self GeneralInstance
t2
        ([c], GeneralInstance) -> m ([c], GeneralInstance)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,GeneralInstance
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
-> GeneralInstance
-> m ()
checkFunctionCallVisibility r
r Map ParamName [TypeFilter]
fs ScopedFunction c
f = FunctionVisibility c -> GeneralInstance -> m ()
check (ScopedFunction c -> FunctionVisibility c
forall c. ScopedFunction c -> FunctionVisibility c
sfVisibility ScopedFunction c
f) where
  check :: FunctionVisibility c -> GeneralInstance -> m ()
check FunctionVisibility c
FunctionVisibilityDefault GeneralInstance
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  check (FunctionVisibility [c]
_ [([c], GeneralInstance)]
ts) GeneralInstance
t0 = String
"Cannot call " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show (ScopedFunction c -> FunctionName
forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction c
f) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in context of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
t0 String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
!!>
    [m (MergeTree InferredTypeGuess)] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectFirstM_ ((([c], GeneralInstance) -> m (MergeTree InferredTypeGuess))
-> [([c], GeneralInstance)] -> [m (MergeTree InferredTypeGuess)]
forall a b. (a -> b) -> [a] -> [b]
map (GeneralInstance
-> ([c], GeneralInstance) -> m (MergeTree InferredTypeGuess)
checkSingle GeneralInstance
t0) [([c], GeneralInstance)]
ts)
  checkSingle :: GeneralInstance
-> ([c], GeneralInstance) -> m (MergeTree InferredTypeGuess)
checkSingle GeneralInstance
t0 ([c]
c,GeneralInstance
t) = String
"In visibility " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c String
-> m (MergeTree InferredTypeGuess)
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??>
    r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
fs Variance
Covariant GeneralInstance
t0 GeneralInstance
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) = ValueType -> String
forall a. Show a => a -> String
show ValueType
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueType -> String
forall a. Show a => a -> String
show ValueType
r
  show (TypePattern Variance
Contravariant ValueType
l ValueType
r) = ValueType -> String
forall a. Show a => a -> String
show ValueType
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" <- "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueType -> String
forall a. Show a => a -> String
show ValueType
r
  show (TypePattern Variance
Invariant     ValueType
l ValueType
r) = ValueType -> String
forall a. Show a => a -> String
show ValueType
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" <-> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueType -> String
forall a. Show a => a -> String
show ValueType
r
  show (DefinesPattern TypeInstance
l DefinesInstance
r) = TypeInstance -> String
forall a. Show a => a -> String
show TypeInstance
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DefinesInstance -> String
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 GeneralInstance
-> [PatternMatch]
-> m (MergeTree InferredTypeGuess)
inferParamTypes r
r Map ParamName [TypeFilter]
f Map ParamName GeneralInstance
ps = ([MergeTree InferredTypeGuess] -> MergeTree InferredTypeGuess)
-> m [MergeTree InferredTypeGuess]
-> m (MergeTree InferredTypeGuess)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [MergeTree InferredTypeGuess] -> MergeTree InferredTypeGuess
forall a (f :: * -> *). (Mergeable a, Foldable f) => f a -> a
forall (f :: * -> *).
Foldable f =>
f (MergeTree InferredTypeGuess) -> MergeTree InferredTypeGuess
mergeAll (m [MergeTree InferredTypeGuess]
 -> m (MergeTree InferredTypeGuess))
-> ([PatternMatch] -> m [MergeTree InferredTypeGuess])
-> [PatternMatch]
-> m (MergeTree InferredTypeGuess)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatternMatch -> m (MergeTree InferredTypeGuess))
-> [PatternMatch] -> m [MergeTree InferredTypeGuess]
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' <- (ParamName -> m GeneralInstance) -> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance) -> ValueType -> m ValueType
uncheckedSubValueType (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
ps) ValueType
t2
    r
-> Map ParamName [TypeFilter]
-> Variance
-> ValueType
-> ValueType
-> m (MergeTree InferredTypeGuess)
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 <- r -> TypeInstance -> CategoryName -> m InstanceParams
forall r (m :: * -> *).
(TypeResolver r, CollectErrorsM m) =>
r -> TypeInstance -> CategoryName -> m InstanceParams
forall (m :: * -> *).
CollectErrorsM m =>
r -> TypeInstance -> CategoryName -> m InstanceParams
trDefines r
r TypeInstance
t1 CategoryName
n
    InstanceParams
ps2' <- ([GeneralInstance] -> InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional (m [GeneralInstance] -> m InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> m GeneralInstance)
-> [GeneralInstance] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ((ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
uncheckedSubInstance (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
ps)) ([GeneralInstance] -> m [GeneralInstance])
-> [GeneralInstance] -> m [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralInstance]
forall a. Positional a -> [a]
pValues InstanceParams
ps2
    r
-> Map ParamName [TypeFilter]
-> DefinesInstance
-> DefinesInstance
-> m (MergeTree InferredTypeGuess)
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
(GuessRange a -> GuessRange a -> Bool)
-> (GuessRange a -> GuessRange a -> Bool) -> Eq (GuessRange a)
forall a. Eq a => GuessRange a -> GuessRange a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: GuessRange a -> GuessRange a -> Bool
Eq,Eq (GuessRange a)
Eq (GuessRange a) =>
(GuessRange a -> GuessRange a -> Ordering)
-> (GuessRange a -> GuessRange a -> Bool)
-> (GuessRange a -> GuessRange a -> Bool)
-> (GuessRange a -> GuessRange a -> Bool)
-> (GuessRange a -> GuessRange a -> Bool)
-> (GuessRange a -> GuessRange a -> GuessRange a)
-> (GuessRange a -> GuessRange a -> GuessRange a)
-> Ord (GuessRange a)
GuessRange a -> GuessRange a -> Bool
GuessRange a -> GuessRange a -> Ordering
GuessRange a -> GuessRange a -> GuessRange a
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
$ccompare :: forall a. Ord a => GuessRange a -> GuessRange a -> Ordering
compare :: GuessRange a -> GuessRange a -> Ordering
$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
>= :: GuessRange a -> GuessRange a -> Bool
$cmax :: forall a. Ord a => GuessRange a -> GuessRange a -> GuessRange a
max :: GuessRange a -> GuessRange a -> GuessRange a
$cmin :: forall a. Ord a => GuessRange a -> GuessRange a -> GuessRange a
min :: GuessRange a -> GuessRange a -> GuessRange a
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
hi
  show (GuessRange (Just a
lo) Maybe a
Nothing)   = String
"something at or above " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
lo
  show (GuessRange (Just a
lo) (Just a
hi)) = String
"something between " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
lo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
hi

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