Commit 1a3f1eeb authored by Matthew Pickering's avatar Matthew Pickering

COMPLETE pragmas for enhanced pattern exhaustiveness checking

This patch adds a new pragma so that users can specify `COMPLETE` sets of
`ConLike`s in order to sate the pattern match checker.

A function which matches on all the patterns in a complete grouping
will not cause the exhaustiveness checker to emit warnings.

```
pattern P :: ()
pattern P = ()

{-# COMPLETE P #-}

foo P = ()
```

This example would previously have caused the checker to warn that
all cases were not matched even though matching on `P` is sufficient to
make `foo` covering. With the addition of the pragma, the compiler
will recognise that matching on `P` alone is enough and not emit
any warnings.

Reviewers: goldfire, gkaracha, alanz, austin, bgamari

Reviewed By: alanz

Subscribers: lelf, nomeata, gkaracha, thomie

Differential Revision: https://phabricator.haskell.org/D2669

GHC Trac Issues: #8779
parent 078c2114
......@@ -21,6 +21,7 @@ module ConLike (
, conLikeResTy
, conLikeFieldType
, conLikesWithFields
, conLikeIsInfix
) where
#include "HsVersions.h"
......@@ -185,3 +186,7 @@ conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields con_likes lbls = filter has_flds con_likes
where has_flds dc = all (has_fld dc) lbls
has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
conLikeIsInfix :: ConLike -> Bool
conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps
This diff is collapsed.
......@@ -296,7 +296,9 @@ deSugar hsc_env
tcg_tcs = tcs,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
tcg_hpc = other_hpc_info})
tcg_hpc = other_hpc_info,
tcg_complete_matches = complete_matches
})
= do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env
......@@ -313,8 +315,9 @@ deSugar hsc_env
then addTicksToBinds hsc_env mod mod_loc
export_set (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, Nothing)
; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
; (msgs, mb_res)
<- initDs hsc_env mod rdr_env type_env
fam_inst_env complete_matches $
do { ds_ev_binds <- dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
......@@ -396,7 +399,8 @@ deSugar hsc_env
mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo,
mg_safe_haskell = safe_mode,
mg_trust_pkg = imp_trust_own_pkg imports
mg_trust_pkg = imp_trust_own_pkg imports,
mg_complete_sigs = complete_matches
}
; return (msgs, Just mod_guts)
}}}}
......@@ -451,7 +455,7 @@ deSugarExpr hsc_env tc_expr
-- Do desugaring
; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
type_env fam_inst_env $
type_env fam_inst_env [] $
dsLExpr tc_expr
; case mb_core_expr of
......
......@@ -737,6 +737,7 @@ rep_sig (L loc (SpecSig nm tys ispec))
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
rep_sig (L _ (CompleteMatchSig {})) = notHandled "CompleteMatchSig" empty
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
......
......@@ -35,7 +35,7 @@ module DsMonad (
getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
-- Iterations for pm checking
incrCheckPmIterDs, resetPmIterDs,
incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,
-- Warnings and errors
DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
......@@ -83,6 +83,7 @@ import FastString
import Maybes
import Var (EvVar)
import qualified GHC.LanguageExtensions as LangExt
import UniqFM ( lookupWithDefaultUFM )
import Data.IORef
import Control.Monad
......@@ -152,17 +153,19 @@ type DsWarning = (SrcSpan, SDoc)
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> [CompleteMatch]
-> DsM a
-> IO (Messages, Maybe a)
-- Print errors and warnings, if any arise
initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
initDs hsc_env mod rdr_env type_env fam_inst_env complete_matches thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
; let all_matches = (hptCompleteSigs hsc_env) ++ complete_matches
; pm_iter_var <- newIORef 0
; let dflags = hsc_dflags hsc_env
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
fam_inst_env msg_var
pm_iter_var
pm_iter_var all_matches
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP $
......@@ -241,8 +244,9 @@ initDsTc thing_inside
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_env tcg_env
complete_matches = tcg_complete_matches tcg_env
ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
msg_var pm_iter_var
msg_var pm_iter_var complete_matches
; setEnvs ds_envs thing_inside
}
......@@ -270,13 +274,15 @@ initTcDsForSolver thing_inside
thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
-> IORef Messages -> IORef Int -> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
False -- not boot!
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
completeMatchMap = mkCompleteMatchMap complete_matches
gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
, ds_if_env = (if_genv, if_lenv)
......@@ -284,6 +290,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
, ds_msgs = msg_var
, ds_dph_env = emptyGlobalRdrEnv
, ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
, ds_complete_matches = completeMatchMap
}
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span
......@@ -293,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
}
in (gbl_env, lcl_env)
-- Attempt to load the given module and return its exported entities if successful.
--
loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
......@@ -608,6 +616,12 @@ dsGetFamInstEnvs
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
-- | The @COMPLETE@ pragams provided by the user for a given `TyCon`.
dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches tc = do
env <- getGblEnv
return $ (lookupWithDefaultUFM (ds_complete_matches env) [] tc)
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
......
......@@ -53,11 +53,15 @@ refer to variables that are otherwise substituted away.
-- | Lifted expressions for pattern match checking.
data PmExpr = PmExprVar Name
| PmExprCon DataCon [PmExpr]
| PmExprCon ConLike [PmExpr]
| PmExprLit PmLit
| PmExprEq PmExpr PmExpr -- Syntactic equality
| PmExprOther (HsExpr Id) -- Note [PmExprOther in PmExpr]
mkPmExprData :: DataCon -> [PmExpr] -> PmExpr
mkPmExprData dc args = PmExprCon (RealDataCon dc) args
-- | Literals (simple and overloaded ones) for pattern match checking.
data PmLit = PmSLit HsLit -- simple
| PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded
......@@ -148,11 +152,11 @@ toComplex (x,e) = (PmExprVar (idName x), e)
-- | Expression `True'
truePmExpr :: PmExpr
truePmExpr = PmExprCon trueDataCon []
truePmExpr = mkPmExprData trueDataCon []
-- | Expression `False'
falsePmExpr :: PmExpr
falsePmExpr = PmExprCon falseDataCon []
falsePmExpr = mkPmExprData falseDataCon []
-- ----------------------------------------------------------------------------
-- ** Predicates on PmExpr
......@@ -169,17 +173,17 @@ isNegatedPmLit _other_lit = False
-- | Check whether a PmExpr is syntactically equal to term `True'.
isTruePmExpr :: PmExpr -> Bool
isTruePmExpr (PmExprCon c []) = c == trueDataCon
isTruePmExpr (PmExprCon c []) = c == RealDataCon trueDataCon
isTruePmExpr _other_expr = False
-- | Check whether a PmExpr is syntactically equal to term `False'.
isFalsePmExpr :: PmExpr -> Bool
isFalsePmExpr (PmExprCon c []) = c == falseDataCon
isFalsePmExpr (PmExprCon c []) = c == RealDataCon falseDataCon
isFalsePmExpr _other_expr = False
-- | Check whether a PmExpr is syntactically e
isNilPmExpr :: PmExpr -> Bool
isNilPmExpr (PmExprCon c _) = c == nilDataCon
isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon
isNilPmExpr _other_expr = False
-- | Check whether a PmExpr is syntactically equal to (x == y).
......@@ -242,7 +246,7 @@ hsExprToPmExpr e@(NegApp _ neg_e)
hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
hsExprToPmExpr e@(ExplicitTuple ps boxity)
| all tupArgPresent ps = PmExprCon tuple_con tuple_args
| all tupArgPresent ps = mkPmExprData tuple_con tuple_args
| otherwise = PmExprOther e
where
tuple_con = tupleDataCon boxity (length ps)
......@@ -252,11 +256,12 @@ hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
| Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
| otherwise = PmExprOther e {- overloaded list: No PmExprApp -}
where
cons x xs = PmExprCon consDataCon [x,xs]
nil = PmExprCon nilDataCon []
cons x xs = mkPmExprData consDataCon [x,xs]
nil = mkPmExprData nilDataCon []
hsExprToPmExpr (ExplicitPArr _elem_ty elems)
= PmExprCon (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
= mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
-- we want this but we would have to make everything monadic :/
-- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon
......@@ -388,30 +393,22 @@ needsParens (PmExprVar {}) = False
needsParens (PmExprLit l) = isNegatedPmLit l
needsParens (PmExprEq {}) = False -- will become a wildcard
needsParens (PmExprOther {}) = False -- will become a wildcard
needsParens (PmExprCon c es)
needsParens (PmExprCon (RealDataCon c) es)
| isTupleDataCon c || isPArrFakeCon c
|| isConsDataCon c || null es = False
| otherwise = True
needsParens (PmExprCon (PatSynCon _) es) = not (null es)
pprPmExprWithParens :: PmExpr -> PmPprM SDoc
pprPmExprWithParens expr
| needsParens expr = parens <$> pprPmExpr expr
| otherwise = pprPmExpr expr
pprPmExprCon :: DataCon -> [PmExpr] -> PmPprM SDoc
pprPmExprCon con args
pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc
pprPmExprCon (RealDataCon con) args
| isTupleDataCon con = mkTuple <$> mapM pprPmExpr args
| isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args
| isConsDataCon con = pretty_list
| dataConIsInfix con = case args of
[x, y] -> do x' <- pprPmExprWithParens x
y' <- pprPmExprWithParens y
return (x' <+> ppr con <+> y')
-- can it be infix but have more than two arguments?
list -> pprPanic "pprPmExprCon:" (ppr list)
| null args = return (ppr con)
| otherwise = do args' <- mapM pprPmExprWithParens args
return (fsep (ppr con : args'))
where
mkTuple, mkPArr :: [SDoc] -> SDoc
mkTuple = parens . fsep . punctuate comma
......@@ -426,10 +423,22 @@ pprPmExprCon con args
list = list_elements args
list_elements [x,y]
| PmExprCon c es <- y, nilDataCon == c = ASSERT(null es) [x,y]
| PmExprCon c es <- y, consDataCon == c = x : list_elements es
| PmExprCon c es <- y, RealDataCon nilDataCon == c
= ASSERT(null es) [x,y]
| PmExprCon c es <- y, RealDataCon consDataCon == c
= x : list_elements es
| otherwise = [x,y]
list_elements list = pprPanic "list_elements:" (ppr list)
pprPmExprCon cl args
| conLikeIsInfix cl = case args of
[x, y] -> do x' <- pprPmExprWithParens x
y' <- pprPmExprWithParens y
return (x' <+> ppr cl <+> y')
-- can it be infix but have more than two arguments?
list -> pprPanic "pprPmExprCon:" (ppr list)
| null args = return (ppr cl)
| otherwise = do args' <- mapM pprPmExprWithParens args
return (fsep (ppr cl : args'))
instance Outputable PmLit where
ppr (PmSLit l) = pmPprHsLit l
......
......@@ -26,7 +26,6 @@ import PmExpr
import Id
import Name
import TysWiredIn
import Type
import HsLit
import TcHsSyn
......@@ -113,12 +112,12 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
(PmExprCon c1 ts1, PmExprCon c2 ts2)
| c1 == c2 -> foldlM solveComplexEq solver_state (zip ts1 ts2)
| otherwise -> Nothing
(PmExprCon c [], PmExprEq t1 t2)
| c == trueDataCon -> solveComplexEq solver_state (t1, t2)
| c == falseDataCon -> Just (eq:standby, (unhandled, env))
(PmExprEq t1 t2, PmExprCon c [])
| c == trueDataCon -> solveComplexEq solver_state (t1, t2)
| c == falseDataCon -> Just (eq:standby, (unhandled, env))
(PmExprCon _ [], PmExprEq t1 t2)
| isTruePmExpr e1 -> solveComplexEq solver_state (t1, t2)
| isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))
(PmExprEq t1 t2, PmExprCon _ [])
| isTruePmExpr e2 -> solveComplexEq solver_state (t1, t2)
| isFalsePmExpr e2 -> Just (eq:standby, (unhandled, env))
(PmExprVar x, PmExprVar y)
| x == y -> Just solver_state
......
......@@ -853,6 +853,7 @@ data Sig name
| SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes
(Located name) -- Function name
(Maybe StringLiteral)
| CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name))
deriving instance (DataId name) => Data (Sig name)
......@@ -920,6 +921,7 @@ isPragLSig :: LSig name -> Bool
isPragLSig (L _ (SpecSig {})) = True
isPragLSig (L _ (InlineSig {})) = True
isPragLSig (L _ (SCCFunSig {})) = True
isPragLSig (L _ (CompleteMatchSig {})) = True
isPragLSig _ = False
isInlineLSig :: LSig name -> Bool
......@@ -935,6 +937,10 @@ isSCCFunSig :: LSig name -> Bool
isSCCFunSig (L _ (SCCFunSig {})) = True
isSCCFunSig _ = False
isCompleteMatchSig :: LSig name -> Bool
isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True
isCompleteMatchSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = text "type signature"
hsSigDoc (PatSynSig {}) = text "pattern synonym signature"
......@@ -948,6 +954,7 @@ hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma"
hsSigDoc (FixSig {}) = text "fixity declaration"
hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
hsSigDoc (SCCFunSig {}) = text "SCC pragma"
hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"
{-
Check if signatures overlap; this is used when checking for duplicate
......@@ -983,6 +990,12 @@ ppr_sig (PatSynSig names sig_ty)
= text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
ppr_sig (SCCFunSig src fn mlabel)
= pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )
ppr_sig (CompleteMatchSig src cs mty)
= pragSrcBrackets src "{-# COMPLETE"
((hsep (punctuate comma (map ppr (unLoc cs))))
<+> opt_sig)
where
opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
......
......@@ -19,6 +19,7 @@ module IfaceSyn (
IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
IfaceAxBranch(..),
IfaceTyConParent(..),
IfaceCompleteMatch(..),
-- * Binding names
IfaceTopBndr,
......@@ -295,6 +296,11 @@ data IfaceAnnotation
type IfaceAnnTarget = AnnTarget OccName
data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName
-- Here's a tricky case:
-- * Compile with -O module A, and B which imports A.f
-- * Change function f in A, and recompile without -O
......@@ -2090,3 +2096,7 @@ instance Binary IfaceTyConParent where
pr <- get bh
ty <- get bh
return $ IfDataInstance ax pr ty
instance Binary IfaceCompleteMatch where
put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts
get bh = IfaceCompleteMatch <$> get bh <*> get bh
......@@ -206,7 +206,8 @@ mkIface_ hsc_env maybe_old_fingerprint
md_anns = anns,
md_vect_info = vect_info,
md_types = type_env,
md_exports = exports }
md_exports = exports,
md_complete_sigs = complete_sigs }
-- NB: notice that mkIface does not look at the bindings
-- only at the TypeEnv. The previous Tidy phase has
-- put exactly the info into the TypeEnv that we want
......@@ -241,6 +242,7 @@ mkIface_ hsc_env maybe_old_fingerprint
iface_vect_info = flattenVectInfo vect_info
trust_info = setSafeMode safe_mode
annotations = map mkIfaceAnnotation anns
icomplete_sigs = map mkIfaceCompleteSig complete_sigs
intermediate_iface = ModIface {
mi_module = this_mod,
......@@ -285,7 +287,8 @@ mkIface_ hsc_env maybe_old_fingerprint
-- And build the cached values
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities }
mi_fix_fn = mkIfaceFixCache fixities,
mi_complete_sigs = icomplete_sigs }
(new_iface, no_change_at_all)
<- {-# SCC "versioninfo" #-}
......@@ -990,6 +993,19 @@ mkOrphMap get_key decls
= (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
| otherwise = (non_orphs, d:orphs)
{-
************************************************************************
* *
COMPLETE Pragmas
* *
************************************************************************
-}
mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
mkIfaceCompleteSig (CompleteMatch cls tc) =
IfaceCompleteMatch (map conLikeName cls) (tyConName tc)
{-
************************************************************************
* *
......
......@@ -177,6 +177,9 @@ typecheckIface iface
-- Exports
; exports <- ifaceExportNames (mi_exports iface)
-- Complete Sigs
; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
-- Finished
; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
-- Careful! If we tug on the TyThing thunks too early
......@@ -190,6 +193,7 @@ typecheckIface iface
, md_anns = anns
, md_vect_info = vect_info
, md_exports = exports
, md_complete_sigs = complete_sigs
}
}
......@@ -327,6 +331,7 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
anns <- tcIfaceAnnotations (mi_anns iface)
vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
exports <- ifaceExportNames (mi_exports iface)
complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
......@@ -334,6 +339,7 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
, md_anns = anns
, md_vect_info = vect_info
, md_exports = exports
, md_complete_sigs = complete_sigs
}
return (global_type_env, details)
......@@ -366,6 +372,7 @@ typecheckIfaceForInstantiate nsubst iface =
anns <- tcIfaceAnnotations (mi_anns iface)
vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
exports <- ifaceExportNames (mi_exports iface)
complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
......@@ -373,6 +380,7 @@ typecheckIfaceForInstantiate nsubst iface =
, md_anns = anns
, md_vect_info = vect_info
, md_exports = exports
, md_complete_sigs = complete_sigs
}
-- Note [Resolving never-exported Names in TcIface]
......@@ -1013,6 +1021,21 @@ tcIfaceAnnTarget (NamedTarget occ) = do
tcIfaceAnnTarget (ModuleTarget mod) = do
return $ ModuleTarget mod
{-
************************************************************************
* *
Complete Match Pragmas
* *
************************************************************************
-}
tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
tcIfaceCompleteSig (IfaceCompleteMatch ms t) =
CompleteMatch <$> (mapM tcIfaceConLike ms) <*> tcIfaceTyConByName t
{-
************************************************************************
* *
......@@ -1668,6 +1691,14 @@ tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
AConLike (RealDataCon dc) -> return dc
_ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
tcIfaceConLike :: Name -> IfL ConLike
tcIfaceConLike name =
do { thing <- tcIfaceGlobal name
; case thing of
AConLike cl -> return cl
_ -> pprPanic "tcIfaceExtCL" (ppr name$$ ppr thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
; case thing of
......
......@@ -37,6 +37,7 @@ module HscTypes (
HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt,
addToHpt, addListToHpt, lookupHptDirectly, listToHpt,
hptCompleteSigs,
hptInstances, hptRules, hptVectInfo, pprHPT,
hptObjs,
......@@ -131,6 +132,9 @@ module HscTypes (
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
throwOneError, handleSourceError,
handleFlagWarnings, printOrThrowWarnings,
-- * COMPLETE signature
CompleteMatch(..)
) where
#include "HsVersions.h"
......@@ -614,6 +618,8 @@ lookupIfaceByModule _dflags hpt pit mod
-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
-- of its own, but it doesn't seem worth the bother.
hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details)
-- | Find all the instance declarations (of classes and families) from
-- the Home Package Table filtered by the provided predicate function.
......@@ -916,13 +922,14 @@ data ModIface
mi_trust :: !IfaceTrustInfo,
-- ^ Safe Haskell Trust information for this module.
mi_trust_pkg :: !Bool
mi_trust_pkg :: !Bool,
-- ^ Do we require the package this module resides in be trusted
-- to trust this module? This is used for the situation where a
-- module is Safe (so doesn't require the package be trusted
-- itself) but imports some trustworthy modules from its own
-- package (which does require its own package be trusted).
-- See Note [RnNames . Trust Own Package]
mi_complete_sigs :: [IfaceCompleteMatch]
}
-- | Old-style accessor for whether or not the ModIface came from an hs-boot
......@@ -997,7 +1004,8 @@ instance Binary ModIface where
mi_vect_info = vect_info,
mi_hpc = hpc_info,
mi_trust = trust,
mi_trust_pkg = trust_pkg }) = do
mi_trust_pkg = trust_pkg,
mi_complete_sigs = complete_sigs }) = do
put_ bh mod
put_ bh sig_of
put_ bh hsc_src
......@@ -1023,6 +1031,7 @@ instance Binary ModIface where
put_ bh hpc_info
put_ bh trust
put_ bh trust_pkg
put_ bh complete_sigs
get bh = do
mod <- get bh
......@@ -1050,6 +1059,7 @@ instance Binary ModIface where
hpc_info <- get bh
trust <- get bh
trust_pkg <- get bh
complete_sigs <- get bh
return (ModIface {
mi_module = mod,
mi_sig_of = sig_of,
......@@ -1080,7 +1090,8 @@ instance Binary ModIface where
-- And build the cached values
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls })
mi_hash_fn = mkIfaceHashCache decls,
mi_complete_sigs = complete_sigs })
-- | The original names declared of a certain module that are exported
type IfaceExport = AvailInfo
......@@ -1116,7 +1127,8 @@ emptyModIface mod
mi_hash_fn = emptyIfaceHashCache,
mi_hpc = False,
mi_trust = noIfaceTrustInfo,
mi_trust_pkg = False }
mi_trust_pkg = False,
mi_complete_sigs = [] }
-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
......@@ -1148,7 +1160,9 @@ data ModDetails
md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules
md_anns :: ![Annotation], -- ^ Annotations present in this module: currently
-- they only annotate things also declared in this module
md_vect_info :: !VectInfo -- ^ Module vectorisation information
md_vect_info :: !VectInfo, -- ^ Module vectorisation information
md_complete_sigs :: [CompleteMatch]
-- ^ Complete match pragmas for this module
}
-- | Constructs an empty ModDetails
......@@ -1160,7 +1174,8 @@ emptyModDetails
md_rules = [],
md_fam_insts = [],
md_anns = [],
md_vect_info = noVectInfo }
md_vect_info = noVectInfo,
md_complete_sigs = [] }
-- | Records the modules directly imported by a module for extracting e.g.
-- usage information, and also to give better error message
......@@ -1207,6 +1222,7 @@ data ModGuts
mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module
mg_warns :: !Warnings, -- ^ Warnings declared in the module
mg_anns :: [Annotation], -- ^ Annotations declared in this module
mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches
mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module
mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module
mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module
......@@ -2965,3 +2981,17 @@ nameOfObject other = pprPanic "nameOfObject" (ppr other)
byteCodeOfObject :: Unlinked -> CompiledByteCode
byteCodeOfObject (BCOs bc) = bc
byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
-------------------------------------------
-- | A list of conlikes which represents a complete pattern match.
-- These arise from @COMPLETE@ signatures.
data CompleteMatch = CompleteMatch {
completeMatch :: [ConLike]
, completeMatchType :: TyCon
}
instance Outputable CompleteMatch where
ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl
<+> dcolon <+> ppr ty
......@@ -163,6 +163,7 @@ mkBootModDetailsTc hsc_env
, md_anns = []
, md_exports = exports
, md_vect_info = noVectInfo
, md_complete_sigs = []
})
}
where
......@@ -318,6 +319,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_rules = imp_rules
, mg_vect_info = vect_info
, mg_anns = anns
, mg_complete_sigs = complete_sigs
, mg_deps = deps
, mg_foreign = foreign_stubs
, mg_hpc_info = hpc_info
......@@ -425,7 +427,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
md_vect_info = tidy_vect_info,
md_fam_insts = fam_insts,
md_exports = exports,
md_anns = anns -- are already tidy
md_anns = anns, -- are already tidy
md_complete_sigs = complete_sigs
})
}
where
......
......@@ -636,6 +636,7 @@ data Token
| ITunpack_prag SourceText
| ITnounpack_prag SourceText
| ITann_prag SourceText
| ITcomplete_prag SourceText
| ITclose_prag
| IToptions_prag String
| ITinclude_prag String
......@@ -2716,7 +2717,7 @@ ignoredPrags = Map.fromList (map ignored pragmas)
-- CFILES is a hugs-only thing.
pragmas = options_pragmas ++ ["cfiles", "contract"]
oneWordPrags = Map.fromList([
oneWordPrags = Map.fromList [