Adding pushing of hpc translation status through hi files.

[ghc-hetmet.git] / compiler / typecheck / TcPat.lhs

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index ca3433c..9cea0ea 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -34,6 +34,7 @@ import Type
 import StaticFlags
 import TyCon
 import DataCon
+import DynFlags
 import PrelNames
 import BasicTypes hiding (SuccessFlag(..))
 import SrcLoc
@@ -470,7 +471,7 @@ tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
        ; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
        ; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
 
-tc_pat _ _other_pat _ _ = panic "tc_pat"       -- DictPat, ConPatOut, SigPatOut, VarPatOut
+tc_pat _ _other_pat _ _ = panic "tc_pat"       -- ConPatOut, SigPatOut, VarPatOut
 \end{code}
 
 
@@ -543,10 +544,10 @@ further type refinement is local to the alternative.
 
 tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon 
         -> BoxySigmaType       -- Type of the pattern
-        -> HsConDetails Name (LPat Name) -> (PatState -> TcM a)
+        -> HsConPatDetails Name -> (PatState -> TcM a)
         -> TcM (Pat TcId, [TcTyVar], a)
 tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
-  = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
+  = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
              skol_info = PatSkol data_con
              origin    = SigOrigin skol_info
 
@@ -583,9 +584,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
             ex_tvs' ++ inner_tvs, res)
        }
   where
-    -- Split against the family tycon if the pattern constructor belongs to a
-    -- representation tycon.
-    --
+    -- Split against the family tycon if the pattern constructor 
+    -- belongs to a family instance tycon.
     boxySplitTyConAppWithFamily tycon pat_ty =
       traceTc traceMsg >>
       case tyConFamInst_maybe tycon of
@@ -622,8 +622,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 
 
 tcConArgs :: DataCon -> [TcSigmaType]
-         -> Checker (HsConDetails Name (LPat Name)) 
-                    (HsConDetails Id (LPat Id))
+         -> Checker (HsConPatDetails Name) (HsConPatDetails Id)
 
 tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside
   = do { checkTc (con_arity == no_of_args)     -- Check correct arity
@@ -648,16 +647,15 @@ tcConArgs data_con [arg_ty1,arg_ty2] (InfixCon p1 p2) pstate thing_inside
 tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside
   = pprPanic "tcConArgs" (ppr data_con)        -- InfixCon always has two arguments
 
-tcConArgs data_con arg_tys (RecCon rpats) pstate thing_inside
+tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
   = do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
-       ; return (RecCon rpats', tvs, res) }
+       ; return (RecCon (HsRecFields rpats' dd), tvs, res) }
   where
-    -- doc comments are typechecked to Nothing here
     tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
-    tc_field (HsRecField field_lbl pat _) pstate thing_inside
+    tc_field (HsRecField field_lbl pat pun) pstate thing_inside
       = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
           ; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
-          ; return (mkRecField sel_id pat', tvs, res) }
+          ; return (HsRecField sel_id pat' pun, tvs, res) }
 
     find_field_ty :: FieldLabel -> TcM (Id, TcType)
     find_field_ty field_lbl
@@ -730,8 +728,11 @@ refineAlt con pstate ex_tvs [] pat_ty
   = return pstate      -- Common case: no equational constraints
 
 refineAlt con pstate ex_tvs co_vars pat_ty
-  | not (isRigidTy pat_ty)
-  = failWithTc (nonRigidMatch con)
+  = do { opt_gadt <- doptM Opt_GADTs   -- No type-refinement unless GADTs are on
+       ; if (not opt_gadt) then return pstate
+         else do 
+
+       { checkTc (isRigidTy pat_ty) (nonRigidMatch con)
        -- We are matching against a GADT constructor with non-trivial
        -- constraints, but pattern type is wobbly.  For now we fail.
        -- We can make sense of this, however:
@@ -746,8 +747,8 @@ refineAlt con pstate ex_tvs co_vars pat_ty
        -- then unify these constraints to make pat_ty the right shape;
        -- then proceed exactly as in the rigid case
 
-  | otherwise  -- In the rigid case, we perform type refinement
-  = case gadtRefine (pat_reft pstate) ex_tvs co_vars of {
+               -- In the rigid case, we perform type refinement
+       ; case gadtRefine (pat_reft pstate) ex_tvs co_vars of {
            Failed msg     -> failWithTc (inaccessibleAlt msg) ;
            Succeeded reft -> do { traceTc trace_msg
                                 ; return (pstate { pat_reft = reft }) }
@@ -759,7 +760,7 @@ refineAlt con pstate ex_tvs co_vars pat_ty
                                vcat [ ppr con <+> ppr ex_tvs,
                                       ppr [(v, tyVarKind v) | v <- co_vars],
                                       ppr reft]
-       }
+       } } }
 \end{code}
 
 
@@ -919,6 +920,7 @@ patCtxt pat             = Just (hang (ptext SLIT("In the pattern:"))
 existentialExplode pat
   = hang (vcat [text "My brain just exploded.",
                text "I can't handle pattern bindings for existentially-quantified constructors.",
+               text "Instead, use a case-expression, or do-notation, to unpack the constructor.",
                text "In the binding group for"])
        4 (ppr pat)
 
@@ -956,7 +958,7 @@ badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
 
 lazyPatErr pat tvs
   = failWithTc $
-    hang (ptext SLIT("A lazy (~) pattern connot bind existential type variables"))
+    hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables"))
        2 (vcat (map pprSkolTvBinding tvs))
 
 nonRigidMatch con