diff options
Diffstat (limited to 'compiler/GHC/Tc/Gen/Bind.hs')
| -rw-r--r-- | compiler/GHC/Tc/Gen/Bind.hs | 33 |
1 files changed, 21 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 |