Implement unboxed sum primitive type
[ghc.git] / compiler / deSugar / Check.hs
index fe1b4bc..6ee5bff 100644 (file)
@@ -368,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"
@@ -1256,6 +1261,8 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
     flag_u = exhaustive dflags kind
     flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
 
+    maxPatterns = maxUncoveredPatterns dflags
+
     -- Print a single clause (for redundant/with-inaccessible-rhs)
     pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q
 
@@ -1266,7 +1273,8 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
                     -> 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
@@ -1285,9 +1293,10 @@ 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
@@ -1324,8 +1333,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
 
     (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
@@ -1347,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