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