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, hsLitKey, hsOverLitKey,
   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 DataCon          ( DataCon )
  24 import TcType           ( tcSplitTyConApp, isIntegerTy, isIntTy,
  25                           isFloatTy, isDoubleTy, isStringTy )
  26 import Type             ( Type )
  27 import PrelNames        ( ratioTyConKey )
  28 import TysWiredIn       ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
  29 import PrelNames        ( eqStringName )
  30 import Unique           ( hasKey )
  31 import Literal          ( mkMachInt, Literal(..) )
  32 import SrcLoc           ( noLoc )
  33 import Ratio            ( numerator, denominator )
  34 import SrcLoc           ( Located(..), unLoc )
  35 import Outputable
  36 import Util             ( mapAndUnzip )
  37 import FastString       ( lengthFS, unpackFS )
  38 \end{code}
  39
  40 %************************************************************************
  41 %*                                                                      *
  42                 Desugaring literals
  43         [used to be in DsExpr, but DsMeta needs it,
  44          and it's nice to avoid a loop]
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 We give int/float literals type @Integer@ and @Rational@, respectively.
  49 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
  50 around them.
  51
  52 ToDo: put in range checks for when converting ``@i@''
  53 (or should that be in the typechecker?)
  54
  55 For numeric literals, we try to detect there use at a standard type
  56 (@Int@, @Float@, etc.) are directly put in the right constructor.
  57 [NB: down with the @App@ conversion.]
  58
  59 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
  60
  61 \begin{code}
  62 dsLit :: HsLit -> DsM CoreExpr
  63 dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
  64 dsLit (HsCharPrim c)   = returnDs (mkLit (MachChar c))
  65 dsLit (HsIntPrim i)    = returnDs (mkLit (MachInt i))
  66 dsLit (HsFloatPrim f)  = returnDs (mkLit (MachFloat f))
  67 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
  68
  69 dsLit (HsChar c)       = returnDs (mkCharExpr c)
  70 dsLit (HsString str)   = mkStringExprFS str
  71 dsLit (HsInteger i _)  = mkIntegerExpr i
  72 dsLit (HsInt i)        = returnDs (mkIntExpr i)
  73
  74 dsLit (HsRat r ty)
  75   = mkIntegerExpr (numerator r)         `thenDs` \ num ->
  76     mkIntegerExpr (denominator r)       `thenDs` \ denom ->
  77     returnDs (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
  84 dsOverLit :: HsOverLit Id -> DsM CoreExpr
  85 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
  86 -- (an expression for) the literal value itself
  87 dsOverLit (HsIntegral   _ lit) = dsExpr lit
  88 dsOverLit (HsFractional _ 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 \end{code}
 112
 113 %************************************************************************
 114 %*                                                                      *
 115         Tidying lit pats
 116 %*                                                                      *
 117 %************************************************************************
 118
 119 \begin{code}
 120 tidyLitPat :: HsLit -> Pat Id
 121 -- Result has only the following HsLits:
 122 --      HsIntPrim, HsCharPrim, HsFloatPrim
 123 --      HsDoublePrim, HsStringPrim, HsString
 124 --  * HsInteger, HsRat, HsInt can't show up in LitPats
 125 --  * We get rid of HsChar right here
 126 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
 127 tidyLitPat (HsString s)
 128   | lengthFS s <= 1     -- Short string literals only
 129   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
 130                   (mkNilPat stringTy) (unpackFS s)
 131         -- The stringTy is the type of the whole pattern, not
 132         -- the type to instantiate (:) or [] with!
 133 tidyLitPat lit = LitPat lit
 134
 135 ----------------
 136 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
 137          -> Type -> Pat Id
 138 tidyNPat over_lit mb_neg eq lit_ty
 139   | isIntTy    lit_ty = mk_con_pat intDataCon    (HsIntPrim int_val)
 140   | isFloatTy  lit_ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
 141   | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
 142   | otherwise         = NPat over_lit mb_neg eq lit_ty
 143   where
 144     mk_con_pat :: DataCon -> HsLit -> Pat Id
 145     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty)
 146     neg_lit = case (mb_neg, over_lit) of
 147                 (Nothing,              _)   -> over_lit
 148                 (Just _,  HsIntegral i s)   -> HsIntegral   (-i) s
 149                 (Just _,  HsFractional f s) -> HsFractional (-f) s
 150
 151     int_val :: Integer
 152     int_val = case neg_lit of
 153                 HsIntegral   i _ -> i
 154                 HsFractional f _ -> panic "tidyNPat"
 155
 156     rat_val :: Rational
 157     rat_val = case neg_lit of
 158                 HsIntegral   i _ -> fromInteger i
 159                 HsFractional f _ -> f
 160 \end{code}
 161
 162
 163 %************************************************************************
 164 %*                                                                      *
 165                 Pattern matching on LitPat
 166 %*                                                                      *
 167 %************************************************************************
 168
 169 \begin{code}
 170 matchLiterals :: [Id]
 171               -> Type                   -- Type of the whole case expression
 172               -> [[EquationInfo]]       -- All PgLits
 173               -> DsM MatchResult
 174
 175 matchLiterals (var:vars) ty sub_groups
 176   = do  {       -- Deal with each group
 177         ; alts <- mapM match_group sub_groups
 178
 179                 -- Combine results.  For everything except String
 180                 -- we can use a case expression; for String we need
 181                 -- a chain of if-then-else
 182         ; if isStringTy (idType var) then
 183             do  { eq_str <- dsLookupGlobalId eqStringName
 184                 ; mrs <- mapM (wrap_str_guard eq_str) alts
 185                 ; return (foldr1 combineMatchResults mrs) }
 186           else
 187             return (mkCoPrimCaseMatchResult var ty alts)
 188         }
 189   where
 190     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
 191     match_group eqns
 192         = do { let LitPat hs_lit = firstPat (head eqns)
 193              ; match_result <- match vars ty (shiftEqns eqns)
 194              ; return (hsLitKey hs_lit, match_result) }
 195
 196     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
 197         -- Equality check for string literals
 198     wrap_str_guard eq_str (MachStr s, mr)
 199         = do { lit    <- mkStringExprFS s
 200              ; let pred = mkApps (Var eq_str) [Var var, lit]
 201              ; return (mkGuardedMatchResult pred mr) }
 202 \end{code}
 203
 204
 205 %************************************************************************
 206 %*                                                                      *
 207                 Pattern matching on NPat
 208 %*                                                                      *
 209 %************************************************************************
 210
 211 \begin{code}
 212 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
 213         -- All NPats, but perhaps for different literals
 214 matchNPats vars ty groups
 215   = do {  match_results <- mapM (matchOneNPat vars ty) groups
 216         ; return (foldr1 combineMatchResults match_results) }
 217
 218 matchOneNPat (var:vars) ty (eqn1:eqns)  -- All for the same literal
 219   = do  { let NPat lit mb_neg eq_chk _ = firstPat eqn1
 220         ; lit_expr <- dsOverLit lit
 221         ; neg_lit <- case mb_neg of
 222                             Nothing -> return lit_expr
 223                             Just neg -> do { neg_expr <- dsExpr neg
 224                                            ; return (App neg_expr lit_expr) }
 225         ; eq_expr <- dsExpr eq_chk
 226         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
 227         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
 228         ; return (mkGuardedMatchResult pred_expr match_result) }
 229 \end{code}
 230
 231
 232 %************************************************************************
 233 %*                                                                      *
 234                 Pattern matching on n+k patterns
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 For an n+k pattern, we use the various magic expressions we've been given.
 239 We generate:
 240 \begin{verbatim}
 241     if ge var lit then
 242         let n = sub var lit
 243         in  <expr-for-a-successful-match>
 244     else
 245         <try-next-pattern-or-whatever>
 246 \end{verbatim}
 247
 248
 249 \begin{code}
 250 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 251         -- All NPlusKPats, for the *same* literal k
 252 matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
 253   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
 254         ; ge_expr     <- dsExpr ge
 255         ; minus_expr  <- dsExpr minus
 256         ; lit_expr    <- dsOverLit lit
 257         ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
 258               minusk_expr = mkApps minus_expr [Var var, lit_expr]
 259               (wraps, eqns') = mapAndUnzip (shift n1) eqns
 260         ; match_result <- match vars ty eqns'
 261         ; return  (mkGuardedMatchResult pred_expr               $
 262                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
 263                    adjustMatchResult (foldr1 (.) wraps)         $
 264                    match_result) }
 265   where
 266     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
 267         = (wrapBind n n1, eqn { eqn_pats = pats })
 268         -- The wrapBind is a no-op for the first equation
 269 \end{code}