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