X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=a537ee8164595207456be32bdf0f122738a33992;hb=39068cf49bf3553f90ec316569619c310a6be8de;hp=c71eb5c2f1ada411d0474ebf908d26cd3327c6dc;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index c71eb5c..a537ee8 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,40 +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 DsHsSyn ( 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, - 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} @@ -57,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` \ () -> @@ -71,15 +62,17 @@ 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 \end{code} -This variable shows the maximun number of lines of output generated for warnings. -It will limit the number of patterns/equations displayed to maximum_output. +This variable shows the maximum number of lines of output generated for warnings. +It will limit the number of patterns/equations displayed to@ maximum_output@. (ToDo: add command-line option?) @@ -87,7 +80,7 @@ It will limit the number of patterns/equations displayed to maximum_output. maximum_output = 4 \end{code} -The next two functions creates the warning message. +The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () @@ -115,69 +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 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 message (nest 8 (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) + + message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':' 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 +131,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} @@ -457,14 +403,21 @@ tidy1 v (LazyPat pat) match_result -- re-express as (ConPat ...) [directly] -tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result - = returnDs (ConPat data_con pat_ty tvs dicts pats, match_result) +tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result + | null rpats + = -- Special case for C {}, which can be used for + -- a constructor that isn't declared to have + -- fields at all + returnDs (ConPat data_con pat_ty ex_tvs dicts (map WildPat con_arg_tys'), match_result) + + | otherwise + = returnDs (ConPat data_con pat_ty ex_tvs dicts pats, match_result) where 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 + 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, @@ -485,89 +438,31 @@ tidy1 v (ListPat ty pats) match_result (ConPat nilDataCon list_ty [] [] []) pats -tidy1 v (TuplePat pats True{-boxed-}) match_result +tidy1 v (TuplePat pats boxity) 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 - = 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 - | isUnLiftedType lit_ty - = returnDs (pat, match_result) - - | lit_ty == charTy - = returnDs (ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy], - match_result) - - | otherwise = pprPanic "tidy1:LitPat:" (ppr pat) - where - mk_char (HsChar c) = HsCharPrim c + = 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 (better_pat, match_result) - where - better_pat - | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy] - | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy] - | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy] - | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy] - | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy] - | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy] - - -- Convert the literal pattern "" to the constructor pattern []. - | null_str_lit lit = ConPat nilDataCon lit_ty [] [] [] - - | otherwise = pat - - mk_int (HsInt i) = HsIntPrim i - mk_int l@(HsLitLit s) = l - - mk_char (HsChar c) = HsCharPrim c - mk_char l@(HsLitLit s) = l - - mk_word l@(HsLitLit s) = l - - mk_addr l@(HsLitLit s) = l - - mk_float (HsInt i) = HsFloatPrim (fromInteger i) - mk_float (HsFrac f) = HsFloatPrim f - mk_float l@(HsLitLit s) = l - - mk_double (HsInt i) = HsDoublePrim (fromInteger i) - mk_double (HsFrac f) = HsDoublePrim f - mk_double l@(HsLitLit s) = l - - null_str_lit (HsString s) = _NULL_ s - null_str_lit other_lit = False + = returnDs (tidyNPat lit lit_ty pat, match_result) -- and everything else goes through unchanged... @@ -575,7 +470,8 @@ tidy1 v non_interesting_pat match_result = returnDs (non_interesting_pat, match_result) \end{code} -PREVIOUS matchTwiddled STUFF: +\noindent +{\bf Previous @matchTwiddled@ stuff:} Now we get to the only interesting part; note: there are choices for translation [from Simon's notes]; translation~1: @@ -726,44 +622,52 @@ 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 :: HsMatchContext -- For shadowing warning messages + -> [TypecheckedMatch] -- Matches being desugared + -> String -- Error message if the match fails -> DsM ([Id], CoreExpr) -- Results \end{code} There is one small problem with the Lambda Patterns, when somebody writes something similar to: +\begin{verbatim} (\ (x:xs) -> ...) +\end{verbatim} he/she don't want a warning about incomplete patterns, that is done with - the flag opt_WarnSimplePatterns. - This problem also appears in the : - do patterns, but if the do can fail it creates another equation if the match can - fail (see DsExpr.doDo function) - let patterns, are treated by matchSimply - List Comprension Patterns, are treated by matchSimply also - -We can't call matchSimply with Lambda patterns, due to lambda patterns can have more than + the flag @opt_WarnSimplePatterns@. + This problem also appears in the: +\begin{itemize} +\item @do@ patterns, but if the @do@ can fail + it creates another equation if the match can fail + (see @DsExpr.doDo@ function) +\item @let@ patterns, are treated by @matchSimply@ + List Comprension Patterns, are treated by @matchSimply@ also +\end{itemize} + +We can't call @matchSimply@ with Lambda patterns, +due to the fact that lambda patterns can have more than 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) -> + = getDOptsDs `thenDs` \ dflags -> + flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) -> let EqnInfo _ _ arg_pats _ : _ = eqns_info 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 kind of + LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport + | otherwise -> match + _ -> matchExport \end{code} %************************************************************************ @@ -777,11 +681,11 @@ situation where we want to match a single expression against a single pattern. It returns an expression. \begin{code} -matchSimply :: CoreExpr -- Scrutinee - -> DsMatchKind -- Match kind - -> TypecheckedPat -- Pattern it should match - -> CoreExpr -- Return this if it matches - -> CoreExpr -- Return this if it doesn't +matchSimply :: CoreExpr -- Scrutinee + -> HsMatchContext -- Match kind + -> TypecheckedPat -- Pattern it should match + -> CoreExpr -- Return this if it matches + -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr matchSimply scrut kind pat result_expr fail_expr @@ -798,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 -> @@ -820,10 +726,9 @@ matchSinglePat scrut ctx pat match_result This is actually local to @matchWrapper@. \begin{code} -flattenMatches - :: DsMatchKind - -> [TypecheckedMatch] - -> DsM (Type, [EquationInfo]) +flattenMatches :: HsMatchContext + -> [TypecheckedMatch] + -> DsM (Type, [EquationInfo]) flattenMatches kind matches = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) ->