module Language.PureScript.Environment where

import Prelude

import GHC.Generics (Generic)

import Control.DeepSeq (NFData)

import Control.Monad (unless)

import Codec.Serialise (Serialise)

import Data.Aeson ((.=), (.:))

import qualified Data.Aeson as A

import Data.Foldable (find, fold)

import qualified Data.IntMap as IM

import qualified Data.IntSet as IS

import qualified Data.Map as M

import qualified Data.Set as S

import Data.Maybe (fromMaybe)

import Data.Semigroup (First(..))

import Data.Text (Text)

import qualified Data.Text as T

import qualified Data.List.NonEmpty as NEL

import Language.PureScript.AST.SourcePos

import Language.PureScript.Crash

import Language.PureScript.Names

import Language.PureScript.Roles

import Language.PureScript.TypeClassDictionaries

import Language.PureScript.Types

import qualified Language.PureScript.Constants.Prim as C

-- | The @Environment@ defines all values and types which are currently in scope:

data Environment = Environment

{ names :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility)

-- ^ Values currently in scope

, types :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

-- ^ Type names currently in scope

, dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident])

-- ^ Data constructors currently in scope, along with their associated type

-- constructor name, argument types and return type.

, typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType)

-- ^ Type synonyms currently in scope

, typeClassDictionaries :: M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))

-- ^ Available type class dictionaries. When looking up 'Nothing' in the

-- outer map, this returns the map of type class dictionaries in local

-- scope (ie dictionaries brought in by a constrained type).

, typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

-- ^ Type classes

} deriving (Show, Generic)

instance NFData Environment

-- | Information about a type class

data TypeClassData = TypeClassData

{ typeClassArguments :: [(Text, Maybe SourceType)]

-- ^ A list of type argument names, and their kinds, where kind annotations

-- were provided.

, typeClassMembers :: [(Ident, SourceType)]

-- ^ A list of type class members and their types. Type arguments listed above

-- are considered bound in these types.

, typeClassSuperclasses :: [SourceConstraint]

-- ^ A list of superclasses of this type class. Type arguments listed above

-- are considered bound in the types appearing in these constraints.

, typeClassDependencies :: [FunctionalDependency]

-- ^ A list of functional dependencies for the type arguments of this class.

, typeClassDeterminedArguments :: S.Set Int

-- ^ A set of indexes of type argument that are fully determined by other

-- arguments via functional dependencies. This can be computed from both

-- typeClassArguments and typeClassDependencies.

, typeClassCoveringSets :: S.Set (S.Set Int)

-- ^ A sets of arguments that can be used to infer all other arguments.

, typeClassIsEmpty :: Bool

-- ^ Whether or not dictionaries for this type class are necessarily empty.

} deriving (Show, Generic)

instance NFData TypeClassData

-- | A functional dependency indicates a relationship between two sets of

data FunctionalDependency = FunctionalDependency

{ fdDeterminers :: [Int]

-- ^ the type arguments which determine the determined type arguments

, fdDetermined :: [Int]

-- ^ the determined type arguments

} deriving (Show, Generic)

instance NFData FunctionalDependency

instance Serialise FunctionalDependency

instance A.FromJSON FunctionalDependency where

parseJSON = A.withObject "FunctionalDependency" $ \o ->

FunctionalDependency

<$> o .: "determiners"

<*> o .: "determined"

instance A.ToJSON FunctionalDependency where

toJSON FunctionalDependency{..} =

A.object [ "determiners" .= fdDeterminers

, "determined" .= fdDetermined

]

-- | The initial environment with no values and only the default javascript types defined

initEnvironment :: Environment

initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty allPrimClasses

-- | A constructor for TypeClassData that computes which type class arguments are fully determined

makeTypeClassData

:: [(Text, Maybe SourceType)]

-> [(Ident, SourceType)]

-> [SourceConstraint]

-> [FunctionalDependency]

-> Bool

-> TypeClassData

makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets

where

( determinedArgs, coveringSets ) = computeCoveringSets (length args) deps

