%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[MatchLit]{Pattern-matching literal patterns}
+
+Pattern-matching literal patterns
\begin{code}
-module MatchLit ( dsLit, dsOverLit,
- tidyLitPat, tidyNPat,
+module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
+ tidyLitPat, tidyNPat,
matchLiterals, matchNPlusKPats, matchNPats ) where
#include "HsVersions.h"
import DsUtils
import HsSyn
-import Id ( Id, idType )
+
+import Id
import CoreSyn
-import TyCon ( tyConDataCons )
-import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy,
- isFloatTy, isDoubleTy, isStringTy )
-import Type ( Type )
-import PrelNames ( ratioTyConKey )
-import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
-import PrelNames ( eqStringName )
-import Unique ( hasKey )
-import Literal ( mkMachInt, Literal(..) )
-import SrcLoc ( noLoc )
-import ListSetOps ( equivClasses, runs )
-import Ratio ( numerator, denominator )
-import SrcLoc ( Located(..) )
+import MkCore
+import TyCon
+import DataCon
+import TcHsSyn ( shortCutLit )
+import TcType
+import PrelNames
+import TysWiredIn
+import Literal
+import SrcLoc
+import Data.Ratio
import Outputable
-import FastString ( lengthFS, unpackFS )
+import BasicTypes
+import Util
+import FastString
\end{code}
%************************************************************************
\begin{code}
dsLit :: HsLit -> DsM CoreExpr
-dsLit (HsChar c) = returnDs (mkCharExpr c)
-dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
+dsLit (HsStringPrim s) = return (Lit (MachStr s))
+dsLit (HsCharPrim c) = return (Lit (MachChar c))
+dsLit (HsIntPrim i) = return (Lit (MachInt i))
+dsLit (HsWordPrim w) = return (Lit (MachWord w))
+dsLit (HsFloatPrim f) = return (Lit (MachFloat f))
+dsLit (HsDoublePrim d) = return (Lit (MachDouble d))
+
+dsLit (HsChar c) = return (mkCharExpr c)
dsLit (HsString str) = mkStringExprFS str
-dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
dsLit (HsInteger i _) = mkIntegerExpr i
-dsLit (HsInt i) = returnDs (mkIntExpr i)
-dsLit (HsIntPrim i) = returnDs (mkIntLit i)
-dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
-dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
-
-dsLit (HsRat r ty)
- = mkIntegerExpr (numerator r) `thenDs` \ num ->
- mkIntegerExpr (denominator r) `thenDs` \ denom ->
- returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
+dsLit (HsInt i) = return (mkIntExpr i)
+
+dsLit (HsRat r ty) = do
+ num <- mkIntegerExpr (numerator r)
+ denom <- mkIntegerExpr (denominator r)
+ return (mkConApp ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
- = case tcSplitTyConApp ty of
- (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
- (head (tyConDataCons tycon), i_ty)
+ = case tcSplitTyConApp ty of
+ (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+ (head (tyConDataCons tycon), i_ty)
+ x -> pprPanic "dsLit" (ppr x)
dsOverLit :: HsOverLit Id -> DsM CoreExpr
-- Post-typechecker, the SyntaxExpr field of an OverLit contains
-- (an expression for) the literal value itself
-dsOverLit (HsIntegral _ lit) = dsExpr lit
-dsOverLit (HsFractional _ lit) = dsExpr lit
+dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable
+ , ol_witness = witness, ol_type = ty })
+ | not rebindable
+ , Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut]
+ | otherwise = dsExpr witness
+\end{code}
+
+Note [Literal short cut]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The type checker tries to do this short-cutting as early as possible, but
+becuase of unification etc, more information is available to the desugarer.
+And where it's possible to generate the correct literal right away, it's
+much better do do so.
+
+
+\begin{code}
+hsLitKey :: HsLit -> Literal
+-- Get a Core literal to use (only) a grouping key
+-- Hence its type doesn't need to match the type of the original literal
+-- (and doesn't for strings)
+-- It only works for primitive types and strings;
+-- others have been removed by tidy
+hsLitKey (HsIntPrim i) = mkMachInt i
+hsLitKey (HsWordPrim w) = mkMachWord w
+hsLitKey (HsCharPrim c) = MachChar c
+hsLitKey (HsStringPrim s) = MachStr s
+hsLitKey (HsFloatPrim f) = MachFloat f
+hsLitKey (HsDoublePrim d) = MachDouble d
+hsLitKey (HsString s) = MachStr s
+hsLitKey l = pprPanic "hsLitKey" (ppr l)
+
+hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
+-- Ditto for HsOverLit; the boolean indicates to negate
+hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
+
+litValKey :: OverLitVal -> Bool -> Literal
+litValKey (HsIntegral i) False = MachInt i
+litValKey (HsIntegral i) True = MachInt (-i)
+litValKey (HsFractional r) False = MachFloat (fl_value r)
+litValKey (HsFractional r) True = MachFloat (negate (fl_value r))
+litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tidyLitPat :: HsLit -> LPat Id -> LPat Id
+tidyLitPat :: HsLit -> Pat Id
-- Result has only the following HsLits:
--- HsIntPrim, HsCharPrim, HsFloatPrim
+-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
-- HsDoublePrim, HsStringPrim, HsString
-- * HsInteger, HsRat, HsInt can't show up in LitPats
-- * We get rid of HsChar right here
-tidyLitPat (HsChar c) pat = mkCharLitPat c
-tidyLitPat (HsString s) pat
+tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
+tidyLitPat (HsString s)
| lengthFS s <= 1 -- Short string literals only
- = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
- (mkNilPat stringTy) (unpackFS s)
+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
+ (mkNilPat stringTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
-tidyLitPat lit pat = pat
+tidyLitPat lit = LitPat lit
----------------
-tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> LPat Id -> LPat Id
-tidyNPat over_lit mb_neg lit_ty default_pat
- | isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val)
- | isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
- | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
- | otherwise = default_pat
+tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat
+ -- We need this argument because tidyNPat is called
+ -- both by Match and by Check, but they tidy LitPats
+ -- slightly differently; and we must desugar
+ -- literals consistently (see Trac #5117)
+ -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
+ -> Pat Id
+tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
+ -- False: Take short cuts only if the literal is not using rebindable syntax
+ --
+ -- Once that is settled, look for cases where the type of the
+ -- entire overloaded literal matches the type of the underlying literal,
+ -- and in that case take the short cut
+ -- NB: Watch out for wierd cases like Trac #3382
+ -- f :: Int -> Int
+ -- f "blah" = 4
+ -- which might be ok if we hvae 'instance IsString Int'
+ --
+
+ | isIntTy ty, Just int_lit <- mb_int_lit = mk_con_pat intDataCon (HsIntPrim int_lit)
+ | isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit)
+ | isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit)
+ | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
+ | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
where
- mk_con_pat con lit = mkPrefixConPat con [noLoc $ LitPat lit] lit_ty
- neg_lit = case (mb_neg, over_lit) of
- (Nothing, _) -> over_lit
- (Just _, HsIntegral i s) -> HsIntegral (-i) s
- (Just _, HsFractional f s) -> HsFractional (-f) s
-
- int_val :: Integer
- int_val = case neg_lit of
- HsIntegral i _ -> i
- HsFractional f _ -> panic "tidyNPat"
+ mk_con_pat :: DataCon -> HsLit -> Pat Id
+ mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
+
+ mb_int_lit :: Maybe Integer
+ mb_int_lit = case (mb_neg, val) of
+ (Nothing, HsIntegral i) -> Just i
+ (Just _, HsIntegral i) -> Just (-i)
+ _ -> Nothing
- rat_val :: Rational
- rat_val = case neg_lit of
- HsIntegral i _ -> fromInteger i
- HsFractional f _ -> f
+ mb_rat_lit :: Maybe Rational
+ mb_rat_lit = case (mb_neg, val) of
+ (Nothing, HsIntegral i) -> Just (fromInteger i)
+ (Just _, HsIntegral i) -> Just (fromInteger (-i))
+ (Nothing, HsFractional f) -> Just (fl_value f)
+ (Just _, HsFractional f) -> Just (negate (fl_value f))
+ _ -> Nothing
+
+ mb_str_lit :: Maybe FastString
+ mb_str_lit = case (mb_neg, val) of
+ (Nothing, HsIsString s) -> Just s
+ _ -> Nothing
+
+tidyNPat _ over_lit mb_neg eq
+ = NPat over_lit mb_neg eq
\end{code}
\begin{code}
matchLiterals :: [Id]
- -> Type -- Type of the whole case expression
- -> [EquationInfo]
+ -> Type -- Type of the whole case expression
+ -> [[EquationInfo]] -- All PgLits
-> DsM MatchResult
--- All the EquationInfos have LitPats at the front
-
-matchLiterals (var:vars) ty eqns
- = do { -- Group by literal
- let groups :: [[(Literal, EquationInfo)]]
- groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
- -- Deal with each group
- ; alts <- mapM match_group groups
+matchLiterals (var:vars) ty sub_groups
+ = ASSERT( all notNull sub_groups )
+ do { -- Deal with each group
+ ; alts <- mapM match_group sub_groups
-- Combine results. For everything except String
-- we can use a case expression; for String we need
-- a chain of if-then-else
; if isStringTy (idType var) then
- do { mrs <- mapM wrap_str_guard alts
+ do { eq_str <- dsLookupGlobalId eqStringName
+ ; mrs <- mapM (wrap_str_guard eq_str) alts
; return (foldr1 combineMatchResults mrs) }
else
return (mkCoPrimCaseMatchResult var ty alts)
}
where
- match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
- match_group group
- = do { let (lits, eqns) = unzip group
+ match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
+ match_group eqns
+ = do { let LitPat hs_lit = firstPat (head eqns)
; match_result <- match vars ty (shiftEqns eqns)
- ; return (head lits, match_result) }
+ ; return (hsLitKey hs_lit, match_result) }
- wrap_str_guard :: (Literal,MatchResult) -> DsM MatchResult
+ wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
-- Equality check for string literals
- wrap_str_guard (MachStr s, mr)
- = do { eq_str <- dsLookupGlobalId eqStringName
- ; lit <- mkStringExprFS s
+ wrap_str_guard eq_str (MachStr s, mr)
+ = do { lit <- mkStringExprFS s
; let pred = mkApps (Var eq_str) [Var var, lit]
; return (mkGuardedMatchResult pred mr) }
+ wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
+
+matchLiterals [] _ _ = panic "matchLiterals []"
\end{code}
+
%************************************************************************
%* *
Pattern matching on NPat
\begin{code}
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
--- All the EquationInfos have NPat at the front
-
-matchNPats (var:vars) ty eqns
- = do { let groups :: [[(Literal, EquationInfo)]]
- groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
-
- ; match_results <- mapM (match_group . map snd) groups
-
- ; ASSERT( not (null match_results) )
- return (foldr1 combineMatchResults match_results) }
- where
- match_group :: [EquationInfo] -> DsM MatchResult
- match_group (eqn1:eqns)
- = do { lit_expr <- dsOverLit lit
- ; neg_lit <- case mb_neg of
+matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
+ = do { let NPat lit mb_neg eq_chk = firstPat eqn1
+ ; lit_expr <- dsOverLit lit
+ ; neg_lit <- case mb_neg of
Nothing -> return lit_expr
Just neg -> do { neg_expr <- dsExpr neg
; return (App neg_expr lit_expr) }
- ; eq_expr <- dsExpr eq_chk
- ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
- ; match_result <- match vars ty (eqn1' : shiftEqns eqns)
- ; return (adjustMatchResult (eqn_wrap eqn1) $
- -- Bring the eqn1 wrapper stuff into scope because
- -- it may be used in pred_expr
- mkGuardedMatchResult pred_expr match_result) }
- where
- NPat lit mb_neg eq_chk _ : pats1 = eqn_pats eqn1
- eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
+ ; eq_expr <- dsExpr eq_chk
+ ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
+ ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
+ ; return (mkGuardedMatchResult pred_expr match_result) }
+matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
\end{code}
<try-next-pattern-or-whatever>
\end{verbatim}
-WATCH OUT! Consider
-
- f (n+1) = ...
- f (n+2) = ...
- f (n+1) = ...
-
-We can't group the first and third together, because the second may match
-the same thing as the first. Contrast
- f 1 = ...
- f 2 = ...
- f 1 = ...
-where we can group the first and third. Hence 'runs' rather than 'equivClasses'
\begin{code}
-matchNPlusKPats all_vars@(var:vars) ty eqns
- = do { let groups :: [[(Literal, EquationInfo)]]
- groups = runs eqTaggedEqn (tagLitEqns eqns)
-
- ; match_results <- mapM (match_group . map snd) groups
-
- ; ASSERT( not (null match_results) )
- return (foldr1 combineMatchResults match_results) }
+matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- All NPlusKPats, for the *same* literal k
+matchNPlusKPats (var:vars) ty (eqn1:eqns)
+ = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
+ ; ge_expr <- dsExpr ge
+ ; minus_expr <- dsExpr minus
+ ; lit_expr <- dsOverLit lit
+ ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
+ minusk_expr = mkApps minus_expr [Var var, lit_expr]
+ (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
+ ; match_result <- match vars ty eqns'
+ ; return (mkGuardedMatchResult pred_expr $
+ mkCoLetMatchResult (NonRec n1 minusk_expr) $
+ adjustMatchResult (foldr1 (.) wraps) $
+ match_result) }
where
- match_group :: [EquationInfo] -> DsM MatchResult
- match_group (eqn1:eqns)
- = do { ge_expr <- dsExpr ge
- ; minus_expr <- dsExpr minus
- ; lit_expr <- dsOverLit lit
- ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
- minusk_expr = mkApps minus_expr [Var var, lit_expr]
- ; match_result <- match vars ty (eqn1' : map shift eqns)
- ; return (adjustMatchResult (eqn_wrap eqn1) $
- -- Bring the eqn1 wrapper stuff into scope because
- -- it may be used in ge_expr, minusk_expr
- mkGuardedMatchResult pred_expr $
- mkCoLetMatchResult (NonRec n1 minusk_expr) $
- match_result) }
- where
- NPlusKPat (L _ n1) lit ge minus : pats1 = eqn_pats eqn1
- eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
-
- shift eqn@(EqnInfo { eqn_wrap = wrap,
- eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
- = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }
-\end{code}
+ shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
+ = (wrapBind n n1, eqn { eqn_pats = pats })
+ -- The wrapBind is a no-op for the first equation
+ shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
-
-%************************************************************************
-%* *
- Grouping functions
-%* *
-%************************************************************************
-
-Given a blob of @LitPat@s/@NPat@s, we want to split them into those
-that are ``same''/different as one we are looking at. We need to know
-whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
-
-\begin{code}
--- Tag equations by the leading literal
--- NB: we have ordering on Core Literals, but not on HsLits
-cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
-cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
-
-eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
-eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
-
-tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
-tagLitEqns eqns = [(get_lit (firstPat eqn), eqn) | eqn <- eqns]
-
-get_lit :: Pat Id -> Literal
--- Get a Core literal to use (only) a grouping key
--- Hence its type doesn't need to match the type of the original literal
-get_lit (LitPat (HsIntPrim i)) = mkMachInt i
-get_lit (LitPat (HsCharPrim c)) = MachChar c
-get_lit (LitPat (HsStringPrim s)) = MachStr s
-get_lit (LitPat (HsFloatPrim f)) = MachFloat f
-get_lit (LitPat (HsDoublePrim d)) = MachDouble d
-get_lit (LitPat (HsString s)) = MachStr s
-
-get_lit (NPat (HsIntegral i _) Nothing _ _) = MachInt i
-get_lit (NPat (HsIntegral i _) (Just _) _ _) = MachInt (-i)
-get_lit (NPat (HsFractional r _) Nothing _ _) = MachFloat r
-get_lit (NPat (HsFractional r _) (Just _) _ _) = MachFloat (-r)
-
-get_lit (NPlusKPat _ (HsIntegral i _) _ _) = MachInt i
-
--- These ones can't happen
--- get_lit (LitPat (HsChar c))
--- get_lit (LitPat (HsInt i))
-get_lit other = pprPanic "get_lit:bad pattern" (ppr other)
+matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
\end{code}
-
projects / ghc-hetmet.git / blobdiff