-- |
-- The top-level type checker, which checks all declarations in a module.
--
module Language.PureScript.TypeChecker
  ( module T
  , typeCheckModule
  , checkNewtype
  ) where

import Prelude
import Protolude (headMay, maybeToLeft, ordNub)

import Control.Lens ((^..), _2)
import Control.Monad (when, unless, void, forM, zipWithM_)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), modify, gets)
import Control.Monad.Supply.Class (MonadSupply)
import Control.Monad.Writer.Class (MonadWriter, tell)

import Data.Foldable (for_, traverse_, toList)
import Data.List (nub, nubBy, (\\), sort, group)
import Data.Maybe
import Data.Either (partitionEithers)
import Data.Text (Text)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T

import Language.PureScript.AST
import Language.PureScript.AST.Declarations.ChainId (ChainId)
import qualified Language.PureScript.Constants.Libs as Libs
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Linter
import Language.PureScript.Linter.Wildcards
import Language.PureScript.Names
import Language.PureScript.Roles
import Language.PureScript.Sugar.Names.Env (Exports(..))
import Language.PureScript.TypeChecker.Kinds as T
import Language.PureScript.TypeChecker.Monad as T
import Language.PureScript.TypeChecker.Roles as T
import Language.PureScript.TypeChecker.Synonyms as T
import Language.PureScript.TypeChecker.Types as T
import Language.PureScript.TypeChecker.Unify (varIfUnknown)
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types

addDataType
  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => ModuleName
  -> DataDeclType
  -> ProperName 'TypeName
  -> [(Text, Maybe SourceType, Role)]
  -> [(DataConstructorDeclaration, SourceType)]
  -> SourceType
  -> m ()
addDataType :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType, Role)]
-> [(DataConstructorDeclaration, SourceType)]
-> SourceType
-> m ()
addDataType ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType, Role)]
args [(DataConstructorDeclaration, SourceType)]
dctors SourceType
ctorKind = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  let mapDataCtor :: DataConstructorDeclaration
-> (ProperName 'ConstructorName, [SourceType])
mapDataCtor (DataConstructorDeclaration SourceAnn
_ ProperName 'ConstructorName
ctorName [(Ident, SourceType)]
vars) = (ProperName 'ConstructorName
ctorName, forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Ident, SourceType)]
vars)
      qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
      hasSig :: Bool
hasSig = Qualified (ProperName 'TypeName)
qualName forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
ctorKind, DataDeclType
-> [(Text, Maybe SourceType, Role)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> TypeKind
DataType DataDeclType
dtype [(Text, Maybe SourceType, Role)]
args (forall a b. (a -> b) -> [a] -> [b]
map (DataConstructorDeclaration
-> (ProperName 'ConstructorName, [SourceType])
mapDataCtor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(DataConstructorDeclaration, SourceType)]
dctors)) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSig Bool -> Bool -> Bool
|| forall (a :: ProperNameType). ProperName a -> Bool
isDictTypeName ProperName 'TypeName
name Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Type a -> Bool
containsForAll SourceType
ctorKind)) forall a b. (a -> b) -> a -> b
$ do
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ KindSignatureFor
-> ProperName 'TypeName -> SourceType -> SimpleErrorMessage
MissingKindDeclaration (if DataDeclType
dtype forall a. Eq a => a -> a -> Bool
== DataDeclType
Newtype then KindSignatureFor
NewtypeSig else KindSignatureFor
DataSig) ProperName 'TypeName
name SourceType
ctorKind
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(DataConstructorDeclaration, SourceType)]
dctors forall a b. (a -> b) -> a -> b
$ \(DataConstructorDeclaration SourceAnn
_ ProperName 'ConstructorName
dctor [(Ident, SourceType)]
fields, SourceType
polyType) ->
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'ConstructorName -> ErrorMessageHint
ErrorInDataConstructor ProperName 'ConstructorName
dctor)) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> ProperName 'ConstructorName
-> [(Ident, SourceType)]
-> SourceType
-> m ()
addDataConstructor ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name ProperName 'ConstructorName
dctor [(Ident, SourceType)]
fields SourceType
polyType

addDataConstructor
  :: (MonadState CheckState m, MonadError MultipleErrors m)
  => ModuleName
  -> DataDeclType
  -> ProperName 'TypeName
  -> ProperName 'ConstructorName
  -> [(Ident, SourceType)]
  -> SourceType
  -> m ()
addDataConstructor :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> ProperName 'ConstructorName
-> [(Ident, SourceType)]
-> SourceType
-> m ()
addDataConstructor ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name ProperName 'ConstructorName
dctor [(Ident, SourceType)]
dctorArgs SourceType
polyType = do
  let fields :: [Ident]
fields = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Ident, SourceType)]
dctorArgs
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceType -> m ()
checkTypeSynonyms SourceType
polyType
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { dataConstructors :: Map
  (Qualified (ProperName 'ConstructorName))
  (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'ConstructorName
dctor) (DataDeclType
dtype, ProperName 'TypeName
name, SourceType
polyType, [Ident]
fields) (Environment
-> Map
     (Qualified (ProperName 'ConstructorName))
     (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Environment
env) }

checkRoleDeclaration
  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => ModuleName
  -> RoleDeclarationData
  -> m ()
checkRoleDeclaration :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName -> RoleDeclarationData -> m ()
checkRoleDeclaration ModuleName
moduleName (RoleDeclarationData (SourceSpan
ss, [Comment]
_) ProperName 'TypeName
name [Role]
declaredRoles) = do
  forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInRoleDeclaration ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
    Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
    let qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'TypeName)
qualName (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) of
      Just (SourceType
kind, DataType DataDeclType
dtype [(Text, Maybe SourceType, Role)]
args [(ProperName 'ConstructorName, [SourceType])]
dctors) -> do
        forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName -> [Role] -> Int -> m ()
checkRoleDeclarationArity ProperName 'TypeName
name [Role]
declaredRoles (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Maybe SourceType, Role)]
args)
        forall (m :: * -> *).
MonadError MultipleErrors m =>
[(Text, Maybe SourceType, Role)] -> [Role] -> m ()
checkRoles [(Text, Maybe SourceType, Role)]
args [Role]
declaredRoles
        let args' :: [(Text, Maybe SourceType, Role)]
args' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Text
v, Maybe SourceType
k, Role
_) Role
r -> (Text
v, Maybe SourceType
k, Role
r)) [(Text, Maybe SourceType, Role)]
args [Role]
declaredRoles
        forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, DataDeclType
-> [(Text, Maybe SourceType, Role)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> TypeKind
DataType DataDeclType
dtype [(Text, Maybe SourceType, Role)]
args' [(ProperName 'ConstructorName, [SourceType])]
dctors) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
      Just (SourceType
kind, ExternData [Role]
_) -> do
        forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName -> [Role] -> Int -> m ()
checkRoleDeclarationArity ProperName 'TypeName
name [Role]
declaredRoles (forall a. Type a -> Int
kindArity SourceType
kind)
        forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, [Role] -> TypeKind
ExternData [Role]
declaredRoles) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
      Maybe (SourceType, TypeKind)
_ -> forall a. HasCallStack => String -> a
internalError String
"Unsupported role declaration"

addTypeSynonym
  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => ModuleName
  -> ProperName 'TypeName
  -> [(Text, Maybe SourceType)]
  -> SourceType
  -> SourceType
  -> m ()
addTypeSynonym :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> SourceType
-> m ()
addTypeSynonym ModuleName
moduleName ProperName 'TypeName
name [(Text, Maybe SourceType)]
args SourceType
ty SourceType
kind = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceType -> m ()
checkTypeSynonyms SourceType
ty
  let qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
      hasSig :: Bool
hasSig = Qualified (ProperName 'TypeName)
qualName forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSig Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Type a -> Bool
containsForAll SourceType
kind)) forall a b. (a -> b) -> a -> b
$ do
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ KindSignatureFor
-> ProperName 'TypeName -> SourceType -> SimpleErrorMessage
MissingKindDeclaration KindSignatureFor
TypeSynonymSig ProperName 'TypeName
name SourceType
kind
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, TypeKind
TypeSynonym) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)
               , typeSynonyms :: Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
typeSynonyms = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName ([(Text, Maybe SourceType)]
args, SourceType
ty) (Environment
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
typeSynonyms Environment
env) }

valueIsNotDefined
  :: (MonadState CheckState m, MonadError MultipleErrors m)
  => ModuleName
  -> Ident
  -> m ()
valueIsNotDefined :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName -> Ident -> m ()
valueIsNotDefined ModuleName
moduleName Ident
name = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) of
    Just (SourceType, NameKind, NameVisibility)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
RedefinedIdent Ident
name
    Maybe (SourceType, NameKind, NameVisibility)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

addValue
  :: (MonadState CheckState m)
  => ModuleName
  -> Ident
  -> SourceType
  -> NameKind
  -> m ()
addValue :: forall (m :: * -> *).
MonadState CheckState m =>
ModuleName -> Ident -> SourceType -> NameKind -> m ()
addValue ModuleName
moduleName Ident
name SourceType
ty NameKind
nameKind = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv (Environment
env { names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (SourceType
ty, NameKind
nameKind, NameVisibility
Defined) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) })

