X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=92dae2227fbc206c1c8abf06ceac371393ec1dc4;hb=2c6d73e2ca9a545c4295c6f532cd3612e7fd3d8d;hp=91bfde287e0cea3d92b43d51ab0d943ae8f668b8;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 91bfde2..92dae22 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,39 +8,26 @@ 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 TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext ) import DsHsSyn ( outPatType ) import Check ( check, ExhaustivePat ) import CoreSyn +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 Type ( splitAlgTyConApp, mkTyVarTys, Type ) +import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon ) +import BasicTypes ( Boxity(..) ) import UniqSet -import ErrUtils ( addErrLocHdrLine, dontAddErrLoc ) +import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc ) import Outputable \end{code} @@ -56,7 +43,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` \ () -> @@ -70,8 +62,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 @@ -114,76 +108,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 RecUpdMatch pats - = (hang (ptext SLIT("in a record-update construct")) - 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 (RecUpdMatch) = 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) = @@ -477,7 +417,7 @@ tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result -- 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) + 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, @@ -498,44 +438,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... @@ -695,9 +622,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} @@ -724,21 +650,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} %************************************************************************ @@ -753,7 +682,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 @@ -773,10 +702,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 -> @@ -795,10 +726,9 @@ 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) ->