X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=e56a8abc1d3a1aaa61d6a6241c4de5dfdb6ec821;hb=225d251337438e2f7870f0ec2781b1c616ef7462;hp=fcc65af8a1c0be47477ad488ea959606ffcd5d2a;hpb=03434db2706b0a8a15956e07cf3445b11b645260;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index fcc65af..e56a8ab 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,40 +8,25 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) - -import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns, - opt_WarnSimplePatterns - ) +import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( TypecheckedPat, TypecheckedMatch ) -import DsHsSyn ( outPatType ) +import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType ) import Check ( check, ExhaustivePat ) import CoreSyn -import CoreUtils ( coreExprType ) +import CoreUtils ( bindNonRec ) import DsMonad import DsGRHSs ( dsGRHSs ) import DsUtils import Id ( idType, recordSelectorFieldLabel, Id ) -import DataCon ( dataConFieldLabels, dataConArgTys ) +import DataCon ( dataConFieldLabels, dataConInstOrigArgTys ) import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import PrelInfo ( pAT_ERROR_ID ) -import Type ( isUnLiftedType, splitAlgTyConApp, - mkTyVarTys, Type - ) -import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, - addrPrimTy, wordPrimTy - ) -import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, - charTy, charDataCon, intTy, intDataCon, - floatTy, floatDataCon, doubleTy, tupleCon, - doubleDataCon, addrTy, - addrDataCon, wordTy, wordDataCon, - mkUnboxedTupleTy, unboxedTupleCon - ) +import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType ) +import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon ) +import BasicTypes ( Boxity(..) ) import UniqSet -import ErrUtils ( addErrLocHdrLine, dontAddErrLoc ) +import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc ) import Outputable \end{code} @@ -57,7 +42,12 @@ matchExport :: [Id] -- Vars rep'ing the exprs we're matching with -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) + +matchExport vars qs + = getDOptsDs `thenDs` \ dflags -> + matchExport_really dflags vars qs + +matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) | incomplete && shadow = dsShadowWarn ctx eqns_shadow `thenDs` \ () -> dsIncompleteWarn ctx pats `thenDs` \ () -> @@ -71,8 +61,10 @@ matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) | otherwise = match vars qs where (pats,indexs) = check qs - incomplete = opt_WarnIncompletePatterns && (length pats /= 0) - shadow = opt_WarnOverlappingPatterns && sizeUniqSet indexs < no_eqns + incomplete = dopt Opt_WarnIncompletePatterns dflags + && (length pats /= 0) + shadow = dopt Opt_WarnOverlappingPatterns dflags + && sizeUniqSet indexs < no_eqns no_eqns = length qs unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs) eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns @@ -115,69 +107,22 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn | otherwise = empty pp_context NoMatchContext msg rest_of_msg_fun - = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) + = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun - = case pp_match kind pats of - (ppr_match, pref) -> - addErrLocHdrLine loc message (nest 8 (rest_of_msg_fun pref)) - where - message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':' - where - pp_match (FunMatch fun) pats - = let ppr_fun = ppr fun in - ( hsep [ptext SLIT("in the definition of function"), quotes ppr_fun] - , (\ x -> ppr_fun <+> x) - ) - - pp_match CaseMatch pats - = (hang (ptext SLIT("in a group of case alternatives beginning")) - 4 (ppr_pats pats) - , id - ) - - pp_match PatBindMatch pats - = ( hang (ptext SLIT("in a pattern binding")) - 4 (ppr_pats pats) - , id - ) - - pp_match LambdaMatch pats - = ( hang (ptext SLIT("in a lambda abstraction")) - 4 (ppr_pats pats) - , id - ) - - pp_match DoBindMatch pats - = ( hang (ptext SLIT("in a `do' pattern binding")) - 4 (ppr_pats pats) - , id - ) - - pp_match ListCompMatch pats - = ( hang (ptext SLIT("in a `list comprension' pattern binding")) - 4 (ppr_pats pats) - , id - ) - - pp_match LetMatch pats - = ( hang (ptext SLIT("in a `let' pattern binding")) - 4 (ppr_pats pats) - , id - ) + = addWarnLocHdrLine loc + (ptext SLIT("Pattern match(es)") <+> msg) + (sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]) + where + (ppr_match, pref) + = case kind of + FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + other -> (pprMatchContext kind <+> ppr_pats pats, \ pp -> pp) ppr_pats pats = sep (map ppr pats) -separator (FunMatch _) = SLIT("=") -separator (CaseMatch) = SLIT("->") -separator (LambdaMatch) = SLIT("->") -separator (PatBindMatch) = panic "When is this used?" -separator (DoBindMatch) = SLIT("<-") -separator (ListCompMatch) = SLIT("<-") -separator (LetMatch) = SLIT("=") - ppr_shadow_pats kind pats - = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")] + = sep [ppr_pats pats, ptext (matchSeparator kind), ptext SLIT("...")] ppr_incomplete_pats kind (pats,[]) = ppr_pats pats ppr_incomplete_pats kind (pats,constraints) = @@ -185,7 +130,7 @@ ppr_incomplete_pats kind (pats,constraints) = sep (map ppr_constraint constraints)] -ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats] +ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats] ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats) \end{code} @@ -470,8 +415,8 @@ tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor - (_, inst_tys, _) = splitAlgTyConApp pat_ty - con_arg_tys' = dataConArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs) + inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque + con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs) tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con) -- mk_pat picks a WildPat of the appropriate type for absent fields, @@ -492,44 +437,31 @@ tidy1 v (ListPat ty pats) match_result (ConPat nilDataCon list_ty [] [] []) pats -tidy1 v (TuplePat pats True{-boxed-}) match_result - = returnDs (tuple_ConPat, match_result) - where - arity = length pats - tuple_ConPat - = ConPat (tupleCon arity) - (mkTupleTy arity (map outPatType pats)) [] [] - pats - -tidy1 v (TuplePat pats False{-unboxed-}) match_result +tidy1 v (TuplePat pats boxity) match_result = returnDs (tuple_ConPat, match_result) where arity = length pats tuple_ConPat - = ConPat (unboxedTupleCon arity) - (mkUnboxedTupleTy arity (map outPatType pats)) [] [] + = ConPat (tupleCon boxity arity) + (mkTupleTy boxity arity (map outPatType pats)) [] [] pats tidy1 v (DictPat dicts methods) match_result = case num_of_d_and_ms of - 0 -> tidy1 v (TuplePat [] True) match_result + 0 -> tidy1 v (TuplePat [] Boxed) match_result 1 -> tidy1 v (head dict_and_method_pats) match_result - _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result + _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) - --- deeply ugly mangling for some (common) NPats/LitPats - --- LitPats: the desugarer only sees these at well-known types - +-- LitPats: we *might* be able to replace these w/ a simpler form tidy1 v pat@(LitPat lit lit_ty) match_result - = returnDs (tidyLitPat lit lit_ty pat, match_result) + = returnDs (tidyLitPat lit pat, match_result) -- NPats: we *might* be able to replace these w/ a simpler form tidy1 v pat@(NPat lit lit_ty _) match_result - = returnDs (tidyLitPat lit lit_ty pat, match_result) + = returnDs (tidyNPat lit lit_ty pat, match_result) -- and everything else goes through unchanged... @@ -689,9 +621,8 @@ Call @match@ with all of this information! \end{enumerate} \begin{code} -matchWrapper :: DsMatchKind -- For shadowing warning messages - -> [TypecheckedMatch] -- Matches being desugared - -> String -- Error message if the match fails +matchWrapper :: TypecheckedMatchContext -- For shadowing warning messages + -> [TypecheckedMatch] -- Matches being desugared -> DsM ([Id], CoreExpr) -- Results \end{code} @@ -718,21 +649,24 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 \begin{code} -matchWrapper kind matches error_string - = flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) -> +matchWrapper ctxt matches + = getDOptsDs `thenDs` \ dflags -> + flattenMatches ctxt matches `thenDs` \ (result_ty, eqns_info) -> let EqnInfo _ _ arg_pats _ : _ = eqns_info + error_string = matchContextErrString ctxt in - mapDs selectMatchVar arg_pats `thenDs` \ new_vars -> - match_fun new_vars eqns_info `thenDs` \ match_result -> + mapDs selectMatchVar arg_pats `thenDs` \ new_vars -> + match_fun dflags new_vars eqns_info `thenDs` \ match_result -> mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) - where match_fun = case kind of - LambdaMatch | opt_WarnSimplePatterns -> matchExport - | otherwise -> match - _ -> matchExport + where match_fun dflags + = case ctxt of + LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport + | otherwise -> match + _ -> matchExport \end{code} %************************************************************************ @@ -747,7 +681,7 @@ pattern. It returns an expression. \begin{code} matchSimply :: CoreExpr -- Scrutinee - -> DsMatchKind -- Match kind + -> TypecheckedMatchContext -- Match kind -> TypecheckedPat -- Pattern it should match -> CoreExpr -- Return this if it matches -> CoreExpr -- Return this if it doesn't @@ -767,10 +701,12 @@ matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat -> MatchResult -> DsM MatchResult matchSinglePat (Var var) ctx pat match_result - = match_fn [var] [EqnInfo 1 ctx [pat] match_result] + = getDOptsDs `thenDs` \ dflags -> + match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result] where - match_fn | opt_WarnSimplePatterns = matchExport - | otherwise = match + match_fn dflags + | dopt Opt_WarnSimplePatterns dflags = matchExport + | otherwise = match matchSinglePat scrut ctx pat match_result = selectMatchVar pat `thenDs` \ var -> @@ -789,17 +725,16 @@ matchSinglePat scrut ctx pat match_result This is actually local to @matchWrapper@. \begin{code} -flattenMatches - :: DsMatchKind - -> [TypecheckedMatch] - -> DsM (Type, [EquationInfo]) +flattenMatches :: TypecheckedMatchContext + -> [TypecheckedMatch] + -> DsM (Type, [EquationInfo]) flattenMatches kind matches = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) -> let result_ty = head result_tys in - ASSERT( all (== result_ty) result_tys ) + ASSERT( all (tcEqType result_ty) result_tys ) returnDs (result_ty, eqn_infos) where flatten_match (Match _ pats _ grhss, n)