compiler/deSugar/MatchLit.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[MatchLit]{Pattern-matching literal patterns}
   5
   6 \begin{code}
   7 module MatchLit ( dsLit, dsOverLit,
   8                   tidyLitPat, tidyNPat,
   9                   matchLiterals, matchNPlusKPats, matchNPats ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} Match  ( match )
  14 import {-# SOURCE #-} DsExpr ( dsExpr )
  15
  16 import DsMonad
  17 import DsUtils
  18
  19 import HsSyn
  20 import Id               ( Id, idType )
  21 import CoreSyn
  22 import TyCon            ( tyConDataCons )
  23 import TcType           ( tcSplitTyConApp, isIntegerTy, isIntTy,
  24                           isFloatTy, isDoubleTy, isStringTy )
  25 import Type             ( Type )
  26 import PrelNames        ( ratioTyConKey )
  27 import TysWiredIn       ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
  28 import PrelNames        ( eqStringName )
  29 import Unique           ( hasKey )
  30 import Literal          ( mkMachInt, Literal(..) )
  31 import SrcLoc           ( noLoc )
  32 import ListSetOps       ( equivClasses, runs )
  33 import Ratio            ( numerator, denominator )
  34 import SrcLoc           ( Located(..) )
  35 import Outputable
  36 import FastString       ( lengthFS, unpackFS )
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41                 Desugaring literals
  42         [used to be in DsExpr, but DsMeta needs it,
  43          and it's nice to avoid a loop]
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 We give int/float literals type @Integer@ and @Rational@, respectively.
  48 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
  49 around them.
  50
  51 ToDo: put in range checks for when converting ``@i@''
  52 (or should that be in the typechecker?)
  53
  54 For numeric literals, we try to detect there use at a standard type
  55 (@Int@, @Float@, etc.) are directly put in the right constructor.
  56 [NB: down with the @App@ conversion.]
  57
  58 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
  59
  60 \begin{code}
  61 dsLit :: HsLit -> DsM CoreExpr
  62 dsLit (HsChar c)       = returnDs (mkCharExpr c)
  63 dsLit (HsCharPrim c)   = returnDs (mkLit (MachChar c))
  64 dsLit (HsString str)   = mkStringExprFS str
  65 dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
  66 dsLit (HsInteger i _)  = mkIntegerExpr i
  67 dsLit (HsInt i)        = returnDs (mkIntExpr i)
  68 dsLit (HsIntPrim i)    = returnDs (mkIntLit i)
  69 dsLit (HsFloatPrim f)  = returnDs (mkLit (MachFloat f))
  70 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
  71
  72 dsLit (HsRat r ty)
  73   = mkIntegerExpr (numerator r)         `thenDs` \ num ->
  74     mkIntegerExpr (denominator r)       `thenDs` \ denom ->
  75     returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
  76   where
  77     (ratio_data_con, integer_ty)
  78         = case tcSplitTyConApp ty of
  79                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
  80                                    (head (tyConDataCons tycon), i_ty)
  81
  82 dsOverLit :: HsOverLit Id -> DsM CoreExpr
  83 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
  84 -- (an expression for) the literal value itself
  85 dsOverLit (HsIntegral   _ lit) = dsExpr lit
  86 dsOverLit (HsFractional _ lit) = dsExpr lit
  87 \end{code}
  88
  89 %************************************************************************
  90 %*                                                                      *
  91         Tidying lit pats
  92 %*                                                                      *
  93 %************************************************************************
  94
  95 \begin{code}
  96 tidyLitPat :: HsLit -> LPat Id -> LPat Id
  97 -- Result has only the following HsLits:
  98 --      HsIntPrim, HsCharPrim, HsFloatPrim
  99 --      HsDoublePrim, HsStringPrim, HsString
 100 --  * HsInteger, HsRat, HsInt can't show up in LitPats
 101 --  * We get rid of HsChar right here
 102 tidyLitPat (HsChar c) pat = mkCharLitPat c
 103 tidyLitPat (HsString s) pat
 104   | lengthFS s <= 1     -- Short string literals only
 105   = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
 106           (mkNilPat stringTy) (unpackFS s)
 107         -- The stringTy is the type of the whole pattern, not
 108         -- the type to instantiate (:) or [] with!
 109 tidyLitPat lit        pat = pat
 110
 111 ----------------
 112 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> LPat Id -> LPat Id
 113 tidyNPat over_lit mb_neg lit_ty default_pat
 114   | isIntTy    lit_ty = mk_con_pat intDataCon    (HsIntPrim int_val)
 115   | isFloatTy  lit_ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
 116   | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
 117   | otherwise         = default_pat
 118   where
 119     mk_con_pat con lit = mkPrefixConPat con [noLoc $ LitPat lit] lit_ty
 120     neg_lit = case (mb_neg, over_lit) of
 121                 (Nothing,              _)   -> over_lit
 122                 (Just _,  HsIntegral i s)   -> HsIntegral   (-i) s
 123                 (Just _,  HsFractional f s) -> HsFractional (-f) s
 124
 125     int_val :: Integer
 126     int_val = case neg_lit of
 127                 HsIntegral   i _ -> i
 128                 HsFractional f _ -> panic "tidyNPat"
 129
 130     rat_val :: Rational
 131     rat_val = case neg_lit of
 132                 HsIntegral   i _ -> fromInteger i
 133                 HsFractional f _ -> f
 134 \end{code}
 135
 136
 137 %************************************************************************
 138 %*                                                                      *
 139                 Pattern matching on LitPat
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 \begin{code}
 144 matchLiterals :: [Id]
 145               -> Type   -- Type of the whole case expression
 146               -> [EquationInfo]
 147               -> DsM MatchResult
 148 -- All the EquationInfos have LitPats at the front
 149
 150 matchLiterals (var:vars) ty eqns
 151   = do  {       -- Group by literal
 152           let groups :: [[(Literal, EquationInfo)]]
 153               groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
 154
 155                 -- Deal with each group
 156         ; alts <- mapM match_group groups
 157
 158                 -- Combine results.  For everything except String
 159                 -- we can use a case expression; for String we need
 160                 -- a chain of if-then-else
 161         ; if isStringTy (idType var) then
 162             do  { mrs <- mapM wrap_str_guard alts
 163                 ; return (foldr1 combineMatchResults mrs) }
 164           else
 165             return (mkCoPrimCaseMatchResult var ty alts)
 166         }
 167   where
 168     match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
 169     match_group group
 170         = do { let (lits, eqns) = unzip group
 171              ; match_result <- match vars ty (shiftEqns eqns)
 172              ; return (head lits, match_result) }
 173
 174     wrap_str_guard :: (Literal,MatchResult) -> DsM MatchResult
 175         -- Equality check for string literals
 176     wrap_str_guard (MachStr s, mr)
 177         = do { eq_str <- dsLookupGlobalId eqStringName
 178              ; lit    <- mkStringExprFS s
 179              ; let pred = mkApps (Var eq_str) [Var var, lit]
 180              ; return (mkGuardedMatchResult pred mr) }
 181 \end{code}
 182
 183 %************************************************************************
 184 %*                                                                      *
 185                 Pattern matching on NPat
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 \begin{code}
 190 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 191 -- All the EquationInfos have NPat at the front
 192
 193 matchNPats (var:vars) ty eqns
 194   = do {  let groups :: [[(Literal, EquationInfo)]]
 195               groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
 196
 197         ; match_results <- mapM (match_group . map snd) groups
 198
 199         ; ASSERT( not (null match_results) )
 200           return (foldr1 combineMatchResults match_results) }
 201   where
 202     match_group :: [EquationInfo] -> DsM MatchResult
 203     match_group (eqn1:eqns)
 204         = do { lit_expr <- dsOverLit lit
 205              ; neg_lit <- case mb_neg of
 206                             Nothing -> return lit_expr
 207                             Just neg -> do { neg_expr <- dsExpr neg
 208                                            ; return (App neg_expr lit_expr) }
 209              ; eq_expr <- dsExpr eq_chk
 210              ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
 211              ; match_result <- match vars ty (eqn1' : shiftEqns eqns)
 212              ; return (adjustMatchResult (eqn_wrap eqn1) $
 213                         -- Bring the eqn1 wrapper stuff into scope because
 214                         -- it may be used in pred_expr
 215                        mkGuardedMatchResult pred_expr match_result) }
 216         where
 217           NPat lit mb_neg eq_chk _ : pats1 = eqn_pats eqn1
 218           eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
 219 \end{code}
 220
 221
 222 %************************************************************************
 223 %*                                                                      *
 224                 Pattern matching on n+k patterns
 225 %*                                                                      *
 226 %************************************************************************
 227
 228 For an n+k pattern, we use the various magic expressions we've been given.
 229 We generate:
 230 \begin{verbatim}
 231     if ge var lit then
 232         let n = sub var lit
 233         in  <expr-for-a-successful-match>
 234     else
 235         <try-next-pattern-or-whatever>
 236 \end{verbatim}
 237
 238 WATCH OUT!  Consider
 239
 240         f (n+1) = ...
 241         f (n+2) = ...
 242         f (n+1) = ...
 243
 244 We can't group the first and third together, because the second may match
 245 the same thing as the first.  Contrast
 246         f 1 = ...
 247         f 2 = ...
 248         f 1 = ...
 249 where we can group the first and third.  Hence 'runs' rather than 'equivClasses'
 250
 251 \begin{code}
 252 matchNPlusKPats all_vars@(var:vars) ty eqns
 253   = do {  let groups :: [[(Literal, EquationInfo)]]
 254               groups = runs eqTaggedEqn (tagLitEqns eqns)
 255
 256         ; match_results <- mapM (match_group . map snd) groups
 257
 258         ; ASSERT( not (null match_results) )
 259           return (foldr1 combineMatchResults match_results) }
 260   where
 261     match_group :: [EquationInfo] -> DsM MatchResult
 262     match_group (eqn1:eqns)
 263         = do { ge_expr     <- dsExpr ge
 264              ; minus_expr  <- dsExpr minus
 265              ; lit_expr    <- dsOverLit lit
 266              ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
 267                    minusk_expr = mkApps minus_expr [Var var, lit_expr]
 268              ; match_result <- match vars ty (eqn1' : map shift eqns)
 269              ; return  (adjustMatchResult (eqn_wrap eqn1)            $
 270                         -- Bring the eqn1 wrapper stuff into scope because
 271                         -- it may be used in ge_expr, minusk_expr
 272                         mkGuardedMatchResult pred_expr              $
 273                         mkCoLetMatchResult (NonRec n1 minusk_expr)  $
 274                         match_result) }
 275         where
 276           NPlusKPat (L _ n1) lit ge minus : pats1 = eqn_pats eqn1
 277           eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
 278
 279           shift eqn@(EqnInfo { eqn_wrap = wrap,
 280                                eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
 281             = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }
 282 \end{code}
 283
 284
 285 %************************************************************************
 286 %*                                                                      *
 287                 Grouping functions
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 Given a blob of @LitPat@s/@NPat@s, we want to split them into those
 292 that are ``same''/different as one we are looking at.  We need to know
 293 whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
 294
 295 \begin{code}
 296 -- Tag equations by the leading literal
 297 -- NB: we have ordering on Core Literals, but not on HsLits
 298 cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
 299 cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
 300
 301 eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
 302 eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
 303
 304 tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
 305 tagLitEqns eqns = [(get_lit (firstPat eqn), eqn) | eqn <- eqns]
 306
 307 get_lit :: Pat Id -> Literal
 308 -- Get a Core literal to use (only) a grouping key
 309 -- Hence its type doesn't need to match the type of the original literal
 310 get_lit (LitPat (HsIntPrim     i)) = mkMachInt  i
 311 get_lit (LitPat (HsCharPrim    c)) = MachChar   c
 312 get_lit (LitPat (HsStringPrim  s)) = MachStr    s
 313 get_lit (LitPat (HsFloatPrim   f)) = MachFloat  f
 314 get_lit (LitPat (HsDoublePrim  d)) = MachDouble d
 315 get_lit (LitPat (HsString s))      = MachStr    s
 316
 317 get_lit (NPat (HsIntegral i _) Nothing  _ _)   = MachInt i
 318 get_lit (NPat (HsIntegral i _) (Just _) _ _)   = MachInt (-i)
 319 get_lit (NPat (HsFractional r _) Nothing  _ _) = MachFloat r
 320 get_lit (NPat (HsFractional r _) (Just _) _ _) = MachFloat (-r)
 321
 322 get_lit (NPlusKPat _ (HsIntegral i _) _ _) = MachInt i
 323
 324 -- These ones can't happen
 325 -- get_lit (LitPat (HsChar c))
 326 -- get_lit (LitPat (HsInt i))
 327 get_lit other = pprPanic "get_lit:bad pattern" (ppr other)
 328 \end{code}
 329