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 ( ...@@ -21,6 +21,7 @@ module ConLike (
, conLikeResTy , conLikeResTy
, conLikeFieldType , conLikeFieldType
, conLikesWithFields , conLikesWithFields
, conLikeIsInfix
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -185,3 +186,7 @@ conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] ...@@ -185,3 +186,7 @@ conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields con_likes lbls = filter has_flds con_likes conLikesWithFields con_likes lbls = filter has_flds con_likes
where has_flds dc = all (has_fld dc) lbls where has_flds dc = all (has_fld dc) lbls
has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) 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 ...@@ -296,7 +296,9 @@ deSugar hsc_env
tcg_tcs = tcs, tcg_tcs = tcs,
tcg_insts = insts, tcg_insts = insts,
tcg_fam_insts = fam_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 = do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env print_unqual = mkPrintUnqualified dflags rdr_env
...@@ -313,8 +315,9 @@ deSugar hsc_env ...@@ -313,8 +315,9 @@ deSugar hsc_env
then addTicksToBinds hsc_env mod mod_loc then addTicksToBinds hsc_env mod mod_loc
export_set (typeEnvTyCons type_env) binds export_set (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, Nothing) else return (binds, hpcInfo, Nothing)
; (msgs, mb_res)
; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $ <- initDs hsc_env mod rdr_env type_env
fam_inst_env complete_matches $
do { ds_ev_binds <- dsEvBinds ev_binds do { ds_ev_binds <- dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds binds_cvr ; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
...@@ -396,7 +399,8 @@ deSugar hsc_env ...@@ -396,7 +399,8 @@ deSugar hsc_env
mg_vect_decls = ds_vects, mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo, mg_vect_info = noVectInfo,
mg_safe_haskell = safe_mode, 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) ; return (msgs, Just mod_guts)
}}}} }}}}
...@@ -451,7 +455,7 @@ deSugarExpr hsc_env tc_expr ...@@ -451,7 +455,7 @@ deSugarExpr hsc_env tc_expr
-- Do desugaring -- Do desugaring
; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
type_env fam_inst_env $ type_env fam_inst_env [] $
dsLExpr tc_expr dsLExpr tc_expr
; case mb_core_expr of ; case mb_core_expr of
......
...@@ -737,6 +737,7 @@ rep_sig (L loc (SpecSig nm tys ispec)) ...@@ -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 loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC 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 rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
-> DsM (SrcSpan, Core TH.DecQ) -> DsM (SrcSpan, Core TH.DecQ)
......
...@@ -35,7 +35,7 @@ module DsMonad ( ...@@ -35,7 +35,7 @@ module DsMonad (
getDictsDs, addDictsDs, getTmCsDs, addTmCsDs, getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
-- Iterations for pm checking -- Iterations for pm checking
incrCheckPmIterDs, resetPmIterDs, incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,
-- Warnings and errors -- Warnings and errors
DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
...@@ -83,6 +83,7 @@ import FastString ...@@ -83,6 +83,7 @@ import FastString
import Maybes import Maybes
import Var (EvVar) import Var (EvVar)
import qualified GHC.LanguageExtensions as LangExt import qualified GHC.LanguageExtensions as LangExt
import UniqFM ( lookupWithDefaultUFM )
import Data.IORef import Data.IORef
import Control.Monad import Control.Monad
...@@ -152,17 +153,19 @@ type DsWarning = (SrcSpan, SDoc) ...@@ -152,17 +153,19 @@ type DsWarning = (SrcSpan, SDoc)
initDs :: HscEnv initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> [CompleteMatch]
-> DsM a -> DsM a
-> IO (Messages, Maybe a) -> IO (Messages, Maybe a)
-- Print errors and warnings, if any arise -- 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) = do { msg_var <- newIORef (emptyBag, emptyBag)
; let all_matches = (hptCompleteSigs hsc_env) ++ complete_matches
; pm_iter_var <- newIORef 0 ; pm_iter_var <- newIORef 0
; let dflags = hsc_dflags hsc_env ; let dflags = hsc_dflags hsc_env
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
fam_inst_env msg_var 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 $ ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP $ loadDAP $
...@@ -241,8 +244,9 @@ initDsTc thing_inside ...@@ -241,8 +244,9 @@ initDsTc thing_inside
; let type_env = tcg_type_env tcg_env ; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_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 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 ; setEnvs ds_envs thing_inside
} }
...@@ -270,13 +274,15 @@ initTcDsForSolver thing_inside ...@@ -270,13 +274,15 @@ initTcDsForSolver thing_inside
thing_inside } thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv) -> IORef Messages -> IORef Int -> [CompleteMatch]
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar -> (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", = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
if_rec_types = Just (mod, return type_env) } if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
False -- not boot! False -- not boot!
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
completeMatchMap = mkCompleteMatchMap complete_matches
gbl_env = DsGblEnv { ds_mod = mod gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env , ds_fam_inst_env = fam_inst_env
, ds_if_env = (if_genv, if_lenv) , ds_if_env = (if_genv, if_lenv)
...@@ -284,6 +290,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar ...@@ -284,6 +290,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
, ds_msgs = msg_var , ds_msgs = msg_var
, ds_dph_env = emptyGlobalRdrEnv , ds_dph_env = emptyGlobalRdrEnv
, ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
, ds_complete_matches = completeMatchMap
} }
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span , dsl_loc = real_span
...@@ -293,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar ...@@ -293,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
} }
in (gbl_env, lcl_env) in (gbl_env, lcl_env)
-- Attempt to load the given module and return its exported entities if successful. -- Attempt to load the given module and return its exported entities if successful.
-- --
loadModule :: SDoc -> Module -> DsM GlobalRdrEnv loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
...@@ -608,6 +616,12 @@ dsGetFamInstEnvs ...@@ -608,6 +616,12 @@ dsGetFamInstEnvs
dsGetMetaEnv :: DsM (NameEnv DsMetaVal) dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } 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 -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) } dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
......
...@@ -53,11 +53,15 @@ refer to variables that are otherwise substituted away. ...@@ -53,11 +53,15 @@ refer to variables that are otherwise substituted away.
-- | Lifted expressions for pattern match checking. -- | Lifted expressions for pattern match checking.
data PmExpr = PmExprVar Name data PmExpr = PmExprVar Name
| PmExprCon DataCon [PmExpr] | PmExprCon ConLike [PmExpr]
| PmExprLit PmLit | PmExprLit PmLit
| PmExprEq PmExpr PmExpr -- Syntactic equality | PmExprEq PmExpr PmExpr -- Syntactic equality
| PmExprOther (HsExpr Id) -- Note [PmExprOther in PmExpr] | 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. -- | Literals (simple and overloaded ones) for pattern match checking.
data PmLit = PmSLit HsLit -- simple data PmLit = PmSLit HsLit -- simple
| PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded
...@@ -148,11 +152,11 @@ toComplex (x,e) = (PmExprVar (idName x), e) ...@@ -148,11 +152,11 @@ toComplex (x,e) = (PmExprVar (idName x), e)
-- | Expression `True' -- | Expression `True'
truePmExpr :: PmExpr truePmExpr :: PmExpr
truePmExpr = PmExprCon trueDataCon [] truePmExpr = mkPmExprData trueDataCon []
-- | Expression `False' -- | Expression `False'
falsePmExpr :: PmExpr falsePmExpr :: PmExpr
falsePmExpr = PmExprCon falseDataCon [] falsePmExpr = mkPmExprData falseDataCon []
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- ** Predicates on PmExpr -- ** Predicates on PmExpr
...@@ -169,17 +173,17 @@ isNegatedPmLit _other_lit = False ...@@ -169,17 +173,17 @@ isNegatedPmLit _other_lit = False
-- | Check whether a PmExpr is syntactically equal to term `True'. -- | Check whether a PmExpr is syntactically equal to term `True'.
isTruePmExpr :: PmExpr -> Bool isTruePmExpr :: PmExpr -> Bool
isTruePmExpr (PmExprCon c []) = c == trueDataCon isTruePmExpr (PmExprCon c []) = c == RealDataCon trueDataCon
isTruePmExpr _other_expr = False isTruePmExpr _other_expr = False
-- | Check whether a PmExpr is syntactically equal to term `False'. -- | Check whether a PmExpr is syntactically equal to term `False'.
isFalsePmExpr :: PmExpr -> Bool isFalsePmExpr :: PmExpr -> Bool
isFalsePmExpr (PmExprCon c []) = c == falseDataCon isFalsePmExpr (PmExprCon c []) = c == RealDataCon falseDataCon
isFalsePmExpr _other_expr = False isFalsePmExpr _other_expr = False
-- | Check whether a PmExpr is syntactically e -- | Check whether a PmExpr is syntactically e
isNilPmExpr :: PmExpr -> Bool isNilPmExpr :: PmExpr -> Bool
isNilPmExpr (PmExprCon c _) = c == nilDataCon isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon
isNilPmExpr _other_expr = False isNilPmExpr _other_expr = False
-- | Check whether a PmExpr is syntactically equal to (x == y). -- | Check whether a PmExpr is syntactically equal to (x == y).
...@@ -242,7 +246,7 @@ hsExprToPmExpr e@(NegApp _ neg_e) ...@@ -242,7 +246,7 @@ hsExprToPmExpr e@(NegApp _ neg_e)
hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
hsExprToPmExpr e@(ExplicitTuple ps boxity) hsExprToPmExpr e@(ExplicitTuple ps boxity)
| all tupArgPresent ps = PmExprCon tuple_con tuple_args | all tupArgPresent ps = mkPmExprData tuple_con tuple_args
| otherwise = PmExprOther e | otherwise = PmExprOther e
where where
tuple_con = tupleDataCon boxity (length ps) tuple_con = tupleDataCon boxity (length ps)
...@@ -252,11 +256,12 @@ hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems) ...@@ -252,11 +256,12 @@ hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
| Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems) | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
| otherwise = PmExprOther e {- overloaded list: No PmExprApp -} | otherwise = PmExprOther e {- overloaded list: No PmExprApp -}
where where
cons x xs = PmExprCon consDataCon [x,xs] cons x xs = mkPmExprData consDataCon [x,xs]
nil = PmExprCon nilDataCon [] nil = mkPmExprData nilDataCon []
hsExprToPmExpr (ExplicitPArr _elem_ty elems) 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 :/ -- we want this but we would have to make everything monadic :/
-- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon -- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon
...@@ -388,30 +393,22 @@ needsParens (PmExprVar {}) = False ...@@ -388,30 +393,22 @@ needsParens (PmExprVar {}) = False
needsParens (PmExprLit l) = isNegatedPmLit l needsParens (PmExprLit l) = isNegatedPmLit l
needsParens (PmExprEq {}) = False -- will become a wildcard needsParens (PmExprEq {}) = False -- will become a wildcard
needsParens (PmExprOther {}) = 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 | isTupleDataCon c || isPArrFakeCon c
|| isConsDataCon c || null es = False || isConsDataCon c || null es = False
| otherwise = True | otherwise = True
needsParens (PmExprCon (PatSynCon _) es) = not (null es)
pprPmExprWithParens :: PmExpr -> PmPprM SDoc pprPmExprWithParens :: PmExpr -> PmPprM SDoc
pprPmExprWithParens expr pprPmExprWithParens expr
| needsParens expr = parens <$> pprPmExpr expr | needsParens expr = parens <$> pprPmExpr expr
| otherwise = pprPmExpr expr | otherwise = pprPmExpr expr
pprPmExprCon :: DataCon -> [PmExpr] -> PmPprM SDoc pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc
pprPmExprCon con args pprPmExprCon (RealDataCon con) args
| isTupleDataCon con = mkTuple <$> mapM pprPmExpr args | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args
| isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args | isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args
| isConsDataCon con = pretty_list | 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 where
mkTuple, mkPArr :: [SDoc] -> SDoc mkTuple, mkPArr :: [SDoc] -> SDoc
mkTuple = parens . fsep . punctuate comma mkTuple = parens . fsep . punctuate comma
...@@ -426,10 +423,22 @@ pprPmExprCon con args ...@@ -426,10 +423,22 @@ pprPmExprCon con args
list = list_elements args list = list_elements args
list_elements [x,y] list_elements [x,y]
| PmExprCon c es <- y, nilDataCon == c = ASSERT(null es) [x,y] | PmExprCon c es <- y, RealDataCon nilDataCon == c
| PmExprCon c es <- y, consDataCon == c = x : list_elements es = ASSERT(null es) [x,y]
| PmExprCon c es <- y, RealDataCon consDataCon == c
= x : list_elements es
| otherwise = [x,y] | otherwise = [x,y]
list_elements list = pprPanic "list_elements:" (ppr list) 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 instance Outputable PmLit where
ppr (PmSLit l) = pmPprHsLit l ppr (PmSLit l) = pmPprHsLit l
......
...@@ -26,7 +26,6 @@ import PmExpr ...@@ -26,7 +26,6 @@ import PmExpr
import Id import Id
import Name import Name
import TysWiredIn
import Type import Type
import HsLit import HsLit
import TcHsSyn import TcHsSyn
...@@ -113,12 +112,12 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of ...@@ -113,12 +112,12 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
(PmExprCon c1 ts1, PmExprCon c2 ts2) (PmExprCon c1 ts1, PmExprCon c2 ts2)
| c1 == c2 -> foldlM solveComplexEq solver_state (zip ts1 ts2) | c1 == c2 -> foldlM solveComplexEq solver_state (zip ts1 ts2)
| otherwise -> Nothing | otherwise -> Nothing
(PmExprCon c [], PmExprEq t1 t2) (PmExprCon _ [], PmExprEq t1 t2)
| c == trueDataCon -> solveComplexEq solver_state (t1, t2) | isTruePmExpr e1 -> solveComplexEq solver_state (t1, t2)
| c == falseDataCon -> Just (eq:standby, (unhandled, env)) | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))
(PmExprEq t1 t2, PmExprCon c []) (PmExprEq t1 t2, PmExprCon _ [])
| c == trueDataCon -> solveComplexEq solver_state (t1, t2) | isTruePmExpr e2 -> solveComplexEq solver_state (t1, t2)
| c == falseDataCon -> Just (eq:standby, (unhandled, env)) | isFalsePmExpr e2 -> Just (eq:standby, (unhandled, env))
(PmExprVar x, PmExprVar y) (PmExprVar x, PmExprVar y)
| x == y -> Just solver_state | x == y -> Just solver_state
......
...@@ -853,6 +853,7 @@ data Sig name ...@@ -853,6 +853,7 @@ data Sig name
| SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes
(Located name) -- Function name (Located name) -- Function name
(Maybe StringLiteral) (Maybe StringLiteral)
| CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name))
deriving instance (DataId name) => Data (Sig name) deriving instance (DataId name) => Data (Sig name)
...@@ -920,6 +921,7 @@ isPragLSig :: LSig name -> Bool ...@@ -920,6 +921,7 @@ isPragLSig :: LSig name -> Bool
isPragLSig (L _ (SpecSig {})) = True isPragLSig (L _ (SpecSig {})) = True
isPragLSig (L _ (InlineSig {})) = True isPragLSig (L _ (InlineSig {})) = True
isPragLSig (L _ (SCCFunSig {})) = True isPragLSig (L _ (SCCFunSig {})) = True
isPragLSig (L _ (CompleteMatchSig {})) = True
isPragLSig _ = False isPragLSig _ = False
isInlineLSig :: LSig name -> Bool isInlineLSig :: LSig name -> Bool
...@@ -935,6 +937,10 @@ isSCCFunSig :: LSig name -> Bool ...@@ -935,6 +937,10 @@ isSCCFunSig :: LSig name -> Bool
isSCCFunSig (L _ (SCCFunSig {})) = True isSCCFunSig (L _ (SCCFunSig {})) = True
isSCCFunSig _ = False isSCCFunSig _ = False
isCompleteMatchSig :: LSig name -> Bool
isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True
isCompleteMatchSig _ = False
hsSigDoc :: Sig name -> SDoc hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = text "type signature" hsSigDoc (TypeSig {}) = text "type signature"
hsSigDoc (PatSynSig {}) = text "pattern synonym signature" hsSigDoc (PatSynSig {}) = text "pattern synonym signature"
...@@ -948,6 +954,7 @@ hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" ...@@ -948,6 +954,7 @@ hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma"
hsSigDoc (FixSig {}) = text "fixity declaration" hsSigDoc (FixSig {}) = text "fixity declaration"
hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
hsSigDoc (SCCFunSig {}) = text "SCC pragma" hsSigDoc (SCCFunSig {}) = text "SCC pragma"
hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"
{- {-
Check if signatures overlap; this is used when checking for duplicate Check if signatures overlap; this is used when checking for duplicate
...@@ -983,6 +990,12 @@ ppr_sig (PatSynSig names sig_ty) ...@@ -983,6 +990,12 @@ ppr_sig (PatSynSig names sig_ty)
= text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
ppr_sig (SCCFunSig src fn mlabel) ppr_sig (SCCFunSig src fn mlabel)
= pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr 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 instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig names fixity) = sep [ppr fixity, pprops] ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
......
...@@ -19,6 +19,7 @@ module IfaceSyn ( ...@@ -19,6 +19,7 @@ module IfaceSyn (
IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
IfaceAxBranch(..), IfaceAxBranch(..),
IfaceTyConParent(..), IfaceTyConParent(..),
IfaceCompleteMatch(..),
-- * Binding names -- * Binding names
IfaceTopBndr, IfaceTopBndr,
...@@ -295,6 +296,11 @@ data IfaceAnnotation ...@@ -295,6 +296,11 @@ data IfaceAnnotation
type IfaceAnnTarget = AnnTarget OccName type IfaceAnnTarget = AnnTarget OccName
data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName
-- Here's a tricky case: -- Here's a tricky case:
-- * Compile with -O module A, and B which imports A.f -- * Compile with -O module A, and B which imports A.f
-- * Change function f in A, and recompile without -O -- * Change function f in A, and recompile without -O
...@@ -2090,3 +2096,7 @@ instance Binary IfaceTyConParent where ...@@ -2090,3 +2096,7 @@ instance Binary IfaceTyConParent where
pr <- get bh pr <- get bh
ty <- get bh ty <- get bh
return $ IfDataInstance ax pr ty 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 ...@@ -206,7 +206,8 @@ mkIface_ hsc_env maybe_old_fingerprint
md_anns = anns, md_anns = anns,
md_vect_info = vect_info, md_vect_info = vect_info,
md_types = type_env, 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 -- NB: notice that mkIface does not look at the bindings
-- only at the TypeEnv. The previous Tidy phase has -- only at the TypeEnv. The previous Tidy phase has
-- put exactly the info into the TypeEnv that we want -- put exactly the info into the TypeEnv that we want
...@@ -241,6 +242,7 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -241,6 +242,7 @@ mkIface_ hsc_env maybe_old_fingerprint
iface_vect_info = flattenVectInfo vect_info iface_vect_info = flattenVectInfo vect_info
trust_info = setSafeMode safe_mode trust_info = setSafeMode safe_mode
annotations = map mkIfaceAnnotation anns annotations = map mkIfaceAnnotation anns
icomplete_sigs = map mkIfaceCompleteSig complete_sigs
intermediate_iface = ModIface { intermediate_iface = ModIface {
mi_module = this_mod, mi_module = this_mod,
...@@ -285,7 +287,8 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -285,7 +287,8 @@ mkIface_ hsc_env maybe_old_fingerprint
-- And build the cached values