diff options
Diffstat (limited to 'compiler/GHC/Tc')
| -rw-r--r-- | compiler/GHC/Tc/Gen/Bind.hs | 33 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Types/Origin.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Validity.hs | 3 |
3 files changed, 26 insertions, 12 deletions
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 0ab561a0a7..4d4e1cc385 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {- @@ -50,6 +49,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) import GHC.Builtin.Types ( mkBoxedTupleTy ) import GHC.Builtin.Types.Prim +import GHC.Types.CompleteMatch import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Var as Var @@ -66,7 +66,6 @@ import GHC.Data.Graph.Directed import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Types.Basic -import GHC.Types.CompleteMatch import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Names( ipClassName ) @@ -202,17 +201,27 @@ tcTopBinds binds sigs tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] tcCompleteSigs sigs = - let + let orphanError :: SDoc + orphanError = + text "Orphan COMPLETE pragmas not supported" $$ + text "A COMPLETE pragma must mention at least one data constructor" $$ + text "or pattern synonym defined in the same module." + doOne :: LSig GhcRn -> TcM (Maybe CompleteMatch) - -- We don't need to "type-check" COMPLETE signatures anymore; if their - -- combinations are invalid it will be found so at match sites. - -- There it is also where we consider if the type of the pattern match is - -- compatible with the result type constructor 'mb_tc'. - doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mb_tc_nm)) - = fmap Just $ setSrcSpan loc $ addErrCtxt (text "In" <+> ppr c) $ do - cls <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns - mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm - pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc } + doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mty)) + = do this_mod <- fmap tcg_mod getGblEnv + mt <- forM mty $ \ty -> do + (_,_,t) <- tcHsPatSigType CompletePragCtxt HM_FamPat ty OpenKind + return t + + fmap Just $ setSrcSpan loc $ addErrCtxt (text "In" <+> ppr c) $ do + -- Check if this COMPLETE pragma is an orphan. + unless (any (nameIsLocalOrFrom this_mod . unLoc) ns || any (nameSetAny (nameIsLocalOrFrom this_mod) . orphNamesOfType) mt) $ + -- Why 'any'? See Note [Orphan COMPLETE pragmas] + failWithTc orphanError + -- Look up the ConLikes mentioned + conlikes <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns + return (CompleteMatch { cmConLikes = conlikes, cmResultType = mt }) doOne _ = return Nothing -- For some reason I haven't investigated further, the signatures come in diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 648bf5ce12..16a4a24467 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -109,6 +109,7 @@ data UserTypeCtxt | DataKindCtxt Name -- The kind of a data/newtype (instance) | TySynKindCtxt Name -- The kind of the RHS of a type synonym | TyFamResKindCtxt Name -- The result kind of a type family + | CompletePragCtxt -- The scrutinee type of a COMPLETE pragma {- -- Notes re TySynCtxt @@ -150,6 +151,7 @@ pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type va pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) +pprUserTypeCtxt CompletePragCtxt = text "the scrutinee type of a COMPLETE pragma" isSigMaybe :: UserTypeCtxt -> Maybe Name isSigMaybe (FunSigCtxt n _) = Just n diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index f446b69634..c10e29fa80 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -377,6 +377,7 @@ checkValidType ctxt ty DataKindCtxt _ -> rank1 TySynKindCtxt _ -> rank1 TyFamResKindCtxt _ -> rank1 + CompletePragCtxt -> rank1 _ -> panic "checkValidType" -- Can't happen; not used for *user* sigs @@ -507,6 +508,7 @@ typeOrKindCtxt (SigmaCtxt {}) = OnlyTypeCtxt typeOrKindCtxt (DataTyCtxt {}) = OnlyTypeCtxt typeOrKindCtxt (DerivClauseCtxt {}) = OnlyTypeCtxt typeOrKindCtxt (ConArgCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (CompletePragCtxt {}) = OnlyTypeCtxt -- Although data constructors can be promoted with DataKinds, we always -- validity-check them as though they are the types of terms. We may need -- to revisit this decision if we ever allow visible dependent quantification @@ -1376,6 +1378,7 @@ okIPCtxt (TyVarBndrKindCtxt {}) = False okIPCtxt (DataKindCtxt {}) = False okIPCtxt (TySynKindCtxt {}) = False okIPCtxt (TyFamResKindCtxt {}) = False +okIPCtxt (CompletePragCtxt {}) = False {- Note [Kind polymorphic type classes] |