type Frontier = M.Map IS.IntSet (First (IM.IntMap (NEL.NonEmpty IS.IntSet)))

-- ^ ^ ^ ^

computeCoveringSets :: Int -> [FunctionalDependency] -> (S.Set Int, S.Set (S.Set Int))

computeCoveringSets nargs deps = ( determinedArgs, coveringSets )

where

argumentIndices = S.fromList [0 .. nargs - 1]

-- Compute all sets of arguments that determine the remaining arguments via

-- functional dependencies. This is done in stages, where each stage

-- considers sets of the same size to share work.

allCoveringSets :: S.Set (S.Set Int)

allCoveringSets = S.map (S.fromDistinctAscList . IS.toAscList) $ fst $ search $

-- The initial frontier consists of just the set of all parameters and all

-- fundeps organized into the map structure.

M.singleton

(IS.fromList [0 .. nargs - 1]) $

First $ IM.fromListWith (<>) $ do

fd <- deps

let srcs = pure (IS.fromList (fdDeterminers fd))

tgt <- fdDetermined fd

pure (tgt, srcs)

where

-- Recursively advance the frontier until all frontiers are exhausted

-- and coverings sets found. The covering sets found during the process

-- are locally-minimal, in that none can be reduced by a fundep, but

-- there may be subsets found from other frontiers.

search :: Frontier -> (S.Set IS.IntSet, ())

search frontier = unless (null frontier) $ M.foldMapWithKey step frontier >>= search

-- The input set from the frontier is known to cover all parameters, but

-- it may be able to be reduced by more fundeps.

step :: IS.IntSet -> First (IM.IntMap (NEL.NonEmpty IS.IntSet)) -> (S.Set IS.IntSet, Frontier)

step needed (First inEdges)

-- If there are no applicable fundeps, record it as a locally minimal

-- covering set. This has already been reduced to only applicable fundeps

| IM.null inEdges = (S.singleton needed, M.empty)

| otherwise = (S.empty, foldMap removeParameter paramsToTry)

where

determined = IM.keys inEdges

-- If there is an acyclically determined functional dependency, prefer

-- it to reduce the number of cases to check. That is a dependency

-- that does not help determine other parameters.

acycDetermined = find (`IS.notMember` (IS.unions $ concatMap NEL.toList $ IM.elems inEdges)) determined

paramsToTry = maybe determined pure acycDetermined

-- For each parameter to be removed to build the next frontier,

-- delete the fundeps that determine it and filter out the fundeps

-- that make use of it. Of course, if it an acyclic fundep we already

-- found that there are none that use it.

removeParameter :: Int -> Frontier

removeParameter y =

M.singleton

(IS.delete y needed) $

case acycDetermined of

Just _ -> First $ IM.delete y inEdges

Nothing ->

First $ IM.mapMaybe (NEL.nonEmpty . NEL.filter (y `IS.notMember`)) $ IM.delete y inEdges

-- Reduce to the inclusion-minimal sets

coveringSets = S.filter (\v -> not (any (\c -> c `S.isProperSubsetOf` v) allCoveringSets)) allCoveringSets

-- An argument is determined if it is in no covering set

determinedArgs = argumentIndices `S.difference` fold coveringSets

-- | The visibility of a name in scope

data NameVisibility

= Undefined

-- ^ The name is defined in the current binding group, but is not visible

| Defined

-- ^ The name is defined in the another binding group, or has been made visible by a function binder

deriving (Show, Eq, Generic)

instance NFData NameVisibility

instance Serialise NameVisibility

-- | A flag for whether a name is for an private or public value - only public values will be

data NameKind

= Private

-- ^ A private value introduced as an artifact of code generation (class instances, class member

-- accessors, etc.)

| Public

-- ^ A public value for a module member or foreign import declaration

| External

-- ^ A name for member introduced by foreign import

deriving (Show, Eq, Generic)

instance NFData NameKind

instance Serialise NameKind

-- | The kinds of a type

data TypeKind