addTypeClass
  :: forall m
   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => ModuleName
  -> Qualified (ProperName 'ClassName)
  -> [(Text, Maybe SourceType)]
  -> [SourceConstraint]
  -> [FunctionalDependency]
  -> [Declaration]
  -> SourceType
  -> m ()
addTypeClass :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> [Declaration]
-> SourceType
-> m ()
addTypeClass ModuleName
_ Qualified (ProperName 'ClassName)
qualifiedClassName [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [FunctionalDependency]
dependencies [Declaration]
ds SourceType
kind = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  TypeClassData
newClass <- m TypeClassData
mkNewClass
  let qualName :: Qualified (ProperName 'TypeName)
qualName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName Qualified (ProperName 'ClassName)
qualifiedClassName
      hasSig :: Bool
hasSig = Qualified (ProperName 'TypeName)
qualName forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSig Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Type a -> Bool
containsForAll SourceType
kind)) forall a b. (a -> b) -> a -> b
$ do
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ KindSignatureFor
-> ProperName 'TypeName -> SourceType -> SimpleErrorMessage
MissingKindDeclaration KindSignatureFor
ClassSig (forall a. Qualified a -> a
disqualify Qualified (ProperName 'TypeName)
qualName) SourceType
kind
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (TypeClassData
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> (Ident, SourceType)
-> m ()
checkMemberIsUsable TypeClassData
newClass (Environment
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
typeSynonyms Environment
env) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)) [(Ident, SourceType)]
classMembers
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, [Role] -> TypeKind
ExternData (forall a. Type a -> [Role]
nominalRolesForKind SourceType
kind)) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)
               , typeClasses :: Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'ClassName)
qualifiedClassName TypeClassData
newClass (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env) }
  where
    classMembers :: [(Ident, SourceType)]
    classMembers :: [(Ident, SourceType)]
classMembers = forall a b. (a -> b) -> [a] -> [b]
map Declaration -> (Ident, SourceType)
toPair [Declaration]
ds

    mkNewClass :: m TypeClassData
    mkNewClass :: m TypeClassData
mkNewClass = do
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      [SourceConstraint]
implies' <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Functor f =>
([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)
overConstraintArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceConstraint]
implies
      let ctIsEmpty :: Bool
ctIsEmpty = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, SourceType)]
classMembers Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TypeClassData -> Bool
typeClassIsEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Environment -> Constraint a -> TypeClassData
findSuperClass Environment
env) [SourceConstraint]
implies'
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(Text, Maybe SourceType)]
-> [(Ident, SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> Bool
-> TypeClassData
makeTypeClassData [(Text, Maybe SourceType)]
args [(Ident, SourceType)]
classMembers [SourceConstraint]
implies' [FunctionalDependency]
dependencies Bool
ctIsEmpty
      where
      findSuperClass :: Environment -> Constraint a -> TypeClassData
findSuperClass Environment
env Constraint a
c = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Constraint a -> Qualified (ProperName 'ClassName)
constraintClass Constraint a
c) (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env) of
        Just TypeClassData
tcd -> TypeClassData
tcd
        Maybe TypeClassData
Nothing -> forall a. HasCallStack => String -> a
internalError String
"Unknown super class in TypeClassDeclaration"

    coveringSets :: TypeClassData -> [S.Set Int]
    coveringSets :: TypeClassData -> [Set Int]
coveringSets = forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeClassData -> Set (Set Int)
typeClassCoveringSets

    argToIndex :: Text -> Maybe Int
    argToIndex :: Text -> Maybe Int
argToIndex = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Maybe SourceType)]
args [Int
0..])

    toPair :: Declaration -> (Ident, SourceType)
toPair (TypeDeclaration (TypeDeclarationData SourceAnn
_ Ident
ident SourceType
ty)) = (Ident
ident, SourceType
ty)
    toPair Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid declaration in TypeClassDeclaration"

    -- Currently we are only checking usability based on the type class currently
    -- being defined.  If the mentioned arguments don't include a covering set,
    -- then we won't be able to find a instance.
    checkMemberIsUsable :: TypeClassData -> T.SynonymMap -> T.KindMap -> (Ident, SourceType) -> m ()
    checkMemberIsUsable :: TypeClassData
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> (Ident, SourceType)
-> m ()
checkMemberIsUsable TypeClassData
newClass Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
syns Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
kinds (Ident
ident, SourceType
memberTy) = do
      SourceType
memberTy' <- forall (m :: * -> *).
MonadError MultipleErrors m =>
Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> SourceType
-> m SourceType
T.replaceAllTypeSynonymsM Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
syns Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
kinds SourceType
memberTy
      let mentionedArgIndexes :: Set Int
mentionedArgIndexes = forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Int
argToIndex (forall a. Type a -> [Text]
freeTypeVariables SourceType
memberTy'))
      let leftovers :: [Set Int]
leftovers = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Int
mentionedArgIndexes) (TypeClassData -> [Set Int]
coveringSets TypeClassData
newClass)

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Set Int]
leftovers) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$
        let
          solutions :: [[Text]]
solutions = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Text, Maybe SourceType)]
args forall a. [a] -> Int -> a
!!)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList) [Set Int]
leftovers
        in
          Ident -> [[Text]] -> SimpleErrorMessage
UnusableDeclaration Ident
ident (forall a. Eq a => [a] -> [a]
nub [[Text]]
solutions)

addTypeClassDictionaries
  :: (MonadState CheckState m)
  => QualifiedBy
  -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
  -> m ()
addTypeClassDictionaries :: forall (m :: * -> *).
MonadState CheckState m =>
QualifiedBy
-> Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict))
-> m ()
addTypeClassDictionaries QualifiedBy
mn Map
  (Qualified (ProperName 'ClassName))
  (Map (Qualified Ident) (NonEmpty NamedDict))
entries =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkEnv :: Environment
checkEnv = (CheckState -> Environment
checkEnv CheckState
st) { typeClassDictionaries :: Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries = CheckState
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
insertState CheckState
st } }
  where insertState :: CheckState
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
insertState CheckState
st = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Semigroup a => a -> a -> a
(<>))) QualifiedBy
mn Map
  (Qualified (ProperName 'ClassName))
  (Map (Qualified Ident) (NonEmpty NamedDict))
entries (Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv forall a b. (a -> b) -> a -> b
$ CheckState
st)

checkDuplicateTypeArguments
  :: (MonadState CheckState m, MonadError MultipleErrors m)
  => [Text]
  -> m ()
checkDuplicateTypeArguments :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments [Text]
args = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
firstDup forall a b. (a -> b) -> a -> b
$ \Text
dup ->
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Text -> SimpleErrorMessage
DuplicateTypeArgument Text
dup
  where
  firstDup :: Maybe Text
  firstDup :: Maybe Text
firstDup = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [Text]
args forall a. Eq a => [a] -> [a] -> [a]
\\ forall a. Ord a => [a] -> [a]
ordNub [Text]
args

checkTypeClassInstance
  :: (MonadState CheckState m, MonadError MultipleErrors m)
  => TypeClassData
  -> Int -- ^ index of type class argument
  -> SourceType
  -> m ()
checkTypeClassInstance :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
TypeClassData -> Int -> SourceType -> m ()
checkTypeClassInstance TypeClassData
cls Int
i = SourceType -> m ()
check where
  -- If the argument is determined via fundeps then we are less restrictive in
  -- what type is allowed. This is because the type cannot be used to influence
  -- which instance is selected. Currently the only weakened restriction is that
  -- row types are allowed in determined type class arguments.
  isFunDepDetermined :: Bool
isFunDepDetermined = forall a. Ord a => a -> Set a -> Bool
S.member Int
i (TypeClassData -> Set Int
typeClassDeterminedArguments TypeClassData
cls)
  check :: SourceType -> m ()
check = \case
    TypeVar SourceAnn
_ Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TypeLevelString SourceAnn
_ PSString
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TypeLevelInt SourceAnn
_ Integer
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TypeConstructor SourceAnn
_ Qualified (ProperName 'TypeName)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TypeApp SourceAnn
_ SourceType
t1 SourceType
t2 -> SourceType -> m ()
check SourceType
t1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SourceType -> m ()
check SourceType
t2
    KindApp SourceAnn
_ SourceType
t SourceType
k -> SourceType -> m ()
check SourceType
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SourceType -> m ()
check SourceType
k
    KindedType SourceAnn
_ SourceType
t SourceType
_ -> SourceType -> m ()
check SourceType
t
    REmpty SourceAnn
_ | Bool
isFunDepDetermined -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    RCons SourceAnn
_ Label
_ SourceType
hd SourceType
tl | Bool
isFunDepDetermined -> SourceType -> m ()
check SourceType
hd forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SourceType -> m ()
check SourceType
tl
    SourceType
ty -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ SourceType -> SimpleErrorMessage
InvalidInstanceHead SourceType
ty

-- |
-- Check that type synonyms are fully-applied in a type
--
checkTypeSynonyms
  :: (MonadState CheckState m, MonadError MultipleErrors m)
  => SourceType
  -> m ()
checkTypeSynonyms :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceType -> m ()
checkTypeSynonyms = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms

-- |
-- Type check all declarations in a module
--
-- At this point, many declarations will have been desugared, but it is still necessary to
--
--  * Kind-check all types and add them to the @Environment@
--
--  * Type-check all values and add them to the @Environment@
--
--  * Infer all type roles and add them to the @Environment@
--
--  * Bring type class instances into scope
--
--  * Process module imports
--
typeCheckAll
  :: forall m
   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => ModuleName
  -> [Declaration]
  -> m [Declaration]
typeCheckAll :: forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
 MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
ModuleName -> [Declaration] -> m [Declaration]
typeCheckAll ModuleName
moduleName = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Declaration -> m Declaration
go
  where
  go :: Declaration -> m Declaration
  go :: Declaration -> m Declaration
go (DataDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType)]
args [DataConstructorDeclaration]
dctors) = do
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInTypeConstructor ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DataDeclType
dtype forall a. Eq a => a -> a -> Bool
== DataDeclType
Newtype) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName
-> [DataConstructorDeclaration]
-> m (DataConstructorDeclaration, (Ident, SourceType))
checkNewtype ProperName 'TypeName
name [DataConstructorDeclaration]
dctors
      forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
args
      ([(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
ctorKind) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
    [DataConstructorDeclaration])
-> m ([(DataConstructorDeclaration, SourceType)], SourceType)
kindOfData ModuleName
moduleName (SourceAnn
sa, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, [DataConstructorDeclaration]
dctors)
      let args' :: [(Text, Maybe SourceType)]
args' = [(Text, Maybe SourceType)]
args [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
`withKinds` SourceType
ctorKind
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      [DataConstructorDeclaration]
dctors' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (DataConstructorDeclaration -> m DataConstructorDeclaration
replaceTypeSynonymsInDataConstructor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(DataConstructorDeclaration, SourceType)]
dataCtors
      let args'' :: [(Text, Maybe SourceType, Role)]
args'' = [(Text, Maybe SourceType)]
args' [(Text, Maybe SourceType)]
-> [Role] -> [(Text, Maybe SourceType, Role)]
`withRoles` Environment
-> ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> [DataConstructorDeclaration]
-> [Role]
inferRoles Environment
env ModuleName
moduleName ProperName 'TypeName
name [(Text, Maybe SourceType)]
args' [DataConstructorDeclaration]
dctors'
      forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType, Role)]
-> [(DataConstructorDeclaration, SourceType)]
-> SourceType
-> m ()
addDataType ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType, Role)]
args'' [(DataConstructorDeclaration, SourceType)]
dataCtors SourceType
ctorKind
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> [DataConstructorDeclaration]
-> Declaration
DataDeclaration SourceAnn
sa DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType)]
args [DataConstructorDeclaration]
dctors
  go d :: Declaration
d@(DataBindingGroupDeclaration NonEmpty Declaration
tys) = do
    let tysList :: [Declaration]
tysList = forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Declaration
tys
        syns :: [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
  SourceType)]
syns = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration
-> Maybe
     (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
      SourceType)
toTypeSynonym [Declaration]
tysList
        dataDecls :: [(DataDeclType,
  (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
   [DataConstructorDeclaration]))]
dataDecls = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration
-> Maybe
     (DataDeclType,
      (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
       [DataConstructorDeclaration]))
toDataDecl [Declaration]
tysList
        roleDecls :: [RoleDeclarationData]
roleDecls = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe RoleDeclarationData
toRoleDecl [Declaration]
tysList
        clss :: [([FunctionalDependency],
  (SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
   [SourceConstraint], [Declaration]))]
clss = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration
-> Maybe
     ([FunctionalDependency],
      (SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
       [SourceConstraint], [Declaration]))
