{- -----------------------------------------------------------------------------
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(..),
  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,
  getCategoryParams,
  getCategoryRefines,
  getConcreteCategory,
  getFilterMap,
  getFunctionFilterMap,
  getInstanceCategory,
  getValueCategory,
  guessesAsParams,
  includeNewTypes,
  inferParamTypes,
  instanceFromCategory,
  isInstanceInterface,
  isNoNamespace,
  isPrivateNamespace,
  isPublicNamespace,
  isStaticNamespace,
  isValueConcrete,
  isValueInterface,
  mergeDefines,
  mergeFunctions,
  mergeInferredTypes,
  mergeRefines,
  noDuplicateDefines,
  noDuplicateRefines,
  parsedToFunctionType,
  partitionByScope,
  replaceSelfFunction,
  setCategoryNamespace,
  topoSortCategories,
  uncheckedSubFunction,
  validateCategoryFunction,
) where

import Control.Arrow (second)
import Control.Monad ((>=>),when)
import Data.List (group,groupBy,intercalate,nub,nubBy,sort,sortBy)
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 -> [ValueParam c]
viParams :: [ValueParam c],
    AnyCategory c -> [ValueRefine c]
viRefines :: [ValueRefine c],
    AnyCategory c -> [ParamFilter c]
viParamFilter :: [ParamFilter 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 -> [ValueParam c]
iiParams :: [ValueParam c],
    AnyCategory c -> [ParamFilter c]
iiParamFilter :: [ParamFilter 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 -> [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]
  }

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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
cs) String -> String -> String
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 [ValueParam c]
ps [ValueRefine c]
rs [ParamFilter c]
vs [ScopedFunction c]
fs) =
      String
"@value interface " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ValueParam c] -> String
forall (t :: * -> *) c. Foldable t => t (ValueParam c) -> String
formatParams [ValueParam c]
ps String -> String -> String
forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespace Namespace
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatContext [c]
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
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
$
         (ValueRefine c -> String) -> [ValueRefine c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> String
"  " String -> String -> String
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]
++
         (ParamFilter c -> String) -> [ParamFilter c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
v -> String
"  " String -> String -> String
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
formatInterfaceFunc ScopedFunction c
f) [ScopedFunction c]
fs) String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"\n}\n"
    format (InstanceInterface [c]
cs Namespace
ns CategoryName
n [ValueParam c]
ps [ParamFilter c]
vs [ScopedFunction c]
fs) =
      String