= DataType DataDeclType [(Text, Maybe SourceType, Role)] [(ProperName 'ConstructorName, [SourceType])]

-- ^ Data type

| TypeSynonym

-- ^ Type synonym

| ExternData [Role]

-- ^ Foreign data

| LocalTypeVariable

-- ^ A local type variable

| ScopedTypeVar

-- ^ A scoped type variable

deriving (Show, Eq, Generic)

instance NFData TypeKind

instance Serialise TypeKind

-- | The type ('data' or 'newtype') of a data type declaration

data DataDeclType

= Data

-- ^ A standard data constructor

| Newtype

-- ^ A newtype constructor

deriving (Show, Eq, Ord, Generic)

instance NFData DataDeclType

instance Serialise DataDeclType

showDataDeclType :: DataDeclType -> Text

showDataDeclType Data = "data"

showDataDeclType Newtype = "newtype"

instance A.ToJSON DataDeclType where

toJSON = A.toJSON . showDataDeclType

instance A.FromJSON DataDeclType where

parseJSON = A.withText "DataDeclType" $ \case

"data" -> return Data

"newtype" -> return Newtype

other -> fail $ "invalid type: '" ++ T.unpack other ++ "'"

-- | Construct a ProperName in the Prim module

primName :: Text -> Qualified (ProperName a)

primName = Qualified (ByModuleName C.Prim) . ProperName

-- | Construct a 'ProperName' in the @Prim.NAME@ module.

primSubName :: Text -> Text -> Qualified (ProperName a)

primSubName sub =

Qualified (ByModuleName $ ModuleName $ C.prim <> "." <> sub) . ProperName

primKind :: Text -> SourceType

primKind = primTy

primSubKind :: Text -> Text -> SourceType

primSubKind sub = TypeConstructor nullSourceAnn . primSubName sub

-- | Kind of ground types

kindType :: SourceType

kindType = primKind C.typ

kindConstraint :: SourceType

kindConstraint = primKind C.constraint

kindSymbol :: SourceType

kindSymbol = primKind C.symbol

kindDoc :: SourceType

kindDoc = primSubKind C.typeError C.doc

kindOrdering :: SourceType

kindOrdering = primSubKind C.moduleOrdering C.kindOrdering

kindRowList :: SourceType -> SourceType

kindRowList = TypeApp nullSourceAnn (primSubKind C.moduleRowList C.kindRowList)

kindRow :: SourceType -> SourceType

kindRow = TypeApp nullSourceAnn (primKind C.row)

kindOfREmpty :: SourceType

kindOfREmpty = tyForall "k" kindType (kindRow (tyVar "k"))

-- | Construct a type in the Prim module

primTy :: Text -> SourceType

primTy = TypeConstructor nullSourceAnn . primName

-- | Type constructor for functions

tyFunction :: SourceType

tyFunction = primTy "Function"

-- | Type constructor for strings

tyString :: SourceType

tyString = primTy "String"

-- | Type constructor for strings

tyChar :: SourceType

tyChar = primTy "Char"

-- | Type constructor for numbers

tyNumber :: SourceType

tyNumber = primTy "Number"

-- | Type constructor for integers

tyInt :: SourceType

tyInt = primTy "Int"

-- | Type constructor for booleans

tyBoolean :: SourceType

tyBoolean = primTy "Boolean"

-- | Type constructor for arrays

tyArray :: SourceType

tyArray = primTy "Array"

-- | Type constructor for records

tyRecord :: SourceType

tyRecord = primTy "Record"

tyVar :: Text -> SourceType

tyVar = TypeVar nullSourceAnn

tyForall :: Text -> SourceType -> SourceType -> SourceType

tyForall var k ty = ForAll nullSourceAnn var (Just k) ty Nothing

-- | Smart constructor for function types

function :: SourceType -> SourceType -> SourceType

function = TypeApp nullSourceAnn . TypeApp nullSourceAnn tyFunction

(-:>) :: SourceType -> SourceType -> SourceType

(-:>) = function

infixr 4 -:>

primClass :: Qualified (ProperName 'TypeName) -> (SourceType -> SourceType) -> [(Qualified (ProperName 'TypeName), (SourceType, TypeKind))]

