compiler/deSugar/MatchLit.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Pattern-matching literal patterns
   7
   8 \begin{code}
   9 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
  10                   tidyLitPat, tidyNPat,
  11                   matchLiterals, matchNPlusKPats, matchNPats ) where
  12
  13 #include "HsVersions.h"
  14
  15 import {-# SOURCE #-} Match  ( match )
  16 import {-# SOURCE #-} DsExpr ( dsExpr )
  17
  18 import DsMonad
  19 import DsUtils
  20
  21 import HsSyn
  22 import Id
  23 import CoreSyn
  24 import TyCon
  25 import DataCon
  26 import TcType
  27 import Type
  28 import PrelNames
  29 import TysWiredIn
  30 import Unique
  31 import Literal
  32 import SrcLoc
  33 import Ratio
  34 import Outputable
  35 import Util
  36 import FastString
  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 (HsStringPrim s) = returnDs (mkLit (MachStr s))
  63 dsLit (HsCharPrim c)   = returnDs (mkLit (MachChar c))
  64 dsLit (HsIntPrim i)    = returnDs (mkLit (MachInt i))
  65 dsLit (HsFloatPrim f)  = returnDs (mkLit (MachFloat f))
  66 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
  67
  68 dsLit (HsChar c)       = returnDs (mkCharExpr c)
  69 dsLit (HsString str)   = mkStringExprFS str
  70 dsLit (HsInteger i _)  = mkIntegerExpr i
  71 dsLit (HsInt i)        = returnDs (mkIntExpr i)
  72
  73 dsLit (HsRat r ty)
  74   = mkIntegerExpr (numerator r)         `thenDs` \ num ->
  75     mkIntegerExpr (denominator r)       `thenDs` \ denom ->
  76     returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
  77   where
  78     (ratio_data_con, integer_ty)
  79         = case tcSplitTyConApp ty of
  80                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
  81                                    (head (tyConDataCons tycon), i_ty)
  82
  83 dsOverLit :: HsOverLit Id -> DsM CoreExpr
  84 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
  85 -- (an expression for) the literal value itself
  86 dsOverLit (HsIntegral   _ lit) = dsExpr lit
  87 dsOverLit (HsFractional _ lit) = dsExpr lit
  88 dsOverLit (HsIsString   _ lit) = dsExpr lit
  89 \end{code}
  90
  91 \begin{code}
  92 hsLitKey :: HsLit -> Literal
  93 -- Get a Core literal to use (only) a grouping key
  94 -- Hence its type doesn't need to match the type of the original literal
  95 --      (and doesn't for strings)
  96 -- It only works for primitive types and strings;
  97 -- others have been removed by tidy
  98 hsLitKey (HsIntPrim     i) = mkMachInt  i
  99 hsLitKey (HsCharPrim    c) = MachChar   c
 100 hsLitKey (HsStringPrim  s) = MachStr    s
 101 hsLitKey (HsFloatPrim   f) = MachFloat  f
 102 hsLitKey (HsDoublePrim  d) = MachDouble d
 103 hsLitKey (HsString s)      = MachStr    s
 104
 105 hsOverLitKey :: HsOverLit a -> Bool -> Literal
 106 -- Ditto for HsOverLit; the boolean indicates to negate
 107 hsOverLitKey (HsIntegral i _) False   = MachInt i
 108 hsOverLitKey (HsIntegral i _) True    = MachInt (-i)
 109 hsOverLitKey (HsFractional r _) False = MachFloat r
 110 hsOverLitKey (HsFractional r _) True  = MachFloat (-r)
 111 hsOverLitKey (HsIsString s _)  False  = MachStr s
 112 -- negated string should never happen
 113 \end{code}
 114
 115 %************************************************************************
 116 %*                                                                      *
 117         Tidying lit pats
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 \begin{code}
 122 tidyLitPat :: HsLit -> Pat Id
 123 -- Result has only the following HsLits:
 124 --      HsIntPrim, HsCharPrim, HsFloatPrim
 125 --      HsDoublePrim, HsStringPrim, HsString
 126 --  * HsInteger, HsRat, HsInt can't show up in LitPats
 127 --  * We get rid of HsChar right here
 128 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
 129 tidyLitPat (HsString s)
 130   | lengthFS s <= 1     -- Short string literals only
 131   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
 132                   (mkNilPat stringTy) (unpackFS s)
 133         -- The stringTy is the type of the whole pattern, not
 134         -- the type to instantiate (:) or [] with!
 135 tidyLitPat lit = LitPat lit
 136
 137 ----------------
 138 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
 139          -> Type -> Pat Id
 140 tidyNPat over_lit mb_neg eq lit_ty
 141   | isIntTy    lit_ty = mk_con_pat intDataCon    (HsIntPrim int_val)
 142   | isFloatTy  lit_ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
 143   | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
 144 --  | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
 145   | otherwise         = NPat over_lit mb_neg eq lit_ty
 146   where
 147     mk_con_pat :: DataCon -> HsLit -> Pat Id
 148     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty)
 149     neg_lit = case (mb_neg, over_lit) of
 150                 (Nothing,              _)   -> over_lit
 151                 (Just _,  HsIntegral i s)   -> HsIntegral   (-i) s
 152                 (Just _,  HsFractional f s) -> HsFractional (-f) s
 153
 154     int_val :: Integer
 155     int_val = case neg_lit of
 156                 HsIntegral   i _ -> i
 157                 HsFractional f _ -> panic "tidyNPat"
 158
 159     rat_val :: Rational
 160     rat_val = case neg_lit of
 161                 HsIntegral   i _ -> fromInteger i
 162                 HsFractional f _ -> f
 163
 164     str_val :: FastString
 165     str_val = case neg_lit of
 166                 HsIsString   s _ -> s
 167                 _                -> error "tidyNPat"
 168 \end{code}
 169
 170
 171 %************************************************************************
 172 %*                                                                      *
 173                 Pattern matching on LitPat
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 \begin{code}
 178 matchLiterals :: [Id]
 179               -> Type                   -- Type of the whole case expression
 180               -> [[EquationInfo]]       -- All PgLits
 181               -> DsM MatchResult
 182
 183 matchLiterals (var:vars) ty sub_groups
 184   = ASSERT( all notNull sub_groups )
 185     do  {       -- Deal with each group
 186         ; alts <- mapM match_group sub_groups
 187
 188                 -- Combine results.  For everything except String
 189                 -- we can use a case expression; for String we need
 190                 -- a chain of if-then-else
 191         ; if isStringTy (idType var) then
 192             do  { eq_str <- dsLookupGlobalId eqStringName
 193                 ; mrs <- mapM (wrap_str_guard eq_str) alts
 194                 ; return (foldr1 combineMatchResults mrs) }
 195           else
 196             return (mkCoPrimCaseMatchResult var ty alts)
 197         }
 198   where
 199     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
 200     match_group eqns
 201         = do { let LitPat hs_lit = firstPat (head eqns)
 202              ; match_result <- match vars ty (shiftEqns eqns)
 203              ; return (hsLitKey hs_lit, match_result) }
 204
 205     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
 206         -- Equality check for string literals
 207     wrap_str_guard eq_str (MachStr s, mr)
 208         = do { lit    <- mkStringExprFS s
 209              ; let pred = mkApps (Var eq_str) [Var var, lit]
 210              ; return (mkGuardedMatchResult pred mr) }
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216                 Pattern matching on NPat
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 \begin{code}
 221 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
 222         -- All NPats, but perhaps for different literals
 223 matchNPats vars ty groups
 224   = do {  match_results <- mapM (matchOneNPat vars ty) groups
 225         ; return (foldr1 combineMatchResults match_results) }
 226
 227 matchOneNPat (var:vars) ty (eqn1:eqns)  -- All for the same literal
 228   = do  { let NPat lit mb_neg eq_chk _ = firstPat eqn1
 229         ; lit_expr <- dsOverLit lit
 230         ; neg_lit <- case mb_neg of
 231                             Nothing -> return lit_expr
 232                             Just neg -> do { neg_expr <- dsExpr neg
 233                                            ; return (App neg_expr lit_expr) }
 234         ; eq_expr <- dsExpr eq_chk
 235         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
 236         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
 237         ; return (mkGuardedMatchResult pred_expr match_result) }
 238 \end{code}
 239
 240
 241 %************************************************************************
 242 %*                                                                      *
 243                 Pattern matching on n+k patterns
 244 %*                                                                      *
 245 %************************************************************************
 246
 247 For an n+k pattern, we use the various magic expressions we've been given.
 248 We generate:
 249 \begin{verbatim}
 250     if ge var lit then
 251         let n = sub var lit
 252         in  <expr-for-a-successful-match>
 253     else
 254         <try-next-pattern-or-whatever>
 255 \end{verbatim}
 256
 257
 258 \begin{code}
 259 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 260         -- All NPlusKPats, for the *same* literal k
 261 matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
 262   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
 263         ; 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               (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
 269         ; match_result <- match vars ty eqns'
 270         ; return  (mkGuardedMatchResult pred_expr               $
 271                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
 272                    adjustMatchResult (foldr1 (.) wraps)         $
 273                    match_result) }
 274   where
 275     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
 276         = (wrapBind n n1, eqn { eqn_pats = pats })
 277         -- The wrapBind is a no-op for the first equation
 278 \end{code}