toClassDecl [Declaration]
tysList
        bindingGroupNames :: [ProperName 'TypeName]
bindingGroupNames = forall a. Ord a => [a] -> [a]
ordNub (([(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
  SourceType)]
syns forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) forall a. [a] -> [a] -> [a]
++ ([(DataDeclType,
  (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
   [DataConstructorDeclaration]))]
dataDecls forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ([([FunctionalDependency],
  (SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
   [SourceConstraint], [Declaration]))]
clss forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2))
        sss :: NonEmpty SourceSpan
sss = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Declaration -> SourceSpan
declSourceSpan NonEmpty Declaration
tys
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint ([ProperName 'TypeName] -> ErrorMessageHint
ErrorInDataBindingGroup [ProperName 'TypeName]
bindingGroupNames) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (NonEmpty SourceSpan -> ErrorMessageHint
PositionedError NonEmpty SourceSpan
sss)) forall a b. (a -> b) -> a -> b
$ do
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      ([TypeDeclarationResult]
syn_ks, [([(DataConstructorDeclaration, SourceType)], SourceType)]
data_ks, [ClassDeclarationResult]
cls_ks) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
     SourceType)]
-> [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
     [DataConstructorDeclaration])]
-> [(SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
     [SourceConstraint], [Declaration])]
-> m ([TypeDeclarationResult],
      [([(DataConstructorDeclaration, SourceType)], SourceType)],
      [ClassDeclarationResult])
kindsOfAll ModuleName
moduleName [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
  SourceType)]
syns (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [(DataDeclType,
  (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
   [DataConstructorDeclaration]))]
dataDecls) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [([FunctionalDependency],
  (SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
   [SourceConstraint], [Declaration]))]
clss)
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a b. [a] -> [b] -> [(a, b)]
zip [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
  SourceType)]
syns [TypeDeclarationResult]
syn_ks) forall a b. (a -> b) -> a -> b
$ \((SourceAnn
_, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, SourceType
_), (SourceType
elabTy, SourceType
kind)) -> do
        forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
args
        let args' :: [(Text, Maybe SourceType)]
args' = [(Text, Maybe SourceType)]
args [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
`withKinds` SourceType
kind
        forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> SourceType
-> m ()
addTypeSynonym ModuleName
moduleName ProperName 'TypeName
name [(Text, Maybe SourceType)]
args' SourceType
elabTy SourceType
kind
      let dataDeclsWithKinds :: [(DataDeclType, ProperName 'TypeName, [(Text, Maybe SourceType)],
  [(DataConstructorDeclaration, SourceType)], SourceType)]
dataDeclsWithKinds = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(DataDeclType
dtype, (SourceAnn
_, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, [DataConstructorDeclaration]
_)) ([(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
ctorKind) ->
            (DataDeclType
dtype, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
`withKinds` SourceType
ctorKind, [(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
ctorKind)) [(DataDeclType,
  (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
   [DataConstructorDeclaration]))]
dataDecls [([(DataConstructorDeclaration, SourceType)], SourceType)]
data_ks
      ProperName 'TypeName -> [(Text, Maybe SourceType)] -> [Role]
inferRoles' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Environment
-> ModuleName
-> [RoleDeclarationData]
-> [DataDeclaration]
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> [Role]
inferDataBindingGroupRoles Environment
env ModuleName
moduleName [RoleDeclarationData]
roleDecls) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(DataDeclType, ProperName 'TypeName, [(Text, Maybe SourceType)],
  [(DataConstructorDeclaration, SourceType)], SourceType)]
dataDeclsWithKinds forall a b. (a -> b) -> a -> b
$ \(DataDeclType
_, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, [(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
_) ->
          (ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (DataConstructorDeclaration -> m DataConstructorDeclaration
replaceTypeSynonymsInDataConstructor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(DataConstructorDeclaration, SourceType)]
dataCtors
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(DataDeclType, ProperName 'TypeName, [(Text, Maybe SourceType)],
  [(DataConstructorDeclaration, SourceType)], SourceType)]
dataDeclsWithKinds forall a b. (a -> b) -> a -> b
$ \(DataDeclType
dtype, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args', [(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
ctorKind) -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DataDeclType
dtype forall a. Eq a => a -> a -> Bool
== DataDeclType
Newtype) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName
-> [DataConstructorDeclaration]
-> m (DataConstructorDeclaration, (Ident, SourceType))
checkNewtype ProperName 'TypeName
name (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(DataConstructorDeclaration, SourceType)]
dataCtors)
        forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
args'
        let args'' :: [(Text, Maybe SourceType, Role)]
args'' = [(Text, Maybe SourceType)]
args' [(Text, Maybe SourceType)]
-> [Role] -> [(Text, Maybe SourceType, Role)]
`withRoles` ProperName 'TypeName -> [(Text, Maybe SourceType)] -> [Role]
inferRoles' ProperName 'TypeName
name [(Text, Maybe SourceType)]
args'
        forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType, Role)]
-> [(DataConstructorDeclaration, SourceType)]
-> SourceType
-> m ()
addDataType ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType, Role)]
args'' [(DataConstructorDeclaration, SourceType)]
dataCtors SourceType
ctorKind
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [RoleDeclarationData]
roleDecls forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName -> RoleDeclarationData -> m ()
checkRoleDeclaration ModuleName
moduleName
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a b. [a] -> [b] -> [(a, b)]
zip [([FunctionalDependency],
  (SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
   [SourceConstraint], [Declaration]))]
clss [ClassDeclarationResult]
cls_ks) forall a b. (a -> b) -> a -> b
$ \(([FunctionalDependency]
deps, (SourceAnn
sa, ProperName 'ClassName
pn, [(Text, Maybe SourceType)]
_, [SourceConstraint]
_, [Declaration]
_)), ([(Text, SourceType)]
args', [SourceConstraint]
implies', [Declaration]
tys', SourceType
kind)) -> do
        let qualifiedClassName :: Qualified (ProperName 'ClassName)
qualifiedClassName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'ClassName
pn
        forall e (m :: * -> *). MonadError e m => e -> Bool -> m ()
guardWith (SimpleErrorMessage -> MultipleErrors
errorMessage (ProperName 'ClassName -> SourceSpan -> SimpleErrorMessage
DuplicateTypeClass ProperName 'ClassName
pn (forall a b. (a, b) -> a
fst SourceAnn
sa))) forall a b. (a -> b) -> a -> b
$
          Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member Qualified (ProperName 'ClassName)
qualifiedClassName (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env))
        forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> [Declaration]
-> SourceType
-> m ()
addTypeClass ModuleName
moduleName Qualified (ProperName 'ClassName)
qualifiedClassName (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, SourceType)]
args') [SourceConstraint]
implies' [FunctionalDependency]
deps [Declaration]
tys' SourceType
kind
    forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
    where
    toTypeSynonym :: Declaration
-> Maybe
     (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
      SourceType)
toTypeSynonym (TypeSynonymDeclaration SourceAnn
sa ProperName 'TypeName
nm [(Text, Maybe SourceType)]
args SourceType
ty) = forall a. a -> Maybe a
Just (SourceAnn
sa, ProperName 'TypeName
nm, [(Text, Maybe SourceType)]
args, SourceType
ty)
    toTypeSynonym Declaration
_ = forall a. Maybe a
Nothing
    toDataDecl :: Declaration
-> Maybe
     (DataDeclType,
      (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
       [DataConstructorDeclaration]))
toDataDecl (DataDeclaration SourceAnn
sa DataDeclType
dtype ProperName 'TypeName
nm [(Text, Maybe SourceType)]
args [DataConstructorDeclaration]
dctors) = forall a. a -> Maybe a
Just (DataDeclType
dtype, (SourceAnn
sa, ProperName 'TypeName
nm, [(Text, Maybe SourceType)]
args, [DataConstructorDeclaration]
dctors))
    toDataDecl Declaration
_ = forall a. Maybe a
Nothing
    toRoleDecl :: Declaration -> Maybe RoleDeclarationData
toRoleDecl (RoleDeclaration RoleDeclarationData
rdd) = forall a. a -> Maybe a
Just RoleDeclarationData
rdd
    toRoleDecl Declaration
_ = forall a. Maybe a
Nothing
    toClassDecl :: Declaration
-> Maybe
     ([FunctionalDependency],
      (SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
       [SourceConstraint], [Declaration]))
toClassDecl (TypeClassDeclaration SourceAnn
sa ProperName 'ClassName
nm [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [FunctionalDependency]
deps [Declaration]
decls) = forall a. a -> Maybe a
Just ([FunctionalDependency]
deps, (SourceAnn
sa, ProperName 'ClassName
nm, [(Text, Maybe SourceType)]
args, [SourceConstraint]
implies, [Declaration]
decls))
    toClassDecl Declaration
_ = forall a. Maybe a
Nothing
  go (TypeSynonymDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) ProperName 'TypeName
name [(Text, Maybe SourceType)]
args SourceType
ty) = do
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInTypeSynonym ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss) ) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
args
      (SourceType
elabTy, SourceType
kind) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
    SourceType)
-> m TypeDeclarationResult
kindOfTypeSynonym ModuleName
moduleName (SourceAnn
sa, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, SourceType
ty)
      let args' :: [(Text, Maybe SourceType)]
args' = [(Text, Maybe SourceType)]
args [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
`withKinds` SourceType
kind
      forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> SourceType
-> m ()
addTypeSynonym ModuleName
moduleName ProperName 'TypeName
name [(Text, Maybe SourceType)]
args' SourceType
elabTy SourceType
kind
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> Declaration
TypeSynonymDeclaration SourceAnn
sa ProperName 'TypeName
name [(Text, Maybe SourceType)]
args SourceType
ty
  go (KindDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) KindSignatureFor
kindFor ProperName 'TypeName
name SourceType
ty) = do
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInKindDeclaration ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
      SourceType
elabTy <- forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withFreshSubstitution forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m,
 MonadState CheckState m) =>
ModuleName -> SourceType -> m SourceType
checkKindDeclaration ModuleName
moduleName SourceType
ty
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name) (SourceType
elabTy, TypeKind
LocalTypeVariable) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> KindSignatureFor
-> ProperName 'TypeName
-> SourceType
-> Declaration
KindDeclaration SourceAnn
sa KindSignatureFor
kindFor ProperName 'TypeName
name SourceType
elabTy
  go d :: Declaration
d@(RoleDeclaration RoleDeclarationData
rdd) = do
    forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName -> RoleDeclarationData -> m ()
checkRoleDeclaration ModuleName
moduleName RoleDeclarationData
rdd
    forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
  go TypeDeclaration{} =
    forall a. HasCallStack => String -> a
internalError String
"Type declarations should have been removed before typeCheckAlld"
  go (ValueDecl sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) Ident
name NameKind
nameKind [] [MkUnguarded Expr
val]) = do
    Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
    let declHint :: MultipleErrors -> MultipleErrors