primClass name mkKind =

[ let k = mkKind kindConstraint

in (name, (k, ExternData (nominalRolesForKind k)))

, let k = mkKind kindType

in (dictTypeName <$> name, (k, TypeSynonym))

]

-- | The primitive types in the external environment with their

primTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

primTypes =

M.fromList

[ (primName "Type", (kindType, ExternData []))

, (primName "Constraint", (kindType, ExternData []))

, (primName "Symbol", (kindType, ExternData []))

, (primName "Row", (kindType -:> kindType, ExternData [Phantom]))

, (primName "Function", (kindType -:> kindType -:> kindType, ExternData [Representational, Representational]))

, (primName "Array", (kindType -:> kindType, ExternData [Representational]))

, (primName "Record", (kindRow kindType -:> kindType, ExternData [Representational]))

, (primName "String", (kindType, ExternData []))

, (primName "Char", (kindType, ExternData []))

, (primName "Number", (kindType, ExternData []))

, (primName "Int", (kindType, ExternData []))

, (primName "Boolean", (kindType, ExternData []))

, (primName "Partial", (kindConstraint, ExternData []))

]

-- | This 'Map' contains all of the prim types from all Prim modules.

allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

allPrimTypes = M.unions

[ primTypes

, primBooleanTypes

, primCoerceTypes

, primOrderingTypes

, primRowTypes

, primRowListTypes

, primSymbolTypes

, primIntTypes

, primTypeErrorTypes

]

primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

primBooleanTypes =

M.fromList

[ (primSubName C.moduleBoolean "True", (tyBoolean, ExternData []))

, (primSubName C.moduleBoolean "False", (tyBoolean, ExternData []))

]

primCoerceTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

primCoerceTypes =

M.fromList $ mconcat

[ primClass (primSubName C.moduleCoerce "Coercible") (\kind -> tyForall "k" kindType $ tyVar "k" -:> tyVar "k" -:> kind)

]

primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

primOrderingTypes =

M.fromList

[ (primSubName C.moduleOrdering "Ordering", (kindType, ExternData []))

, (primSubName C.moduleOrdering "LT", (kindOrdering, ExternData []))

, (primSubName C.moduleOrdering "EQ", (kindOrdering, ExternData []))

, (primSubName C.moduleOrdering "GT", (kindOrdering, ExternData []))

]

primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

primRowTypes =

M.fromList $ mconcat

[ primClass (primSubName C.moduleRow "Union") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind)

, primClass (primSubName C.moduleRow "Nub") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind)

, primClass (primSubName C.moduleRow "Lacks") (\kind -> tyForall "k" kindType $ kindSymbol -:> kindRow (tyVar "k") -:> kind)

, primClass (primSubName C.moduleRow "Cons") (\kind -> tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind)

]

primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

primRowListTypes =

M.fromList $

[ (primSubName C.moduleRowList "RowList", (kindType -:> kindType, ExternData [Phantom]))

, (primSubName C.moduleRowList "Cons", (tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRowList (tyVar "k") -:> kindRowList (tyVar "k"), ExternData [Phantom, Phantom, Phantom]))

, (primSubName C.moduleRowList "Nil", (tyForall "k" kindType $ kindRowList (tyVar "k"), ExternData []))

] <> mconcat

[ primClass (primSubName C.moduleRowList "RowToList") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRowList (tyVar "k") -:> kind)

]

primSymbolTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

primSymbolTypes =

M.fromList $ mconcat

[ primClass (primSubName C.moduleSymbol "Append") (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind)

, primClass (primSubName C.moduleSymbol "Compare") (\kind -> kindSymbol -:> kindSymbol -:> kindOrdering -:> kind)

, primClass (primSubName C.moduleSymbol "Cons") (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind)

]

primIntTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

primIntTypes =

M.fromList $ mconcat

[ primClass (primSubName C.moduleInt "Add") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind)

, primClass (primSubName C.moduleInt "Compare") (\kind -> tyInt -:> tyInt -:> kindOrdering -:> kind)

, primClass (primSubName C.moduleInt "Mul") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind)

