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 (eqn1:eqns)
 171         = do { pred_expr <- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var))
 172              ; match_result <- match vars ty (eqn1' : shiftEqns eqns)
 173              ; return (adjustMatchResult (eqn_wrap eqn1) $
 174                         -- Bring the eqn1 wrapper stuff into scope because
 175                         -- it may be used in pred_expr
 176                        mkGuardedMatchResult pred_expr match_result) }
 177         where
 178           NPatOut _ _ eq_chk : pats1 = eqn_pats eqn1
 179           eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
 180 \end{code}
 181
 182
 183 %************************************************************************
 184 %*                                                                      *
 185                 Pattern matching on n+k patterns
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 For an n+k pattern, we use the various magic expressions we've been given.
 190 We generate:
 191 \begin{verbatim}
 192     if ge var lit then
 193         let n = sub var lit
 194         in  <expr-for-a-successful-match>
 195     else
 196         <try-next-pattern-or-whatever>
 197 \end{verbatim}
 198
 199 WATCH OUT!  Consider
 200
 201         f (n+1) = ...
 202         f (n+2) = ...
 203         f (n+1) = ...
 204
 205 We can't group the first and third together, because the second may match
 206 the same thing as the first.  Contrast
 207         f 1 = ...
 208         f 2 = ...
 209         f 1 = ...
 210 where we can group the first and third.  Hence 'runs' rather than 'equivClasses'
 211
 212 \begin{code}
 213 matchNPlusKPats all_vars@(var:vars) ty eqns
 214   = do {  let groups :: [[(Literal, EquationInfo)]]
 215               groups = runs eqTaggedEqn (tagLitEqns eqns)
 216
 217         ; match_results <- mapM (match_group . map snd) groups
 218
 219         ; ASSERT( not (null match_results) )
 220           return (foldr1 combineMatchResults match_results) }
 221   where
 222     match_group :: [EquationInfo] -> DsM MatchResult
 223     match_group (eqn1:eqns)
 224         = do { ge_expr      <- dsExpr (HsApp (noLoc ge)  (nlHsVar var))
 225              ; minusk_expr  <- dsExpr (HsApp (noLoc sub) (nlHsVar var))
 226              ; match_result <- match vars ty (eqn1' : map shift eqns)
 227              ; return  (adjustMatchResult (eqn_wrap eqn1)            $
 228                         -- Bring the eqn1 wrapper stuff into scope because
 229                         -- it may be used in ge_expr, minusk_expr
 230                         mkGuardedMatchResult ge_expr                $
 231                         mkCoLetMatchResult (NonRec n1 minusk_expr)  $
 232                         match_result) }
 233         where
 234           NPlusKPatOut (L _ n1) _ ge sub : pats1 = eqn_pats eqn1
 235           eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
 236
 237           shift eqn@(EqnInfo { eqn_wrap = wrap,
 238                                eqn_pats = NPlusKPatOut (L _ n) _ _ _ : pats })
 239             = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }
 240 \end{code}
 241
 242
 243 %************************************************************************
 244 %*                                                                      *
 245                 Grouping functions
 246 %*                                                                      *
 247 %************************************************************************
 248
 249 Given a blob of @LitPat@s/@NPat@s, we want to split them into those
 250 that are ``same''/different as one we are looking at.  We need to know
 251 whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
 252
 253 \begin{code}
 254 -- Tag equations by the leading literal
 255 -- NB: we have ordering on Core Literals, but not on HsLits
 256 cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
 257 cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
 258
 259 eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
 260 eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
 261
 262 tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
 263 tagLitEqns eqns
 264   = [(get_lit eqn, eqn) | eqn <- eqns]
 265   where
 266     get_lit eqn = case firstPat eqn of
 267                     LitPat  hs_lit       -> mk_core_lit hs_lit
 268                     NPatOut hs_lit _ _   -> mk_core_lit hs_lit
 269                     NPlusKPatOut _ i _ _ -> MachInt i
 270                     other -> panic "tagLitEqns:bad pattern"
 271
 272 mk_core_lit :: HsLit -> Literal
 273 mk_core_lit (HsIntPrim     i) = mkMachInt  i
 274 mk_core_lit (HsCharPrim    c) = MachChar   c
 275 mk_core_lit (HsStringPrim  s) = MachStr    s
 276 mk_core_lit (HsFloatPrim   f) = MachFloat  f
 277 mk_core_lit (HsDoublePrim  d) = MachDouble d
 278
 279         -- These ones are only needed in the NPatOut case,
 280         -- and the Literal is only used as a key for grouping,
 281         -- so the type doesn't matter.  Actually I think HsInt, HsChar
 282         -- can't happen, but it does no harm to include them
 283 mk_core_lit (HsString s)    = MachStr s
 284 mk_core_lit (HsRat r _)     = MachFloat r
 285 mk_core_lit (HsInteger i _) = MachInt i
 286 mk_core_lit (HsInt i)       = MachInt i
 287 mk_core_lit (HsChar c)      = MachChar c
 288 \end{code}
 289