Implement unboxed sum primitive type
[ghc.git] / compiler / deSugar / Check.hs
index 5570ce9..6ee5bff 100644 (file)
@@ -130,7 +130,7 @@ type Triple = (Bool, Uncovered, Bool)
 -- * Redundant clauses
 -- * Not-covered clauses
 -- * Clauses with inaccessible RHS
-type PmResult = ([[LPat Id]], Uncovered, [[LPat Id]])
+type PmResult = ([Located [LPat Id]], Uncovered, [Located [LPat Id]])
 
 {-
 %************************************************************************
@@ -142,15 +142,15 @@ type PmResult = ([[LPat Id]], Uncovered, [[LPat Id]])
 
 -- | Check a single pattern binding (let)
 checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
-checkSingle dflags ctxt var p = do
-  mb_pm_res <- tryM (checkSingle' var p)
+checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
+  mb_pm_res <- tryM (checkSingle' locn var p)
   case mb_pm_res of
     Left  _   -> warnPmIters dflags ctxt
     Right res -> dsPmWarn dflags ctxt res
 
 -- | Check a single pattern binding (let)
-checkSingle' :: Id -> Pat Id -> DsM PmResult
-checkSingle' var p = do
+checkSingle' :: SrcSpan -> Id -> Pat Id -> DsM PmResult
+checkSingle' locn var p = do
   resetPmIterDs -- set the iter-no to zero
   fam_insts <- dsGetFamInstEnvs
   clause    <- translatePat fam_insts p
@@ -160,7 +160,7 @@ checkSingle' var p = do
     (True,  _    ) -> ([], us, []) -- useful
     (False, False) -> ( m, us, []) -- redundant
     (False, True ) -> ([], us,  m) -- inaccessible rhs
-  where m = [[noLoc p]]
+  where m = [L locn [L locn p]]
 
 -- | Check a matchgroup (case, functions, etc.)
 checkMatches :: DynFlags -> DsMatchContext
@@ -179,7 +179,7 @@ checkMatches' vars matches
       resetPmIterDs -- set the iter-no to zero
       missing    <- mkInitialUncovered vars
       (rs,us,ds) <- go matches missing
-      return (map hsLMatchPats rs, us, map hsLMatchPats ds)
+      return (map hsLMatchToLPats rs, us, map hsLMatchToLPats ds)
   where
     go []     missing = return ([], missing, [])
     go (m:ms) missing = do
@@ -192,6 +192,9 @@ checkMatches' vars matches
         (False, False) -> (m:rs, final_u,   is) -- redundant
         (False, True ) -> (  rs, final_u, m:is) -- inaccessible
 
+    hsLMatchToLPats :: LMatch id body -> Located [LPat id]
+    hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -365,6 +368,11 @@ translatePat fam_insts pat = case pat of
     let tuple_con = tupleDataCon boxity (length ps)
     return [vanillaConPattern tuple_con tys (concat tidy_ps)]
 
+  SumPat p alt arity ty -> do
+    tidy_p <- translatePat fam_insts (unLoc p)
+    let sum_con = sumDataCon alt arity
+    return [vanillaConPattern sum_con ty tidy_p]
+
   -- --------------------------------------------------------------------------
   -- Not supposed to happen
   ConPatIn  {} -> panic "Check.translatePat: ConPatIn"
@@ -1238,28 +1246,35 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
       let exists_r = flag_i && notNull redundant
           exists_i = flag_i && notNull inaccessible
           exists_u = flag_u && notNull uncovered
-      when exists_r $ putSrcSpanDs loc (warnDs (pprEqns  redundant    rmsg))
-      when exists_i $ putSrcSpanDs loc (warnDs (pprEqns  inaccessible imsg))
-      when exists_u $ putSrcSpanDs loc (warnDs (pprEqnsU uncovered))
+      when exists_r $ forM_ redundant $ \(L l q) -> do
+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+                               (pprEqn q "is redundant"))
+      when exists_i $ forM_ inaccessible $ \(L l q) -> do
+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+                               (pprEqn q "has inaccessible right hand side"))
+      when exists_u $
+        putSrcSpanDs loc (warnDs flag_u_reason (pprEqns uncovered))
   where
     (redundant, uncovered, inaccessible) = pm_result
 
     flag_i = wopt Opt_WarnOverlappingPatterns dflags
     flag_u = exhaustive dflags kind
+    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
 
-    rmsg = "are redundant"
-    imsg = "have inaccessible right hand side"
+    maxPatterns = maxUncoveredPatterns dflags
 
-    pprEqns qs txt = pp_context ctx (text txt) $ \f ->
-      vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ dots qs
+    -- Print a single clause (for redundant/with-inaccessible-rhs)
+    pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q
 
-    pprEqnsU qs = pp_context ctx (text "are non-exhaustive") $ \_ ->
+    -- Print several clauses (for uncovered clauses)
+    pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->
       case qs of -- See #11245
            [ValVec [] _]
                     -> text "Guards do not cover entire pattern space"
            _missing -> let us = map ppr qs
                        in  hang (text "Patterns not matched:") 4
-                                (vcat (take maximum_output us) $$ dots us)
+                                (vcat (take maxPatterns us)
+                                 $$ dots maxPatterns us)
 
 -- | Issue a warning when the predefined number of iterations is exceeded
 -- for the pattern match checker
@@ -1267,7 +1282,7 @@ warnPmIters :: DynFlags -> DsMatchContext -> PmM ()
 warnPmIters dflags (DsMatchContext kind loc)
   = when (flag_i || flag_u) $ do
       iters <- maxPmCheckIterations <$> getDynFlags
-      putSrcSpanDs loc (warnDs (msg iters))
+      putSrcSpanDs loc (warnDs NoReason (msg iters))
   where
     ctxt   = pprMatchContext kind
     msg is = fsep [ text "Pattern match checker exceeded"
@@ -1278,37 +1293,49 @@ warnPmIters dflags (DsMatchContext kind loc)
     flag_i = wopt Opt_WarnOverlappingPatterns dflags
     flag_u = exhaustive dflags kind
 
-dots :: [a] -> SDoc
-dots qs | qs `lengthExceeds` maximum_output = text "..."
-        | otherwise                         = empty
+dots :: Int -> [a] -> SDoc
+dots maxPatterns qs
+    | qs `lengthExceeds` maxPatterns = text "..."
+    | otherwise                      = empty
 
 -- | Check whether the exhaustiveness checker should run (exhaustiveness only)
 exhaustive :: DynFlags -> HsMatchContext id -> Bool
-exhaustive  dflags (FunRhs {})   = wopt Opt_WarnIncompletePatterns dflags
-exhaustive  dflags CaseAlt       = wopt Opt_WarnIncompletePatterns dflags
-exhaustive _dflags IfAlt         = False
-exhaustive  dflags LambdaExpr    = wopt Opt_WarnIncompleteUniPatterns dflags
-exhaustive  dflags PatBindRhs    = wopt Opt_WarnIncompleteUniPatterns dflags
-exhaustive  dflags ProcExpr      = wopt Opt_WarnIncompleteUniPatterns dflags
-exhaustive  dflags RecUpd        = wopt Opt_WarnIncompletePatternsRecUpd dflags
-exhaustive _dflags ThPatSplice   = False
-exhaustive _dflags PatSyn        = False
-exhaustive _dflags ThPatQuote    = False
-exhaustive _dflags (StmtCtxt {}) = False -- Don't warn about incomplete patterns
+exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
+
+-- | Denotes whether an exhaustiveness check is supported, and if so,
+-- via which 'WarningFlag' it's controlled.
+-- Returns 'Nothing' if check is not supported.
+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
+exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag IfAlt         = Nothing
+exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd
+exhaustiveWarningFlag ThPatSplice   = Nothing
+exhaustiveWarningFlag PatSyn        = Nothing
+exhaustiveWarningFlag ThPatQuote    = Nothing
+exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns
                                        -- in list comprehensions, pattern guards
                                        -- etc. They are often *supposed* to be
                                        -- incomplete
 
-pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
-pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
-  = vcat [text "Pattern match(es)" <+> msg,
+-- True <==> singular
+pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
+  = vcat [text txt <+> msg,
           sep [ text "In" <+> ppr_match <> char ':'
               , nest 4 (rest_of_msg_fun pref)]]
   where
+    txt | singular  = "Pattern match"
+        | otherwise = "Pattern match(es)"
+
     (ppr_match, pref)
         = case kind of
-             FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
-             _          -> (pprMatchContext kind, \ pp -> pp)
+             FunRhs (L _ fun) _ -> (pprMatchContext kind,
+                                    \ pp -> ppr fun <+> pp)
+             _                  -> (pprMatchContext kind, \ pp -> pp)
 
 ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
 ppr_pats kind pats
@@ -1330,12 +1357,6 @@ ppr_uncovered (expr_vec, complex)
     sdoc_vec = mapM pprPmExprWithParens expr_vec
     (vec,cs) = runPmPprM sdoc_vec (filterComplex complex)
 
--- | This variable shows the maximum number of lines of output generated for
--- warnings. It will limit the number of patterns/equations displayed to
--- maximum_output. (TODO: add command-line option?)
-maximum_output :: Int
-maximum_output = 4
-
 {- Note [Representation of Term Equalities]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In the paper, term constraints always take the form (x ~ e). Of course, a more