, primClass (primSubName C.moduleInt "ToString") (\kind -> tyInt -:> kindSymbol -:> kind)

]

primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)

primTypeErrorTypes =

M.fromList $

[ (primSubName C.typeError "Doc", (kindType, ExternData []))

, (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData [Nominal]))

, (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData [Nominal]))

, (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData [Phantom]))

, (primSubName C.typeError "Quote", (tyForall "k" kindType $ tyVar "k" -:> kindDoc, ExternData [Phantom]))

, (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData [Phantom]))

, (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom]))

, (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom]))

] <> mconcat

[ primClass (primSubName C.typeError "Fail") (\kind -> kindDoc -:> kind)

, primClass (primSubName C.typeError "Warn") (\kind -> kindDoc -:> kind)

]

-- | The primitive class map. This just contains the `Partial` class.

primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

primClasses =

M.fromList

[ (primName "Partial", makeTypeClassData [] [] [] [] True)

]

-- | This contains all of the type classes from all Prim modules.

allPrimClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

allPrimClasses = M.unions

[ primClasses

, primCoerceClasses

, primRowClasses

, primRowListClasses

, primSymbolClasses

, primIntClasses

, primTypeErrorClasses

]

primCoerceClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

primCoerceClasses =

M.fromList

-- class Coercible (a :: k) (b :: k)

[ (primSubName C.moduleCoerce "Coercible", makeTypeClassData

[ ("a", Just (tyVar "k"))

, ("b", Just (tyVar "k"))

] [] [] [] True)

]

primRowClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

primRowClasses =

M.fromList

-- class Union (left :: Row k) (right :: Row k) (union :: Row k) | left right -> union, right union -> left, union left -> right

[ (primSubName C.moduleRow "Union", makeTypeClassData

[ ("left", Just (kindRow (tyVar "k")))

, ("right", Just (kindRow (tyVar "k")))

, ("union", Just (kindRow (tyVar "k")))

] [] []

[ FunctionalDependency [0, 1] [2]

, FunctionalDependency [1, 2] [0]

, FunctionalDependency [2, 0] [1]

] True)

-- class Nub (original :: Row k) (nubbed :: Row k) | original -> nubbed

, (primSubName C.moduleRow "Nub", makeTypeClassData

[ ("original", Just (kindRow (tyVar "k")))

, ("nubbed", Just (kindRow (tyVar "k")))

] [] []

[ FunctionalDependency [0] [1]

] True)

-- class Lacks (label :: Symbol) (row :: Row k)

, (primSubName C.moduleRow "Lacks", makeTypeClassData

[ ("label", Just kindSymbol)

, ("row", Just (kindRow (tyVar "k")))

] [] [] [] True)

-- class RowCons (label :: Symbol) (a :: k) (tail :: Row k) (row :: Row k) | label tail a -> row, label row -> tail a

, (primSubName C.moduleRow "Cons", makeTypeClassData

[ ("label", Just kindSymbol)

, ("a", Just (tyVar "k"))

, ("tail", Just (kindRow (tyVar "k")))

, ("row", Just (kindRow (tyVar "k")))

] [] []

[ FunctionalDependency [0, 1, 2] [3]

, FunctionalDependency [0, 3] [1, 2]

] True)

]

primRowListClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

primRowListClasses =

M.fromList

-- class RowToList (row :: Row k) (list :: RowList k) | row -> list

[ (primSubName C.moduleRowList "RowToList", makeTypeClassData

[ ("row", Just (kindRow (tyVar "k")))

, ("list", Just (kindRowList (tyVar "k")))

] [] []

[ FunctionalDependency [0] [1]

] True)

]

primSymbolClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

primSymbolClasses =

M.fromList

-- class Append (left :: Symbol) (right :: Symbol) (appended :: Symbol) | left right -> appended, right appended -> left, appended left -> right