"@type interface " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ValueParam c] -> String
forall (t :: * -> *) c. Foldable t => t (ValueParam c) -> String
formatParams [ValueParam c]
ps String -> String -> String
forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespace Namespace
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatContext [c]
cs String -> String -> String
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
$
         (ParamFilter c -> String) -> [ParamFilter c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ParamFilter c
v -> String
"  " String -> String -> String
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
formatInterfaceFunc ScopedFunction c
f) [ScopedFunction c]
fs) String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"\n}\n"
    format (ValueConcrete [c]
cs Namespace
ns CategoryName
n [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs) =
      String
"concrete " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ValueParam c] -> String
forall (t :: * -> *) c. Foldable t => t (ValueParam c) -> String
formatParams [ValueParam c]
ps String -> String -> String
forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespace Namespace
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatContext [c]
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
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
$
         (ValueRefine c -> String) -> [ValueRefine c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
r -> String
"  " String -> String -> String
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 -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"\n}\n"
    namespace :: Namespace -> String
namespace Namespace
ns
      | Namespace -> Bool
isStaticNamespace Namespace
ns = String
" /*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Namespace -> String
forall a. Show a => a -> String
show Namespace
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"*/"
      | Bool
otherwise = String
""
    formatContext :: [a] -> String
formatContext [a]
cs = String
"/*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContext [a]
cs String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
con String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"|" String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
inv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"|" String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
cov String -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++
                    String
" " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") String
"  " ScopedFunction c
f

getCategoryName :: AnyCategory c -> CategoryName
getCategoryName :: AnyCategory c -> CategoryName
getCategoryName (ValueInterface [c]
_ Namespace
_ CategoryName
n [ValueParam c]
_ [ValueRefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_)  = CategoryName
n
getCategoryName (InstanceInterface [c]
_ Namespace
_ CategoryName
n [ValueParam c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = CategoryName
n
getCategoryName (ValueConcrete [c]
_ Namespace
_ CategoryName
n [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
_ [ValueParam c]
_ [ValueRefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_)  = [c]
c
getCategoryContext (InstanceInterface [c]
c Namespace
_ CategoryName
_ [ValueParam c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = [c]
c
getCategoryContext (ValueConcrete [c]
c Namespace
_ CategoryName
_ [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
_ [ValueParam c]
_ [ValueRefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_)  = Namespace
ns
getCategoryNamespace (InstanceInterface [c]
_ Namespace
ns CategoryName
_ [ValueParam c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = Namespace
ns
getCategoryNamespace (ValueConcrete [c]
_ Namespace
ns CategoryName
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = Namespace
ns

setCategoryNamespace :: Namespace -> AnyCategory c -> AnyCategory c
setCategoryNamespace :: Namespace -> AnyCategory c -> AnyCategory c
setCategoryNamespace Namespace
ns (ValueInterface [c]
c Namespace
_ CategoryName
n [ValueParam c]
ps [ValueRefine c]
rs [ParamFilter c]
vs [ScopedFunction c]
fs)   = ([c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ValueRefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ValueRefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueInterface [c]
c Namespace
ns CategoryName
n [ValueParam c]
ps [ValueRefine c]
rs [ParamFilter c]
vs [ScopedFunction c]
fs)
setCategoryNamespace Namespace
ns (InstanceInterface [c]
c Namespace
_ CategoryName
n [ValueParam c]
ps [ParamFilter c]
vs [ScopedFunction c]
fs)   = ([c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
InstanceInterface [c]
c Namespace
ns CategoryName
n [ValueParam c]
ps [ParamFilter c]
vs [ScopedFunction c]
fs)
setCategoryNamespace Namespace
ns (ValueConcrete [c]
c Namespace
_ CategoryName
n [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs) = ([c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueConcrete [c]
c Namespace
ns CategoryName
n [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
_ [ValueParam c]
ps [ValueRefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_)  = [ValueParam c]
ps
getCategoryParams (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [ValueParam c]
ps [ParamFilter c]
_ [ScopedFunction c]
_) = [ValueParam c]
ps
getCategoryParams (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [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
_ [ValueParam c]
_ [ValueRefine c]
rs [ParamFilter c]
_ [ScopedFunction c]
_)  = [ValueRefine c]
rs
getCategoryRefines (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [ValueParam c]
_ [ParamFilter c]
_ [ScopedFunction c]
_)  = []
getCategoryRefines (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [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
_ [ValueParam c]
_ [ValueRefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_)  = []
getCategoryDefines (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [ValueParam c]
_ [ParamFilter c]
_ [ScopedFunction c]
_)  = []
getCategoryDefines (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [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
_ [ValueParam c]
_ [ValueRefine c]
_ [ParamFilter c]
vs [ScopedFunction c]
_)  = [ParamFilter c]
vs
getCategoryFilters (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [ValueParam c]
_ [ParamFilter c]
vs [ScopedFunction c]
_) = [ParamFilter c]
vs
getCategoryFilters (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [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
_ [ValueParam c]
_ [ValueRefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
fs)  = [ScopedFunction c]
fs
getCategoryFunctions (InstanceInterface [c]
_ Namespace
_ CategoryName
_ [ValueParam c]
_ [ParamFilter c]
_ [ScopedFunction c]
fs) = [ScopedFunction c]
fs
getCategoryFunctions (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [ValueParam c]
_ [ValueRefine c]
_ [ValueDefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
fs) = [ScopedFunction c]
fs

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

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 (GeneralInstance -> [CategoryName]
fromInstance (GeneralInstance -> [CategoryName])
-> (ValueRefine c -> GeneralInstance)
-> ValueRefine c
-> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> (ValueRefine c -> TypeInstanceOrParam)
-> ValueRefine c
-> GeneralInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> (ValueRefine c -> TypeInstance)
-> ValueRefine c
-> TypeInstanceOrParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType) ([ValueRefine c] -> [[CategoryName]])
-> [ValueRefine c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueRefine c]
forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t
  defines :: [CategoryName]
defines = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (ValueDefine c -> [CategoryName])
-> [ValueDefine c] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map (DefinesInstance -> [CategoryName]
fromDefine (DefinesInstance -> [CategoryName])
-> (ValueDefine c -> DefinesInstance)
-> ValueDefine c
-> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType) ([ValueDefine c] -> [[CategoryName]])
-> [ValueDefine c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueDefine c]
forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t
  filters :: [CategoryName]
filters = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (ParamFilter c -> [CategoryName])
-> [ParamFilter c] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map (TypeFilter -> [CategoryName]
fromFilter (TypeFilter -> [CategoryName])
-> (ParamFilter c -> TypeFilter) -> ParamFilter c -> [CategoryName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamFilter c -> TypeFilter
forall c. ParamFilter c -> TypeFilter
pfFilter) ([ParamFilter c] -> [[CategoryName]])
-> [ParamFilter c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ParamFilter c]
forall c. AnyCategory c -> [ParamFilter c]
getCategoryFilters AnyCategory c
t
  functions :: [CategoryName]
functions = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (ScopedFunction c -> [CategoryName])
-> [ScopedFunction c] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map ScopedFunction c -> [CategoryName]
forall c. ScopedFunction c -> [CategoryName]
fromFunction ([ScopedFunction c] -> [[CategoryName]])
-> [ScopedFunction c] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ScopedFunction c]
forall c. AnyCategory c -> [ScopedFunction c]
getCategoryFunctions AnyCategory c
t
  fromInstance :: GeneralInstance -> [CategoryName]
fromInstance = ([[CategoryName]] -> [CategoryName])
-> ([[CategoryName]] -> [CategoryName])
-> (T GeneralInstance -> [CategoryName])
-> GeneralInstance
-> [CategoryName]
forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat T GeneralInstance -> [CategoryName]
TypeInstanceOrParam -> [CategoryName]
fromSingle
  fromSingle :: TypeInstanceOrParam -> [CategoryName]
fromSingle (JustTypeInstance (TypeInstance CategoryName
n InstanceParams
ps)) = CategoryName
nCategoryName -> [CategoryName] -> [CategoryName]
forall a. a -> [a] -> [a]
:([[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> [CategoryName])
-> [GeneralInstance] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> [CategoryName]
fromInstance ([GeneralInstance] -> [[CategoryName]])
-> [GeneralInstance] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralInstance]
forall a. Positional a -> [a]
pValues InstanceParams
ps)
  fromSingle TypeInstanceOrParam
_ = []
  fromDefine :: DefinesInstance -> [CategoryName]
fromDefine (DefinesInstance CategoryName
n InstanceParams
ps) = CategoryName
nCategoryName -> [CategoryName] -> [CategoryName]
forall a. a -> [a] -> [a]
:([[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> [CategoryName])
-> [GeneralInstance] -> [[CategoryName]]
forall a b. (a -> b) -> [a] -> [b]
map GeneralInstance -> [CategoryName]
fromInstance ([GeneralInstance] -> [[CategoryName]])
-> [GeneralInstance] -> [[CategoryName]]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralInstance]
forall a. Positional a -> [a]
pValues InstanceParams
ps)
  fromFilter :: TypeFilter -> [CategoryName]
fromFilter (TypeFilter FilterDirection
_ GeneralInstance
t2)  = GeneralInstance -> [CategoryName]
fromInstance GeneralInstance
t2
  fromFilter (DefinesFilter DefinesInstance
t2) = DefinesInstance -> [CategoryName]
fromDefine DefinesInstance
t2
  fromType :: ValueType -> [CategoryName]
fromType (ValueType StorageType
_ GeneralInstance
t2) = GeneralInstance -> [CategoryName]
fromInstance GeneralInstance
t2
  fromFunction :: ScopedFunction c -> [CategoryName]
fromFunction ScopedFunction c
f = [CategoryName]
args [CategoryName] -> [CategoryName] -> [CategoryName]
forall a. [a] -> [a] -> [a]
++ [CategoryName]
returns [CategoryName] -> [CategoryName] -> [CategoryName]
forall a. [a] -> [a] -> [a]
++ [CategoryName]
filters2 where
    args :: [CategoryName]
args = [[CategoryName]] -> [CategoryName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CategoryName]] -> [CategoryName])
-> [[CategoryName]] -> [CategoryName]
forall a b. (a -> b) -> a -> b
$ (PassedValue c -> [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
_ [ValueParam c]
_ [ValueRefine c]
_ [ParamFilter c]
_ [ScopedFunction c]
_) = Bool
True
isValueInterface AnyCategory c
_ = Bool
False

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

isValueConcrete :: AnyCategory c -> Bool
isValueConcrete :: AnyCategory c -> Bool
isValueConcrete (ValueConcrete [c]
_ Namespace
_ CategoryName
_ [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 -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Variance -> String
forall a. Show a => a -> String
show Variance
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c

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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeFilter -> String
forall a. Show a => a -> String
show TypeFilter
f String -> String -> String
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) (TypeInstance CategoryName
n1 InstanceParams
ps1) CategoryName
n2
      | CategoryName
n1 CategoryName -> CategoryName -> Bool
forall a. Eq a => a -> a -> Bool
== CategoryName
n2 = do
        ([c]
_,AnyCategory c
t) <- CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getValueCategory CategoryMap c
tm ([],CategoryName
n1)
        (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName -> InstanceParams -> m ()
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m ()
processPairs_ ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional ([ParamName] -> Positional ParamName)
-> [ParamName] -> Positional ParamName
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t) InstanceParams
ps1
        InstanceParams -> m InstanceParams
forall (m :: * -> *) a. Monad m => a -> m a
return InstanceParams
ps1
      | Bool
otherwise = 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)
        let params :: [ParamName]
params = (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
        Map ParamName GeneralInstance
assigned <- ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(ParamName, GeneralInstance)]
 -> m (Map ParamName GeneralInstance))
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> a -> b
$ (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
params) InstanceParams
ps1
        let pa :: Map CategoryName InstanceParams
pa = [(CategoryName, InstanceParams)] -> Map CategoryName InstanceParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CategoryName, InstanceParams)]
 -> Map CategoryName InstanceParams)
-> [(CategoryName, InstanceParams)]
-> Map CategoryName InstanceParams
forall a b. (a -> b) -> a -> b
$ (TypeInstance -> (CategoryName, InstanceParams))
-> [TypeInstance] -> [(CategoryName, InstanceParams)]
forall a b. (a -> b) -> [a] -> [b]
map (\TypeInstance
r -> (TypeInstance -> CategoryName
tiName TypeInstance
r,TypeInstance -> InstanceParams
tiParams TypeInstance
r)) ([TypeInstance] -> [(CategoryName, InstanceParams)])
-> [TypeInstance] -> [(CategoryName, InstanceParams)]
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> TypeInstance)
-> [ValueRefine c] -> [TypeInstance]
forall a b. (a -> b) -> [a] -> [b]
map ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ([ValueRefine c] -> [TypeInstance])
-> [ValueRefine c] -> [TypeInstance]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueRefine c]
forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t
        InstanceParams
ps2 <- case CategoryName
n2 CategoryName
-> Map CategoryName InstanceParams -> Maybe InstanceParams
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName InstanceParams
pa of
                    (Just InstanceParams
x) -> InstanceParams -> m InstanceParams
forall (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 -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not refine " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n2
        ([GeneralInstance] -> InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional (m [GeneralInstance] -> m InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> m GeneralInstance)
-> [GeneralInstance] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName GeneralInstance
-> GeneralInstance -> m GeneralInstance
subAllParams Map ParamName GeneralInstance
assigned) ([GeneralInstance] -> m [GeneralInstance])
-> [GeneralInstance] -> m [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralInstance]
forall a. Positional a -> [a]
pValues InstanceParams
ps2
    trDefines :: CategoryResolver c
-> TypeInstance -> CategoryName -> m InstanceParams
trDefines (CategoryResolver CategoryMap c
tm) (TypeInstance CategoryName
n1 InstanceParams
ps1) 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)
      let params :: [ParamName]
params = (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
      Map ParamName GeneralInstance
assigned <- ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(ParamName, GeneralInstance)]
 -> m (Map ParamName GeneralInstance))
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> a -> b
$ (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
params) InstanceParams
ps1
      let pa :: Map CategoryName InstanceParams
pa = [(CategoryName, InstanceParams)] -> Map CategoryName InstanceParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CategoryName, InstanceParams)]
 -> Map CategoryName InstanceParams)
-> [(CategoryName, InstanceParams)]
-> Map CategoryName InstanceParams
forall a b. (a -> b) -> a -> b
$ (DefinesInstance -> (CategoryName, InstanceParams))
-> [DefinesInstance] -> [(CategoryName, InstanceParams)]
forall a b. (a -> b) -> [a] -> [b]
map (\DefinesInstance
r -> (DefinesInstance -> CategoryName
diName DefinesInstance
r,DefinesInstance -> InstanceParams
diParams DefinesInstance
r)) ([DefinesInstance] -> [(CategoryName, InstanceParams)])
-> [DefinesInstance] -> [(CategoryName, InstanceParams)]
forall a b. (a -> b) -> a -> b
$ (ValueDefine c -> DefinesInstance)
-> [ValueDefine c] -> [DefinesInstance]
forall a b. (a -> b) -> [a] -> [b]
map ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType ([ValueDefine c] -> [DefinesInstance])
-> [ValueDefine c] -> [DefinesInstance]
forall a b. (a -> b) -> a -> b
$ AnyCategory c -> [ValueDefine c]
forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t
      InstanceParams
ps2 <- case CategoryName
n2 CategoryName
-> Map CategoryName InstanceParams -> Maybe InstanceParams
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName InstanceParams
pa of
                  (Just InstanceParams
x) -> InstanceParams -> m InstanceParams
forall (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 -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not define " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n2
      ([GeneralInstance] -> InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional (m [GeneralInstance] -> m InstanceParams)
-> m [GeneralInstance] -> m InstanceParams
forall a b. (a -> b) -> a -> b
$ (GeneralInstance -> m GeneralInstance)
-> [GeneralInstance] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
Map ParamName GeneralInstance
-> GeneralInstance -> m GeneralInstance
subAllParams Map ParamName GeneralInstance
assigned) ([GeneralInstance] -> m [GeneralInstance])
-> [GeneralInstance] -> m [GeneralInstance]
forall a b. (a -> b) -> a -> b
$ InstanceParams -> [GeneralInstance]
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)

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 GeneralInstance
assigned <- ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParamName
-> GeneralInstance
-> Map ParamName GeneralInstance
-> Map ParamName GeneralInstance
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf GeneralInstance
selfType (Map ParamName GeneralInstance -> Map ParamName GeneralInstance)
-> ([(ParamName, GeneralInstance)]
    -> Map ParamName GeneralInstance)
-> [(ParamName, GeneralInstance)]
-> Map ParamName GeneralInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) (m [(ParamName, GeneralInstance)]
 -> m (Map ParamName GeneralInstance))
-> m [(ParamName, GeneralInstance)]
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> a -> b
$ (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
params) InstanceParams
ps
  [(ParamName, TypeFilter)]
fs <- (ParamFilter c -> m (ParamName, TypeFilter))
-> [ParamFilter c] -> m [(ParamName, TypeFilter)]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> (ParamName, TypeFilter) -> m (ParamName, TypeFilter)
forall (m :: * -> *) a.
CollectErrorsM m =>
Map ParamName GeneralInstance
-> (a, TypeFilter) -> m (a, TypeFilter)
subSingleFilter Map ParamName GeneralInstance
assigned ((ParamName, TypeFilter) -> m (ParamName, TypeFilter))
-> (ParamFilter c -> (ParamName, TypeFilter))
-> ParamFilter c
-> m (ParamName, TypeFilter)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \ParamFilter c
f -> (ParamFilter c -> ParamName
forall c. ParamFilter c -> ParamName
pfParam ParamFilter c
f,ParamFilter c -> TypeFilter
forall c. ParamFilter c -> TypeFilter
pfFilter ParamFilter c
f)) [ParamFilter c]
allFilters
  let fa :: Map ParamName [TypeFilter]
fa = ([TypeFilter] -> [TypeFilter] -> [TypeFilter])
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
(++) ([(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter])
-> [(ParamName, [TypeFilter])] -> Map ParamName [TypeFilter]
forall a b. (a -> b) -> a -> b
$ ((ParamName, TypeFilter) -> (ParamName, [TypeFilter]))
-> [(ParamName, TypeFilter)] -> [(ParamName, [TypeFilter])]
forall a b. (a -> b) -> [a] -> [b]
map ((TypeFilter -> [TypeFilter])
-> (ParamName, TypeFilter) -> (ParamName, [TypeFilter])
forall (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 GeneralInstance
-> (a, TypeFilter) -> m (a, TypeFilter)
subSingleFilter Map ParamName GeneralInstance
pa (a
n,(TypeFilter FilterDirection
v GeneralInstance
t2)) = do
      GeneralInstance
t3<- (ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
uncheckedSubInstance (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
pa) GeneralInstance
t2
      (a, TypeFilter) -> m (a, TypeFilter)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
n,(FilterDirection -> GeneralInstance -> TypeFilter
TypeFilter FilterDirection
v GeneralInstance
t3))
    subSingleFilter Map ParamName GeneralInstance
pa (a
n,(DefinesFilter (DefinesInstance CategoryName
n2 InstanceParams
ps2))) = do
      [GeneralInstance]
ps3 <- (GeneralInstance -> m GeneralInstance)
-> [GeneralInstance] -> m [GeneralInstance]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ((ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
uncheckedSubInstance ((ParamName -> m GeneralInstance)
 -> GeneralInstance -> m GeneralInstance)
-> (ParamName -> m GeneralInstance)
-> GeneralInstance
-> m GeneralInstance
forall a b. (a -> b) -> a -> b
$ Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
pa) (InstanceParams -> [GeneralInstance]
forall a. Positional a -> [a]
pValues InstanceParams
ps2)
      (a, TypeFilter) -> m (a, TypeFilter)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
n,(DefinesInstance -> TypeFilter
DefinesFilter (CategoryName -> InstanceParams -> DefinesInstance
DefinesInstance CategoryName
n2 ([GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional [GeneralInstance]
ps3))))
    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 = [GeneralInstance] -> InstanceParams
forall a. [a] -> Positional a
Positional ([GeneralInstance] -> InstanceParams)
-> [GeneralInstance] -> InstanceParams
forall a b. (a -> b) -> a -> b
$ (ParamName -> GeneralInstance) -> [ParamName] -> [GeneralInstance]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> (ParamName -> TypeInstanceOrParam)
-> ParamName
-> GeneralInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False) [ParamName]
params
  selfFilters :: [TypeFilter]
selfFilters
    | AnyCategory c -> Bool
forall c. AnyCategory c -> Bool
isInstanceInterface AnyCategory c
t = [
        DefinesInstance -> TypeFilter
DefinesFilter (DefinesInstance -> TypeFilter) -> DefinesInstance -> TypeFilter
forall a b. (a -> b) -> a -> b
$ CategoryName -> InstanceParams -> DefinesInstance
DefinesInstance (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) InstanceParams
selfParams
      ] [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
++ [TypeFilter]
inheritedFilters
    | Bool
otherwise = [
        FilterDirection -> GeneralInstance -> TypeFilter
TypeFilter FilterDirection
FilterRequires (GeneralInstance -> TypeFilter) -> GeneralInstance -> TypeFilter
forall a b. (a -> b) -> a -> b
$ TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> TypeInstance -> TypeInstanceOrParam
forall a b. (a -> b) -> a -> b
$ CategoryName -> InstanceParams -> TypeInstance
TypeInstance (AnyCategory c -> CategoryName
forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) InstanceParams
selfParams
      ] [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
++ [TypeFilter]
inheritedFilters
  inheritedFilters :: [TypeFilter]
inheritedFilters = (ValueDefine c -> TypeFilter) -> [ValueDefine c] -> [TypeFilter]
forall a b. (a -> b) -> [a] -> [b]
map (DefinesInstance -> TypeFilter
DefinesFilter (DefinesInstance -> TypeFilter)
-> (ValueDefine c -> DefinesInstance)
-> ValueDefine c
-> TypeFilter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueDefine c -> DefinesInstance
forall c. ValueDefine c -> DefinesInstance
vdType) (AnyCategory c -> [ValueDefine c]
forall c. AnyCategory c -> [ValueDefine c]
getCategoryDefines AnyCategory c
t) [TypeFilter] -> [TypeFilter] -> [TypeFilter]
forall a. [a] -> [a] -> [a]
++
                     (ValueRefine c -> TypeFilter) -> [ValueRefine c] -> [TypeFilter]
forall a b. (a -> b) -> [a] -> [b]
map (FilterDirection -> GeneralInstance -> TypeFilter
TypeFilter FilterDirection
FilterRequires (GeneralInstance -> TypeFilter)
-> (ValueRefine c -> GeneralInstance)
-> ValueRefine c
-> TypeFilter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> (ValueRefine c -> TypeInstanceOrParam)
-> ValueRefine c
-> GeneralInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> (ValueRefine c -> TypeInstance)
-> ValueRefine c
-> TypeInstanceOrParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType) (AnyCategory c -> [ValueRefine c]
forall c. AnyCategory c -> [ValueRefine c]
getCategoryRefines AnyCategory c
t)

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

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 -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
context String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           String
" cannot be used as a value" String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           String
" cannot be used as a type interface" String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           String
" cannot be used as concrete" String -> String -> String
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 -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++
                                      String
" has already been declared" String -> String -> String
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 GeneralInstance
p2)) = do
      Maybe TypeInstanceOrParam
p <- [m (Maybe TypeInstanceOrParam)] -> m (Maybe TypeInstanceOrParam)
forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM [(TypeInstanceOrParam -> Maybe TypeInstanceOrParam)
-> m TypeInstanceOrParam -> m (Maybe TypeInstanceOrParam)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeInstanceOrParam -> Maybe TypeInstanceOrParam
forall a. a -> Maybe a
Just (m TypeInstanceOrParam -> m (Maybe TypeInstanceOrParam))
-> m TypeInstanceOrParam -> m (Maybe TypeInstanceOrParam)
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> m (T GeneralInstance)
forall a (m :: * -> *).
(PreserveMerge a, CollectErrorsM m) =>
a -> m (T a)
matchOnlyLeaf GeneralInstance
p2,Maybe TypeInstanceOrParam -> m (Maybe TypeInstanceOrParam)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TypeInstanceOrParam
forall a. Maybe a
Nothing]
      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 -> GeneralInstance -> TypeFilter
TypeFilter (FilterDirection -> FilterDirection
flipFilter FilterDirection
d) (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False ParamName
p1))))]
               else [ParamFilter c] -> m [ParamFilter c]
forall (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

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

disallowBoundedParams :: CollectErrorsM m => ParamFilters -> m ()
disallowBoundedParams :: Map ParamName [TypeFilter] -> m ()
disallowBoundedParams = ((ParamName, [TypeFilter]) -> m ())
-> [(ParamName, [TypeFilter])] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (ParamName, [TypeFilter]) -> m ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Show a, CollectErrorsM f) =>
(a, t TypeFilter) -> f ()
checkBounds ([(ParamName, [TypeFilter])] -> m ())
-> (Map ParamName [TypeFilter] -> [(ParamName, [TypeFilter])])
-> Map ParamName [TypeFilter]
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ParamName [TypeFilter] -> [(ParamName, [TypeFilter])]
forall k a. Map k a -> [(k, a)]
Map.toList where
  checkBounds :: (a, t TypeFilter) -> f ()
checkBounds (a
p,t TypeFilter
fs) = do
    let (GeneralInstance
lb,GeneralInstance
ub) = (TypeFilter
 -> (GeneralInstance, GeneralInstance)
 -> (GeneralInstance, GeneralInstance))
-> (GeneralInstance, GeneralInstance)
-> t TypeFilter
-> (GeneralInstance, GeneralInstance)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeFilter
-> (GeneralInstance, GeneralInstance)
-> (GeneralInstance, GeneralInstance)
splitBounds (GeneralInstance
forall a. Bounded a => a
minBound,GeneralInstance
forall a. Bounded a => a
maxBound) t TypeFilter
fs
    Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralInstance
lb GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
/= GeneralInstance
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& GeneralInstance
ub GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
/= GeneralInstance
forall a. Bounded a => a
maxBound) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
      String
"Param " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
p String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
ub
          ]
  splitBounds :: TypeFilter
-> (GeneralInstance, GeneralInstance)
-> (GeneralInstance, GeneralInstance)
splitBounds (TypeFilter FilterDirection
FilterRequires GeneralInstance
t) (GeneralInstance
lb,GeneralInstance
ub) = (GeneralInstance
lb,GeneralInstance
tGeneralInstance -> GeneralInstance -> GeneralInstance
forall a. Mergeable a => a -> a -> a
<&&>GeneralInstance
ub)
  splitBounds (TypeFilter FilterDirection
FilterAllows   GeneralInstance
t) (GeneralInstance
lb,GeneralInstance
ub) = (GeneralInstance
tGeneralInstance -> GeneralInstance -> GeneralInstance
forall a. Mergeable a => a -> a -> a
<||>GeneralInstance
lb,GeneralInstance
ub)
  splitBounds TypeFilter
_ (GeneralInstance, GeneralInstance)
bs = (GeneralInstance, GeneralInstance)
bs

checkConnectedTypes :: (Show c, CollectErrorsM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkConnectedTypes :: 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 [ValueParam c]
_ [ValueRefine c]
rs [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
      [([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 [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 -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine type interface " String -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine concrete type " String -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine instance interface " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2 String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
" cannot define value interface " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c2 String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
" cannot refine concrete type " String -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
" cannot define concrete type " String -> String -> String
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 -> String -> String
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 [ValueParam c]
_ [ValueRefine c]
rs [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]
us (ValueConcrete [c]
c Namespace
_ CategoryName
n [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 -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
" refers back to itself: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show ([a]
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 :: * -> *) a r.
(Show a, CollectErrorsM m, TypeResolver r) =>
r -> AnyCategory a -> 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 -> String -> String
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 -> String -> String
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 a -> m ()
checkCategory r
r t :: AnyCategory a
t@(ValueInterface [a]
c Namespace
_ CategoryName
n [ValueParam a]
ps [ValueRefine a]
rs [ParamFilter a]
fa [ScopedFunction a]
_) = AnyCategory a -> String
forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory a
t String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      [a] -> CategoryName -> [ValueParam a] -> m ()
forall (m :: * -> *) a a c.
(Show a, Show a, CollectErrorsM m) =>
[a] -> a -> [ValueParam c] -> m ()
noDuplicates [a]
c CategoryName
n [ValueParam a]
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 a -> (ParamName, Variance))
-> [ValueParam a] -> [(ParamName, Variance)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueParam a
p -> (ValueParam a -> ParamName
forall c. ValueParam c -> ParamName
vpParam ValueParam a
p,ValueParam a -> Variance
forall c. ValueParam c -> Variance
vpVariance ValueParam a
p)) [ValueParam a]
ps
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((ValueRefine a -> m ()) -> [ValueRefine a] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (r -> Map ParamName Variance -> ValueRefine a -> 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 a]
rs)
      (ParamFilter a -> m ()) -> [ParamFilter a] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (r -> Map ParamName Variance -> ParamFilter a -> m ()
forall (m :: * -> *) a r.
(Show a, CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName Variance -> ParamFilter a -> m ()
checkFilterVariance r
r Map ParamName Variance
vm) [ParamFilter a]
fa
    checkCategory r
r t :: AnyCategory a
t@(ValueConcrete [a]
c Namespace
_ CategoryName
n [ValueParam a]
ps [ValueRefine a]
rs [ValueDefine a]
ds [ParamFilter a]
fa [ScopedFunction a]
_) = AnyCategory a -> String
forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory a
t String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      [a] -> CategoryName -> [ValueParam a] -> m ()
forall (m :: * -> *) a a c.
(Show a, Show a, CollectErrorsM m) =>
[a] -> a -> [ValueParam c] -> m ()
noDuplicates [a]
c CategoryName
n [ValueParam a]
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 a -> (ParamName, Variance))
-> [ValueParam a] -> [(ParamName, Variance)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueParam a
p -> (ValueParam a -> ParamName
forall c. ValueParam c -> ParamName
vpParam ValueParam a
p,ValueParam a -> Variance
forall c. ValueParam c -> Variance
vpVariance ValueParam a
p)) [ValueParam a]
ps
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((ValueRefine a -> m ()) -> [ValueRefine a] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (r -> Map ParamName Variance -> ValueRefine a -> 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 a]
rs)
      [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ ((ValueDefine a -> m ()) -> [ValueDefine a] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (r -> Map ParamName Variance -> ValueDefine a -> 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 a]
ds)
      (ParamFilter a -> m ()) -> [ParamFilter a] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (r -> Map ParamName Variance -> ParamFilter a -> m ()
forall (m :: * -> *) a r.
(Show a, CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName Variance -> ParamFilter a -> m ()
checkFilterVariance r
r Map ParamName Variance
vm) [ParamFilter a]
fa
    checkCategory r
r t :: AnyCategory a
t@(InstanceInterface [a]
c Namespace
_ CategoryName
n [ValueParam a]
ps [ParamFilter a]
fa [ScopedFunction a]
_) = AnyCategory a -> String
forall c. Show c => AnyCategory c -> String
categoryContext AnyCategory a
t String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      [a] -> CategoryName -> [ValueParam a] -> m ()
forall (m :: * -> *) a a c.
(Show a, Show a, CollectErrorsM m) =>
[a] -> a -> [ValueParam c] -> m ()
noDuplicates [a]
c CategoryName
n [ValueParam a]
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 a -> (ParamName, Variance))
-> [ValueParam a] -> [(ParamName, Variance)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueParam a
p -> (ValueParam a -> ParamName
forall c. ValueParam c -> ParamName
vpParam ValueParam a
p,ValueParam a -> Variance
forall c. ValueParam c -> Variance
vpVariance ValueParam a
p)) [ValueParam a]
ps
      (ParamFilter a -> m ()) -> [ParamFilter a] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (r -> Map ParamName Variance -> ParamFilter a -> m ()
forall (m :: * -> *) a r.
(Show a, CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName Variance -> ParamFilter a -> m ()
checkFilterVariance r
r Map ParamName Variance
vm) [ParamFilter a]
fa
    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 -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" occurs " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
" times in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [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 -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName Variance -> Variance -> GeneralInstance -> m ()
validateInstanceVariance r
r Map ParamName Variance
vm Variance
Covariant (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t) m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeInstance -> String
forall a. Show a => a -> String
show TypeInstance
t String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ DefinesInstance -> String
forall a. Show a => a -> String
show DefinesInstance
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    checkFilterVariance :: r -> Map ParamName Variance -> ParamFilter a -> m ()
checkFilterVariance r
r Map ParamName Variance
vs (ParamFilter [a]
c ParamName
n f :: TypeFilter
f@(TypeFilter FilterDirection
FilterRequires GeneralInstance
t)) =
      String
"In filter " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeFilter -> String
forall a. Show a => a -> String
show TypeFilter
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
        case ParamName
n ParamName -> Map ParamName Variance -> Maybe Variance
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map ParamName Variance
vs of
             Just Variance
Contravariant -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Contravariant param " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                    String
" cannot have a requires filter"
             Maybe Variance
Nothing -> 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is undefined"
             Maybe Variance
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        r -> Map ParamName Variance -> Variance -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName Variance -> Variance -> GeneralInstance -> m ()
validateInstanceVariance r
r Map ParamName Variance
vs Variance
Contravariant GeneralInstance
t
    checkFilterVariance r
r Map ParamName Variance
vs (ParamFilter [a]
c ParamName
n f :: TypeFilter
f@(TypeFilter FilterDirection
FilterAllows GeneralInstance
t)) =
      String
"In filter " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeFilter -> String
forall a. Show a => a -> String
show TypeFilter
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
        case ParamName
n ParamName -> Map ParamName Variance -> Maybe Variance
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map ParamName Variance
vs of
             Just Variance
Covariant -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Covariant param " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                String
" cannot have an allows filter"
             Maybe Variance
Nothing -> 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is undefined"
             Maybe Variance
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        r -> Map ParamName Variance -> Variance -> GeneralInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName Variance -> Variance -> GeneralInstance -> m ()
validateInstanceVariance r
r Map ParamName Variance
vs Variance
Covariant GeneralInstance
t
    checkFilterVariance r
r Map ParamName Variance
vs (ParamFilter [a]
c ParamName
n f :: TypeFilter
f@(DefinesFilter DefinesInstance
t)) =
      String
"In filter " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeFilter -> String
forall a. Show a => a -> String
show TypeFilter
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
        case ParamName
n ParamName -> Map ParamName Variance -> Maybe Variance
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map ParamName Variance
vs of
             Just Variance
Contravariant -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Contravariant param " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                    String
" cannot have a defines filter"
             Maybe Variance
Nothing -> 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is undefined"
             Maybe Variance
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        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
vs Variance
Contravariant DefinesInstance
t

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
      let 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
$ AnyCategory c -> [ValueParam c]
forall c. AnyCategory c -> [ValueParam c]
getCategoryParams AnyCategory c
t
      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
      (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 -> Map ParamName [TypeFilter] -> ValueRefine c -> m ()
forall (m :: * -> *) r a.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Map ParamName [TypeFilter] -> ValueRefine a -> m ()
checkRefine r
r Map ParamName [TypeFilter]
fm) (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 -> Map ParamName [TypeFilter] -> ValueDefine c -> m ()
forall (m :: * -> *) r a.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Map ParamName [TypeFilter] -> ValueDefine a -> m ()
checkDefine r
r Map ParamName [TypeFilter]
fm) (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 -> Map ParamName [TypeFilter] -> ParamFilter c -> m ()
forall (m :: * -> *) r a.
(CollectErrorsM m, TypeResolver r, Show a) =>
r -> Map ParamName [TypeFilter] -> ParamFilter a -> m ()
checkFilter r
r Map ParamName [TypeFilter]
fm) (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 -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found"
    checkRefine :: r -> Map ParamName [TypeFilter] -> ValueRefine a -> m ()
checkRefine r
r Map ParamName [TypeFilter]
fm (ValueRefine [a]
c TypeInstance
t) =
      r -> Map ParamName [TypeFilter] -> TypeInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName [TypeFilter] -> TypeInstance -> m ()
validateTypeInstance r
r Map ParamName [TypeFilter]
fm TypeInstance
t m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeInstance -> String
forall a. Show a => a -> String
show TypeInstance
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    checkDefine :: r -> Map ParamName [TypeFilter] -> ValueDefine a -> m ()
checkDefine r
r Map ParamName [TypeFilter]
fm (ValueDefine [a]
c DefinesInstance
t) =
      r -> Map ParamName [TypeFilter] -> DefinesInstance -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName [TypeFilter] -> DefinesInstance -> m ()
validateDefinesInstance r
r Map ParamName [TypeFilter]
fm DefinesInstance
t m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DefinesInstance -> String
forall a. Show a => a -> String
show DefinesInstance
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [a]
c
    checkFilter :: r -> Map ParamName [TypeFilter] -> ParamFilter a -> m ()
checkFilter r
r Map ParamName [TypeFilter]
fm (ParamFilter [a]
c ParamName
n TypeFilter
f) =
      r -> Map ParamName [TypeFilter] -> TypeFilter -> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r -> Map ParamName [TypeFilter] -> TypeFilter -> m ()
validateTypeFilter r
r Map ParamName [TypeFilter]
fm TypeFilter
f m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<??
        String
"In " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeFilter -> String
forall a. Show a => a -> String
show TypeFilter
f String -> String -> String
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
  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 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
-> Map ParamName [TypeFilter]
-> Map ParamName Variance
-> FunctionType
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName Variance
-> FunctionType
-> m ()
validatateFunctionType r
r Map ParamName [TypeFilter]
forall k a. Map k a
Map.empty Map ParamName Variance
forall k a. Map k a
Map.empty FunctionType
funcType
         SymbolScope
TypeScope     -> r
-> Map ParamName [TypeFilter]
-> Map ParamName Variance
-> FunctionType
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName Variance
-> FunctionType
-> m ()
validatateFunctionType r
r Map ParamName [TypeFilter]
fm Map ParamName Variance
vm FunctionType
funcType
         SymbolScope
ValueScope    -> r
-> Map ParamName [TypeFilter]
-> Map ParamName Variance
-> FunctionType
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName Variance
-> FunctionType
-> m ()
validatateFunctionType r
r Map ParamName [TypeFilter]
fm 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n---\n"
        | Bool
otherwise = String
"In function inherited from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show (ScopedFunction c -> CategoryName
forall c. ScopedFunction c -> CategoryName
sfType ScopedFunction c
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace (AnyCategory c -> [c]
forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory c
t) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n---\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f String -> String -> String
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)

-- For fixed x, if f y x succeeds for some y then x is removed.
mergeObjects :: CollectErrorsM m => (a -> a -> m b) -> [a] -> m [a]
mergeObjects :: (a -> a -> m b) -> [a] -> m [a]
mergeObjects a -> a -> m b
f = [a] -> [a] -> m [a]
merge [] where
  merge :: [a] -> [a] -> m [a]
merge [a]
cs [] = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
cs
  merge [a]
cs (a
x:[a]
xs) = do
    [a]
ys <- [m [a]] -> m [a]
forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM ([m [a]] -> m [a]) -> [m [a]] -> m [a]
forall a b. (a -> b) -> a -> b
$ (a -> m [a]) -> [a] -> [m [a]]
forall a b. (a -> b) -> [a] -> [b]
map a -> m [a]
check ([a]
cs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs) [m [a]] -> [m [a]] -> [m [a]]
forall a. [a] -> [a] -> [a]
++ [[a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a
x]]
    [a] -> [a] -> m [a]
merge ([a]
cs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys) [a]
xs where
      check :: a -> m [a]
check a
x2 = a
x2 a -> a -> m b
`f` a
x m b -> m [a] -> m [a]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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]
mergeObjects 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeInstance -> String
forall a. Show a => a -> String
show TypeInstance
t2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" are incompatible"
    | Bool
otherwise =
      m (MergeTree InferredTypeGuess) -> m ()
forall (m :: * -> *).
CollectErrorsM m =>
m (MergeTree InferredTypeGuess) -> m ()
noInferredTypes (m (MergeTree InferredTypeGuess) -> m ())
-> m (MergeTree InferredTypeGuess) -> m ()
forall a b. (a -> b) -> a -> b
$ r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
Covariant
                        (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> TypeInstance -> TypeInstanceOrParam
forall a b. (a -> b) -> a -> b
$ TypeInstance
t1)
                        (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance (TypeInstance -> TypeInstanceOrParam)
-> TypeInstance -> TypeInstanceOrParam
forall a b. (a -> b) -> a -> b
$ TypeInstance
t2)

mergeDefines :: (CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> [ValueDefine c] -> m [ValueDefine c]
mergeDefines :: 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]
mergeObjects 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DefinesInstance -> String
forall a. Show a => a -> String
show DefinesInstance
t2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" are incompatible"
    | Bool
otherwise = do
      r
-> Map ParamName [TypeFilter]
-> DefinesInstance
-> DefinesInstance
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> DefinesInstance
-> DefinesInstance
-> m ()
checkDefinesMatch r
r Map ParamName [TypeFilter]
f DefinesInstance
t1 DefinesInstance
t2
      () -> 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 =
  ([(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
$ ((CategoryName, a) -> (CategoryName, a) -> Bool)
-> [(CategoryName, a)] -> [[(CategoryName, a)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(CategoryName, a)
x (CategoryName, a)
y -> (CategoryName, a) -> CategoryName
forall a b. (a, b) -> a
fst (CategoryName, a)
x CategoryName -> CategoryName -> Bool
forall a. Eq a => a -> a -> Bool
== (CategoryName, a) -> CategoryName
forall a b. (a, b) -> a
fst (CategoryName, a)
y) ([(CategoryName, a)] -> [[(CategoryName, a)]])
-> [(CategoryName, a)] -> [[(CategoryName, a)]]
forall a b. (a -> b) -> a -> b
$
                               ((CategoryName, a) -> (CategoryName, a) -> Ordering)
-> [(CategoryName, a)] -> [(CategoryName, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(CategoryName, a)
x (CategoryName, a)
y -> (CategoryName, a) -> CategoryName
forall a b. (a, b) -> a
fst (CategoryName, a)
x CategoryName -> CategoryName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (CategoryName, a) -> CategoryName
forall a b. (a, b) -> a
fst (CategoryName, a)
y) [(CategoryName, a)]
ns where
    checkCount :: [(CategoryName, a)] -> m ()
checkCount xa :: [(CategoryName, a)]
xa@((CategoryName, a)
x:(CategoryName, a)
_:[(CategoryName, a)]
_) =
      String -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Category " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show ((CategoryName, a) -> CategoryName
forall a b. (a, b) -> a
fst (CategoryName, a)
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" occurs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([(CategoryName, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(CategoryName, a)]
xa) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
" times in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatFullContextBrace [c]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :\n---\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n---\n" (((CategoryName, a) -> String) -> [(CategoryName, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (a -> String
forall a. Show a => a -> String
show (a -> String)
-> ((CategoryName, a) -> a) -> (CategoryName, a) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CategoryName, a) -> a
forall a b. (a, b) -> b
snd) [(CategoryName, a)]
xa)
    checkCount [(CategoryName, a)]
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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 [ValueParam c]
ps [ValueRefine c]
rs [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
-> [ValueParam c]
-> [ValueRefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ValueRefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueInterface [c]
c Namespace
ns CategoryName
n [ValueParam c]
ps [ValueRefine c]
rs' [ParamFilter c]
vs [ScopedFunction c]
fs
    preMergeSingle CategoryMap c
tm (ValueConcrete [c]
c Namespace
ns CategoryName
n [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
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueConcrete [c]
c Namespace
ns CategoryName
n [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 -> String -> String
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 -> String -> String
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 [ValueParam c]
ps [ValueRefine c]
rs [ParamFilter c]
vs [ScopedFunction c]
fs) = do
      Map ParamName [TypeFilter]
fm <- AnyCategory c -> m (Map ParamName [TypeFilter])
forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Map ParamName [TypeFilter])
getCategoryFilterMap AnyCategory c
t
      let pm :: Map ParamName GeneralInstance
pm = AnyCategory c -> Map ParamName GeneralInstance
forall c. AnyCategory c -> Map ParamName GeneralInstance
getCategoryParamMap AnyCategory c
t
      [ValueRefine c]
rs' <- ([[ValueRefine c]] -> [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall (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''
      -- Only merge from direct parents.
      [ScopedFunction c]
fs' <- r
-> CategoryMap c
-> Map ParamName GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r
-> CategoryMap c
-> Map ParamName GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions r
r CategoryMap c
tm Map ParamName GeneralInstance
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
-> [ValueParam c]
-> [ValueRefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ValueRefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueInterface [c]
c Namespace
ns CategoryName
n [ValueParam c]
ps [ValueRefine c]
rs'' [ParamFilter c]
vs [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 [ValueParam c]
ps [ValueRefine c]
rs [ValueDefine c]
ds [ParamFilter c]
vs [ScopedFunction c]
fs) = do
      Map ParamName [TypeFilter]
fm <- AnyCategory c -> m (Map ParamName [TypeFilter])
forall (m :: * -> *) c.
CollectErrorsM m =>
AnyCategory c -> m (Map ParamName [TypeFilter])
getCategoryFilterMap AnyCategory c
t
      let pm :: Map ParamName GeneralInstance
pm = AnyCategory c -> Map ParamName GeneralInstance
forall c. AnyCategory c -> Map ParamName GeneralInstance
getCategoryParamMap AnyCategory c
t
      [ValueRefine c]
rs' <- ([[ValueRefine c]] -> [ValueRefine c])
-> m [[ValueRefine c]] -> m [ValueRefine c]
forall (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'
      -- Only merge from direct parents.
      [ScopedFunction c]
fs' <- r
-> CategoryMap c
-> Map ParamName GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
forall c (m :: * -> *) r.
(Show c, CollectErrorsM m, TypeResolver r) =>
r
-> CategoryMap c
-> Map ParamName GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions r
r CategoryMap c
tm Map ParamName GeneralInstance
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueDefine c]
ds [ScopedFunction c]
fs
      AnyCategory c -> m (AnyCategory c)
forall (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
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
forall c.
[c]
-> Namespace
-> CategoryName
-> [ValueParam c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ParamFilter c]
-> [ScopedFunction c]
-> AnyCategory c
ValueConcrete [c]
c Namespace
ns CategoryName
n [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 GeneralInstance
pa <- CategoryMap c
-> [c] -> TypeInstance -> m (Map ParamName GeneralInstance)
forall (m :: * -> *) c.
(Show c, CollectErrorsM m) =>
CategoryMap c
-> [c] -> TypeInstance -> m (Map ParamName GeneralInstance)
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 GeneralInstance
-> ValueRefine c
-> m (ValueRefine c)
forall (m :: * -> *) c.
CollectErrorsM m =>
[c]
-> Map ParamName GeneralInstance
-> ValueRefine c
-> m (ValueRefine c)
subAll [c]
c Map ParamName GeneralInstance
pa) [ValueRefine c]
refines
    subAll :: [c]
-> Map ParamName GeneralInstance
-> ValueRefine c
-> m (ValueRefine c)
subAll [c]
c Map ParamName GeneralInstance
pa (ValueRefine [c]
c1 TypeInstance
t1) = do
      TypeInstance
t2 <- (ParamName -> m GeneralInstance) -> TypeInstance -> m TypeInstance
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance) -> TypeInstance -> m TypeInstance
uncheckedSubSingle (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
pa) TypeInstance
t1
      ValueRefine c -> m (ValueRefine c)
forall (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 GeneralInstance)
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, GeneralInstance)]
paired <- (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
ns) InstanceParams
ps
      Map ParamName GeneralInstance -> m (Map ParamName GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ParamName GeneralInstance
 -> m (Map ParamName GeneralInstance))
-> Map ParamName GeneralInstance
-> m (Map ParamName GeneralInstance)
forall a b. (a -> b) -> a -> b
$ ParamName
-> GeneralInstance
-> Map ParamName GeneralInstance
-> Map ParamName GeneralInstance
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
ParamSelf GeneralInstance
selfType (Map ParamName GeneralInstance -> Map ParamName GeneralInstance)
-> Map ParamName GeneralInstance -> Map ParamName GeneralInstance
forall a b. (a -> b) -> a -> b
$ [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ParamName, GeneralInstance)]
paired
    checkMerged :: r
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueRefine c]
-> m ()
checkMerged r
r Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueRefine c]
rs2 = do
      let rm :: Map CategoryName (ValueRefine c)
rm = [(CategoryName, ValueRefine c)] -> Map CategoryName (ValueRefine c)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CategoryName, ValueRefine c)]
 -> Map CategoryName (ValueRefine c))
-> [(CategoryName, ValueRefine c)]
-> Map CategoryName (ValueRefine c)
forall a b. (a -> b) -> a -> b
$ (ValueRefine c -> (CategoryName, ValueRefine c))
-> [ValueRefine c] -> [(CategoryName, ValueRefine c)]
forall a b. (a -> b) -> [a] -> [b]
map (\ValueRefine c
t -> (TypeInstance -> CategoryName
tiName (TypeInstance -> CategoryName) -> TypeInstance -> CategoryName
forall a b. (a -> b) -> a -> b
$ ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
t,ValueRefine c
t)) [ValueRefine c]
rs
      (ValueRefine c -> m ()) -> [ValueRefine c] -> m ()
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (\ValueRefine c
t -> r
-> Map ParamName [TypeFilter]
-> Maybe (ValueRefine c)
-> ValueRefine c
-> m ()
forall (m :: * -> *) r c c.
(CollectErrorsM m, TypeResolver r, Show c, Show c) =>
r
-> Map ParamName [TypeFilter]
-> Maybe (ValueRefine c)
-> ValueRefine c
-> m ()
checkConvert r
r Map ParamName [TypeFilter]
fm (TypeInstance -> CategoryName
tiName (ValueRefine c -> TypeInstance
forall c. ValueRefine c -> TypeInstance
vrType ValueRefine c
t) CategoryName
-> Map CategoryName (ValueRefine c) -> Maybe (ValueRefine c)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName (ValueRefine c)
rm) ValueRefine c
t) [ValueRefine c]
rs2
    checkConvert :: r
-> Map ParamName [TypeFilter]
-> Maybe (ValueRefine c)
-> ValueRefine c
-> m ()
checkConvert r
r Map ParamName [TypeFilter]
fm (Just ta1 :: ValueRefine c
ta1@(ValueRefine [c]
_ TypeInstance
t1)) ta2 :: ValueRefine c
ta2@(ValueRefine [c]
_ TypeInstance
t2) = do
      m (MergeTree InferredTypeGuess) -> m ()
forall (m :: * -> *).
CollectErrorsM m =>
m (MergeTree InferredTypeGuess) -> m ()
noInferredTypes (m (MergeTree InferredTypeGuess) -> m ())
-> m (MergeTree InferredTypeGuess) -> m ()
forall a b. (a -> b) -> a -> b
$ r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
fm Variance
Covariant
                        (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t1)
                        (TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ TypeInstance -> TypeInstanceOrParam
JustTypeInstance TypeInstance
t2) m (MergeTree InferredTypeGuess)
-> String -> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!!
                          String
"Cannot refine " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueRefine c -> String
forall a. Show a => a -> String
show ValueRefine c
ta1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from inherited " String -> String -> String
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 ()

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 GeneralInstance
-> Map ParamName [TypeFilter]
-> [ValueRefine c]
-> [ValueDefine c]
-> [ScopedFunction c]
-> m [ScopedFunction c]
mergeFunctions r
r CategoryMap c
tm Map ParamName GeneralInstance
pm Map ParamName [TypeFilter]
fm [ValueRefine c]
rs [ValueDefine c]
ds [ScopedFunction c]
fs = do
  [ScopedFunction c]
inheritValue <- ([[ScopedFunction c]] -> [ScopedFunction c])
-> m [[ScopedFunction c]] -> m [ScopedFunction c]
forall (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 (r
-> Map ParamName [TypeFilter]
-> Map FunctionName [ScopedFunction c]
-> Map FunctionName [ScopedFunction c]
-> FunctionName
-> m (ScopedFunction c)
mergeByName r
r Map ParamName [TypeFilter]
fm 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, GeneralInstance)]
paired <- (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
ps) InstanceParams
ts2
      let assigned :: Map ParamName GeneralInstance
assigned = [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall a b. (a -> b) -> a -> b
$ (ParamName
ParamSelf,GeneralInstance
selfType)(ParamName, GeneralInstance)
-> [(ParamName, GeneralInstance)] -> [(ParamName, GeneralInstance)]
forall a. a -> [a] -> [a]
:[(ParamName, GeneralInstance)]
paired
      (ScopedFunction c -> m (ScopedFunction c))
-> [ScopedFunction c] -> m [ScopedFunction c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName GeneralInstance
assigned) [ScopedFunction c]
fs2
    getDefinesFuncs :: 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, GeneralInstance)]
paired <- (ParamName -> GeneralInstance -> m (ParamName, GeneralInstance))
-> Positional ParamName
-> InstanceParams
-> m [(ParamName, GeneralInstance)]
forall a b (m :: * -> *) c.
(Show a, Show b, CollectErrorsM m) =>
(a -> b -> m c) -> Positional a -> Positional b -> m [c]
processPairs ParamName -> GeneralInstance -> m (ParamName, GeneralInstance)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
alwaysPair ([ParamName] -> Positional ParamName
forall a. [a] -> Positional a
Positional [ParamName]
ps) InstanceParams
ts2
      let assigned :: Map ParamName GeneralInstance
assigned = [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall a b. (a -> b) -> a -> b
$ (ParamName
ParamSelf,GeneralInstance
selfType)(ParamName, GeneralInstance)
-> [(ParamName, GeneralInstance)] -> [(ParamName, GeneralInstance)]
forall a. a -> [a] -> [a]
:[(ParamName, GeneralInstance)]
paired
      (ScopedFunction c -> m (ScopedFunction c))
-> [ScopedFunction c] -> m [ScopedFunction c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName GeneralInstance
assigned) [ScopedFunction c]
fs2
    mergeByName :: r
-> Map ParamName [TypeFilter]
-> Map FunctionName [ScopedFunction c]
-> Map FunctionName [ScopedFunction c]
-> FunctionName
-> m (ScopedFunction c)
mergeByName r
r2 Map ParamName [TypeFilter]
fm2 Map FunctionName [ScopedFunction c]
im Map FunctionName [ScopedFunction c]
em FunctionName
n =
      r
-> Map ParamName [TypeFilter]
-> FunctionName
-> Maybe [ScopedFunction c]
-> Maybe [ScopedFunction c]
-> m (ScopedFunction c)
tryMerge r
r2 Map ParamName [TypeFilter]
fm2 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 :: r
-> Map ParamName [TypeFilter]
-> FunctionName
-> Maybe [ScopedFunction c]
-> Maybe [ScopedFunction c]
-> m (ScopedFunction c)
tryMerge r
_ Map ParamName [TypeFilter]
_ 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is inherited " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" times:\n---\n" String -> String -> String
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 r
r2 Map ParamName [TypeFilter]
fm2 FunctionName
n Maybe [ScopedFunction c]
Nothing Maybe [ScopedFunction c]
es = r
-> Map ParamName [TypeFilter]
-> FunctionName
-> Maybe [ScopedFunction c]
-> Maybe [ScopedFunction c]
-> m (ScopedFunction c)
tryMerge r
r2 Map ParamName [TypeFilter]
fm2 FunctionName
n ([ScopedFunction c] -> Maybe [ScopedFunction c]
forall a. a -> Maybe a
Just []) Maybe [ScopedFunction c]
es
    -- Explicit override, possibly inherited.
    tryMerge r
r2 Map ParamName [TypeFilter]
fm2 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is declared " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" times:\n---\n" String -> String -> String
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_ (r
-> Map ParamName [TypeFilter]
-> ScopedFunction c
-> ScopedFunction c
-> m ()
checkMerge r
r2 Map ParamName [TypeFilter]
fm2 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 :: r
-> Map ParamName [TypeFilter]
-> ScopedFunction c
-> ScopedFunction c
-> m ()
checkMerge r
r3 Map ParamName [TypeFilter]
fm3 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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in function merge:\n---\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  ->\n" String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  ->\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
f1 String -> String -> String
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
                r
-> Map ParamName [TypeFilter]
-> Map ParamName GeneralInstance
-> FunctionType
-> FunctionType
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Map ParamName GeneralInstance
-> FunctionType
-> FunctionType
-> m ()
checkFunctionConvert r
r3 Map ParamName [TypeFilter]
fm3 Map ParamName GeneralInstance
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CategoryName -> String
forall a. Show a => a -> String
show CategoryName
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"*/ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [c] -> String
forall a. Show a => [a] -> String
formatContext [c]
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamFilter c -> String
forall a. Show a => ParamFilter a -> String
formatValue ParamFilter c
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") [ParamFilter c]
fa) String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
indent String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
    formatContext :: [a] -> String
formatContext [a]
cs2 = String
"/*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => [a] -> String
formatFullContext [a]
cs2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"*/"
    formatValue :: ParamFilter a -> String
formatValue ParamFilter a
v = String
"  " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++
                    String
" " String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show ([a] -> [String]) -> [a] -> [String]
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
ms2) String -> String -> String
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 -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
" is not defined for function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionName -> String
forall a. Show a => a -> String
show FunctionName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       [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 GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction = Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction (Map ParamName GeneralInstance
 -> ScopedFunction c -> m (ScopedFunction c))
-> (Map ParamName GeneralInstance -> Map ParamName GeneralInstance)
-> Map ParamName GeneralInstance
-> ScopedFunction c
-> m (ScopedFunction c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GeneralInstance -> GeneralInstance)
-> Map ParamName GeneralInstance -> Map ParamName GeneralInstance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GeneralInstance -> GeneralInstance
fixTypeParams

unfixedSubFunction :: (Show c, CollectErrorsM m) =>
  ParamValues -> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction :: Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
unfixedSubFunction Map ParamName GeneralInstance
pa ff :: ScopedFunction c
ff@(ScopedFunction [c]
c FunctionName
n CategoryName
t SymbolScope
s Positional (PassedValue c)
as Positional (PassedValue c)
rs Positional (ValueParam c)
ps [ParamFilter c]
fa [ScopedFunction c]
ms) =
  String
"In function:\n---\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
ff String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n---\n" String -> m (ScopedFunction c) -> m (ScopedFunction c)
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
    let unresolved :: Map ParamName GeneralInstance
unresolved = [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall a b. (a -> b) -> a -> b
$ (ParamName -> (ParamName, GeneralInstance))
-> [ParamName] -> [(ParamName, GeneralInstance)]
forall a b. (a -> b) -> [a] -> [b]
map (\ParamName
n2 -> (ParamName
n2,TypeInstanceOrParam -> GeneralInstance
forall a. (Eq a, Ord a) => a -> GeneralType a
singleType (TypeInstanceOrParam -> GeneralInstance)
-> TypeInstanceOrParam -> GeneralInstance
forall a b. (a -> b) -> a -> b
$ Bool -> ParamName -> TypeInstanceOrParam
JustParamName Bool
False ParamName
n2)) ([ParamName] -> [(ParamName, GeneralInstance)])
-> [ParamName] -> [(ParamName, GeneralInstance)]
forall a b. (a -> b) -> a -> b
$ (ValueParam c -> ParamName) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map ValueParam c -> ParamName
forall c. ValueParam c -> ParamName
vpParam ([ValueParam c] -> [ParamName]) -> [ValueParam c] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ Positional (ValueParam c) -> [ValueParam c]
forall a. Positional a -> [a]
pValues Positional (ValueParam c)
ps
    let pa' :: Map ParamName GeneralInstance
pa' = Map ParamName GeneralInstance
pa Map ParamName GeneralInstance
-> Map ParamName GeneralInstance -> Map ParamName GeneralInstance
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map ParamName GeneralInstance
unresolved
    Positional (PassedValue c)
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 GeneralInstance -> PassedValue c -> m (PassedValue c)
forall (m :: * -> *) c.
CollectErrorsM m =>
Map ParamName GeneralInstance -> PassedValue c -> m (PassedValue c)
subPassed Map ParamName GeneralInstance
pa') ([PassedValue c] -> m [PassedValue c])
-> [PassedValue c] -> m [PassedValue c]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c) -> [PassedValue c]
forall a. Positional a -> [a]
pValues Positional (PassedValue c)
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 GeneralInstance -> PassedValue c -> m (PassedValue c)
forall (m :: * -> *) c.
CollectErrorsM m =>
Map ParamName GeneralInstance -> PassedValue c -> m (PassedValue c)
subPassed Map ParamName GeneralInstance
pa') ([PassedValue c] -> m [PassedValue c])
-> [PassedValue c] -> m [PassedValue c]
forall a b. (a -> b) -> a -> b
$ Positional (PassedValue c) -> [PassedValue c]
forall a. Positional a -> [a]
pValues Positional (PassedValue c)
rs
    [ParamFilter c]
fa' <- (ParamFilter c -> m (ParamFilter c))
-> [ParamFilter c] -> m [ParamFilter c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance -> ParamFilter c -> m (ParamFilter c)
forall (m :: * -> *) c.
CollectErrorsM m =>
Map ParamName GeneralInstance -> ParamFilter c -> m (ParamFilter c)
subFilter Map ParamName GeneralInstance
pa') [ParamFilter c]
fa
    [ScopedFunction c]
ms' <- (ScopedFunction c -> m (ScopedFunction c))
-> [ScopedFunction c] -> m [ScopedFunction c]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
Map ParamName GeneralInstance
-> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction Map ParamName GeneralInstance
pa) [ScopedFunction c]
ms
    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 GeneralInstance -> PassedValue c -> m (PassedValue c)
subPassed Map ParamName GeneralInstance
pa2 (PassedValue [c]
c2 ValueType
t2) = do
        ValueType
t' <- (ParamName -> m GeneralInstance) -> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance) -> ValueType -> m ValueType
uncheckedSubValueType (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
pa2) ValueType
t2
        PassedValue c -> m (PassedValue c)
forall (m :: * -> *) a. Monad m => a -> m a
return (PassedValue c -> m (PassedValue c))
-> PassedValue c -> m (PassedValue c)
forall a b. (a -> b) -> a -> b
$ [c] -> ValueType -> PassedValue c
forall c. [c] -> ValueType -> PassedValue c
PassedValue [c]
c2 ValueType
t'
      subFilter :: Map ParamName GeneralInstance -> ParamFilter c -> m (ParamFilter c)
subFilter Map ParamName GeneralInstance
pa2 (ParamFilter [c]
c2 ParamName
n2 TypeFilter
f) = do
        TypeFilter
f' <- (ParamName -> m GeneralInstance) -> TypeFilter -> m TypeFilter
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance) -> TypeFilter -> m TypeFilter
uncheckedSubFilter (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
pa2) TypeFilter
f
        ParamFilter c -> m (ParamFilter c)
forall (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 :: GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction GeneralInstance
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedFunction c -> String
forall a. Show a => a -> String
show ScopedFunction c
ff String -> String -> String
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 (GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
replaceSelfFunction GeneralInstance
self) [ScopedFunction c]
ms
    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' <- GeneralInstance -> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> ValueType -> m ValueType
replaceSelfValueType GeneralInstance
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' <- GeneralInstance -> TypeFilter -> m TypeFilter
forall (m :: * -> *).
CollectErrorsM m =>
GeneralInstance -> TypeFilter -> m TypeFilter
replaceSelfFilter GeneralInstance
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 a =
  PatternMatch {
    PatternMatch a -> Variance
pmVariance :: Variance,
    PatternMatch a -> a
pmData :: a,
    PatternMatch a -> a
pmPattern :: a
  }

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

inferParamTypes :: (CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> ParamValues -> [PatternMatch ValueType] ->
  m (MergeTree InferredTypeGuess)
inferParamTypes :: r
-> Map ParamName [TypeFilter]
-> Map ParamName GeneralInstance
-> [PatternMatch ValueType]
-> m (MergeTree InferredTypeGuess)
inferParamTypes r
r Map ParamName [TypeFilter]
f Map ParamName GeneralInstance
ps [PatternMatch ValueType]
ts = do
  [PatternMatch ValueType]
ts2 <- (PatternMatch ValueType -> m (PatternMatch ValueType))
-> [PatternMatch ValueType] -> m [PatternMatch ValueType]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM PatternMatch ValueType -> m (PatternMatch ValueType)
subAll [PatternMatch ValueType]
ts
  ([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))
-> m [MergeTree InferredTypeGuess]
-> m (MergeTree InferredTypeGuess)
forall a b. (a -> b) -> a -> b
$ (PatternMatch ValueType -> m (MergeTree InferredTypeGuess))
-> [PatternMatch ValueType] -> m [MergeTree InferredTypeGuess]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM PatternMatch ValueType -> m (MergeTree InferredTypeGuess)
matchPattern [PatternMatch ValueType]
ts2 where
    subAll :: PatternMatch ValueType -> m (PatternMatch ValueType)
subAll (PatternMatch Variance
v ValueType
t1 ValueType
t2) = do
      ValueType
t2' <- (ParamName -> m GeneralInstance) -> ValueType -> m ValueType
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance) -> ValueType -> m ValueType
uncheckedSubValueType (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
ps) ValueType
t2
      PatternMatch ValueType -> m (PatternMatch ValueType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Variance -> ValueType -> ValueType -> PatternMatch ValueType
forall a. Variance -> a -> a -> PatternMatch a
PatternMatch Variance
v ValueType
t1 ValueType
t2')
    matchPattern :: PatternMatch ValueType -> m (MergeTree InferredTypeGuess)
matchPattern (PatternMatch Variance
v ValueType
t1 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

guessesAsParams :: [InferredTypeGuess] -> ParamValues
guessesAsParams :: [InferredTypeGuess] -> Map ParamName GeneralInstance
guessesAsParams [InferredTypeGuess]
gs = [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance)
-> [(ParamName, GeneralInstance)] -> Map ParamName GeneralInstance
forall a b. (a -> b) -> a -> b
$ [ParamName] -> [GeneralInstance] -> [(ParamName, GeneralInstance)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((InferredTypeGuess -> ParamName)
-> [InferredTypeGuess] -> [ParamName]
forall a b. (a -> b) -> [a] -> [b]
map InferredTypeGuess -> ParamName
itgParam [InferredTypeGuess]
gs) ((InferredTypeGuess -> GeneralInstance)
-> [InferredTypeGuess] -> [GeneralInstance]
forall a b. (a -> b) -> [a] -> [b]
map InferredTypeGuess -> GeneralInstance
itgGuess [InferredTypeGuess]
gs)

data GuessRange a =
  GuessRange {
    GuessRange a -> a
grLower :: a,
    GuessRange a -> a
grUpper :: 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 (Bounded a, Eq a, Show a) => Show (GuessRange a) where
  show :: GuessRange a -> String
show (GuessRange a
lo a
hi)
    | a
lo a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& a
hi a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
maxBound = String
"Literally anything is possible"
    | a
lo a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
minBound = String
"Something at or below " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
hi
    | a
hi a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
maxBound = String
"Something at or above " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
lo
    | Bool
otherwise = String
"Something between " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
lo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
hi

data GuessUnion a =
  GuessUnion {
    GuessUnion a -> [GuessRange a]
guGuesses :: [GuessRange a]
  }

mergeInferredTypes :: (CollectErrorsM m, TypeResolver r) =>
  r -> ParamFilters -> ParamFilters -> ParamValues -> MergeTree InferredTypeGuess ->
  m [InferredTypeGuess]
mergeInferredTypes :: r
-> Map ParamName [TypeFilter]
-> Map ParamName [TypeFilter]
-> Map ParamName GeneralInstance
-> MergeTree InferredTypeGuess
-> m [InferredTypeGuess]
mergeInferredTypes r
r Map ParamName [TypeFilter]
f Map ParamName [TypeFilter]
ff Map ParamName GeneralInstance
ps MergeTree InferredTypeGuess
gs0 = do
  let gs0' :: Map ParamName (MergeTree InferredTypeGuess)
gs0' = MergeTree InferredTypeGuess
-> Map ParamName (MergeTree InferredTypeGuess)
mapTypeGuesses MergeTree InferredTypeGuess
gs0
  ((ParamName, MergeTree InferredTypeGuess) -> m InferredTypeGuess)
-> [(ParamName, MergeTree InferredTypeGuess)]
-> m [InferredTypeGuess]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (ParamName, MergeTree InferredTypeGuess) -> m InferredTypeGuess
reduce ([(ParamName, MergeTree InferredTypeGuess)]
 -> m [InferredTypeGuess])
-> [(ParamName, MergeTree InferredTypeGuess)]
-> m [InferredTypeGuess]
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' where
    reduce :: (ParamName, MergeTree InferredTypeGuess) -> m InferredTypeGuess
reduce (ParamName
i,MergeTree InferredTypeGuess
is) = do
      (GuessUnion [GuessRange GeneralInstance]
gs) <- ([m (GuessUnion GeneralInstance)]
 -> m (GuessUnion GeneralInstance))
-> ([m (GuessUnion GeneralInstance)]
    -> m (GuessUnion GeneralInstance))
-> (T (MergeTree InferredTypeGuess)
    -> m (GuessUnion GeneralInstance))
-> MergeTree InferredTypeGuess
-> m (GuessUnion GeneralInstance)
forall a b.
PreserveMerge a =>
([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b
reduceMergeTree [m (GuessUnion GeneralInstance)] -> m (GuessUnion GeneralInstance)
forall a. [m (GuessUnion a)] -> m (GuessUnion a)
anyOp [m (GuessUnion GeneralInstance)] -> m (GuessUnion GeneralInstance)
allOp T (MergeTree InferredTypeGuess) -> m (GuessUnion GeneralInstance)
forall (m :: * -> *).
Monad m =>
InferredTypeGuess -> m (GuessUnion GeneralInstance)
leafOp MergeTree InferredTypeGuess
is m (GuessUnion GeneralInstance)
-> (GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance))
-> m (GuessUnion GeneralInstance)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParamName
-> GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
filterGuesses ParamName
i
      GeneralInstance
t <- ParamName -> [GuessRange GeneralInstance] -> m GeneralInstance
takeBest ParamName
i [GuessRange GeneralInstance]
gs
      InferredTypeGuess -> m InferredTypeGuess
forall (m :: * -> *) a. Monad m => a -> m a
return (ParamName -> GeneralInstance -> Variance -> InferredTypeGuess
InferredTypeGuess ParamName
i GeneralInstance
t Variance
Invariant)
    leafOp :: InferredTypeGuess -> m (GuessUnion GeneralInstance)
leafOp (InferredTypeGuess ParamName
_ GeneralInstance
t Variance
Covariant)     = GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance))
-> GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall a b. (a -> b) -> a -> b
$ [GuessRange GeneralInstance] -> GuessUnion GeneralInstance
forall a. [GuessRange a] -> GuessUnion a
GuessUnion [GeneralInstance -> GeneralInstance -> GuessRange GeneralInstance
forall a. a -> a -> GuessRange a
GuessRange GeneralInstance
t GeneralInstance
forall a. Bounded a => a
maxBound]
    leafOp (InferredTypeGuess ParamName
_ GeneralInstance
t Variance
Contravariant) = GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance))
-> GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall a b. (a -> b) -> a -> b
$ [GuessRange GeneralInstance] -> GuessUnion GeneralInstance
forall a. [GuessRange a] -> GuessUnion a
GuessUnion [GeneralInstance -> GeneralInstance -> GuessRange GeneralInstance
forall a. a -> a -> GuessRange a
GuessRange GeneralInstance
forall a. Bounded a => a
minBound GeneralInstance
t]
    leafOp (InferredTypeGuess ParamName
_ GeneralInstance
t Variance
_)             = GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance))
-> GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall a b. (a -> b) -> a -> b
$ [GuessRange GeneralInstance] -> GuessUnion GeneralInstance
forall a. [GuessRange a] -> GuessUnion a
GuessUnion [GeneralInstance -> GeneralInstance -> GuessRange GeneralInstance
forall a. a -> a -> GuessRange a
GuessRange GeneralInstance
t GeneralInstance
t]
    anyOp :: [m (GuessUnion a)] -> m (GuessUnion a)
anyOp = ([GuessUnion a] -> GuessUnion a)
-> m [GuessUnion a] -> m (GuessUnion a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([GuessRange a] -> GuessUnion a
forall a. [GuessRange a] -> GuessUnion a
GuessUnion ([GuessRange a] -> GuessUnion a)
-> ([GuessUnion a] -> [GuessRange a])
-> [GuessUnion a]
-> GuessUnion a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[GuessRange a]] -> [GuessRange a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[GuessRange a]] -> [GuessRange a])
-> ([GuessUnion a] -> [[GuessRange a]])
-> [GuessUnion a]
-> [GuessRange a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GuessUnion a -> [GuessRange a])
-> [GuessUnion a] -> [[GuessRange a]]
forall a b. (a -> b) -> [a] -> [b]
map GuessUnion a -> [GuessRange a]
forall a. GuessUnion a -> [GuessRange a]
guGuesses) (m [GuessUnion a] -> m (GuessUnion a))
-> ([m (GuessUnion a)] -> m [GuessUnion a])
-> [m (GuessUnion a)]
-> m (GuessUnion a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [m (GuessUnion a)] -> m [GuessUnion a]
forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAllM
    allOp :: [m (GuessUnion GeneralInstance)] -> m (GuessUnion GeneralInstance)
allOp = [m (GuessUnion GeneralInstance)] -> m [GuessUnion GeneralInstance]
forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAllM ([m (GuessUnion GeneralInstance)]
 -> m [GuessUnion GeneralInstance])
-> ([GuessUnion GeneralInstance] -> m (GuessUnion GeneralInstance))
-> [m (GuessUnion GeneralInstance)]
-> m (GuessUnion GeneralInstance)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [GuessUnion GeneralInstance] -> m (GuessUnion GeneralInstance)
prodAll
    prodAll :: [GuessUnion GeneralInstance] -> m (GuessUnion GeneralInstance)
prodAll [] = GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance))
-> GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall a b. (a -> b) -> a -> b
$ [GuessRange GeneralInstance] -> GuessUnion GeneralInstance
forall a. [GuessRange a] -> GuessUnion a
GuessUnion []
    prodAll [GuessUnion [GuessRange GeneralInstance]
gs] = GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance))
-> GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
forall a b. (a -> b) -> a -> b
$ [GuessRange GeneralInstance] -> GuessUnion GeneralInstance
forall a. [GuessRange a] -> GuessUnion a
GuessUnion ([GuessRange GeneralInstance] -> GuessUnion GeneralInstance)
-> [GuessRange GeneralInstance] -> GuessUnion GeneralInstance
forall a b. (a -> b) -> a -> b
$ [GuessRange GeneralInstance] -> [GuessRange GeneralInstance]
forall a. Eq a => [a] -> [a]
nub [GuessRange GeneralInstance]
gs
    prodAll ((GuessUnion [GuessRange GeneralInstance]
g1):(GuessUnion [GuessRange GeneralInstance]
g2):[GuessUnion GeneralInstance]
gs) = do
      [GuessRange GeneralInstance]
g <- [GuessRange GeneralInstance]
g1 [GuessRange GeneralInstance]
-> [GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
`guessProd` [GuessRange GeneralInstance]
g2
      [GuessUnion GeneralInstance] -> m (GuessUnion GeneralInstance)
prodAll ([GuessRange GeneralInstance] -> GuessUnion GeneralInstance
forall a. [GuessRange a] -> GuessUnion a
GuessUnion [GuessRange GeneralInstance]
gGuessUnion GeneralInstance
-> [GuessUnion GeneralInstance] -> [GuessUnion GeneralInstance]
forall a. a -> [a] -> [a]
:[GuessUnion GeneralInstance]
gs)
    guessProd :: [GuessRange GeneralInstance]
-> [GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
guessProd [GuessRange GeneralInstance]
xs [GuessRange GeneralInstance]
ys = ([[GuessRange GeneralInstance]] -> [GuessRange GeneralInstance])
-> m [[GuessRange GeneralInstance]]
-> m [GuessRange GeneralInstance]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[GuessRange GeneralInstance]] -> [GuessRange GeneralInstance]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[GuessRange GeneralInstance]]
 -> m [GuessRange GeneralInstance])
-> m [[GuessRange GeneralInstance]]
-> m [GuessRange GeneralInstance]
forall a b. (a -> b) -> a -> b
$ [m [GuessRange GeneralInstance]]
-> m [[GuessRange GeneralInstance]]
forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAllM ([m [GuessRange GeneralInstance]]
 -> m [[GuessRange GeneralInstance]])
-> [m [GuessRange GeneralInstance]]
-> m [[GuessRange GeneralInstance]]
forall a b. (a -> b) -> a -> b
$ do
      GuessRange GeneralInstance
x <- [GuessRange GeneralInstance] -> [GuessRange GeneralInstance]
forall a. Eq a => [a] -> [a]
nub [GuessRange GeneralInstance]
xs
      GuessRange GeneralInstance
y <- [GuessRange GeneralInstance] -> [GuessRange GeneralInstance]
forall a. Eq a => [a] -> [a]
nub [GuessRange GeneralInstance]
ys
      [GuessRange GeneralInstance
x GuessRange GeneralInstance
-> GuessRange GeneralInstance -> m [GuessRange GeneralInstance]
`guessIntersect` GuessRange GeneralInstance
y]
    guessIntersect :: GuessRange GeneralInstance
-> GuessRange GeneralInstance -> m [GuessRange GeneralInstance]
guessIntersect (GuessRange GeneralInstance
loX GeneralInstance
hiX) (GuessRange GeneralInstance
loY GeneralInstance
hiY) = do
      Bool
q1 <- GeneralInstance
loX GeneralInstance -> GeneralInstance -> m Bool
`convertsTo` GeneralInstance
hiY
      Bool
q2 <- GeneralInstance
loY GeneralInstance -> GeneralInstance -> m Bool
`convertsTo` GeneralInstance
hiX
      if Bool
q1 Bool -> Bool -> Bool
&& Bool
q2
         then do
           GeneralInstance
loZ <- Variance -> GeneralInstance -> GeneralInstance -> m GeneralInstance
tryMerge Variance
Covariant     GeneralInstance
loX GeneralInstance
loY
           GeneralInstance
hiZ <- Variance -> GeneralInstance -> GeneralInstance -> m GeneralInstance
tryMerge Variance
Contravariant GeneralInstance
hiX GeneralInstance
hiY
           [GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
forall (m :: * -> *) a. Monad m => a -> m a
return [GeneralInstance -> GeneralInstance -> GuessRange GeneralInstance
forall a. a -> a -> GuessRange a
GuessRange GeneralInstance
loZ GeneralInstance
hiZ]
         else [GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    convertsTo :: GeneralInstance -> GeneralInstance -> m Bool
convertsTo GeneralInstance
t1 GeneralInstance
t2 = m (MergeTree InferredTypeGuess) -> m Bool
forall (m :: * -> *) a. CollectErrorsM m => m a -> m Bool
isCompilerSuccessM (m (MergeTree InferredTypeGuess) -> m Bool)
-> m (MergeTree InferredTypeGuess) -> m Bool
forall a b. (a -> b) -> a -> b
$ r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
Covariant GeneralInstance
t1 GeneralInstance
t2
    tryMerge :: Variance -> GeneralInstance -> GeneralInstance -> m GeneralInstance
tryMerge Variance
v GeneralInstance
t1 GeneralInstance
t2 = [m GeneralInstance] -> m GeneralInstance
forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m a
collectFirstM [
        r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
v GeneralInstance
t1 GeneralInstance
t2 m (MergeTree InferredTypeGuess)
-> m GeneralInstance -> m GeneralInstance
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GeneralInstance -> m GeneralInstance
forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
t2,
        r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> Variance
-> GeneralInstance
-> GeneralInstance
-> m (MergeTree InferredTypeGuess)
checkGeneralMatch r
r Map ParamName [TypeFilter]
f Variance
v GeneralInstance
t2 GeneralInstance
t1 m (MergeTree InferredTypeGuess)
-> m GeneralInstance -> m GeneralInstance
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GeneralInstance -> m GeneralInstance
forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
t1,
        GeneralInstance -> m GeneralInstance
forall (m :: * -> *) a. Monad m => a -> m a
return (GeneralInstance -> m GeneralInstance)
-> GeneralInstance -> m GeneralInstance
forall a b. (a -> b) -> a -> b
$ case Variance
v of
                      Variance
Covariant     -> [GeneralInstance] -> GeneralInstance
forall a (f :: * -> *). (Mergeable a, Foldable f) => f a -> a
mergeAny [GeneralInstance
t1,GeneralInstance
t2]
                      Variance
Contravariant -> [GeneralInstance] -> GeneralInstance
forall a (f :: * -> *). (Mergeable a, Foldable f) => f a -> a
mergeAll [GeneralInstance
t1,GeneralInstance
t2]
                      Variance
_ -> GeneralInstance
forall a. HasCallStack => a
undefined
      ]
    simplifyUnion :: [GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
simplifyUnion [] = [GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    simplifyUnion (GuessRange GeneralInstance
g:[GuessRange GeneralInstance]
gs) = do
      Maybe [GuessRange GeneralInstance]
ga <- [GuessRange GeneralInstance]
-> GuessRange GeneralInstance
-> [GuessRange GeneralInstance]
-> m (Maybe [GuessRange GeneralInstance])
tryRangeUnion [] GuessRange GeneralInstance
g [GuessRange GeneralInstance]
gs
      case Maybe [GuessRange GeneralInstance]
ga of
           Just [GuessRange GeneralInstance]
gs2 -> [GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
simplifyUnion [GuessRange GeneralInstance]
gs2
           Maybe [GuessRange GeneralInstance]
Nothing -> do
             [GuessRange GeneralInstance]
gs2 <- [GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
simplifyUnion [GuessRange GeneralInstance]
gs
             [GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
forall (m :: * -> *) a. Monad m => a -> m a
return (GuessRange GeneralInstance
gGuessRange GeneralInstance
-> [GuessRange GeneralInstance] -> [GuessRange GeneralInstance]
forall a. a -> [a] -> [a]
:[GuessRange GeneralInstance]
gs2)
    -- Returns Just a new list if there was a merge, and Nothing otherwise.
    tryRangeUnion :: [GuessRange GeneralInstance]
-> GuessRange GeneralInstance
-> [GuessRange GeneralInstance]
-> m (Maybe [GuessRange GeneralInstance])
tryRangeUnion [GuessRange GeneralInstance]
ms g1 :: GuessRange GeneralInstance
g1@(GuessRange GeneralInstance
loX GeneralInstance
hiX) (g2 :: GuessRange GeneralInstance
g2@(GuessRange GeneralInstance
loY GeneralInstance
hiY):[GuessRange GeneralInstance]
gs) = do
      Bool
l1 <- GeneralInstance
loX GeneralInstance -> GeneralInstance -> m Bool
`convertsTo` GeneralInstance
loY
      Bool
l2 <- GeneralInstance
loY GeneralInstance -> GeneralInstance -> m Bool
`convertsTo` GeneralInstance
loX
      let loZ :: Maybe GeneralInstance
loZ = case (Bool
l1,Bool
l2) of
                     (Bool
True,Bool
_) -> GeneralInstance -> Maybe GeneralInstance
forall a. a -> Maybe a
Just GeneralInstance
loX
                     (Bool
_,Bool
True) -> GeneralInstance -> Maybe GeneralInstance
forall a. a -> Maybe a
Just GeneralInstance
loY
                     (Bool, Bool)
_ -> Maybe GeneralInstance
forall a. Maybe a
Nothing
      Bool
h1 <- GeneralInstance
hiX GeneralInstance -> GeneralInstance -> m Bool
`convertsTo` GeneralInstance
hiY
      Bool
h2 <- GeneralInstance
hiY GeneralInstance -> GeneralInstance -> m Bool
`convertsTo` GeneralInstance
hiX
      let hiZ :: Maybe GeneralInstance
hiZ = case (Bool
h1,Bool
h2) of
                     (Bool
True,Bool
_) -> GeneralInstance -> Maybe GeneralInstance
forall a. a -> Maybe a
Just GeneralInstance
hiY
                     (Bool
_,Bool
True) -> GeneralInstance -> Maybe GeneralInstance
forall a. a -> Maybe a
Just GeneralInstance
hiX
                     (Bool, Bool)
_ -> Maybe GeneralInstance
forall a. Maybe a
Nothing
      case (Maybe GeneralInstance
loZ,Maybe GeneralInstance
hiZ) of
           (Just GeneralInstance
lo,Just GeneralInstance
hi) -> Maybe [GuessRange GeneralInstance]
-> m (Maybe [GuessRange GeneralInstance])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [GuessRange GeneralInstance]
 -> m (Maybe [GuessRange GeneralInstance]))
-> Maybe [GuessRange GeneralInstance]
-> m (Maybe [GuessRange GeneralInstance])
forall a b. (a -> b) -> a -> b
$ [GuessRange GeneralInstance] -> Maybe [GuessRange GeneralInstance]
forall a. a -> Maybe a
Just ([GuessRange GeneralInstance]
 -> Maybe [GuessRange GeneralInstance])
-> [GuessRange GeneralInstance]
-> Maybe [GuessRange GeneralInstance]
forall a b. (a -> b) -> a -> b
$ [GuessRange GeneralInstance]
ms [GuessRange GeneralInstance]
-> [GuessRange GeneralInstance] -> [GuessRange GeneralInstance]
forall a. [a] -> [a] -> [a]
++ [GeneralInstance -> GeneralInstance -> GuessRange GeneralInstance
forall a. a -> a -> GuessRange a
GuessRange GeneralInstance
lo GeneralInstance
hi] [GuessRange GeneralInstance]
-> [GuessRange GeneralInstance] -> [GuessRange GeneralInstance]
forall a. [a] -> [a] -> [a]
++ [GuessRange GeneralInstance]
gs
           (Maybe GeneralInstance, Maybe GeneralInstance)
_                 -> [GuessRange GeneralInstance]
-> GuessRange GeneralInstance
-> [GuessRange GeneralInstance]
-> m (Maybe [GuessRange GeneralInstance])
tryRangeUnion ([GuessRange GeneralInstance]
ms [GuessRange GeneralInstance]
-> [GuessRange GeneralInstance] -> [GuessRange GeneralInstance]
forall a. [a] -> [a] -> [a]
++ [GuessRange GeneralInstance
g2]) GuessRange GeneralInstance
g1 [GuessRange GeneralInstance]
gs
    tryRangeUnion [GuessRange GeneralInstance]
_ GuessRange GeneralInstance
_ [GuessRange GeneralInstance]
_ = Maybe [GuessRange GeneralInstance]
-> m (Maybe [GuessRange GeneralInstance])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [GuessRange GeneralInstance]
forall a. Maybe a
Nothing
    takeBest :: ParamName -> [GuessRange GeneralInstance] -> m GeneralInstance
takeBest ParamName
i [g :: GuessRange GeneralInstance
g@(GuessRange GeneralInstance
lo GeneralInstance
hi)] = do
      Bool
same <- GeneralInstance
hi GeneralInstance -> GeneralInstance -> m Bool
`convertsTo` GeneralInstance
lo
      let openHi :: Bool
openHi = GeneralInstance
hi GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
== GeneralInstance
forall a. Bounded a => a
maxBound
      let openLo :: Bool
openLo = GeneralInstance
lo GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
== GeneralInstance
forall a. Bounded a => a
minBound
      case (Bool
same,Bool
openHi,Bool
openLo) of
           (Bool
True,Bool
_,Bool
_)     -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
lo
           (Bool
_,Bool
True,Bool
False) -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
lo
           (Bool
_,Bool
False,Bool
True) -> GeneralInstance -> m GeneralInstance
forall (m :: * -> *) a. Monad m => a -> m a
return GeneralInstance
hi
           (Bool, Bool, Bool)
_ -> String -> m GeneralInstance
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (GuessRange GeneralInstance -> String
forall a. Show a => a -> String
show GuessRange GeneralInstance
g) m GeneralInstance -> String -> m GeneralInstance
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!! String
"Type for param " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is ambiguous"
    takeBest ParamName
i [GuessRange GeneralInstance]
gs = [String] -> m GeneralInstance
forall (m :: * -> *) a. CollectErrorsM m => [String] -> m a
mapErrorsM ((GuessRange GeneralInstance -> String)
-> [GuessRange GeneralInstance] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GuessRange GeneralInstance -> String
forall a. Show a => a -> String
show [GuessRange GeneralInstance]
gs) m GeneralInstance -> String -> m GeneralInstance
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!! String
"Type for param " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is ambiguous"
    filterGuesses :: ParamName
-> GuessUnion GeneralInstance -> m (GuessUnion GeneralInstance)
filterGuesses ParamName
i (GuessUnion [GuessRange GeneralInstance]
gs) = do
      let ga :: [m (GuessRange GeneralInstance)]
ga = (GuessRange GeneralInstance -> m (GuessRange GeneralInstance))
-> [GuessRange GeneralInstance] -> [m (GuessRange GeneralInstance)]
forall a b. (a -> b) -> [a] -> [b]
map (ParamName
-> GuessRange GeneralInstance -> m (GuessRange GeneralInstance)
filterGuess ParamName
i) [GuessRange GeneralInstance]
gs
      [m (GuessRange GeneralInstance)] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectFirstM_ [m (GuessRange GeneralInstance)]
ga m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!! String
"No valid guesses for param " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
i
      [GuessRange GeneralInstance]
gs' <- [m (GuessRange GeneralInstance)] -> m [GuessRange GeneralInstance]
forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAnyM [m (GuessRange GeneralInstance)]
ga
      ([GuessRange GeneralInstance] -> GuessUnion GeneralInstance)
-> m [GuessRange GeneralInstance] -> m (GuessUnion GeneralInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GuessRange GeneralInstance] -> GuessUnion GeneralInstance
forall a. [GuessRange a] -> GuessUnion a
GuessUnion ([GuessRange GeneralInstance] -> m [GuessRange GeneralInstance]
simplifyUnion [GuessRange GeneralInstance]
gs')
    filterGuess :: ParamName
-> GuessRange GeneralInstance -> m (GuessRange GeneralInstance)
filterGuess ParamName
i g :: GuessRange GeneralInstance
g@(GuessRange GeneralInstance
lo GeneralInstance
hi) = do
      case (GeneralInstance
lo GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
== GeneralInstance
forall a. Bounded a => a
minBound,GeneralInstance
hi GeneralInstance -> GeneralInstance -> Bool
forall a. Eq a => a -> a -> Bool
== GeneralInstance
forall a. Bounded a => a
maxBound) of
           (Bool
False,Bool
False) -> do
             let checkLo :: m ()
checkLo = ParamName -> GeneralInstance -> m ()
checkSubFilters ParamName
i GeneralInstance
lo
             let checkHi :: m ()
checkHi = ParamName -> GeneralInstance -> m ()
checkSubFilters ParamName
i GeneralInstance
hi
             Bool
pLo <- m () -> m Bool
forall (m :: * -> *) a. CollectErrorsM m => m a -> m Bool
isCompilerErrorM m ()
checkLo
             Bool
pHi <- m () -> m Bool
forall (m :: * -> *) a. CollectErrorsM m => m a -> m Bool
isCompilerErrorM m ()
checkHi
             case (Bool
pLo,Bool
pHi) of
                  (Bool
True,Bool
True) -> [m ()] -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, CollectErrorsM m) =>
f (m a) -> m ()
collectAllM_ [m ()
checkLo,m ()
checkHi] m ()
-> m (GuessRange GeneralInstance) -> m (GuessRange GeneralInstance)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m (GuessRange GeneralInstance)
forall (m :: * -> *) a. CollectErrorsM m => m a
emptyErrorM
                  (Bool
True,Bool
_) -> GuessRange GeneralInstance -> m (GuessRange GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (GuessRange GeneralInstance -> m (GuessRange GeneralInstance))
-> GuessRange GeneralInstance -> m (GuessRange GeneralInstance)
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> GeneralInstance -> GuessRange GeneralInstance
forall a. a -> a -> GuessRange a
GuessRange GeneralInstance
hi GeneralInstance
hi
                  (Bool
_,Bool
True) -> GuessRange GeneralInstance -> m (GuessRange GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (GuessRange GeneralInstance -> m (GuessRange GeneralInstance))
-> GuessRange GeneralInstance -> m (GuessRange GeneralInstance)
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> GeneralInstance -> GuessRange GeneralInstance
forall a. a -> a -> GuessRange a
GuessRange GeneralInstance
lo GeneralInstance
lo
                  (Bool, Bool)
_        -> GuessRange GeneralInstance -> m (GuessRange GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (GuessRange GeneralInstance -> m (GuessRange GeneralInstance))
-> GuessRange GeneralInstance -> m (GuessRange GeneralInstance)
forall a b. (a -> b) -> a -> b
$ GeneralInstance -> GeneralInstance -> GuessRange GeneralInstance
forall a. a -> a -> GuessRange a
GuessRange GeneralInstance
lo GeneralInstance
hi
           (Bool
loP,Bool
hiP) -> do
             Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
loP) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ParamName -> GeneralInstance -> m ()
checkSubFilters ParamName
i GeneralInstance
lo
             Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
hiP) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ParamName -> GeneralInstance -> m ()
checkSubFilters ParamName
i GeneralInstance
hi
             GuessRange GeneralInstance -> m (GuessRange GeneralInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return GuessRange GeneralInstance
g
    checkSubFilters :: ParamName -> GeneralInstance -> m ()
checkSubFilters ParamName
i GeneralInstance
t = String
"In guess " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GeneralInstance -> String
forall a. Show a => a -> String
show GeneralInstance
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for param " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamName -> String
forall a. Show a => a -> String
show ParamName
i String -> m () -> m ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a -> m a
??> do
      let ps' :: Map ParamName GeneralInstance
ps' = ParamName
-> GeneralInstance
-> Map ParamName GeneralInstance
-> Map ParamName GeneralInstance
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ParamName
i GeneralInstance
t Map ParamName GeneralInstance
ps
      [TypeFilter]
fs <- Map ParamName [TypeFilter]
ff Map ParamName [TypeFilter] -> ParamName -> m [TypeFilter]
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName [TypeFilter] -> ParamName -> m [TypeFilter]
`filterLookup` ParamName
i
      [TypeFilter]
fs' <- (TypeFilter -> m TypeFilter) -> [TypeFilter] -> m [TypeFilter]
forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM ((ParamName -> m GeneralInstance) -> TypeFilter -> m TypeFilter
forall (m :: * -> *).
CollectErrorsM m =>
(ParamName -> m GeneralInstance) -> TypeFilter -> m TypeFilter
uncheckedSubFilter (Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
forall (m :: * -> *).
ErrorContextM m =>
Map ParamName GeneralInstance -> ParamName -> m GeneralInstance
getValueForParam Map ParamName GeneralInstance
ps')) [TypeFilter]
fs
      r
-> Map ParamName [TypeFilter]
-> GeneralInstance
-> [TypeFilter]
-> m ()
forall (m :: * -> *) r.
(CollectErrorsM m, TypeResolver r) =>
r
-> Map ParamName [TypeFilter]
-> GeneralInstance
-> [TypeFilter]
-> m ()
validateAssignment r
r Map ParamName [TypeFilter]
f GeneralInstance
t [TypeFilter]
fs'