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

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

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

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

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

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

module Types.TypeCategory (
  AnyCategory(..),
  CategoryMap,
  CategoryResolver(..),
  FunctionName(..),
  Namespace(..),
  ParamFilter(..),
  PassedValue(..),
  PatternMatch(..),
  PragmaCategory(..),
  ScopedFunction(..),
  SymbolScope(..),
  ValueDefine(..),
  ValueParam(..),
  ValueRefine(..),
  checkCategoryInstances,
  checkConnectedTypes,
  checkConnectionCycles,
  checkParamVariances,
  declareAllTypes, -- TODO: Remove?
  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,
  mergeDefines,
  mergeFunctions,
  mergeInferredTypes,
  mergeRefines,
  noDuplicateDefines,
  noDuplicateRefines,
  parsedToFunctionType,
  partitionByScope,
  prependCategoryPragmaContext,
  replaceSelfFunction,
  setCategoryNamespace,
  singleFromCategory,
  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 {
    AnyCategory c -> [c]
viContext :: [c],
    AnyCategory c -> Namespace
viNamespace :: Namespace,
    AnyCategory c -> CategoryName
viName :: CategoryName,
    AnyCategory c -> [PragmaCategory c]
viPragmas :: [PragmaCategory c],
    AnyCategory c -> [ValueParam c]
viParams :: [ValueParam c],
    AnyCategory c -> [ValueRefine c]
viRefines :: [ValueRefine c],
    AnyCategory c -> [ScopedFunction c]
viFunctions :: [ScopedFunction c]
  } |
  InstanceInterface {
    AnyCategory c -> [c]
iiContext :: [c],
    AnyCategory c -> Namespace
iiNamespace :: Namespace,
    AnyCategory c -> CategoryName
iiName :: CategoryName,
    AnyCategory c -> [PragmaCategory c]
iiPragmas :: [PragmaCategory c],
    AnyCategory c -> [ValueParam c]
iiParams :: [ValueParam c],
    AnyCategory c -> [ScopedFunction c]
iiFunctions :: [ScopedFunction c]
  } |
  ValueConcrete {
    AnyCategory c -> [c]
vcContext :: [c],
    AnyCategory c -> Namespace
vcNamespace :: Namespace,
    AnyCategory c -> CategoryName
vcName :: CategoryName,
    AnyCategory c -> [PragmaCategory c]
vcPragmas :: [PragmaCategory c],
    AnyCategory c -> [ValueParam c]
vcParams :: [ValueParam c],
    AnyCategory c -> [ValueRefine c]
vcRefines :: [ValueRefine c],
    AnyCategory c -> [ValueDefine c]
vcDefines :: [ValueDefine c],
    AnyCategory c -> [ParamFilter c]
vcParamFilter :: [ParamFilter c],
    AnyCategory c -> [ScopedFunction c]
vcFunctions :: [ScopedFunction c]
  }

data PragmaCategory c =
  CategoryImmutable {
    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 :: PragmaCategory c -> Bool
isCategoryImmutable (CategoryImmutable [c]
_) = Bool
True

prependCategoryPragmaContext :: [c] -> PragmaCategory c -> PragmaCategory c
prependCategoryPragmaContext :: [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 :: [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 :: [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 [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 (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 :: 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]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = CategoryName
n

getCategoryContext :: AnyCategory c -> [c]
getCategoryContext :: 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]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [c]
c

getCategoryNamespace :: AnyCategory c -> Namespace
getCategoryNamespace :: 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]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = Namespace
ns

getCategoryPragmas :: AnyCategory c -> [PragmaCategory c]
getCategoryPragmas :: 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 [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [PragmaCategory c]
pg

setCategoryNamespace :: Namespace -> AnyCategory c -> AnyCategory c
setCategoryNamespace :: 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 [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs) = ([c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueConcrete [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs)

getCategoryParams :: AnyCategory c -> [ValueParam c]
getCategoryParams :: 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]
_ [ValueParam c]
ps [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [ValueParam c]
ps

getCategoryRefines :: AnyCategory c -> [ValueRefine c]
getCategoryRefines :: 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]
_ [ValueParam c]
_ [ValueRefine c]
rs [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [ValueRefine c]
rs

getCategoryDefines :: AnyCategory c -> [ValueDefine c]
getCategoryDefines :: 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]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
ds [ParamFilter c]
_ [ScopedFunction c]
_) = [ValueDefine c]
ds

getCategoryFilters :: AnyCategory c -> [ParamFilter c]
getCategoryFilters :: 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]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
vs [ScopedFunction c]
_) = [ParamFilter c]
vs

getCategoryFunctions :: AnyCategory c -> [ScopedFunction c]
getCategoryFunctions :: 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]
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
fs) = [ScopedFunction c]
fs

singleFromCategory :: AnyCategory c -> TypeInstance
singleFromCategory :: AnyCategory c -> TypeInstance
singleFromCategory AnyCategory c
t = CategoryName -> InstanceParams -> TypeInstance
TypeInstance CategoryName
n ([GeneralType TypeInstanceOrParam] -> InstanceParams
forall a. [a] -> Positional a
Positional [GeneralType TypeInstanceOrParam]
ps) where
  n :: CategoryName
n = AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t
  ps :: [GeneralType TypeInstanceOrParam]
ps = (ValueParam c -> GeneralType TypeInstanceOrParam)
-> [ValueParam c] -> [GeneralType TypeInstanceOrParam]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> (ValueParam c -> TypeInstanceOrParam)
-> ValueParam c
-> GeneralType TypeInstanceOrParam
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] -> [GeneralType TypeInstanceOrParam])
-> [ValueParam c] -> [GeneralType TypeInstanceOrParam]
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 :: AnyCategory c -> GeneralType TypeInstanceOrParam
instanceFromCategory = TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> (AnyCategory c -> TypeInstanceOrParam)
-> AnyCategory c
-> GeneralType TypeInstanceOrParam
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 :: 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 (GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance (GeneralType TypeInstanceOrParam -> [CategoryName])
-> (ValueRefine c -> GeneralType TypeInstanceOrParam)
-> ValueRefine c
-> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> (ValueRefine c -> TypeInstanceOrParam)
-> ValueRefine c
-> GeneralType TypeInstanceOrParam
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 :: GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance = ([[CategoryName]] -> [CategoryName])
-> ([[CategoryName]] -> [CategoryName])
-> (T (GeneralType TypeInstanceOrParam) -> [CategoryName])
-> GeneralType TypeInstanceOrParam
-> [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 (GeneralType TypeInstanceOrParam) -> [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
$ (GeneralType TypeInstanceOrParam -> [CategoryName])
-> [GeneralType TypeInstanceOrParam] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance ([GeneralType TypeInstanceOrParam] -> [[CategoryName]])
-> [GeneralType TypeInstanceOrParam] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralType TypeInstanceOrParam]
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
$ (GeneralType TypeInstanceOrParam -> [CategoryName])
-> [GeneralType TypeInstanceOrParam] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance ([GeneralType TypeInstanceOrParam] -> [[CategoryName]])
-> [GeneralType TypeInstanceOrParam] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralType TypeInstanceOrParam]
forall a. Positional a -> [a]
pValues InstanceParams
ps)
  fromFilter :: TypeFilter -> [CategoryName]
fromFilter (TypeFilter FilterDirection
_ GeneralType TypeInstanceOrParam
t2)  = GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance GeneralType TypeInstanceOrParam
t2
  fromFilter (DefinesFilter DefinesInstance
t2) = DefinesInstance -> [CategoryName]
fromDefine DefinesInstance
t2
  fromFilter TypeFilter
ImmutableFilter = []
  fromType :: ValueType -> [CategoryName]
fromType (ValueType StorageType
_ GeneralType TypeInstanceOrParam
t2) = GeneralType TypeInstanceOrParam -> [CategoryName]
fromInstance GeneralType TypeInstanceOrParam
t2
  fromFunction :: ScopedFunction c -> [CategoryName]
