Merge Haddock comment support from ghc.haddock -- big patch

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

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 0f923ff..b9099be 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -11,16 +11,18 @@ module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
 
 import {-# SOURCE #-}  TcExpr( tcSyntaxOp )
 import HsSyn           ( Pat(..), LPat, HsConDetails(..), HsLit(..),
-                         HsOverLit(..), HsExpr(..), OutPat, ExprCoFn(..),
-                         mkCoPat, idCoercion,
+                         HsOverLit(..), HsExpr(..), HsWrapper(..),
+                         mkCoPat, HsRecField(..), mkRecField,
                          LHsBinds, emptyLHsBinds, isEmptyLHsBinds, 
-                         collectPatsBinders, nlHsLit )
+                         collectPatsBinders, nlHsLit,
+                          LHsDoc )
 import TcHsSyn         ( TcId, hsLitType )
 import TcRnMonad
 import Inst            ( InstOrigin(..), shortCutFracLit, shortCutIntLit, 
                          newDictBndrs, instToId, instStupidTheta, isHsVar
                        )
 import Id              ( Id, idType, mkLocalId )
+import Var             ( CoVar, tyVarKind )
 import CoreFVs         ( idFreeTyVars )
 import Name            ( Name, mkSystemVarName )
 import TcSimplify      ( tcSimplifyCheck, bindInstsOfLocalFuns )
@@ -28,14 +30,15 @@ import TcEnv                ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2,
                          tcLookupClass, tcLookupDataCon, refineEnvironment,
                          tcLookupField, tcMetaTy )
 import TcMType                 ( newFlexiTyVarTy, arityErr, tcInstSkolTyVars, 
-                         newCoVars, zonkTcType, tcInstTyVars )
+                         newCoVars, zonkTcType, tcInstTyVars, newBoxyTyVar )
 import TcType          ( TcType, TcTyVar, TcSigmaType, TcRhoType, BoxyType,
                          SkolemInfo(PatSkol), 
                          BoxySigmaType, BoxyRhoType, argTypeKind, typeKind,
                          pprSkolTvBinding, isRigidTy, tcTyVarsOfTypes, 
-                         zipTopTvSubst, isArgTypeKind, isUnboxedTupleType,
+                         zipTopTvSubst, isSubArgTypeKind, isUnboxedTupleType,
                          mkTyVarTys, mkClassPred, isOverloadedTy, substEqSpec,
-                         mkFunTy, mkFunTys, tidyOpenType, tidyOpenTypes )
+                         mkFunTy, mkFunTys, tidyOpenType, tidyOpenTypes,
+                         mkTyVarTy )
 import VarSet          ( elemVarSet )
 import {- Kind parts of -} 
        Type            ( liftedTypeKind )
@@ -44,10 +47,11 @@ import TcUnify              ( boxySplitTyConApp, boxySplitListTy, unBox,
                          checkSigTyVarsWrt, unifyType )
 import TcHsType                ( UserTypeCtxt(..), tcPatSig )
 import TysWiredIn      ( boolTy, parrTyCon, tupleTyCon )
+import TcGadt          ( Refinement, emptyRefinement, gadtRefine, refineType )
 import Type            ( Type, mkTyConApp, substTys, substTheta )
 import StaticFlags     ( opt_IrrefutableTuples )
 import TyCon           ( TyCon, FieldLabel, tyConFamInst_maybe,
-                         tyConFamilyCoercion_maybe, tyConTyVars, isNewTyCon )
+                         tyConFamilyCoercion_maybe, tyConTyVars )
 import DataCon         ( DataCon, dataConTyCon, dataConFullSig, dataConName,
                          dataConFieldLabels, dataConSourceArity, 
                          dataConStupidTheta, dataConUnivTyVars )
@@ -227,7 +231,7 @@ unBoxArgType ty pp_this
        -- but they improve error messages, and allocate fewer tyvars
        ; if isUnboxedTupleType ty' then
                failWithTc msg
-         else if isArgTypeKind (typeKind ty') then
+         else if isSubArgTypeKind (typeKind ty') then
                return ty'
          else do       -- OpenTypeKind, so constrain it
        { ty2 <- newFlexiTyVarTy argTypeKind
@@ -559,7 +563,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
              arg_tys' = substTys    tenv arg_tys
 
        ; co_vars <- newCoVars eq_spec' -- Make coercion variables
-       ; pstate' <- refineAlt data_con pstate ex_tvs co_vars pat_ty
+       ; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty
 
        ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
                tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
@@ -568,7 +572,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
        ; dicts <- newDictBndrs loc theta'
        ; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req
 
-       ; addDataConStupidTheta origin data_con ctxt_res_tys
+       ; addDataConStupidTheta data_con ctxt_res_tys
 
        ; return
            (unwrapFamInstScrutinee tycon ctxt_res_tys $
@@ -613,7 +617,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
           -- NB: We can use CoPat directly, rather than mkCoPat, as we know the
           --    coercion is not the identity; mkCoPat is inconvenient as it
           --    wants a located pattern.
-      = CoPat (ExprCoFn $ mkTyConApp co_con args)       -- co fam ty to repr ty
+      = CoPat (WpCo $ mkTyConApp co_con args)       -- co fam ty to repr ty
              (pat {pat_ty = mkTyConApp tycon args})    -- representation type
              pat_ty                                    -- family inst type
       | otherwise
@@ -644,15 +648,19 @@ tcConArgs data_con [arg_ty1,arg_ty2] (InfixCon p1 p2) pstate thing_inside
   where
     con_arity  = dataConSourceArity data_con
 
+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
   = do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
        ; return (RecCon rpats', tvs, res) }
   where
-    tc_field :: Checker (Located Name, LPat Name) (Located TcId, LPat TcId)
-    tc_field (field_lbl, pat) pstate thing_inside
+    -- 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
       = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
           ; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
-          ; return ((sel_id, pat'), tvs, res) }
+          ; return (mkRecField sel_id pat', tvs, res) }
 
     find_field_ty :: FieldLabel -> TcM (Id, TcType)
     find_field_ty field_lbl
@@ -691,13 +699,16 @@ tcConArg (arg_pat, arg_ty) pstate thing_inside
 \end{code}
 
 \begin{code}
-addDataConStupidTheta :: InstOrigin -> DataCon -> [TcType] -> TcM ()
+addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
 -- Instantiate the "stupid theta" of the data con, and throw 
 -- the constraints into the constraint set
-addDataConStupidTheta origin data_con inst_tys
+addDataConStupidTheta data_con inst_tys
   | null stupid_theta = return ()
   | otherwise        = instStupidTheta origin inst_theta
   where
+    origin = OccurrenceOf (dataConName data_con)
+       -- The origin should always report "occurrence of C"
+       -- even when C occurs in a pattern
     stupid_theta = dataConStupidTheta data_con
     tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
     inst_theta = substTheta tenv stupid_theta
@@ -747,7 +758,10 @@ refineAlt con pstate ex_tvs co_vars pat_ty
                    -- might be inside a lazy pattern.  Instead, refine pstate
                where
                    
-                   trace_msg = text "refineAlt:match" <+> ppr con <+> ppr reft
+                   trace_msg = text "refineAlt:match" <+> 
+                               vcat [ ppr con <+> ppr ex_tvs,
+                                      ppr [(v, tyVarKind v) | v <- co_vars],
+                                      ppr reft]
        }
 \end{code}