ghc/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, tidyLitPat, tidyNPat,
   8                   matchLiterals, matchNPlusKPats, matchNPats ) where
   9
  10 #include "HsVersions.h"
  11
  12 import {-# SOURCE #-} Match  ( match )
  13 import {-# SOURCE #-} DsExpr ( dsExpr )
  14
  15 import DsMonad
  16 import DsUtils
  17
  18 import HsSyn
  19 import Id               ( Id )
  20 import CoreSyn
  21 import TyCon            ( tyConDataCons )
  22 import TcType           ( tcSplitTyConApp, isIntegerTy, isIntTy, isFloatTy, isDoubleTy )
  23 import Type             ( Type )
  24 import PrelNames        ( ratioTyConKey )
  25 import TysWiredIn       ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
  26 import Unique           ( hasKey )
  27 import Literal          ( mkMachInt, Literal(..) )
  28 import SrcLoc           ( noLoc )
  29 import ListSetOps       ( equivClasses, runs )
  30 import Ratio            ( numerator, denominator )
  31 import SrcLoc           ( Located(..) )
  32 import Outputable
  33 import FastString       ( lengthFS, unpackFS )
  34 \end{code}
  35
  36 %************************************************************************
  37 %*                                                                      *
  38                 Desugaring literals
  39         [used to be in DsExpr, but DsMeta needs it,
  40          and it's nice to avoid a loop]
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 We give int/float literals type @Integer@ and @Rational@, respectively.
  45 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
  46 around them.
  47
  48 ToDo: put in range checks for when converting ``@i@''
  49 (or should that be in the typechecker?)
  50
  51 For numeric literals, we try to detect there use at a standard type
  52 (@Int@, @Float@, etc.) are directly put in the right constructor.
  53 [NB: down with the @App@ conversion.]
  54
  55 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
  56
  57 \begin{code}
  58 dsLit :: HsLit -> DsM CoreExpr
  59 dsLit (HsChar c)       = returnDs (mkCharExpr c)
  60 dsLit (HsCharPrim c)   = returnDs (mkLit (MachChar c))
  61 dsLit (HsString str)   = mkStringExprFS str
  62 dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
  63 dsLit (HsInteger i _)  = mkIntegerExpr i
  64 dsLit (HsInt i)        = returnDs (mkIntExpr i)
  65 dsLit (HsIntPrim i)    = returnDs (mkIntLit i)
  66 dsLit (HsFloatPrim f)  = returnDs (mkLit (MachFloat f))
  67 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
  68
  69 dsLit (HsRat r ty)
  70   = mkIntegerExpr (numerator r)         `thenDs` \ num ->
  71     mkIntegerExpr (denominator r)       `thenDs` \ denom ->
  72     returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
  73   where
  74     (ratio_data_con, integer_ty)
  75         = case tcSplitTyConApp ty of
  76                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
  77                                    (head (tyConDataCons tycon), i_ty)
  78 \end{code}
  79
  80 %************************************************************************
  81 %*                                                                      *
  82         Tidying lit pats
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 tidyLitPat :: HsLit -> LPat Id -> LPat Id
  88 -- Result has only the following HsLits:
  89 --      HsIntPrim, HsCharPrim, HsFloatPrim
  90 --      HsDoublePrim, HsStringPrim ?
  91 -- * HsInteger, HsRat, HsInt can't show up in LitPats,
  92 -- * HsString has been turned into an NPat in tcPat
  93 -- and we get rid of HsChar right here
  94 tidyLitPat (HsChar c) pat = mkCharLitPat c
  95 tidyLitPat lit        pat = pat
  96
  97 tidyNPat :: HsLit -> Type -> LPat Id -> LPat Id
  98 tidyNPat (HsString s) _ pat
  99   | lengthFS s <= 1     -- Short string literals only
 100   = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
 101           (mkNilPat stringTy) (unpackFS s)
 102         -- The stringTy is the type of the whole pattern, not
 103         -- the type to instantiate (:) or [] with!
 104
 105 tidyNPat lit lit_ty default_pat
 106   | isIntTy lit_ty      = mkPrefixConPat intDataCon    [noLoc $ LitPat (mk_int lit)]    lit_ty
 107   | isFloatTy lit_ty    = mkPrefixConPat floatDataCon  [noLoc $ LitPat (mk_float lit)]  lit_ty
 108   | isDoubleTy lit_ty   = mkPrefixConPat doubleDataCon [noLoc $ LitPat (mk_double lit)] lit_ty
 109   | otherwise           = default_pat
 110
 111   where
 112     mk_int    (HsInteger i _) = HsIntPrim i
 113
 114     mk_float  (HsInteger i _) = HsFloatPrim (fromInteger i)
 115     mk_float  (HsRat f _)     = HsFloatPrim f
 116
 117     mk_double (HsInteger i _) = HsDoublePrim (fromInteger i)
 118     mk_double (HsRat f _)     = HsDoublePrim f
 119 \end{code}
 120
 121
 122 %************************************************************************
 123 %*                                                                      *
 124                 Pattern matching on LitPat
 125 %*                                                                      *
 126 %************************************************************************
 127
 128 \begin{code}
 129 matchLiterals :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 130 -- All the EquationInfos have LitPats at the front
 131
 132 matchLiterals (var:vars) ty eqns
 133   = do  { -- GROUP BY LITERAL
 134           let groups :: [[(Literal, EquationInfo)]]
 135               groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
 136
 137             -- DO THE MATCHING FOR EACH GROUP
 138         ; alts <- mapM match_group groups
 139
 140             -- MAKE THE PRIMITIVE CASE
 141         ; return (mkCoPrimCaseMatchResult var ty alts) }
 142   where
 143     match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
 144     match_group group
 145         = do { let (lits, eqns) = unzip group
 146              ; match_result <- match vars ty (shiftEqns eqns)
 147              ; return (head lits, match_result) }
 148 \end{code}
 149
 150 %************************************************************************
 151 %*                                                                      *
 152                 Pattern matching on NPat
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 \begin{code}
 157 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 158 -- All the EquationInfos have NPatOut at the front
 159
 160 matchNPats (var:vars) ty eqns
 161   = do {  let groups :: [[(Literal, EquationInfo)]]
 162               groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
 163
 164         ; match_results <- mapM (match_group . map snd) groups
 165
 166         ; ASSERT( not (null match_results) )
 167           return (foldr1 combineMatchResults match_results) }
 168   where
 169     match_group :: [EquationInfo] -> DsM MatchResult
 170     match_group eqns
 171         = do { pred_expr <- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var))
 172              ; match_result <- match vars ty (shiftEqns eqns)
 173              ; return (mkGuardedMatchResult pred_expr match_result) }
 174         where
 175           NPatOut _ _ eq_chk = firstPat (head eqns)
 176 \end{code}
 177
 178
 179 %************************************************************************
 180 %*                                                                      *
 181                 Pattern matching on n+k patterns
 182 %*                                                                      *
 183 %************************************************************************
 184
 185 For an n+k pattern, we use the various magic expressions we've been given.
 186 We generate:
 187 \begin{verbatim}
 188     if ge var lit then
 189         let n = sub var lit
 190         in  <expr-for-a-successful-match>
 191     else
 192         <try-next-pattern-or-whatever>
 193 \end{verbatim}
 194
 195 WATCH OUT!  Consider
 196
 197         f (n+1) = ...
 198         f (n+2) = ...
 199         f (n+1) = ...
 200
 201 We can't group the first and third together, because the second may match
 202 the same thing as the first.  Contrast
 203         f 1 = ...
 204         f 2 = ...
 205         f 1 = ...
 206 where we can group the first and third.  Hence 'runs' rather than 'equivClasses'
 207
 208 \begin{code}
 209 matchNPlusKPats all_vars@(var:vars) ty eqns
 210   = do {  let groups :: [[(Literal, EquationInfo)]]
 211               groups = runs eqTaggedEqn (tagLitEqns eqns)
 212
 213         ; match_results <- mapM (match_group . map snd) groups
 214
 215         ; ASSERT( not (null match_results) )
 216           return (foldr1 combineMatchResults match_results) }
 217   where
 218     match_group :: [EquationInfo] -> DsM MatchResult
 219     match_group eqns
 220         = do { ge_expr      <- dsExpr (HsApp (noLoc ge)  (nlHsVar var))
 221              ; minusk_expr  <- dsExpr (HsApp (noLoc sub) (nlHsVar var))
 222              ; match_result <- match vars ty (shiftEqns eqns)
 223              ; return  (mkGuardedMatchResult ge_expr                 $
 224                         mkCoLetsMatchResult [NonRec n1 minusk_expr]  $
 225                         bindInMatchResult (map line_up other_pats)   $
 226                         match_result) }
 227         where
 228           (NPlusKPatOut (L _ n1) _ ge sub : other_pats) = map firstPat eqns
 229           line_up (NPlusKPatOut (L _ n) _ _ _) = (n,n1)
 230 \end{code}
 231
 232
 233 %************************************************************************
 234 %*                                                                      *
 235                 Grouping functions
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 Given a blob of @LitPat@s/@NPat@s, we want to split them into those
 240 that are ``same''/different as one we are looking at.  We need to know
 241 whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
 242
 243 \begin{code}
 244 -- Tag equations by the leading literal
 245 -- NB: we have ordering on Core Literals, but not on HsLits
 246 cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
 247 cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
 248
 249 eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
 250 eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
 251
 252 tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
 253 tagLitEqns eqns
 254   = [(get_lit eqn, eqn) | eqn <- eqns]
 255   where
 256     get_lit eqn = case firstPat eqn of
 257                     LitPat  hs_lit       -> mk_core_lit hs_lit
 258                     NPatOut hs_lit _ _   -> mk_core_lit hs_lit
 259                     NPlusKPatOut _ i _ _ -> MachInt i
 260                     other -> panic "tagLitEqns:bad pattern"
 261
 262 mk_core_lit :: HsLit -> Literal
 263 mk_core_lit (HsIntPrim     i) = mkMachInt  i
 264 mk_core_lit (HsCharPrim    c) = MachChar   c
 265 mk_core_lit (HsStringPrim  s) = MachStr    s
 266 mk_core_lit (HsFloatPrim   f) = MachFloat  f
 267 mk_core_lit (HsDoublePrim  d) = MachDouble d
 268
 269         -- These ones are only needed in the NPatOut case,
 270         -- and the Literal is only used as a key for grouping,
 271         -- so the type doesn't matter.  Actually I think HsInt, HsChar
 272         -- can't happen, but it does no harm to include them
 273 mk_core_lit (HsString s)    = MachStr s
 274 mk_core_lit (HsRat r _)     = MachFloat r
 275 mk_core_lit (HsInteger i _) = MachInt i
 276 mk_core_lit (HsInt i)       = MachInt i
 277 mk_core_lit (HsChar c)      = MachChar c
 278 \end{code}
 279