fromFunction ScopedFunction c
f = [CategoryName]
args [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 -> [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)
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 :: 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 :: 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 :: AnyCategory c -> Bool
isValueConcrete (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [PragmaCategory 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
/= :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c== :: 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
min :: Namespace -> Namespace -> Namespace
$cmin :: Namespace -> Namespace -> Namespace
max :: Namespace -> Namespace -> Namespace
$cmax :: Namespace -> Namespace -> Namespace
>= :: Namespace -> Namespace -> Bool
$c>= :: Namespace -> Namespace -> Bool
> :: Namespace -> Namespace -> Bool
$c> :: Namespace -> Namespace -> Bool
<= :: Namespace -> Namespace -> Bool
$c<= :: Namespace -> Namespace -> Bool
< :: Namespace -> Namespace -> Bool
$c< :: Namespace -> Namespace -> Bool
compare :: Namespace -> Namespace -> Ordering
$ccompare :: Namespace -> Namespace -> Ordering
$cp1Ord :: Eq 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 {
    ValueRefine c -> [c]
vrContext :: [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 {
    ValueDefine c -> [c]
vdContext :: [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 {
    ValueParam c -> [c]
vpContext :: [c],
    ValueParam c -> ParamName
vpParam :: ParamName,
    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 {
    ParamFilter c -> [c]
pfContext :: [c],
    ParamFilter c -> ParamName
pfParam :: ParamName,
    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 {
    CategoryResolver c -> CategoryMap c
crCategories :: CategoryMap c
  }

instance Show c => TypeResolver (CategoryResolver c) where
    trRefines :: 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
 -> GeneralType TypeInstanceOrParam
 -> m (ParamName, GeneralType TypeInstanceOrParam))
-> 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
-> GeneralType TypeInstanceOrParam
-> m (ParamName, GeneralType TypeInstanceOrParam)
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 (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
ps1
      | Bool
otherwise = do
        let self :: GeneralType TypeInstanceOrParam
self = TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
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 (GeneralType TypeInstanceOrParam)
assigned <- ([(ParamName, GeneralType TypeInstanceOrParam)]
 -> Map ParamName (GeneralType TypeInstanceOrParam))
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(ParamName, GeneralType TypeInstanceOrParam)]
 -> m (Map ParamName (GeneralType TypeInstanceOrParam)))
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
forall a b. (a -> b) -> a -> b
$ (ParamName
 -> GeneralType TypeInstanceOrParam
 -> m (ParamName, GeneralType TypeInstanceOrParam))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName
-> GeneralType TypeInstanceOrParam
-> m (ParamName, GeneralType TypeInstanceOrParam)
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 (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
x
                    Maybe InstanceParams
_ -> String -> m InstanceParams
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
        ([GeneralType TypeInstanceOrParam] -> InstanceParams)
-> m [GeneralType TypeInstanceOrParam] -> m InstanceParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GeneralType TypeInstanceOrParam] -> InstanceParams
forall a. [a] -> Positional a
Positional (m [GeneralType TypeInstanceOrParam] -> m InstanceParams)
-> m [GeneralType TypeInstanceOrParam] -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ (GeneralType TypeInstanceOrParam
 -> m (GeneralType TypeInstanceOrParam))
-> [GeneralType TypeInstanceOrParam]
-> m [GeneralType TypeInstanceOrParam]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName (GeneralType TypeInstanceOrParam)
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
subAllParams Map ParamName (GeneralType TypeInstanceOrParam)
assigned (GeneralType TypeInstanceOrParam
 -> m (GeneralType TypeInstanceOrParam))
-> (GeneralType TypeInstanceOrParam
    -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
CollectErrorsM m =>
GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
replaceSelfInstance GeneralType TypeInstanceOrParam
self) ([GeneralType TypeInstanceOrParam]
 -> m [GeneralType TypeInstanceOrParam])
-> [GeneralType TypeInstanceOrParam]
-> m [GeneralType TypeInstanceOrParam]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralType TypeInstanceOrParam]
forall a. Positional a -> [a]
pValues InstanceParams
ps2
    trDefines :: CategoryResolver c
-> TypeInstance -> CategoryName -> m InstanceParams
trDefines (CategoryResolver CategoryMap c
tm) ta :: TypeInstance
ta@(TypeInstance CategoryName
n1 InstanceParams
ps1) CategoryName
n2 = do
      let self :: GeneralType TypeInstanceOrParam
self = TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
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 (GeneralType TypeInstanceOrParam)
assigned <- ([(ParamName, GeneralType TypeInstanceOrParam)]
 -> Map ParamName (GeneralType TypeInstanceOrParam))
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(ParamName, GeneralType TypeInstanceOrParam)]
 -> m (Map ParamName (GeneralType TypeInstanceOrParam)))
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
forall a b. (a -> b) -> a -> b
$ (ParamName
 -> GeneralType TypeInstanceOrParam
 -> m (ParamName, GeneralType TypeInstanceOrParam))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName
-> GeneralType TypeInstanceOrParam
-> m (ParamName, GeneralType TypeInstanceOrParam)
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 (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
x
                  Maybe InstanceParams
_ -> String -> m InstanceParams
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
      ([GeneralType TypeInstanceOrParam] -> InstanceParams)
-> m [GeneralType TypeInstanceOrParam] -> m InstanceParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GeneralType TypeInstanceOrParam] -> InstanceParams
forall a. [a] -> Positional a
Positional (m [GeneralType TypeInstanceOrParam] -> m InstanceParams)
-> m [GeneralType TypeInstanceOrParam] -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ (GeneralType TypeInstanceOrParam
 -> m (GeneralType TypeInstanceOrParam))
-> [GeneralType TypeInstanceOrParam]
-> m [GeneralType TypeInstanceOrParam]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName (GeneralType TypeInstanceOrParam)
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
subAllParams Map ParamName (GeneralType TypeInstanceOrParam)
assigned (GeneralType TypeInstanceOrParam
 -> m (GeneralType TypeInstanceOrParam))
-> (GeneralType TypeInstanceOrParam
    -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
CollectErrorsM m =>
GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
replaceSelfInstance GeneralType TypeInstanceOrParam
self) ([GeneralType TypeInstanceOrParam]
 -> m [GeneralType TypeInstanceOrParam])
-> [GeneralType TypeInstanceOrParam]
-> m [GeneralType TypeInstanceOrParam]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralType TypeInstanceOrParam]
forall a. Positional a -> [a]
pValues InstanceParams
ps2
    trVariance :: 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 (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 :: 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 :: 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isValueConcrete AnyCategory c
t)
    trImmutable :: 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 (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
/= :: SymbolScope -> SymbolScope -> Bool
$c/= :: SymbolScope -> SymbolScope -> Bool
== :: SymbolScope -> SymbolScope -> Bool
$c== :: 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
min :: SymbolScope -> SymbolScope -> SymbolScope
$cmin :: SymbolScope -> SymbolScope -> SymbolScope
max :: SymbolScope -> SymbolScope -> SymbolScope
$cmax :: SymbolScope -> SymbolScope -> SymbolScope
>= :: SymbolScope -> SymbolScope -> Bool
$c>= :: SymbolScope -> SymbolScope -> Bool
> :: SymbolScope -> SymbolScope -> Bool
$c> :: SymbolScope -> SymbolScope -> Bool
<= :: SymbolScope -> SymbolScope -> Bool
$c<= :: SymbolScope -> SymbolScope -> Bool
< :: SymbolScope -> SymbolScope -> Bool
$c< :: SymbolScope -> SymbolScope -> Bool
compare :: SymbolScope -> SymbolScope -> Ordering
$ccompare :: SymbolScope -> SymbolScope -> Ordering
$cp1Ord :: Eq 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 :: (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 (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 :: AnyCategory c -> InstanceParams -> m InstanceFilters
checkFilters AnyCategory c
t InstanceParams
ps = do
  Map ParamName (GeneralType TypeInstanceOrParam)
assigned <- ([(ParamName, GeneralType TypeInstanceOrParam)]
 -> Map ParamName (GeneralType TypeInstanceOrParam))
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParamName
-> GeneralType TypeInstanceOrParam
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf GeneralType TypeInstanceOrParam
selfType (Map ParamName (GeneralType TypeInstanceOrParam)
 -> Map ParamName (GeneralType TypeInstanceOrParam))
-> ([(ParamName, GeneralType TypeInstanceOrParam)]
    -> Map ParamName (GeneralType TypeInstanceOrParam))
-> [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) (m [(ParamName, GeneralType TypeInstanceOrParam)]
 -> m (Map ParamName (GeneralType TypeInstanceOrParam)))
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
forall a b. (a -> b) -> a -> b
$ (ParamName
 -> GeneralType TypeInstanceOrParam
 -> m (ParamName, GeneralType TypeInstanceOrParam))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName
-> GeneralType TypeInstanceOrParam
-> m (ParamName, GeneralType TypeInstanceOrParam)
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 (GeneralType TypeInstanceOrParam)
-> (ParamName, TypeFilter) -> m (ParamName, TypeFilter)
forall (m :: * -> *) a.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> (a, TypeFilter) -> m (a, TypeFilter)
subSingleFilter Map ParamName (GeneralType TypeInstanceOrParam)
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 (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 (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 (GeneralType TypeInstanceOrParam)
-> (a, TypeFilter) -> m (a, TypeFilter)
subSingleFilter Map ParamName (GeneralType TypeInstanceOrParam)
pa (a
n,(TypeFilter FilterDirection
v GeneralType TypeInstanceOrParam
t2)) = do
      GeneralType TypeInstanceOrParam
t3<- (ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
uncheckedSubInstance (Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa) GeneralType TypeInstanceOrParam
t2
      (a, TypeFilter) -> m (a, TypeFilter)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
n,(FilterDirection -> GeneralType TypeInstanceOrParam -> TypeFilter
TypeFilter FilterDirection
v GeneralType TypeInstanceOrParam
t3))
    subSingleFilter Map ParamName (GeneralType TypeInstanceOrParam)
pa (a
n,(DefinesFilter (DefinesInstance CategoryName
n2 InstanceParams
ps2))) = do
      [GeneralType TypeInstanceOrParam]
ps3 <- (GeneralType TypeInstanceOrParam
 -> m (GeneralType TypeInstanceOrParam))
-> [GeneralType TypeInstanceOrParam]
-> m [GeneralType TypeInstanceOrParam]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ((ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
uncheckedSubInstance ((ParamName -> m (GeneralType TypeInstanceOrParam))
 -> GeneralType TypeInstanceOrParam
 -> m (GeneralType TypeInstanceOrParam))
-> (ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall a b. (a -> b) -> a -> b
$ Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa) (InstanceParams -> [GeneralType TypeInstanceOrParam]
forall a. Positional a -> [a]
pValues InstanceParams
ps2)
      (a, TypeFilter) -> m (a, TypeFilter)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
n,(DefinesInstance -> TypeFilter
DefinesFilter (CategoryName -> InstanceParams -> DefinesInstance
DefinesInstance CategoryName
n2 ([GeneralType TypeInstanceOrParam] -> InstanceParams
forall a. [a] -> Positional a
Positional [GeneralType TypeInstanceOrParam]
ps3))))
    subSingleFilter Map ParamName (GeneralType TypeInstanceOrParam)
_ f :: (a, TypeFilter)
f@(a
_,TypeFilter
ImmutableFilter) = (a, TypeFilter) -> m (a, TypeFilter)
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 (m :: * -> *) a. Monad m => a -> m a
return [a]
x
            Maybe [a]
_ -> [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []

getSelfFilters :: AnyCategory c -> [TypeFilter]
getSelfFilters :: 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 = [GeneralType TypeInstanceOrParam] -> InstanceParams
forall a. [a] -> Positional a
Positional ([GeneralType TypeInstanceOrParam] -> InstanceParams)
-> [GeneralType TypeInstanceOrParam] -> InstanceParams
forall a b. (a -> b) -> a -> b
$ (ParamName -> GeneralType TypeInstanceOrParam)
-> [ParamName] -> [GeneralType TypeInstanceOrParam]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> (ParamName -> TypeInstanceOrParam)
-> ParamName
-> GeneralType TypeInstanceOrParam
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 -> GeneralType TypeInstanceOrParam -> TypeFilter
TypeFilter FilterDirection
FilterRequires (GeneralType TypeInstanceOrParam -> TypeFilter)
-> GeneralType TypeInstanceOrParam -> TypeFilter
forall a b. (a -> b) -> a -> b
$ TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
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 -> GeneralType TypeInstanceOrParam -> TypeFilter
TypeFilter FilterDirection
FilterRequires (GeneralType TypeInstanceOrParam -> TypeFilter)
-> (ValueRefine c -> GeneralType TypeInstanceOrParam)
-> ValueRefine c
-> TypeFilter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> (ValueRefine c -> TypeInstanceOrParam)
-> ValueRefine c
-> GeneralType TypeInstanceOrParam
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 :: Map ParamName (GeneralType TypeInstanceOrParam)
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
subAllParams Map ParamName (GeneralType TypeInstanceOrParam)
pa = (ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
uncheckedSubInstance (Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa)

type CategoryMap c = Map.Map CategoryName (AnyCategory c)

getCategory :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c)
getCategory :: CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getCategory CategoryMap c
tm ([c]
c,CategoryName
n) =
  case CategoryName
n CategoryName -> CategoryMap c -> Maybe (AnyCategory c)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` CategoryMap c
tm of
       (Just AnyCategory c
t) -> ([c], AnyCategory c) -> m ([c], AnyCategory c)
forall (m :: * -> *) a. Monad m => a -> m a
return ([c]
c,AnyCategory c
t)
       Maybe (AnyCategory c)
_ -> String -> m ([c], AnyCategory c)
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
context String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not found"
  where
    context :: String
context
      | [c] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
c = String
""
      | Bool
otherwise = [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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,AnyCategory c
t)
     else String -> m ([c], AnyCategory c)
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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,AnyCategory c
t)
     else String -> m ([c], AnyCategory c)
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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return ([c]
c2,AnyCategory c
t)
     else String -> m ([c], AnyCategory c)
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 :: 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 :: 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 (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 (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
-> Map CategoryName (AnyCategory c)
-> m (Map CategoryName (AnyCategory c))
update AnyCategory c
t) (CategoryMap c -> m (CategoryMap c)
forall (m :: * -> *) a. Monad m => a -> m a
return CategoryMap c
tm0) where
  update :: AnyCategory c
-> Map CategoryName (AnyCategory c)
-> m (Map CategoryName (AnyCategory c))
update AnyCategory c
t 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 (Map CategoryName (AnyCategory c))
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m (Map CategoryName (AnyCategory c)))
-> String -> m (Map CategoryName (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 (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)
_ -> Map CategoryName (AnyCategory c)
-> m (Map CategoryName (AnyCategory c))
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

getFilterMap :: CollectErrorsM m => [ValueParam c] -> [ParamFilter c] -> m ParamFilters
getFilterMap :: [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 (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 (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 GeneralType TypeInstanceOrParam
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
$ GeneralType TypeInstanceOrParam
-> m (T (GeneralType TypeInstanceOrParam))
forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf GeneralType TypeInstanceOrParam
p2
      case Maybe TypeInstanceOrParam
p of
          Just (JustParamName Bool
_ ParamName
p') ->
            if ParamName
p' ParamName -> Set ParamName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ParamName
pa
               then [ParamFilter c] -> m [ParamFilter c]
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 -> GeneralType TypeInstanceOrParam -> TypeFilter
TypeFilter (FilterDirection -> FilterDirection
flipFilter FilterDirection
d) (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
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 (m :: * -> *) a. Monad m => a -> m a
return [ParamFilter c
fa]
          Maybe TypeInstanceOrParam
_ -> [ParamFilter c] -> m [ParamFilter c]
forall (m :: * -> *) a. Monad m => a -> m a
return [ParamFilter c
fa]
    maybeMirror ParamFilter c
fa = [ParamFilter c] -> m [ParamFilter c]
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 (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 :: 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 (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 :: AnyCategory c -> m (Set ParamName)
getCategoryParamSet = Set ParamName -> m (Set ParamName)
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 :: 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 :: AnyCategory c -> Map ParamName (GeneralType TypeInstanceOrParam)
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, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralType TypeInstanceOrParam)]
 -> Map ParamName (GeneralType TypeInstanceOrParam))
-> [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall a b. (a -> b) -> a -> b
$ [ParamName]
-> [GeneralType TypeInstanceOrParam]
-> [(ParamName, GeneralType TypeInstanceOrParam)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ParamName]
ps ((ParamName -> GeneralType TypeInstanceOrParam)
-> [ParamName] -> [GeneralType TypeInstanceOrParam]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> (ParamName -> TypeInstanceOrParam)
-> ParamName
-> GeneralType TypeInstanceOrParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False) [ParamName]
ps) [(ParamName, GeneralType TypeInstanceOrParam)]
-> [(ParamName, GeneralType TypeInstanceOrParam)]
-> [(ParamName, GeneralType TypeInstanceOrParam)]
forall a. [a] -> [a] -> [a]
++ [(ParamName
ParamSelf,GeneralType TypeInstanceOrParam
selfType)]

disallowBoundedParams :: CollectErrorsM m => ParamFilters -> m ()
disallowBoundedParams :: 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 (GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
ub) = (TypeFilter
 -> (GeneralType TypeInstanceOrParam,
     GeneralType TypeInstanceOrParam)
 -> (GeneralType TypeInstanceOrParam,
     GeneralType TypeInstanceOrParam))
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
-> t TypeFilter
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeFilter
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
splitBounds (GeneralType TypeInstanceOrParam
forall a. Bounded a => a
minBound,GeneralType TypeInstanceOrParam
forall a. Bounded a => a
maxBound) t TypeFilter
fs
    Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralType TypeInstanceOrParam
lb GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam -> Bool
forall a. Eq a => a -> a -> Bool
/= GeneralType TypeInstanceOrParam
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& GeneralType TypeInstanceOrParam
ub GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam -> Bool
forall a. Eq a => a -> a -> Bool
/= GeneralType TypeInstanceOrParam
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 (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]
++ GeneralType TypeInstanceOrParam -> String
forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
lb,
            String -> f Any
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]
++ GeneralType TypeInstanceOrParam -> String
forall a. Show a => a -> String
show GeneralType TypeInstanceOrParam
ub
          ]
  splitBounds :: TypeFilter
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
-> (GeneralType TypeInstanceOrParam,
    GeneralType TypeInstanceOrParam)
splitBounds (TypeFilter FilterDirection
FilterRequires GeneralType TypeInstanceOrParam
t) (GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
ub) = (GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
tGeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
forall a. Mergeable a => a -> a -> a
<&&>GeneralType TypeInstanceOrParam
ub)
  splitBounds (TypeFilter FilterDirection
FilterAllows   GeneralType TypeInstanceOrParam
t) (GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
ub) = (GeneralType TypeInstanceOrParam
tGeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
forall a. Mergeable a => a -> a -> a
<||>GeneralType TypeInstanceOrParam
lb,GeneralType TypeInstanceOrParam
ub)
  splitBounds TypeFilter
_ (GeneralType TypeInstanceOrParam, GeneralType TypeInstanceOrParam)
bs = (GeneralType TypeInstanceOrParam, GeneralType TypeInstanceOrParam)
bs

checkConnectedTypes :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkConnectedTypes :: CategoryMap c -> [AnyCategory c] -> m ()
checkConnectedTypes CategoryMap c
tm0 [AnyCategory c]
ts = do
  CategoryMap c
tm <- 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]
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
tm) [AnyCategory c]
ts)
  where
    checkSingle :: CategoryMap c -> AnyCategory c -> m ()
checkSingle CategoryMap c
tm (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
tm) [([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
tm (ValueConcrete [c]
c Namespace
_ CategoryName
n [PragmaCategory 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
tm) [([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
tm) [([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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()

checkConnectionCycles :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkConnectionCycles :: CategoryMap c -> [AnyCategory c] -> m ()
checkConnectionCycles CategoryMap 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 :: CategoryMap c
tm = CategoryMap c -> CategoryMap c -> CategoryMap c
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union CategoryMap c
tm0 (CategoryMap c -> CategoryMap c) -> CategoryMap c -> CategoryMap c
forall a b. (a -> b) -> a -> b
$ [(CategoryName, AnyCategory c)] -> CategoryMap c
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CategoryName, AnyCategory c)] -> CategoryMap c)
-> [(CategoryName, AnyCategory c)] -> CategoryMap 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
  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
tm) [([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]
_ [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
tm) [([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 (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 (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 :: CategoryMap c -> [AnyCategory c] -> m ()
checkParamVariances CategoryMap c
tm0 [AnyCategory c]
ts = do
  CategoryMap c
tm <- 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]
ts
  let r :: CategoryResolver c
r = CategoryMap c -> CategoryResolver c
forall c. CategoryMap c -> CategoryResolver c
CategoryResolver CategoryMap c
tm
  (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 (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]
_ [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)
    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 (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 (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 (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
-> GeneralType TypeInstanceOrParam
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName Variance
-> Variance
-> GeneralType TypeInstanceOrParam
-> m ()
validateInstanceVariance r
r Map ParamName Variance
vm Variance
Covariant (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
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

checkCategoryInstances :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkCategoryInstances :: CategoryMap c -> [AnyCategory c] -> m ()
checkCategoryInstances CategoryMap c
tm0 [AnyCategory c]
ts = do
  CategoryMap c
tm <- 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]
ts
  let r :: CategoryResolver c
r = CategoryMap c -> CategoryResolver c
forall c. CategoryMap c -> CategoryResolver c
CategoryResolver CategoryMap c
tm
  (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)
      (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)
    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 (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 :: 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 (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 (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 where
      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 :: CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
topoSortCategories CategoryMap c
tm0 [AnyCategory c]
ts = do
  CategoryMap c
tm <- 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]
ts
  (([AnyCategory c], Set CategoryName) -> [AnyCategory c])
-> m ([AnyCategory c], Set CategoryName) -> m [AnyCategory c]
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) =>
Map CategoryName (AnyCategory c)
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update CategoryMap c
tm (CategoryMap c -> Set CategoryName
forall k a. Map k a -> Set k
Map.keysSet CategoryMap c
tm0) [AnyCategory c]
ts
  where
    update :: Map CategoryName (AnyCategory c)
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update Map CategoryName (AnyCategory c)
tm 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 Map CategoryName (AnyCategory c)
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update Map CategoryName (AnyCategory c)
tm 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 -> Map CategoryName (AnyCategory 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 (AnyCategory c)
tm (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 -> Map CategoryName (AnyCategory 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 (AnyCategory c)
tm (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) <- Map CategoryName (AnyCategory c)
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update Map CategoryName (AnyCategory c)
tm (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) <- Map CategoryName (AnyCategory c)
-> Set CategoryName
-> [AnyCategory c]
-> m ([AnyCategory c], Set CategoryName)
update Map CategoryName (AnyCategory c)
tm Set CategoryName
ta2 [AnyCategory c]
ts2
           ([AnyCategory c], Set CategoryName)
-> m ([AnyCategory c], Set CategoryName)
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 Map CategoryName (AnyCategory c)
_ Set CategoryName
ta [AnyCategory c]
_ = ([AnyCategory c], Set CategoryName)
-> m ([AnyCategory c], Set CategoryName)
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 :: 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 (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
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
Covariant
                        (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> TypeInstance -> TypeInstanceOrParam
forall a b. (a -> b) -> a -> b
$ TypeInstance
t1)
                        (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
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 :: 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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

noDuplicateRefines :: (Show c, CollectErrorsM m) =>
  [c] -> CategoryName -> [ValueRefine c] -> m ()
noDuplicateRefines :: [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 :: [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 :: [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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()
    checkCount (CategoryName
n2,[a]
xs) =
      String -> m ()
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 (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 :: CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
flattenAllConnections CategoryMap c
tm0 [AnyCategory c]
ts = do
  -- We need to process all refines before type-checking can be done.
  CategoryMap c
tm1 <- (AnyCategory c -> m (CategoryMap c) -> m (CategoryMap c))
-> m (CategoryMap c) -> [AnyCategory c] -> m (CategoryMap c)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AnyCategory c -> m (CategoryMap c) -> m (CategoryMap c)
forall (m :: * -> *) c.
(CollectErrorsM m, Show c) =>
AnyCategory c -> m (CategoryMap c) -> m (CategoryMap c)
preMerge (CategoryMap c -> m (CategoryMap c)
forall (m :: * -> *) a. Monad m => a -> m a
return CategoryMap 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 CategoryMap c
tm1
  ([AnyCategory c]
ts',CategoryMap c
_) <- (AnyCategory c
 -> m ([AnyCategory c], CategoryMap c)
 -> m ([AnyCategory c], CategoryMap c))
-> m ([AnyCategory c], CategoryMap c)
-> [AnyCategory c]
-> m ([AnyCategory c], CategoryMap c)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CategoryResolver c
-> AnyCategory c
-> m ([AnyCategory c], CategoryMap c)
-> m ([AnyCategory c], CategoryMap c)
forall (m :: * -> *) c r.
(CollectErrorsM m, Show c, TypeResolver r) =>
r
-> AnyCategory c
-> m ([AnyCategory c], CategoryMap c)
-> m ([AnyCategory c], CategoryMap c)
update CategoryResolver c
r) (([AnyCategory c], CategoryMap c)
-> m ([AnyCategory c], CategoryMap c)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],CategoryMap c
tm0)) ([AnyCategory c] -> [AnyCategory c]
forall a. [a] -> [a]
reverse [AnyCategory c]
ts)
  [AnyCategory c] -> m [AnyCategory c]
forall (m :: * -> *) a. Monad m => a -> m a
return [AnyCategory c]
ts'
  where
    preMerge :: AnyCategory c -> m (CategoryMap c) -> m (CategoryMap c)
preMerge AnyCategory c
t m (CategoryMap c)
u = do
      CategoryMap c
tm <- m (CategoryMap c)
u
      AnyCategory c
t' <- CategoryMap c -> AnyCategory c -> m (AnyCategory c)
forall (m :: * -> *) c.
(CollectErrorsM m, Show c) =>
CategoryMap c -> AnyCategory c -> m (AnyCategory c)
preMergeSingle CategoryMap c
tm AnyCategory c
t
      CategoryMap c -> m (CategoryMap c)
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
$ CategoryName -> AnyCategory c -> CategoryMap c -> CategoryMap 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' CategoryMap c
tm
    preMergeSingle :: CategoryMap c -> AnyCategory c -> m (AnyCategory c)
preMergeSingle CategoryMap 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 (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 (CategoryMap c -> ValueRefine c -> m [ValueRefine c]
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c -> ValueRefine c -> m [ValueRefine c]
getRefines CategoryMap c
tm) [ValueRefine c]
rs
      AnyCategory c -> m (AnyCategory c)
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 CategoryMap c
tm (ValueConcrete [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [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 (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 (CategoryMap c -> ValueRefine c -> m [ValueRefine c]
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c -> ValueRefine c -> m [ValueRefine c]
getRefines CategoryMap c
tm) [ValueRefine c]
rs
      AnyCategory c -> m (AnyCategory c)
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]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory c]
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueConcrete [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [ValueParam c]
ps [ValueRefine c]
rs' [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs
    preMergeSingle CategoryMap c
_ AnyCategory c
t = AnyCategory c -> m (AnyCategory c)
forall (m :: * -> *) a. Monad m => a -> m a
return AnyCategory c
t
    update :: r
-> AnyCategory c
-> m ([AnyCategory c], CategoryMap c)
-> m ([AnyCategory c], CategoryMap c)
update r
r AnyCategory c
t m ([AnyCategory c], CategoryMap c)
u = do
      ([AnyCategory c]
ts2,CategoryMap c
tm) <- m ([AnyCategory c], CategoryMap c)
u
      AnyCategory c
t' <- r -> CategoryMap c -> AnyCategory c -> m (AnyCategory c)
forall (m :: * -> *) c r.
(CollectErrorsM m, Show c, TypeResolver r) =>
r -> CategoryMap c -> AnyCategory c -> m (AnyCategory c)
updateSingle r
r CategoryMap 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], CategoryMap c)
-> m ([AnyCategory c], CategoryMap c)
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 -> CategoryMap c -> CategoryMap 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' CategoryMap c
tm)
    updateSingle :: r -> CategoryMap c -> AnyCategory c -> m (AnyCategory c)
updateSingle r
r CategoryMap 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 (GeneralType TypeInstanceOrParam)
pm = AnyCategory c -> Map ParamName (GeneralType TypeInstanceOrParam)
forall c.
AnyCategory c -> Map ParamName (GeneralType TypeInstanceOrParam)
getCategoryParamMap AnyCategory c
t
      [ValueRefine c]
rs' <- ([[ValueRefine c]] -> [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
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 (CategoryMap c -> ValueRefine c -> m [ValueRefine c]
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c -> ValueRefine c -> m [ValueRefine c]
getRefines CategoryMap c
tm) [ValueRefine c]
rs
      [ValueRefine c]
rs'' <- r
-> 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 r
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''
      r
-> 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 r
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 (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 (CategoryMap c -> ValueRefine c -> m [PragmaCategory c]
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c -> ValueRefine c -> m [PragmaCategory c]
getRefinesPragmas CategoryMap c
tm) [ValueRefine c]
rs
      -- Only merge from direct parents.
      [ScopedFunction c]
fs' <- r
-> CategoryMap c
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> 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 (GeneralType TypeInstanceOrParam)
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions r
r CategoryMap c
tm Map ParamName (GeneralType TypeInstanceOrParam)
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [] [ScopedFunction c]
fs
      AnyCategory c -> m (AnyCategory c)
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 r
r CategoryMap c
tm t :: AnyCategory c
t@(ValueConcrete [c]
c Namespace
ns CategoryName
n [PragmaCategory c]
pg [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 (GeneralType TypeInstanceOrParam)
pm = AnyCategory c -> Map ParamName (GeneralType TypeInstanceOrParam)
forall c.
AnyCategory c -> Map ParamName (GeneralType TypeInstanceOrParam)
getCategoryParamMap AnyCategory c
t
      [ValueRefine c]
rs' <- ([[ValueRefine c]] -> [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
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 (CategoryMap c -> ValueRefine c -> m [ValueRefine c]
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c -> ValueRefine c -> m [ValueRefine c]
getRefines CategoryMap c
tm) [ValueRefine c]
rs
      [ValueRefine c]
rs'' <- r
-> 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 r
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''
      r
-> 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 r
r Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueRefine c]
rs''
      [ValueDefine c]
ds' <- r
-> 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 r
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 (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 (CategoryMap c -> ValueRefine c -> m [PragmaCategory c]
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c -> ValueRefine c -> m [PragmaCategory c]
getRefinesPragmas CategoryMap c
tm) [ValueRefine c]
rs
      [PragmaCategory c]
pg3 <- ([[PragmaCategory c]] -> [PragmaCategory c])
-> m [[PragmaCategory c]] -> m [PragmaCategory c]
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 (CategoryMap c -> ValueDefine c -> m [PragmaCategory c]
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c -> ValueDefine c -> m [PragmaCategory c]
getDefinesPragmas CategoryMap c
tm) [ValueDefine c]
ds
      -- Only merge from direct parents.
      [ScopedFunction c]
fs' <- r
-> CategoryMap c
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> 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 (GeneralType TypeInstanceOrParam)
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions r
r CategoryMap c
tm Map ParamName (GeneralType TypeInstanceOrParam)
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueDefine c]
ds [ScopedFunction c]
fs
      AnyCategory c -> m (AnyCategory c)
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]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [PragmaCategory 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) [ValueParam c]
ps [ValueRefine c]
rs'' [ValueDefine c]
ds' [ParamFilter c]
vs [ScopedFunction c]
fs'
    updateSingle r
_ CategoryMap c
_ AnyCategory c
t = AnyCategory c -> m (AnyCategory c)
forall (m :: * -> *) a. Monad m => a -> m a
return AnyCategory c
t
    getRefines :: CategoryMap c -> ValueRefine c -> m [ValueRefine c]
getRefines CategoryMap 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 CategoryMap 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 (GeneralType TypeInstanceOrParam)
pa <- CategoryMap c
-> [c]
-> TypeInstance
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c
-> [c]
-> TypeInstance
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
assignParams CategoryMap c
tm [c]
c TypeInstance
t
      ([ValueRefine c] -> [ValueRefine c])
-> m [ValueRefine c] -> m [ValueRefine c]
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 (GeneralType TypeInstanceOrParam)
-> ValueRefine c
-> m (ValueRefine c)
forall (m :: * -> *) c.
CollectErrorsM m =>
[c]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> ValueRefine c
-> m (ValueRefine c)
subAll [c]
c Map ParamName (GeneralType TypeInstanceOrParam)
pa) [ValueRefine c]
refines
    subAll :: [c]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> ValueRefine c
-> m (ValueRefine c)
subAll [c]
c Map ParamName (GeneralType TypeInstanceOrParam)
pa (ValueRefine [c]
c1 TypeInstance
t1) = do
      TypeInstance
t2 <- (ParamName -> m (GeneralType TypeInstanceOrParam))
-> TypeInstance -> m TypeInstance
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> TypeInstance -> m TypeInstance
uncheckedSubSingle (Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa) TypeInstance
t1
      ValueRefine c -> m (ValueRefine c)
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 :: CategoryMap c
-> [c]
-> TypeInstance
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
assignParams CategoryMap 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 CategoryMap 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, GeneralType TypeInstanceOrParam)]
paired <- (ParamName
 -> GeneralType TypeInstanceOrParam
 -> m (ParamName, GeneralType TypeInstanceOrParam))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName
-> GeneralType TypeInstanceOrParam
-> m (ParamName, GeneralType TypeInstanceOrParam)
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 (GeneralType TypeInstanceOrParam)
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ParamName (GeneralType TypeInstanceOrParam)
 -> m (Map ParamName (GeneralType TypeInstanceOrParam)))
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> m (Map ParamName (GeneralType TypeInstanceOrParam))
forall a b. (a -> b) -> a -> b
$ ParamName
-> GeneralType TypeInstanceOrParam
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf GeneralType TypeInstanceOrParam
selfType (Map ParamName (GeneralType TypeInstanceOrParam)
 -> Map ParamName (GeneralType TypeInstanceOrParam))
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall a b. (a -> b) -> a -> b
$ [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ParamName, GeneralType TypeInstanceOrParam)]
paired
    checkMerged :: r
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueRefine c]
-> m ()
checkMerged r
r Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueRefine c]
rs2 = do
      let rm :: Map CategoryName (ValueRefine c)
rm = [(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
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralType TypeInstanceOrParam
-> GeneralType TypeInstanceOrParam
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
fm Variance
Covariant
                        (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t1)
                        (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
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 (m :: * -> *) a. Monad m => a -> m a
return ()
    checkConvert r
_ Map ParamName [TypeFilter]
_ Maybe (ValueRefine c)
_ ValueRefine c
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    getRefinesPragmas :: CategoryMap c -> ValueRefine c -> m [PragmaCategory c]
getRefinesPragmas CategoryMap 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 CategoryMap 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 (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 :: CategoryMap c -> ValueDefine c -> m [PragmaCategory c]
getDefinesPragmas CategoryMap 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 CategoryMap 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 (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 :: r
-> CategoryMap c
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions r
r CategoryMap c
tm Map ParamName (GeneralType TypeInstanceOrParam)
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 (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 (CategoryMap c -> ValueRefine c -> m [ScopedFunction c]
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c -> ValueRefine c -> m [ScopedFunction c]
getRefinesFuncs CategoryMap c
tm) [ValueRefine c]
rs
  [ScopedFunction c]
inheritType  <- ([[ScopedFunction c]] -> [ScopedFunction c])
-> m [[ScopedFunction c]] -> m [ScopedFunction c]
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 (CategoryMap c -> ValueDefine c -> m [ScopedFunction c]
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c -> ValueDefine c -> m [ScopedFunction c]
getDefinesFuncs CategoryMap c
tm) [ValueDefine c]
ds
  let inheritByName :: Map FunctionName [ScopedFunction c]
inheritByName  = ([ScopedFunction c] -> [ScopedFunction c])
-> Map FunctionName [ScopedFunction c]
-> Map FunctionName [ScopedFunction c]
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 :: CategoryMap c -> ValueRefine c -> m [ScopedFunction c]
getRefinesFuncs CategoryMap c
tm2 (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
tm2 ([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, GeneralType TypeInstanceOrParam)]
paired <- (ParamName
 -> GeneralType TypeInstanceOrParam
 -> m (ParamName, GeneralType TypeInstanceOrParam))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName
-> GeneralType TypeInstanceOrParam
-> m (ParamName, GeneralType TypeInstanceOrParam)
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 (GeneralType TypeInstanceOrParam)
assigned = [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralType TypeInstanceOrParam)]
 -> Map ParamName (GeneralType TypeInstanceOrParam))
-> [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall a b. (a -> b) -> a -> b
$ (ParamName
ParamSelf,GeneralType TypeInstanceOrParam
selfType)(ParamName, GeneralType TypeInstanceOrParam)
-> [(ParamName, GeneralType TypeInstanceOrParam)]
-> [(ParamName, GeneralType TypeInstanceOrParam)]
forall a. a -> [a] -> [a]
:[(ParamName, GeneralType TypeInstanceOrParam)]
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 (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName (GeneralType TypeInstanceOrParam)
assigned) [ScopedFunction c]
fs2
    getDefinesFuncs :: CategoryMap c -> ValueDefine c -> m [ScopedFunction c]
getDefinesFuncs CategoryMap c
tm2 (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
tm2 ([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, GeneralType TypeInstanceOrParam)]
paired <- (ParamName
 -> GeneralType TypeInstanceOrParam
 -> m (ParamName, GeneralType TypeInstanceOrParam))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralType TypeInstanceOrParam)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName
-> GeneralType TypeInstanceOrParam
-> m (ParamName, GeneralType TypeInstanceOrParam)
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 (GeneralType TypeInstanceOrParam)
assigned = [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralType TypeInstanceOrParam)]
 -> Map ParamName (GeneralType TypeInstanceOrParam))
-> [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall a b. (a -> b) -> a -> b
$ (ParamName
ParamSelf,GeneralType TypeInstanceOrParam
selfType)(ParamName, GeneralType TypeInstanceOrParam)
-> [(ParamName, GeneralType TypeInstanceOrParam)]
-> [(ParamName, GeneralType TypeInstanceOrParam)]
forall a. a -> [a] -> [a]
:[(ParamName, GeneralType TypeInstanceOrParam)]
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 (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName (GeneralType TypeInstanceOrParam)
assigned) [ScopedFunction c]
fs2
    mergeByName :: Map FunctionName [ScopedFunction c]
-> Map FunctionName [ScopedFunction c]
-> FunctionName
-> m (ScopedFunction c)
mergeByName Map FunctionName [ScopedFunction c]
im Map FunctionName [ScopedFunction c]
em FunctionName
n =
      FunctionName
-> Maybe [ScopedFunction c]
-> Maybe [ScopedFunction c]
-> m (ScopedFunction c)
tryMerge FunctionName
n (FunctionName
n 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 (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 (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. [a] -> a
head [ScopedFunction c]
is
      | Bool
otherwise = String -> m (ScopedFunction c)
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 (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 (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 (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 (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 Positional (PassedValue c)
as Positional (PassedValue c)
rs2 Positional (ValueParam c)
ps [ParamFilter c]
fa [ScopedFunction c]
ms) = [ScopedFunction c] -> ScopedFunction c
forall a. [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 (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
-> Positional (PassedValue c)
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
forall c.
[c]
-> FunctionName
-> CategoryName
-> SymbolScope
-> Positional (PassedValue c)
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
ScopedFunction [c]
c FunctionName
n2 CategoryName
t SymbolScope
s Positional (PassedValue 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 (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
                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 (GeneralType TypeInstanceOrParam)
-> FunctionType
-> FunctionType
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> FunctionType
-> FunctionType
-> m ()
checkFunctionConvert r
r Map ParamName [TypeFilter]
forall k a. Map k a
Map.empty Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Map k a
Map.empty FunctionType
f2' FunctionType
f1'
                     SymbolScope
_             -> r
-> Map ParamName [TypeFilter]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> FunctionType
-> FunctionType
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> FunctionType
-> FunctionType
-> m ()
checkFunctionConvert r
r Map ParamName [TypeFilter]
fm Map ParamName (GeneralType TypeInstanceOrParam)
pm FunctionType
f2' FunctionType
f1'

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

data ScopedFunction c =
  ScopedFunction {
    ScopedFunction c -> [c]
sfContext :: [c],
    ScopedFunction c -> FunctionName
sfName :: FunctionName,
    ScopedFunction c -> CategoryName
sfType :: CategoryName,
    ScopedFunction c -> SymbolScope
sfScope :: SymbolScope,
    ScopedFunction c -> Positional (PassedValue c)
sfArgs :: Positional (PassedValue c),
    ScopedFunction c -> Positional (PassedValue c)
sfReturns :: Positional (PassedValue c),
    ScopedFunction c -> Positional (ValueParam c)
sfParams :: Positional (ValueParam c),
    ScopedFunction c -> [ParamFilter c]
sfFilters :: [ParamFilter 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 :: ScopedFunction c -> ScopedFunction c -> Bool
sameFunction (ScopedFunction [c]
_ FunctionName
n1 CategoryName
t1 SymbolScope
s1 Positional (PassedValue c)
_ Positional (PassedValue c)
_ Positional (ValueParam c)
_ [ParamFilter c]
_ [ScopedFunction c]
_) (ScopedFunction [c]
_ FunctionName
n2 CategoryName
t2 SymbolScope
s2 Positional (PassedValue 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 :: String -> String -> ScopedFunction c -> String
showFunctionInContext String
s String
indent (ScopedFunction [c]
cs FunctionName
n CategoryName
t SymbolScope
_ Positional (PassedValue 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 -> 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)
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
    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 (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 {
    PassedValue c -> [c]
pvContext :: [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 :: ScopedFunction c -> m FunctionType
parsedToFunctionType (ScopedFunction [c]
c FunctionName
n CategoryName
_ SymbolScope
_ Positional (PassedValue 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 -> 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)
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 (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 (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 :: Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction = Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction (Map ParamName (GeneralType TypeInstanceOrParam)
 -> ScopedFunction c -> m (ScopedFunction c))
-> (Map ParamName (GeneralType TypeInstanceOrParam)
    -> Map ParamName (GeneralType TypeInstanceOrParam))
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c
-> m (ScopedFunction c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GeneralType TypeInstanceOrParam
 -> GeneralType TypeInstanceOrParam)
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GeneralType TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
fixTypeParams

unfixedSubFunction :: (Show c, CollectErrorsM m) =>
  ParamValues -> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction :: Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName (GeneralType TypeInstanceOrParam)
pa ff :: ScopedFunction c
ff@(ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s Positional (PassedValue 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 (GeneralType TypeInstanceOrParam)
unresolved = [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralType TypeInstanceOrParam)]
 -> Map ParamName (GeneralType TypeInstanceOrParam))
-> [(ParamName, GeneralType TypeInstanceOrParam)]
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall a b. (a -> b) -> a -> b
$ (ParamName -> (ParamName, GeneralType TypeInstanceOrParam))
-> [ParamName] -> [(ParamName, GeneralType TypeInstanceOrParam)]
forall a b. (a -> b) -> [a] -> [b]
map (\ParamName
n2 -> (ParamName
n2,TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralType TypeInstanceOrParam)
-> TypeInstanceOrParam -> GeneralType TypeInstanceOrParam
forall a b. (a -> b) -> a -> b
$ Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False ParamName
n2)) ([ParamName] -> [(ParamName, GeneralType TypeInstanceOrParam)])
-> [ParamName] -> [(ParamName, GeneralType TypeInstanceOrParam)]
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 (GeneralType TypeInstanceOrParam)
pa' = Map ParamName (GeneralType TypeInstanceOrParam)
pa Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> Map ParamName (GeneralType TypeInstanceOrParam)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map ParamName (GeneralType TypeInstanceOrParam)
unresolved
    Positional (PassedValue c)
as' <- ([PassedValue c] -> Positional (PassedValue c))
-> m [PassedValue c] -> m (Positional (PassedValue c))
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 (GeneralType TypeInstanceOrParam)
-> PassedValue c -> m (PassedValue c)
forall (m :: * -> *) c.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> PassedValue c -> m (PassedValue c)
subPassed Map ParamName (GeneralType TypeInstanceOrParam)
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)
as
    Positional (PassedValue c)
rs' <- ([PassedValue c] -> Positional (PassedValue c))
-> m [PassedValue c] -> m (Positional (PassedValue c))
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 (GeneralType TypeInstanceOrParam)
-> PassedValue c -> m (PassedValue c)
forall (m :: * -> *) c.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> PassedValue c -> m (PassedValue c)
subPassed Map ParamName (GeneralType TypeInstanceOrParam)
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 (GeneralType TypeInstanceOrParam)
-> ParamFilter c -> m (ParamFilter c)
forall (m :: * -> *) c.
CollectErrorsM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamFilter c -> m (ParamFilter c)
subFilter Map ParamName (GeneralType TypeInstanceOrParam)
pa') [ParamFilter c]
fa
    [ScopedFunction c]
ms' <- (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 (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction Map ParamName (GeneralType TypeInstanceOrParam)
pa) [ScopedFunction c]
ms
    ScopedFunction c -> m (ScopedFunction c)
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
-> Positional (PassedValue c)
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
forall c.
[c]
-> FunctionName
-> CategoryName
-> SymbolScope
-> Positional (PassedValue c)
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s Positional (PassedValue c)
as' Positional (PassedValue c)
rs' Positional (ValueParam c)
ps [ParamFilter c]
fa' [ScopedFunction c]
ms')
    where
      subPassed :: Map ParamName (GeneralType TypeInstanceOrParam)
-> PassedValue c -> m (PassedValue c)
subPassed Map ParamName (GeneralType TypeInstanceOrParam)
pa2 (PassedValue [c]
c2 ValueType
t2) = do
        ValueType
t' <- (ParamName -> m (GeneralType TypeInstanceOrParam))
-> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> ValueType -> m ValueType
uncheckedSubValueType (Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa2) ValueType
t2
        PassedValue c -> m (PassedValue c)
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 (GeneralType TypeInstanceOrParam)
-> ParamFilter c -> m (ParamFilter c)
subFilter Map ParamName (GeneralType TypeInstanceOrParam)
pa2 (ParamFilter [c]
c2 ParamName
n2 TypeFilter
f) = do
        TypeFilter
f' <- (ParamName -> m (GeneralType TypeInstanceOrParam))
-> TypeFilter -> m TypeFilter
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> TypeFilter -> m TypeFilter
uncheckedSubFilter (Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
pa2) TypeFilter
f
        ParamFilter c -> m (ParamFilter c)
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'

replaceSelfFunction :: (Show c, CollectErrorsM m) =>
  GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction :: GeneralType TypeInstanceOrParam
-> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction GeneralType TypeInstanceOrParam
self ff :: ScopedFunction c
ff@(ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s Positional (PassedValue 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)
as' <- ([PassedValue c] -> Positional (PassedValue c))
-> m [PassedValue c] -> m (Positional (PassedValue c))
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)
as
    Positional (PassedValue c)
rs' <- ([PassedValue c] -> Positional (PassedValue c))
-> m [PassedValue c] -> m (Positional (PassedValue c))
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 (GeneralType TypeInstanceOrParam
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
GeneralType TypeInstanceOrParam
-> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction GeneralType TypeInstanceOrParam
self) [ScopedFunction c]
ms
    ScopedFunction c -> m (ScopedFunction c)
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
-> Positional (PassedValue c)
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
forall c.
[c]
-> FunctionName
-> CategoryName
-> SymbolScope
-> Positional (PassedValue c)
-> Positional (PassedValue c)
-> Positional (ValueParam c)
-> [ParamFilter c]
-> [ScopedFunction c]
-> ScopedFunction c
ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s Positional (PassedValue c)
as' Positional (PassedValue c)
rs' Positional (ValueParam c)
ps [ParamFilter c]
fa' [ScopedFunction c]
ms')
    where
      subPassed :: PassedValue c -> m (PassedValue c)
subPassed (PassedValue [c]
c2 ValueType
t2) = do
        ValueType
t' <- GeneralType TypeInstanceOrParam -> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
GeneralType TypeInstanceOrParam -> ValueType -> m ValueType
replaceSelfValueType GeneralType TypeInstanceOrParam
self ValueType
t2
        PassedValue c -> m (PassedValue c)
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' <- GeneralType TypeInstanceOrParam -> TypeFilter -> m TypeFilter
forall (m :: * -> *).
CollectErrorsM m =>
GeneralType TypeInstanceOrParam -> TypeFilter -> m TypeFilter
replaceSelfFilter GeneralType TypeInstanceOrParam
self TypeFilter
f
        ParamFilter c -> m (ParamFilter c)
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'

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 :: r
-> Map ParamName [TypeFilter]
-> Map ParamName (GeneralType TypeInstanceOrParam)
-> [PatternMatch]
-> m (MergeTree InferredTypeGuess)
inferParamTypes r
r Map ParamName [TypeFilter]
f Map ParamName (GeneralType TypeInstanceOrParam)
ps = ([MergeTree InferredTypeGuess] -> MergeTree InferredTypeGuess)
-> m [MergeTree InferredTypeGuess]
-> m (MergeTree InferredTypeGuess)
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
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 (GeneralType TypeInstanceOrParam))
-> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> ValueType -> m ValueType
uncheckedSubValueType (Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
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
trDefines r
r TypeInstance
t1 CategoryName
n
    InstanceParams
ps2' <- ([GeneralType TypeInstanceOrParam] -> InstanceParams)
-> m [GeneralType TypeInstanceOrParam] -> m InstanceParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GeneralType TypeInstanceOrParam] -> InstanceParams
forall a. [a] -> Positional a
Positional (m [GeneralType TypeInstanceOrParam] -> m InstanceParams)
-> m [GeneralType TypeInstanceOrParam] -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ (GeneralType TypeInstanceOrParam
 -> m (GeneralType TypeInstanceOrParam))
-> [GeneralType TypeInstanceOrParam]
-> m [GeneralType TypeInstanceOrParam]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ((ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m (GeneralType TypeInstanceOrParam))
-> GeneralType TypeInstanceOrParam
-> m (GeneralType TypeInstanceOrParam)
uncheckedSubInstance (Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName (GeneralType TypeInstanceOrParam)
-> ParamName -> m (GeneralType TypeInstanceOrParam)
getValueForParam Map ParamName (GeneralType TypeInstanceOrParam)
ps)) ([GeneralType TypeInstanceOrParam]
 -> m [GeneralType TypeInstanceOrParam])
-> [GeneralType TypeInstanceOrParam]
-> m [GeneralType TypeInstanceOrParam]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralType TypeInstanceOrParam]
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 {
    GuessRange a -> Maybe a
grLower :: Maybe 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
/= :: GuessRange a -> GuessRange a -> Bool
$c/= :: forall a. Eq a => GuessRange a -> GuessRange a -> Bool
== :: GuessRange a -> GuessRange a -> Bool
$c== :: forall a. Eq a => GuessRange a -> GuessRange a -> Bool
Eq,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
min :: GuessRange a -> GuessRange a -> GuessRange a
$cmin :: forall a. Ord a => GuessRange a -> GuessRange a -> GuessRange a
max :: GuessRange a -> GuessRange a -> GuessRange a
$cmax :: forall a. Ord a => GuessRange a -> GuessRange a -> GuessRange a
>= :: GuessRange a -> GuessRange a -> Bool
$c>= :: forall a. Ord a => GuessRange a -> GuessRange a -> Bool
> :: GuessRange a -> GuessRange a -> Bool
$c> :: forall a. Ord a => GuessRange a -> GuessRange a -> Bool
<= :: GuessRange a -> GuessRange a -> Bool
$c<= :: forall a. Ord a => GuessRange a -> GuessRange a -> Bool
< :: GuessRange a -> GuessRange a -> Bool
$c< :: forall a. Ord a => GuessRange a -> GuessRange a -> Bool
compare :: GuessRange a -> GuessRange a -> Ordering
$ccompare :: forall a. Ord a => GuessRange a -> GuessRange a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (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 (GeneralType TypeInstanceOrParam)]
guGuesses :: [GuessRange GeneralInstance]
  }

guessesFromFilters :: CollectErrorsM m =>
  ParamFilters -> ValueType -> ValueType -> m [PatternMatch]
guessesFromFilters :: Map ParamName [TypeFilter]
-> ValueType -> ValueType -> m [PatternMatch]
guessesFromFilters Map ParamName [TypeFilter]
fm (ValueType StorageType
_ GeneralType TypeInstanceOrParam
t1) (ValueType StorageType
_ GeneralType TypeInstanceOrParam
t2) = m (Maybe TypeInstanceOrParam)
tryParam m (Maybe TypeInstanceOrParam)
-> (Maybe TypeInstanceOrParam -> m [PatternMatch])
-> m [PatternMatch]
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
$ GeneralType TypeInstanceOrParam
-> m (T (GeneralType TypeInstanceOrParam))
forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf GeneralType TypeInstanceOrParam
t2
  fromFilters :: Maybe TypeInstanceOrParam -> m [PatternMatch]
fromFilters (Just (JustParamName Bool
_ ParamName
n)) =
    case ParamName
n 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 (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 (m :: * -> *) a. Monad m => a -> m a
return []
  fromFilters Maybe TypeInstanceOrParam
_ = [PatternMatch] -> m [PatternMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  toGuess :: TypeFilter -> m [PatternMatch]
toGuess (TypeFilter FilterDirection
FilterRequires GeneralType TypeInstanceOrParam
t3) =
    [PatternMatch] -> m [PatternMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return [Variance -> ValueType -> ValueType -> PatternMatch
TypePattern Variance
Covariant (StorageType -> GeneralType TypeInstanceOrParam -> ValueType
ValueType StorageType
RequiredValue GeneralType TypeInstanceOrParam
t1) (StorageType -> GeneralType TypeInstanceOrParam -> ValueType
ValueType StorageType
RequiredValue GeneralType TypeInstanceOrParam
t3)]
  toGuess (TypeFilter FilterDirection
FilterAllows GeneralType TypeInstanceOrParam
t3) =
    [PatternMatch] -> m [PatternMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return [Variance -> ValueType -> ValueType -> PatternMatch
TypePattern Variance
Contravariant (StorageType -> GeneralType TypeInstanceOrParam -> ValueType
ValueType StorageType
RequiredValue GeneralType TypeInstanceOrParam
t1) (StorageType -> GeneralType TypeInstanceOrParam -> ValueType
ValueType StorageType
RequiredValue GeneralType TypeInstanceOrParam
t3)]
  toGuess (DefinesFilter DefinesInstance
t3) = do
    Maybe TypeInstanceOrParam
maybeInstance <- 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
$ GeneralType TypeInstanceOrParam
-> m (T (GeneralType TypeInstanceOrParam))
forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf GeneralType TypeInstanceOrParam
t1
    case Maybe TypeInstanceOrParam
maybeInstance of
         Just (JustTypeInstance TypeInstance
t) -> [PatternMatch] -> m [PatternMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeInstance -> DefinesInstance -> PatternMatch
DefinesPattern TypeInstance
t DefinesInstance
t3]
         Maybe TypeInstanceOrParam
_ -> [PatternMatch] -> m [PatternMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  toGuess TypeFilter
_ = [PatternMatch] -> m [PatternMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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