X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=9cea0eaa7b759d8b8bb49e5d4d61f902832d1e7d;hb=b99310f05faee2abec850da4349fcd5c0498f7ca;hp=e7fd6ca6d1c939a86acfc85ab7bfad6bba24f431;hpb=8ffdb8eed6b38db00761093889f5cddbe8ca1d60;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index e7fd6ca..9cea0ea 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 @@ -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, or do-notation, to unpack the constructor.", text "In the binding group for"]) 4 (ppr pat) @@ -943,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