[ (primSubName C.moduleSymbol "Append", makeTypeClassData

[ ("left", Just kindSymbol)

, ("right", Just kindSymbol)

, ("appended", Just kindSymbol)

] [] []

[ FunctionalDependency [0, 1] [2]

, FunctionalDependency [1, 2] [0]

, FunctionalDependency [2, 0] [1]

] True)

-- class Compare (left :: Symbol) (right :: Symbol) (ordering :: Ordering) | left right -> ordering

, (primSubName C.moduleSymbol "Compare", makeTypeClassData

[ ("left", Just kindSymbol)

, ("right", Just kindSymbol)

, ("ordering", Just kindOrdering)

] [] []

[ FunctionalDependency [0, 1] [2]

] True)

-- class Cons (head :: Symbol) (tail :: Symbol) (symbol :: Symbol) | head tail -> symbol, symbol -> head tail

, (primSubName C.moduleSymbol "Cons", makeTypeClassData

[ ("head", Just kindSymbol)

, ("tail", Just kindSymbol)

, ("symbol", Just kindSymbol)

] [] []

[ FunctionalDependency [0, 1] [2]

, FunctionalDependency [2] [0, 1]

] True)

]

primIntClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

primIntClasses =

M.fromList

-- class Add (left :: Int) (right :: Int) (sum :: Int) | left right -> sum, left sum -> right, right sum -> left

[ (primSubName C.moduleInt "Add", makeTypeClassData

[ ("left", Just tyInt)

, ("right", Just tyInt)

, ("sum", Just tyInt)

] [] []

[ FunctionalDependency [0, 1] [2]

, FunctionalDependency [0, 2] [1]

, FunctionalDependency [1, 2] [0]

] True)

-- class Compare (left :: Int) (right :: Int) (ordering :: Ordering) | left right -> ordering

, (primSubName C.moduleInt "Compare", makeTypeClassData

[ ("left", Just tyInt)

, ("right", Just tyInt)

, ("ordering", Just kindOrdering)

] [] []

[ FunctionalDependency [0, 1] [2]

] True)

-- class Mul (left :: Int) (right :: Int) (product :: Int) | left right -> product

, (primSubName C.moduleInt "Mul", makeTypeClassData

[ ("left", Just tyInt)

, ("right", Just tyInt)

, ("product", Just tyInt)

] [] []

[ FunctionalDependency [0, 1] [2]

] True)

-- class ToString (int :: Int) (string :: Symbol) | int -> string

, (primSubName C.moduleInt "ToString", makeTypeClassData

[ ("int", Just tyInt)

, ("string", Just kindSymbol)

] [] []

[ FunctionalDependency [0] [1]

] True)

]

primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

primTypeErrorClasses =

M.fromList

-- class Fail (message :: Symbol)

[ (primSubName C.typeError "Fail", makeTypeClassData

[("message", Just kindDoc)] [] [] [] True)

-- class Warn (message :: Symbol)

, (primSubName C.typeError "Warn", makeTypeClassData

[("message", Just kindDoc)] [] [] [] True)

]

-- | Finds information about data constructors from the current environment.

lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [Ident])

lookupConstructor env ctor =

fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env

-- | Finds information about values from the current environment.

lookupValue :: Environment -> Qualified Ident -> Maybe (SourceType, NameKind, NameVisibility)

lookupValue env ident = ident `M.lookup` names env

dictTypeName' :: Text -> Text

dictTypeName' = (<> "$Dict")

dictTypeName :: ProperName a -> ProperName a

dictTypeName = ProperName . dictTypeName' . runProperName

isDictTypeName :: ProperName a -> Bool

isDictTypeName = T.isSuffixOf "$Dict" . runProperName

-- |

nominalRolesForKind :: Type a -> [Role]

nominalRolesForKind k = replicate (kindArity k) Nominal

kindArity :: Type a -> Int

kindArity = length . fst . unapplyKinds

unapplyKinds :: Type a -> ([Type a], Type a)

unapplyKinds = go [] where

go kinds (TypeApp _ (TypeApp _ fn k1) k2)

| eqType fn tyFunction = go (k1 : kinds) k2

go kinds (ForAll _ _ _ k _) = go kinds k

go kinds k = (reverse kinds, k)