declHint = if Ident -> Bool
isPlainIdent Ident
name then ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (Ident -> ErrorMessageHint
ErrorInValueDeclaration Ident
name) else forall a. a -> a
id
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (MultipleErrors -> MultipleErrors
declHint forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
      Expr
val' <- forall (m :: * -> *).
MonadWriter MultipleErrors m =>
SourceSpan -> Environment -> ModuleName -> Expr -> m Expr
checkExhaustiveExpr SourceSpan
ss Environment
env ModuleName
moduleName Expr
val
      forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName -> Ident -> m ()
valueIsNotDefined ModuleName
moduleName Ident
name
      forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
 MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
BindingGroupType
-> ModuleName
-> [((SourceAnn, Ident), Expr)]
-> m [((SourceAnn, Ident), (Expr, SourceType))]
typesOf BindingGroupType
NonRecursiveBindingGroup ModuleName
moduleName [((SourceAnn
sa, Ident
name), Expr
val')] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [((SourceAnn, Ident)
_, (Expr
val'', SourceType
ty))] -> do
          forall (m :: * -> *).
MonadState CheckState m =>
ModuleName -> Ident -> SourceType -> NameKind -> m ()
addValue ModuleName
moduleName Ident
name SourceType
ty NameKind
nameKind
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
name NameKind
nameKind [] [Expr -> GuardedExpr
MkUnguarded Expr
val'']
        [((SourceAnn, Ident), (Expr, SourceType))]
_ -> forall a. HasCallStack => String -> a
internalError String
"typesOf did not return a singleton"
  go ValueDeclaration{} = forall a. HasCallStack => String -> a
internalError String
"Binders were not desugared"
  go BoundValueDeclaration{} = forall a. HasCallStack => String -> a
internalError String
"BoundValueDeclaration should be desugared"
  go (BindingGroupDeclaration NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals) = do
    Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
    let sss :: NonEmpty SourceSpan
sss = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(((SourceSpan
ss, [Comment]
_), Ident
_), NameKind
_, Expr
_) -> SourceSpan
ss) NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (NonEmpty Ident -> ErrorMessageHint
ErrorInBindingGroup (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((SourceAnn
_, Ident
ident), NameKind
_, Expr
_) -> Ident
ident) NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (NonEmpty SourceSpan -> ErrorMessageHint
PositionedError NonEmpty SourceSpan
sss)) forall a b. (a -> b) -> a -> b
$ do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals forall a b. (a -> b) -> a -> b
$ \((SourceAnn
_, Ident
ident), NameKind
_, Expr
_) -> forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName -> Ident -> m ()
valueIsNotDefined ModuleName
moduleName Ident
ident
      [((SourceAnn, Ident), NameKind, Expr)]
vals' <- forall a. NonEmpty a -> [a]
NEL.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(sai :: (SourceAnn, Ident)
sai@((SourceSpan
ss, [Comment]
_), Ident
_), NameKind
nk, Expr
expr) -> ((SourceAnn, Ident)
sai, NameKind
nk,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadWriter MultipleErrors m =>
SourceSpan -> Environment -> ModuleName -> Expr -> m Expr
checkExhaustiveExpr SourceSpan
ss Environment
env ModuleName
moduleName Expr
expr) NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals
      [((SourceAnn, Ident), (Expr, SourceType))]
tys <- forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
 MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
BindingGroupType
-> ModuleName
-> [((SourceAnn, Ident), Expr)]
-> m [((SourceAnn, Ident), (Expr, SourceType))]
typesOf BindingGroupType
RecursiveBindingGroup ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((SourceAnn, Ident)
sai, NameKind
_, Expr
ty) -> ((SourceAnn, Ident)
sai, Expr
ty)) [((SourceAnn, Ident), NameKind, Expr)]
vals'
      [((SourceAnn, Ident), NameKind, Expr)]
vals'' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ ((SourceAnn, Ident)
sai, Expr
val, NameKind
nameKind, SourceType
ty)
                     | (sai :: (SourceAnn, Ident)
sai@(SourceAnn
_, Ident
name), NameKind
nameKind, Expr
_) <- [((SourceAnn, Ident), NameKind, Expr)]
vals'
                     , ((SourceAnn
_, Ident
name'), (Expr
val, SourceType
ty)) <- [((SourceAnn, Ident), (Expr, SourceType))]
tys
                     , Ident
name forall a. Eq a => a -> a -> Bool
== Ident
name'
                     ] forall a b. (a -> b) -> a -> b
$ \(sai :: (SourceAnn, Ident)
sai@(SourceAnn
_, Ident
name), Expr
val, NameKind
nameKind, SourceType
ty) -> do
        forall (m :: * -> *).
MonadState CheckState m =>
ModuleName -> Ident -> SourceType -> NameKind -> m ()
addValue ModuleName
moduleName Ident
name SourceType
ty NameKind
nameKind
        forall (m :: * -> *) a. Monad m => a -> m a
return ((SourceAnn, Ident)
sai, NameKind
nameKind, Expr
val)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ((SourceAnn, Ident), NameKind, Expr) -> Declaration
BindingGroupDeclaration forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NEL.fromList [((SourceAnn, Ident), NameKind, Expr)]
vals''
  go d :: Declaration
d@(ExternDataDeclaration (SourceSpan
ss, [Comment]
_) ProperName 'TypeName
name SourceType
kind) = do
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInForeignImportData ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
      SourceType
elabKind <- forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withFreshSubstitution forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m,
 MonadState CheckState m) =>
ModuleName -> SourceType -> m SourceType
checkKindDeclaration ModuleName
moduleName SourceType
kind
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      let qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
          roles :: [Role]
roles = forall a. Type a -> [Role]
nominalRolesForKind SourceType
elabKind
      forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
elabKind, [Role] -> TypeKind
ExternData [Role]
roles) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
      forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
  go d :: Declaration
d@(ExternDeclaration (SourceSpan
ss, [Comment]
_) Ident
name SourceType
ty) = do
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (Ident -> ErrorMessageHint
ErrorInForeignImport Ident
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      (SourceType
elabTy, SourceType
kind) <- forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withFreshSubstitution forall a b. (a -> b) -> a -> b
$ do
        (([(Int, SourceType)]
unks, SourceType
ty'), SourceType
kind) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 HasCallStack) =>
SourceType -> m (([(Int, SourceType)], SourceType), SourceType)
kindOfWithUnknowns SourceType
ty
        SourceType
ty'' <- forall (m :: * -> *).
MonadState CheckState m =>
[(Int, SourceType)] -> SourceType -> m SourceType
varIfUnknown [(Int, SourceType)]
unks SourceType
ty'
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceType
ty'', SourceType
kind)
      forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 HasCallStack) =>
SourceType -> SourceType -> m ()
checkTypeKind SourceType
elabTy SourceType
kind
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) of
        Just (SourceType, NameKind, NameVisibility)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
RedefinedIdent Ident
name
        Maybe (SourceType, NameKind, NameVisibility)
Nothing -> forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv (Environment
env { names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (SourceType
elabTy, NameKind
External, NameVisibility
Defined) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) })
    forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
  go d :: Declaration
d@FixityDeclaration{} = forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
  go d :: Declaration
d@ImportDeclaration{} = forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
  go d :: Declaration
