X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=f65de3c3f2d4624791d728ac7eb4ccbc731983fc;hb=9bb6b6d0fbca6c82040027fab9859c9fcbc1ef7e;hp=6c242a9c9bf52e8e69c8af34b4f797189d2416f3;hpb=a61995821fca70c4d62769757d6808ebbc970e12;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 6c242a9..f65de3c 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,38 +8,24 @@ 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(..), DynFlags, 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 Outputable @@ -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,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 @@ -136,6 +129,12 @@ pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun , 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) @@ -172,6 +171,7 @@ 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("=") @@ -185,7 +185,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,21 +457,21 @@ tidy1 v (LazyPat pat) match_result -- re-express as (ConPat ...) [directly] -tidy1 v (RecPat data_con pat_ty tvs dicts rpats) 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 tvs dicts (map WildPat con_arg_tys'), match_result) + returnDs (ConPat data_con pat_ty ex_tvs dicts (map WildPat con_arg_tys'), match_result) | otherwise - = returnDs (ConPat data_con pat_ty tvs dicts pats, match_result) + = 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, @@ -492,89 +492,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 - | 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... @@ -764,20 +706,22 @@ 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 + LambdaMatch | dopt Opt_WarnSimplePatterns dflags -> matchExport + | otherwise -> match + _ -> matchExport \end{code} %************************************************************************ @@ -812,10 +756,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 ->