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