X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=a8e2d39f7573ba1b421eaf99c23e40baaef97b66;hb=e2b5796d58ffce3f62f71439df51932679ffb16c;hp=f9452924e863ca08796d45aa586c7d7715ea37f5;hpb=36d207aa8c9cedbf58e739178971292048bd41d0;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index f945292..a8e2d39 100644 --- 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 @@ -228,7 +229,7 @@ unBoxArgType ty pp_this Note [Nesting] ~~~~~~~~~~~~~~ -tcPat takes a "thing inside" over which the patter scopes. This is partly +tcPat takes a "thing inside" over which the pattern scopes. This is partly so that tcPat can extend the environment for the thing_inside, but also so that constraints arising in the thing_inside can be discharged by the pattern. @@ -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 @@ -555,7 +556,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad, -- not from ex_tvs ; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs) - (ctxt_res_tys ++ mkTyVarTys ex_tvs') + (ctxt_res_tys ++ mkTyVarTys ex_tvs') eq_spec' = substEqSpec tenv eq_spec theta' = substTheta tenv theta arg_tys' = substTys tenv arg_tys @@ -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} @@ -813,6 +814,19 @@ tcOverloadedLit orig lit@(HsFractional r fr) res_ty = do { expr <- newLitInst orig lit res_ty ; return (HsFractional r expr) } +tcOverloadedLit orig lit@(HsIsString s fr) res_ty + | not (fr `isHsVar` fromStringName) -- c.f. HsIntegral case + = do { str_ty <- tcMetaTy stringTyConName + ; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty) + ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s)))) } + + | Just expr <- shortCutStringLit s res_ty + = return (HsIsString s expr) + + | otherwise + = do { expr <- newLitInst orig lit res_ty + ; return (HsIsString s expr) } + newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId) newLitInst orig lit res_ty -- Make a LitInst = do { loc <- getInstLoc orig @@ -906,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 to unpack the constructor.", text "In the binding group for"]) 4 (ppr pat) @@ -919,13 +934,12 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env sep [ptext SLIT("When checking an existential match that binds"), nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)), ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys), - ptext SLIT("The body has type:") <+> ppr tidy_body_ty, - ppr pats + ptext SLIT("The body has type:") <+> ppr tidy_body_ty ]) } where bound_ids = collectPatsBinders pats show_ids = filter is_interesting bound_ids - is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs + is_interesting id = any (`elemVarSet` varTypeTyVars id) bound_tvs ppr_id id ty = ppr id <+> dcolon <+> ppr ty -- Don't zonk the types so we get the separate, un-unified versions @@ -944,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