d@(TypeClassDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) ProperName 'ClassName
pn [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [FunctionalDependency]
deps [Declaration]
tys) = do
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'ClassName -> ErrorMessageHint
ErrorInTypeClassDeclaration ProperName 'ClassName
pn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      let qualifiedClassName :: Qualified (ProperName 'ClassName)
qualifiedClassName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'ClassName
pn
      forall e (m :: * -> *). MonadError e m => e -> Bool -> m ()
guardWith (SimpleErrorMessage -> MultipleErrors
errorMessage (ProperName 'ClassName -> SourceSpan -> SimpleErrorMessage
DuplicateTypeClass ProperName 'ClassName
pn SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$
        Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member Qualified (ProperName 'ClassName)
qualifiedClassName (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env))
      ([(Text, SourceType)]
args', [SourceConstraint]
implies', [Declaration]
tys', SourceType
kind) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> (SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
    [SourceConstraint], [Declaration])
-> m ClassDeclarationResult
kindOfClass ModuleName
moduleName (SourceAnn
sa, ProperName 'ClassName
pn, [(Text, Maybe SourceType)]
args, [SourceConstraint]
implies, [Declaration]
tys)
      forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> [Declaration]
-> SourceType
-> m ()
addTypeClass ModuleName
moduleName Qualified (ProperName 'ClassName)
qualifiedClassName (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, SourceType)]
args') [SourceConstraint]
implies' [FunctionalDependency]
deps [Declaration]
tys' SourceType
kind
      forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
  go (TypeInstanceDeclaration SourceAnn
_ SourceAnn
_ ChainId
_ Integer
_ (Left Text
_) [SourceConstraint]
_ Qualified (ProperName 'ClassName)
_ [SourceType]
_ TypeInstanceBody
_) = forall a. HasCallStack => String -> a
internalError String
"typeCheckAll: type class instance generated name should have been desugared"
  go d :: Declaration
d@(TypeInstanceDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) SourceAnn
_ ChainId
ch Integer
idx (Right Ident
dictName) [SourceConstraint]
deps Qualified (ProperName 'ClassName)
className [SourceType]
tys TypeInstanceBody
body) =
    forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (Qualified (ProperName 'ClassName)
-> [SourceType] -> ErrorMessageHint
ErrorInInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      let qualifiedDictName :: Qualified Ident
qualifiedDictName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
dictName
      forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_) (Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries Environment
env) forall a b. (a -> b) -> a -> b
$ \Map (Qualified Ident) (NonEmpty NamedDict)
dictionaries ->
        forall e (m :: * -> *). MonadError e m => e -> Bool -> m ()
guardWith (SimpleErrorMessage -> MultipleErrors
errorMessage (Ident -> SourceSpan -> SimpleErrorMessage
DuplicateInstance Ident
dictName SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$
          Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member Qualified Ident
qualifiedDictName Map (Qualified Ident) (NonEmpty NamedDict)
dictionaries)
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
className (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env) of
        Maybe TypeClassData
Nothing -> forall a. HasCallStack => String -> a
internalError String
"typeCheckAll: Encountered unknown type class in instance declaration"
        Just TypeClassData
typeClass -> do
          Ident
-> Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> m ()
checkInstanceArity Ident
dictName Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys
          ([SourceConstraint]
deps', [SourceType]
kinds', [SourceType]
tys', [(Text, SourceType)]
vars) <- forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withFreshSubstitution forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> InstanceDeclarationArgs
-> m ([SourceConstraint], [SourceType], [SourceType],
      [(Text, SourceType)])
checkInstanceDeclaration ModuleName
moduleName (SourceAnn
sa, [SourceConstraint]
deps, Qualified (ProperName 'ClassName)
className, [SourceType]
tys)
          [SourceType]
tys'' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceType]
tys'
          forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
TypeClassData -> Int -> SourceType -> m ()
checkTypeClassInstance TypeClassData
typeClass) [Int
0..] [SourceType]
tys''
          let nonOrphanModules :: Set ModuleName
nonOrphanModules = Qualified (ProperName 'ClassName)
-> TypeClassData -> [SourceType] -> Set ModuleName
findNonOrphanModules Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys''
          Ident
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> Set ModuleName
-> m ()
checkOrphanInstance Ident
dictName Qualified (ProperName 'ClassName)
className [SourceType]
tys'' Set ModuleName
nonOrphanModules
          let chainId :: Maybe ChainId
chainId = forall a. a -> Maybe a
Just ChainId
ch
          SourceSpan
-> Maybe ChainId
-> Ident
-> [(Text, SourceType)]
-> Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> Set ModuleName
-> m ()
checkOverlappingInstance SourceSpan
ss Maybe ChainId
chainId Ident
dictName [(Text, SourceType)]
vars Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys'' Set ModuleName
nonOrphanModules
          TypeInstanceBody
_ <- forall (f :: * -> *).
Applicative f =>
([Declaration] -> f [Declaration])
-> TypeInstanceBody -> f TypeInstanceBody
traverseTypeInstanceBody [Declaration] -> m [Declaration]
checkInstanceMembers TypeInstanceBody
body
          [SourceConstraint]
deps'' <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Functor f =>
([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)
overConstraintArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceConstraint]
deps'
          let dict :: NamedDict
dict =
                forall v.
Maybe ChainId
-> Integer
-> v
-> [(Qualified (ProperName 'ClassName), Integer)]
-> Qualified (ProperName 'ClassName)
-> [(Text, SourceType)]
-> [SourceType]
-> [SourceType]
-> Maybe [SourceConstraint]
-> Maybe SourceType
-> TypeClassDictionaryInScope v
TypeClassDictionaryInScope Maybe ChainId
chainId Integer
idx Qualified Ident
qualifiedDictName [] Qualified (ProperName 'ClassName)
className [(Text, SourceType)]
vars [SourceType]
kinds' [SourceType]
tys'' (forall a. a -> Maybe a
Just [SourceConstraint]
deps'') forall a b. (a -> b) -> a -> b
$
                  if Ident -> Bool
isPlainIdent Ident
dictName then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SourceSpan
-> [(Text, SourceType)]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> SourceType
srcInstanceType SourceSpan
ss [(Text, SourceType)]
vars Qualified (ProperName 'ClassName)
className [SourceType]
tys''
          forall (m :: * -> *).
MonadState CheckState m =>
QualifiedBy
-> Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict))
-> m ()
addTypeClassDictionaries (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. k -> a -> Map k a
M.singleton Qualified (ProperName 'ClassName)
className forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
M.singleton (forall v. TypeClassDictionaryInScope v -> v
tcdValue NamedDict
dict) (forall (f :: * -> *) a. Applicative f => a -> f a
pure NamedDict
dict)
          forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d

  checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> m ()
  checkInstanceArity :: Ident
-> Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> m ()
checkInstanceArity Ident
dictName Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys = do
    let typeClassArity :: Int
typeClassArity = forall (t :: * -> *) a. Foldable t => t a -> Int
length (TypeClassData -> [(Text, Maybe SourceType)]
typeClassArguments TypeClassData
typeClass)
        instanceArity :: Int
instanceArity = forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
typeClassArity forall a. Eq a => a -> a -> Bool
/= Int
instanceArity) forall a b. (a -> b) -> a -> b
$
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident
-> Qualified (ProperName 'ClassName)
-> Int
-> Int
-> SimpleErrorMessage
ClassInstanceArityMismatch Ident
dictName Qualified (ProperName 'ClassName)
className Int
typeClassArity Int
instanceArity

  checkInstanceMembers :: [Declaration] -> m [Declaration]
  checkInstanceMembers :: [Declaration] -> m [Declaration]
checkInstanceMembers [Declaration]
instDecls = do
    let idents :: [Ident]
idents = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [[a]]
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Ident
memberName forall a b. (a -> b) -> a -> b
$ [Declaration]
instDecls
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. Eq a => [a] -> Maybe a
firstDuplicate [Ident]
idents) forall a b. (a -> b) -> a -> b
$ \Ident
ident ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
DuplicateValueDeclaration Ident
ident
    forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
instDecls
    where
    memberName :: Declaration -> Ident
    memberName :: Declaration -> Ident
memberName (ValueDeclaration ValueDeclarationData [GuardedExpr]
vd) = forall a. ValueDeclarationData a -> Ident
valdeclIdent ValueDeclarationData [GuardedExpr]
vd
    memberName Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"checkInstanceMembers: Invalid declaration in type instance definition"

    firstDuplicate :: (Eq a) => [a] -> Maybe a
    firstDuplicate :: forall a. Eq a => [a] -> Maybe a
firstDuplicate (a
x : xs :: [a]
xs@(a
y : [a]
_))
      | a
x forall a. Eq a => a -> a -> Bool
== a
y = forall a. a -> Maybe a
Just a
x
      | Bool
otherwise = forall a. Eq a => [a] -> Maybe a
firstDuplicate [a]
xs
    firstDuplicate [a]
_ = forall a. Maybe a
Nothing

  findNonOrphanModules
    :: Qualified (ProperName 'ClassName)
    -> TypeClassData
    -> [SourceType]
    -> S.Set ModuleName
  findNonOrphanModules :: Qualified (ProperName 'ClassName)
-> TypeClassData -> [SourceType] -> Set ModuleName
findNonOrphanModules (Qualified (ByModuleName ModuleName
mn') ProperName 'ClassName
_) TypeClassData
typeClass [SourceType]
tys' = Set ModuleName
nonOrphanModules
    where
    nonOrphanModules :: S.Set ModuleName
    nonOrphanModules :: Set ModuleName
nonOrphanModules = forall a. Ord a => a -> Set a -> Set a
S.insert ModuleName
mn' Set ModuleName
nonOrphanModules'

    typeModule :: SourceType -> Maybe ModuleName
    typeModule :: SourceType -> Maybe ModuleName
typeModule (TypeVar SourceAnn
_ Text
_) = forall a. Maybe a
Nothing
    typeModule (TypeLevelString SourceAnn
_ PSString
_) = forall a. Maybe a
Nothing
    typeModule (TypeLevelInt SourceAnn
_ Integer
_) = forall a. Maybe a
Nothing
    typeModule (TypeConstructor SourceAnn
_ (Qualified (ByModuleName ModuleName
mn'') ProperName 'TypeName
_)) = forall a. a -> Maybe a
Just ModuleName
mn''
    typeModule (TypeConstructor SourceAnn
_ (Qualified (BySourcePos SourcePos
_) ProperName 'TypeName
_)) = forall a. HasCallStack => String -> a
internalError String
"Unqualified type name in findNonOrphanModules"
    typeModule (TypeApp SourceAnn
_ SourceType
t1 SourceType
_) = SourceType -> Maybe ModuleName
typeModule SourceType
t1
    typeModule (KindApp SourceAnn
_ SourceType
t1 SourceType
_) = SourceType -> Maybe ModuleName
typeModule SourceType
t1
    typeModule (KindedType SourceAnn
_ SourceType
t1 SourceType
_) = SourceType -> Maybe ModuleName
typeModule SourceType
t1
    typeModule SourceType
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid type in instance in findNonOrphanModules"

    modulesByTypeIndex :: M.Map Int (Maybe ModuleName)
    modulesByTypeIndex :: Map Int (Maybe ModuleName)
modulesByTypeIndex = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (SourceType -> Maybe ModuleName
typeModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SourceType]
tys'))

    lookupModule :: Int -> S.Set ModuleName
    lookupModule :: Int -> Set ModuleName
lookupModule Int
idx = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idx Map Int (Maybe ModuleName)
modulesByTypeIndex of
      Just Maybe ModuleName
ms -> forall a. Ord a => [a] -> Set a
S.fromList (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe ModuleName
ms)
      Maybe (Maybe ModuleName)
Nothing -> forall a. HasCallStack => String -> a
internalError String
"Unknown type index in findNonOrphanModules"

    -- If the instance is declared in a module that wouldn't be found based on a covering set
    -- then it is considered an orphan - because we'd have a situation in which we expect an
    -- instance but can't find it. So a valid module must be applicable across *all* covering
    -- sets - therefore we take the intersection of covering set modules.
    nonOrphanModules' :: S.Set ModuleName
    nonOrphanModules' :: Set ModuleName
nonOrphanModules' = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Ord a => Set a -> Set a -> Set a
S.intersection (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> Set ModuleName
lookupModule forall b a. Ord b => (a -> b) -> Set a -> Set b
`S.map` TypeClassData -> Set (Set Int)
typeClassCoveringSets TypeClassData
typeClass)
  findNonOrphanModules Qualified (ProperName 'ClassName)
_ TypeClassData
_ [SourceType]
_ = forall a. HasCallStack => String -> a
internalError String
"Unqualified class name in findNonOrphanModules"

  -- Check that the instance currently being declared doesn't overlap with any
  -- other instance in any module that this instance wouldn't be considered an
  -- orphan in.  There are overlapping instance situations that won't be caught
  -- by this, for example when combining multiparameter type classes with
  -- flexible instances: the instances `Cls X y` and `Cls x Y` overlap and
  -- could live in different modules but won't be caught here.
  checkOverlappingInstance
    :: SourceSpan
    -> Maybe ChainId
    -> Ident
    -> [(Text, SourceType)]
    -> Qualified (ProperName 'ClassName)
    -> TypeClassData
    -> [SourceType]
    -> S.Set ModuleName
    -> m ()
  checkOverlappingInstance :: SourceSpan
-> Maybe ChainId
-> Ident
-> [(Text, SourceType)]
-> Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> Set ModuleName
-> m ()
checkOverlappingInstance SourceSpan
ss Maybe ChainId
ch Ident
dictName [(Text, SourceType)]
vars Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys' Set ModuleName
nonOrphanModules = do
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set ModuleName
nonOrphanModules forall a b. (a -> b) -> a -> b
$ \ModuleName
m -> do
      [(Qualified Ident, NonEmpty NamedDict)]
dicts <- forall k a. Map k a -> [(k, a)]
M.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadState CheckState m =>
QualifiedBy
-> Qualified (ProperName 'ClassName)
-> m (Map (Qualified Ident) (NonEmpty NamedDict))
lookupTypeClassDictionariesForClass (ModuleName -> QualifiedBy
ByModuleName ModuleName
m) Qualified (ProperName 'ClassName)
className

      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Qualified Ident, NonEmpty NamedDict)]
dicts forall a b. (a -> b) -> a -> b
$ \(Qualified QualifiedBy
mn' Ident
ident, NonEmpty NamedDict
dictNel) -> do
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty NamedDict
dictNel forall a b. (a -> b) -> a -> b
$ \NamedDict
dict -> do
          -- ignore instances in the same instance chain
          if Maybe ChainId
ch forall a. Eq a => a -> a -> Bool
== forall v. TypeClassDictionaryInScope v -> Maybe ChainId
tcdChain NamedDict
dict Bool -> Bool -> Bool
||
            Set (Set Int) -> [SourceType] -> [SourceType] -> Bool
instancesAreApart (TypeClassData -> Set (Set Int)
typeClassCoveringSets TypeClassData
typeClass) [SourceType]
tys' (forall v. TypeClassDictionaryInScope v -> [SourceType]
tcdInstanceTypes NamedDict
dict)
          then forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else do
            let this :: Either SourceType Ident
this = if Ident -> Bool
isPlainIdent Ident
dictName then forall a b. b -> Either a b
Right Ident
dictName else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SourceSpan
-> [(Text, SourceType)]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> SourceType
srcInstanceType SourceSpan
ss [(Text, SourceType)]
vars Qualified (ProperName 'ClassName)
className [SourceType]
tys'
            let that :: Qualified (Either SourceType Ident)
that = forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
mn' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r l. r -> Maybe l -> Either l r
maybeToLeft Ident
ident forall a b. (a -> b) -> a -> b
$ forall v. TypeClassDictionaryInScope v -> Maybe SourceType
tcdDescription NamedDict
dict
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$
              Qualified (ProperName 'ClassName)
-> [SourceType]
-> [Qualified (Either SourceType Ident)]
-> SimpleErrorMessage
OverlappingInstances Qualified (ProperName 'ClassName)
className
                                    [SourceType]
tys'
                                    [Qualified (Either SourceType Ident)
that, forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Either SourceType Ident
this]

  instancesAreApart
    :: S.Set (S.Set Int)
    -> [SourceType]
    -> [SourceType]
    -> Bool
  instancesAreApart :: Set (Set Int) -> [SourceType] -> [SourceType] -> Bool
instancesAreApart Set (Set Int)
sets [SourceType]
lhs [SourceType]
rhs = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Int -> Bool
typesApart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList) (forall a. Set a -> [a]
S.toList Set (Set Int)
sets)
    where
      typesApart :: Int -> Bool
      typesApart :: Int -> Bool
typesApart Int
i = SourceType -> SourceType -> Bool
typeHeadsApart ([SourceType]
lhs forall a. [a] -> Int -> a
!! Int
i) ([SourceType]
rhs forall a. [a] -> Int -> a
!! Int
i)

      -- Note: implementation doesn't need to care about all possible cases:
      -- TUnknown, Skolem, etc.
      typeHeadsApart :: SourceType -> SourceType -> Bool
      typeHeadsApart :: SourceType -> SourceType -> Bool
typeHeadsApart SourceType
l                   SourceType
r             | forall a b. Type a -> Type b -> Bool
eqType SourceType
l SourceType
r = Bool
False
      typeHeadsApart (TypeVar SourceAnn
_ Text
_)       SourceType
_                          = Bool
False
      typeHeadsApart SourceType
_                   (TypeVar SourceAnn
_ Text
_)              = Bool
False
      typeHeadsApart (KindedType SourceAnn
_ SourceType
t1 SourceType
_) SourceType
t2                         = SourceType -> SourceType -> Bool
typeHeadsApart SourceType
t1 SourceType
t2
      typeHeadsApart SourceType
t1                  (KindedType SourceAnn
_ SourceType
t2 SourceType
_)        = SourceType -> SourceType -> Bool
typeHeadsApart SourceType
t1 SourceType
t2
      typeHeadsApart (TypeApp SourceAnn
_ SourceType
h1 SourceType
t1)   (TypeApp SourceAnn
_ SourceType
h2 SourceType
t2)          = SourceType -> SourceType -> Bool
typeHeadsApart SourceType
h1 SourceType
h2 Bool -> Bool -> Bool
|| SourceType -> SourceType -> Bool
typeHeadsApart SourceType
t1 SourceType
t2
      typeHeadsApart SourceType
_                   SourceType
_                          = Bool
True

  checkOrphanInstance
    :: Ident
    -> Qualified (ProperName 'ClassName)
    -> [SourceType]
    -> S.Set ModuleName
    -> m ()
  checkOrphanInstance :: Ident
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> Set ModuleName
-> m ()
checkOrphanInstance Ident
dictName Qualified (ProperName 'ClassName)
className [SourceType]
tys' Set ModuleName
nonOrphanModules
    | ModuleName
moduleName forall a. Ord a => a -> Set a -> Bool
`S.member` Set ModuleName
nonOrphanModules = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident
-> Qualified (ProperName 'ClassName)
-> Set ModuleName
-> [SourceType]
-> SimpleErrorMessage
OrphanInstance Ident
dictName Qualified (ProperName 'ClassName)
className Set ModuleName
nonOrphanModules [SourceType]
tys'

  -- |
  -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
  -- extracted from the kind of the type constructor itself.
  --
  withKinds :: [(Text, Maybe SourceType)] -> SourceType -> [(Text, Maybe SourceType)]
  withKinds :: [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [] SourceType
_ = []
  withKinds [(Text, Maybe SourceType)]
ss (ForAll SourceAnn
_ Text
_ Maybe SourceType
_ SourceType
k Maybe SkolemScope
_) = [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [(Text, Maybe SourceType)]
ss SourceType
k
  withKinds (s :: (Text, Maybe SourceType)
s@(Text
_, Just SourceType
_):[(Text, Maybe SourceType)]
ss) (TypeApp SourceAnn
_ (TypeApp SourceAnn
_ SourceType
tyFn SourceType
_) SourceType
k2) | forall a b. Type a -> Type b -> Bool
eqType SourceType
tyFn SourceType
tyFunction = (Text, Maybe SourceType)
s forall a. a -> [a] -> [a]
: [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [(Text, Maybe SourceType)]
ss SourceType
k2
  withKinds ((Text
s, Maybe SourceType
Nothing):[(Text, Maybe SourceType)]
ss) (TypeApp SourceAnn
_ (TypeApp SourceAnn
_ SourceType
tyFn SourceType
k1) SourceType
k2) | forall a b. Type a -> Type b -> Bool
eqType SourceType
tyFn SourceType
tyFunction = (Text
s, forall a. a -> Maybe a
Just SourceType
k1) forall a. a -> [a] -> [a]
: [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [(Text, Maybe SourceType)]
ss SourceType
k2
  withKinds [(Text, Maybe SourceType)]
_ SourceType
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid arguments to withKinds"

  withRoles :: [(Text, Maybe SourceType)] -> [Role] -> [(Text, Maybe SourceType, Role)]
  withRoles :: [(Text, Maybe SourceType)]
-> [Role] -> [(Text, Maybe SourceType, Role)]
withRoles = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
$ \(Text
v, Maybe SourceType
k) Role
r -> (Text
v, Maybe SourceType
k, Role
r)

  replaceTypeSynonymsInDataConstructor :: DataConstructorDeclaration -> m DataConstructorDeclaration
  replaceTypeSynonymsInDataConstructor :: DataConstructorDeclaration -> m DataConstructorDeclaration
replaceTypeSynonymsInDataConstructor DataConstructorDeclaration{[(Ident, SourceType)]
SourceAnn
ProperName 'ConstructorName
dataCtorFields :: DataConstructorDeclaration -> [(Ident, SourceType)]
dataCtorName :: DataConstructorDeclaration -> ProperName 'ConstructorName
dataCtorAnn :: DataConstructorDeclaration -> SourceAnn
dataCtorFields :: [(Ident, SourceType)]
dataCtorName :: ProperName 'ConstructorName
dataCtorAnn :: SourceAnn
..} = do
    [(Ident, SourceType)]
dataCtorFields' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms) [(Ident, SourceType)]
dataCtorFields
    forall (m :: * -> *) a. Monad m => a -> m a
return DataConstructorDeclaration
      { dataCtorFields :: [(Ident, SourceType)]
dataCtorFields = [(Ident, SourceType)]
dataCtorFields'
      , SourceAnn
ProperName 'ConstructorName
dataCtorName :: ProperName 'ConstructorName
dataCtorAnn :: SourceAnn
dataCtorName :: ProperName 'ConstructorName
dataCtorAnn :: SourceAnn
..
      }

-- | Check that a newtype has just one data constructor with just one field, or
-- throw an error. If the newtype is valid, this function returns the single
-- data constructor declaration and the single field, as a 'proof' that the
-- newtype was indeed a valid newtype.
checkNewtype
  :: forall m
   . MonadError MultipleErrors m
  => ProperName 'TypeName
  -> [DataConstructorDeclaration]
  -> m (DataConstructorDeclaration, (Ident, SourceType))
checkNewtype :: forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName
-> [DataConstructorDeclaration]
-> m (DataConstructorDeclaration, (Ident, SourceType))
checkNewtype ProperName 'TypeName
_ [decl :: DataConstructorDeclaration
decl@(DataConstructorDeclaration SourceAnn
_ ProperName 'ConstructorName
_ [(Ident, SourceType)
field])] = forall (m :: * -> *) a. Monad m => a -> m a
return (DataConstructorDeclaration
decl, (Ident, SourceType)
field)
checkNewtype ProperName 'TypeName
name [DataConstructorDeclaration]
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
InvalidNewtype ProperName 'TypeName
name

-- |
-- Type check an entire module and ensure all types and classes defined within the module that are
-- required by exported members are also exported.
--
typeCheckModule
  :: forall m
   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => M.Map ModuleName Exports
  -> Module
  -> m Module
typeCheckModule :: forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
 MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Map ModuleName Exports -> Module -> m Module
typeCheckModule Map ModuleName Exports
_ (Module SourceSpan
_ [Comment]
_ ModuleName
_ [Declaration]
_ Maybe [DeclarationRef]
Nothing) =
  forall a. HasCallStack => String -> a
internalError String
"exports should have been elaborated before typeCheckModule"
typeCheckModule Map ModuleName Exports
modulesExports (Module SourceSpan
ss [Comment]
coms ModuleName
mn [Declaration]
decls (Just [DeclarationRef]
exps)) =
  forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
mn)) forall a b. (a -> b) -> a -> b
$ do
    let ([Declaration]
decls', [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
  Map
    (ProperName 'TypeName)
    ([ProperName 'ConstructorName], ExportSource))]
imports) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ Declaration
-> Either
     Declaration
     (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
      Map
        (ProperName 'TypeName)
        ([ProperName 'ConstructorName], ExportSource))
fromImportDecl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration]
decls
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CheckState
s -> CheckState
s { checkCurrentModule :: Maybe ModuleName
checkCurrentModule = forall a. a -> Maybe a
Just ModuleName
mn, checkCurrentModuleImports :: [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
  Map
    (ProperName 'TypeName)
    ([ProperName 'ConstructorName], ExportSource))]
checkCurrentModuleImports = [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
  Map
    (ProperName 'TypeName)
    ([ProperName 'ConstructorName], ExportSource))]
imports })
    [Declaration]
decls'' <- forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
 MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
ModuleName -> [Declaration] -> m [Declaration]
typeCheckAll ModuleName
mn forall a b. (a -> b) -> a -> b
$ Declaration -> Declaration
ignoreWildcardsUnderCompleteTypeSignatures forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration]
decls'
    DeclarationRef -> m ()
checkSuperClassesAreExported <- m (DeclarationRef -> m ())
getSuperClassExportCheck
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [DeclarationRef]
exps forall a b. (a -> b) -> a -> b
$ \DeclarationRef
e -> do
      DeclarationRef -> m ()
checkTypesAreExported DeclarationRef
e
      DeclarationRef -> m ()
checkClassMembersAreExported DeclarationRef
e
      DeclarationRef -> m ()
checkClassesAreExported DeclarationRef
e
      DeclarationRef -> m ()
checkSuperClassesAreExported DeclarationRef
e
      DeclarationRef -> m ()
checkDataConstructorsAreExported DeclarationRef
e
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
mn (forall a b. (a -> b) -> [a] -> [b]
map (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
 Map
   (ProperName 'TypeName)
   ([ProperName 'ConstructorName], ExportSource))
-> Declaration
toImportDecl [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
  Map
    (ProperName 'TypeName)
    ([ProperName 'ConstructorName], ExportSource))]
imports forall a. [a] -> [a] -> [a]
++ [Declaration]
decls'') (forall a. a -> Maybe a
Just [DeclarationRef]
exps)
  where

  fromImportDecl
    :: Declaration
    -> Either Declaration
              ( SourceAnn
              , ModuleName
              , ImportDeclarationType
              , Maybe ModuleName
              , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
              )
  fromImportDecl :: Declaration
-> Either
     Declaration
     (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
      Map
        (ProperName 'TypeName)
        ([ProperName 'ConstructorName], ExportSource))
fromImportDecl (ImportDeclaration SourceAnn
sa ModuleName
moduleName ImportDeclarationType
importDeclarationType Maybe ModuleName
asModuleName) =
    forall a b. b -> Either a b
Right (SourceAnn
sa, ModuleName
moduleName, ImportDeclarationType
importDeclarationType, Maybe ModuleName
asModuleName, forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exports
-> Map
     (ProperName 'TypeName)
     ([ProperName 'ConstructorName], ExportSource)
exportedTypes forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
moduleName Map ModuleName Exports
modulesExports)
  fromImportDecl Declaration
decl = forall a b. a -> Either a b
Left Declaration
decl

  toImportDecl
    :: ( SourceAnn
       , ModuleName
       , ImportDeclarationType
       , Maybe ModuleName
       , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
       )
    -> Declaration
  toImportDecl :: (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
 Map
   (ProperName 'TypeName)
   ([ProperName 'ConstructorName], ExportSource))
-> Declaration
toImportDecl (SourceAnn
sa, ModuleName
moduleName, ImportDeclarationType
importDeclarationType, Maybe ModuleName
asModuleName, Map
  (ProperName 'TypeName)
  ([ProperName 'ConstructorName], ExportSource)
_) =
    SourceAnn
-> ModuleName
-> ImportDeclarationType
-> Maybe ModuleName
-> Declaration
ImportDeclaration SourceAnn
sa ModuleName
moduleName ImportDeclarationType
importDeclarationType Maybe ModuleName
asModuleName

  qualify' :: a -> Qualified a
  qualify' :: forall a. a -> Qualified a
qualify' = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn)

  getSuperClassExportCheck :: m (DeclarationRef -> m ())
getSuperClassExportCheck = do
    Map
  (Qualified (ProperName 'ClassName))
  (Set (Qualified (ProperName 'ClassName)))
classesToSuperClasses <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets
      ( forall a b k. (a -> b) -> Map k a -> Map k b
M.map
        ( forall a. Ord a => [a] -> Set a
S.fromList
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\(Qualified QualifiedBy
mn' ProperName 'ClassName
_) -> QualifiedBy
mn' forall a. Eq a => a -> a -> Bool
== ModuleName -> QualifiedBy
ByModuleName ModuleName
mn)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Constraint a -> Qualified (ProperName 'ClassName)
constraintClass
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeClassData -> [SourceConstraint]
typeClassSuperclasses
        )
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv
      )
    let
      -- A function that, given a class name, returns the set of
      -- transitive class dependencies that are defined in this
      -- module.
      transitiveSuperClassesFor
          :: Qualified (ProperName 'ClassName)
          -> S.Set (Qualified (ProperName 'ClassName))
      transitiveSuperClassesFor :: Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
transitiveSuperClassesFor Qualified (ProperName 'ClassName)
qname =
        forall a. Eq a => (a -> a) -> a -> a
untilSame
          (\Set (Qualified (ProperName 'ClassName))
s -> Set (Qualified (ProperName 'ClassName))
s forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Qualified (ProperName 'ClassName)
n -> forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
S.empty (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
n Map
  (Qualified (ProperName 'ClassName))
  (Set (Qualified (ProperName 'ClassName)))
classesToSuperClasses)) Set (Qualified (ProperName 'ClassName))
s)
          (forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
S.empty (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
qname Map
  (Qualified (ProperName 'ClassName))
  (Set (Qualified (ProperName 'ClassName)))
classesToSuperClasses))

      superClassesFor :: Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
superClassesFor Qualified (ProperName 'ClassName)
qname =
        forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
S.empty (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
qname Map
  (Qualified (ProperName 'ClassName))
  (Set (Qualified (ProperName 'ClassName)))
classesToSuperClasses)

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Qualified (ProperName 'ClassName)
 -> Set (Qualified (ProperName 'ClassName)))
-> (Qualified (ProperName 'ClassName)
    -> Set (Qualified (ProperName 'ClassName)))
-> DeclarationRef
-> m ()
checkSuperClassExport Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
superClassesFor Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
transitiveSuperClassesFor
  moduleClassExports :: S.Set (Qualified (ProperName 'ClassName))
  moduleClassExports :: Set (Qualified (ProperName 'ClassName))
moduleClassExports = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case
     TypeClassRef SourceSpan
_ ProperName 'ClassName
name -> forall a. a -> Maybe a
Just (forall a. a -> Qualified a
qualify' ProperName 'ClassName
name)
     DeclarationRef
_ -> forall a. Maybe a
Nothing) [DeclarationRef]
exps

  untilSame :: Eq a => (a -> a) -> a -> a
  untilSame :: forall a. Eq a => (a -> a) -> a -> a
untilSame a -> a
f a
a = let a' :: a
a' = a -> a
f a
a in if a
a forall a. Eq a => a -> a -> Bool
== a
a' then a
a else forall a. Eq a => (a -> a) -> a -> a
untilSame a -> a
f a
a'

  checkMemberExport :: (SourceType -> [DeclarationRef]) -> DeclarationRef -> m ()
  checkMemberExport :: (SourceType -> [DeclarationRef]) -> DeclarationRef -> m ()
checkMemberExport SourceType -> [DeclarationRef]
extract dr :: DeclarationRef
dr@(TypeRef SourceSpan
_ ProperName 'TypeName
name Maybe [ProperName 'ConstructorName]
dctors) = do
    Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. a -> Qualified a
qualify' ProperName 'TypeName
name) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)) forall a b. (a -> b) -> a -> b
$ \(SourceType
k, TypeKind
_) -> do
      -- TODO: remove?
      -- let findModuleKinds = everythingOnTypes (++) $ \case
      --       TypeConstructor _ (Qualified (ByModuleName mn') kindName) | mn' == mn -> [kindName]
      --       _ -> []
      DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr (SourceType -> [DeclarationRef]
extract SourceType
k)
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. a -> Qualified a
qualify' ProperName 'TypeName
name) (Environment
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
typeSynonyms Environment
env)) forall a b. (a -> b) -> a -> b
$ \([(Text, Maybe SourceType)]
_, SourceType
ty) ->
      DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr (SourceType -> [DeclarationRef]
extract SourceType
ty)
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe [ProperName 'ConstructorName]
dctors forall a b. (a -> b) -> a -> b
$ \[ProperName 'ConstructorName]
dctors' ->
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ProperName 'ConstructorName]
dctors' forall a b. (a -> b) -> a -> b
$ \ProperName 'ConstructorName
dctor ->
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. a -> Qualified a
qualify' ProperName 'ConstructorName
dctor) (Environment
-> Map
     (Qualified (ProperName 'ConstructorName))
     (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Environment
env)) forall a b. (a -> b) -> a -> b
$ \(DataDeclType
_, ProperName 'TypeName
_, SourceType
ty, [Ident]
_) ->
          DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr (SourceType -> [DeclarationRef]
extract SourceType
ty)
  checkMemberExport SourceType -> [DeclarationRef]
extract dr :: DeclarationRef
dr@(ValueRef SourceSpan
_ Ident
name) = do
    SourceType
ty <- forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
Qualified Ident -> m SourceType
lookupVariable (forall a. a -> Qualified a
qualify' Ident
name)
    DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr (SourceType -> [DeclarationRef]
extract SourceType
ty)
  checkMemberExport SourceType -> [DeclarationRef]
_ DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

  checkSuperClassExport
    :: (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName)))
    -> (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName)))
    -> DeclarationRef
    -> m ()
  checkSuperClassExport :: (Qualified (ProperName 'ClassName)
 -> Set (Qualified (ProperName 'ClassName)))
-> (Qualified (ProperName 'ClassName)
    -> Set (Qualified (ProperName 'ClassName)))
-> DeclarationRef
-> m ()
checkSuperClassExport Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
superClassesFor Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
transitiveSuperClassesFor dr :: DeclarationRef
dr@(TypeClassRef SourceSpan
drss ProperName 'ClassName
className) = do
    let superClasses :: Set (Qualified (ProperName 'ClassName))
superClasses = Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
superClassesFor (forall a. a -> Qualified a
qualify' ProperName 'ClassName
className)
        -- thanks to laziness, the computation of the transitive
        -- superclasses defined in-module will only occur if we actually
        -- throw the error. Constructing the full set of transitive
        -- superclasses is likely to be costly for every single term.
        transitiveSuperClasses :: Set (Qualified (ProperName 'ClassName))
transitiveSuperClasses = Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
transitiveSuperClassesFor (forall a. a -> Qualified a
qualify' ProperName 'ClassName
className)
        unexported :: Set (Qualified (ProperName 'ClassName))
unexported = forall a. Ord a => Set a -> Set a -> Set a
S.difference Set (Qualified (ProperName 'ClassName))
superClasses Set (Qualified (ProperName 'ClassName))
moduleClassExports
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set (Qualified (ProperName 'ClassName))
unexported)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
drss
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationRef -> [DeclarationRef] -> SimpleErrorMessage
TransitiveExportError DeclarationRef
dr
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (SourceSpan -> ProperName 'ClassName -> DeclarationRef
TypeClassRef SourceSpan
drss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Qualified a -> a
disqualify)
      forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (Qualified (ProperName 'ClassName))
transitiveSuperClasses
  checkSuperClassExport Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
_ Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
_ DeclarationRef
_ =
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

  checkExport :: DeclarationRef -> [DeclarationRef] -> m ()
  checkExport :: DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr [DeclarationRef]
drs = case forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationRef -> Bool
exported) [DeclarationRef]
drs of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [DeclarationRef]
hidden -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (DeclarationRef -> SourceSpan
declRefSourceSpan DeclarationRef
dr) forall a b. (a -> b) -> a -> b
$ DeclarationRef -> [DeclarationRef] -> SimpleErrorMessage
TransitiveExportError DeclarationRef
dr (forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy DeclarationRef -> DeclarationRef -> Bool
nubEq [DeclarationRef]
hidden)
    where
    exported :: DeclarationRef -> Bool
exported DeclarationRef
e = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (DeclarationRef -> DeclarationRef -> Bool
exports DeclarationRef
e) [DeclarationRef]
exps
    exports :: DeclarationRef -> DeclarationRef -> Bool
exports (TypeRef SourceSpan
_ ProperName 'TypeName
pn1 Maybe [ProperName 'ConstructorName]
_) (TypeRef SourceSpan
_ ProperName 'TypeName
pn2 Maybe [ProperName 'ConstructorName]
_) = ProperName 'TypeName
pn1 forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
pn2
    exports (ValueRef SourceSpan
_ Ident
id1) (ValueRef SourceSpan
_ Ident
id2) = Ident
id1 forall a. Eq a => a -> a -> Bool
== Ident
id2
    exports (TypeClassRef SourceSpan
_ ProperName 'ClassName
pn1) (TypeClassRef SourceSpan
_ ProperName 'ClassName
pn2) = ProperName 'ClassName
pn1 forall a. Eq a => a -> a -> Bool
== ProperName 'ClassName
pn2
    exports DeclarationRef
_ DeclarationRef
_ = Bool
False
    -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to
    -- `error` for the values generated here (we don't need them anyway)
    nubEq :: DeclarationRef -> DeclarationRef -> Bool
nubEq (TypeRef SourceSpan
_ ProperName 'TypeName
pn1 Maybe [ProperName 'ConstructorName]
_) (TypeRef SourceSpan
_ ProperName 'TypeName
pn2 Maybe [ProperName 'ConstructorName]
_) = ProperName 'TypeName
pn1 forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
pn2
    nubEq DeclarationRef
r1 DeclarationRef
r2 = DeclarationRef
r1 forall a. Eq a => a -> a -> Bool
== DeclarationRef
r2


  -- Check that all the type constructors defined in the current module that appear in member types
  -- have also been exported from the module
  checkTypesAreExported :: DeclarationRef -> m ()
  checkTypesAreExported :: DeclarationRef -> m ()
checkTypesAreExported DeclarationRef
ref = (SourceType -> [DeclarationRef]) -> DeclarationRef -> m ()
checkMemberExport SourceType -> [DeclarationRef]
findTcons DeclarationRef
ref
    where
    findTcons :: SourceType -> [DeclarationRef]
    findTcons :: SourceType -> [DeclarationRef]
findTcons = forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall a. [a] -> [a] -> [a]
(++) SourceType -> [DeclarationRef]
go
      where
      go :: SourceType -> [DeclarationRef]
go (TypeConstructor SourceAnn
_ (Qualified (ByModuleName ModuleName
mn') ProperName 'TypeName
name)) | ModuleName
mn' forall a. Eq a => a -> a -> Bool
== ModuleName
mn =
        [SourceSpan
-> ProperName 'TypeName
-> Maybe [ProperName 'ConstructorName]
-> DeclarationRef
TypeRef (DeclarationRef -> SourceSpan
declRefSourceSpan DeclarationRef
ref) ProperName 'TypeName
name (forall a. HasCallStack => String -> a
internalError String
"Data constructors unused in checkTypesAreExported")]
      go SourceType
_ = []

  -- Check that all the classes defined in the current module that appear in member types have also
  -- been exported from the module
  checkClassesAreExported :: DeclarationRef -> m ()
  checkClassesAreExported :: DeclarationRef -> m ()
checkClassesAreExported DeclarationRef
ref = (SourceType -> [DeclarationRef]) -> DeclarationRef -> m ()
checkMemberExport SourceType -> [DeclarationRef]
findClasses DeclarationRef
ref
    where
    findClasses :: SourceType -> [DeclarationRef]
    findClasses :: SourceType -> [DeclarationRef]
findClasses = forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall a. [a] -> [a] -> [a]
(++) SourceType -> [DeclarationRef]
go
      where
      go :: SourceType -> [DeclarationRef]
go (ConstrainedType SourceAnn
_ SourceConstraint
c SourceType
_) = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceSpan -> ProperName 'ClassName -> DeclarationRef
TypeClassRef (DeclarationRef -> SourceSpan
declRefSourceSpan DeclarationRef
ref)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified (ProperName 'ClassName) -> [ProperName 'ClassName]
extractCurrentModuleClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Constraint a -> Qualified (ProperName 'ClassName)
constraintClass) SourceConstraint
c
      go SourceType
_ = []
    extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName]
    extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName]
extractCurrentModuleClass (Qualified (ByModuleName ModuleName
mn') ProperName 'ClassName
name) | ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
mn' = [ProperName 'ClassName
name]
    extractCurrentModuleClass Qualified (ProperName 'ClassName)
_ = []

  checkClassMembersAreExported :: DeclarationRef -> m ()
  checkClassMembersAreExported :: DeclarationRef -> m ()
checkClassMembersAreExported dr :: DeclarationRef
dr@(TypeClassRef SourceSpan
ss' ProperName 'ClassName
name) = do
    let members :: [DeclarationRef]
members = SourceSpan -> Ident -> DeclarationRef
ValueRef SourceSpan
ss' forall a b. (a -> b) -> [a] -> [b]
`map` forall a. [a] -> a
head (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe [Ident]
findClassMembers [Declaration]
decls)
    let missingMembers :: [DeclarationRef]
missingMembers = [DeclarationRef]
members forall a. Eq a => [a] -> [a] -> [a]
\\ [DeclarationRef]
exps
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DeclarationRef]
missingMembers) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss' forall a b. (a -> b) -> a -> b
$ DeclarationRef -> [DeclarationRef] -> SimpleErrorMessage
TransitiveExportError DeclarationRef
dr [DeclarationRef]
missingMembers
    where
    findClassMembers :: Declaration -> Maybe [Ident]
    findClassMembers :: Declaration -> Maybe [Ident]
findClassMembers (TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
name' [(Text, Maybe SourceType)]
_ [SourceConstraint]
_ [FunctionalDependency]
_ [Declaration]
ds) | ProperName 'ClassName
name forall a. Eq a => a -> a -> Bool
== ProperName 'ClassName
name' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Ident
extractMemberName [Declaration]
ds
    findClassMembers (DataBindingGroupDeclaration NonEmpty Declaration
decls') = forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe [Ident]
findClassMembers forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Declaration
decls'
    findClassMembers Declaration
_ = forall a. Maybe a
Nothing
    extractMemberName :: Declaration -> Ident
    extractMemberName :: Declaration -> Ident
extractMemberName (TypeDeclaration TypeDeclarationData
td) = TypeDeclarationData -> Ident
tydeclIdent TypeDeclarationData
td
    extractMemberName Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Unexpected declaration in typeclass member list"
  checkClassMembersAreExported DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- If a type is exported without data constructors, we warn on `Generic` or `Newtype` instances.
  -- On the other hand if any data constructors are exported, we require all of them to be exported.
  checkDataConstructorsAreExported :: DeclarationRef -> m ()
  checkDataConstructorsAreExported :: DeclarationRef -> m ()
checkDataConstructorsAreExported dr :: DeclarationRef
dr@(TypeRef SourceSpan
ss' ProperName 'TypeName
name (forall a. a -> Maybe a -> a
fromMaybe [] -> [ProperName 'ConstructorName]
exportedDataConstructorsNames))
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProperName 'ConstructorName]
exportedDataConstructorsNames = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
      [ Qualified (ProperName 'ClassName)
Libs.Generic
      , Qualified (ProperName 'ClassName)
Libs.Newtype
      ] forall a b. (a -> b) -> a -> b
$ \Qualified (ProperName 'ClassName)
className -> do
        Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
        let dicts :: [NamedDict]
dicts = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. NonEmpty a -> [a]
NEL.toList) forall a b. (a -> b) -> a -> b
$
              forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) (Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries Environment
env) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
className
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. TypeClassDictionaryInScope a -> Bool
isDictOfTypeRef [NamedDict]
dicts) forall a b. (a -> b) -> a -> b
$
          forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss' forall a b. (a -> b) -> a -> b
$ DeclarationRef
-> Qualified (ProperName 'ClassName) -> SimpleErrorMessage
HiddenConstructors DeclarationRef
dr Qualified (ProperName 'ClassName)
className
    | Bool
otherwise = do
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      let dataConstructorNames :: [ProperName 'ConstructorName]
dataConstructorNames = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. a -> ModuleName -> Qualified a
mkQualified ProperName 'TypeName
name ModuleName
mn) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeKind -> Maybe [ProperName 'ConstructorName]
getDataConstructorNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
          missingDataConstructorsNames :: [ProperName 'ConstructorName]
missingDataConstructorsNames = [ProperName 'ConstructorName]
dataConstructorNames forall a. Eq a => [a] -> [a] -> [a]
\\ [ProperName 'ConstructorName]
exportedDataConstructorsNames
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProperName 'ConstructorName]
missingDataConstructorsNames) forall a b. (a -> b) -> a -> b
$
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss' forall a b. (a -> b) -> a -> b
$ DeclarationRef
-> [ProperName 'ConstructorName] -> SimpleErrorMessage
TransitiveDctorExportError DeclarationRef
dr [ProperName 'ConstructorName]
missingDataConstructorsNames
      where
      isDictOfTypeRef :: TypeClassDictionaryInScope a -> Bool
      isDictOfTypeRef :: forall a. TypeClassDictionaryInScope a -> Bool
isDictOfTypeRef TypeClassDictionaryInScope a
dict
        | (TypeConstructor SourceAnn
_ Qualified (ProperName 'TypeName)
qualTyName, [SourceType]
_, [SourceType]
_) : [(SourceType, [SourceType], [SourceType])]
_ <- forall a. Type a -> (Type a, [Type a], [Type a])
unapplyTypes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. TypeClassDictionaryInScope v -> [SourceType]
tcdInstanceTypes TypeClassDictionaryInScope a
dict
        , Qualified (ProperName 'TypeName)
qualTyName forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'TypeName
name
        = Bool
True
      isDictOfTypeRef TypeClassDictionaryInScope a
_ = Bool
False
      getDataConstructorNames :: TypeKind -> Maybe [ProperName 'ConstructorName]
      getDataConstructorNames :: TypeKind -> Maybe [ProperName 'ConstructorName]
getDataConstructorNames (DataType DataDeclType
_ [(Text, Maybe SourceType, Role)]
_ [(ProperName 'ConstructorName, [SourceType])]
constructors) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ProperName 'ConstructorName, [SourceType])]
constructors
      getDataConstructorNames TypeKind
_ = forall a. Maybe a
Nothing
  checkDataConstructorsAreExported DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()