Pattern-matching literal patterns
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
tidyLitPat, tidyNPat,
matchLiterals, matchNPlusKPats, matchNPats ) where
\begin{code}
dsLit :: HsLit -> DsM CoreExpr
-dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
-dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
-dsLit (HsIntPrim i) = returnDs (mkLit (MachInt i))
-dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
-dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
-
-dsLit (HsChar c) = returnDs (mkCharExpr c)
+dsLit (HsStringPrim s) = return (mkLit (MachStr s))
+dsLit (HsCharPrim c) = return (mkLit (MachChar c))
+dsLit (HsIntPrim i) = return (mkLit (MachInt i))
+dsLit (HsWordPrim w) = return (mkLit (MachWord w))
+dsLit (HsFloatPrim f) = return (mkLit (MachFloat f))
+dsLit (HsDoublePrim d) = return (mkLit (MachDouble d))
+
+dsLit (HsChar c) = return (mkCharExpr c)
dsLit (HsString str) = mkStringExprFS str
dsLit (HsInteger i _) = mkIntegerExpr i
-dsLit (HsInt i) = returnDs (mkIntExpr i)
+dsLit (HsInt i) = return (mkIntExpr i)
-dsLit (HsRat r ty)
- = mkIntegerExpr (numerator r) `thenDs` \ num ->
- mkIntegerExpr (denominator r) `thenDs` \ denom ->
- returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
+dsLit (HsRat r ty) = do
+ num <- mkIntegerExpr (numerator r)
+ denom <- mkIntegerExpr (denominator r)
+ return (mkConApp ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
- = case tcSplitTyConApp ty of
- (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
- (head (tyConDataCons tycon), i_ty)
+ = case tcSplitTyConApp ty of
+ (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+ (head (tyConDataCons tycon), i_ty)
+ x -> pprPanic "dsLit" (ppr x)
dsOverLit :: HsOverLit Id -> DsM CoreExpr
-- Post-typechecker, the SyntaxExpr field of an OverLit contains
-- (an expression for) the literal value itself
-dsOverLit (HsIntegral _ lit) = dsExpr lit
-dsOverLit (HsFractional _ lit) = dsExpr lit
-dsOverLit (HsIsString _ lit) = dsExpr lit
+dsOverLit (HsIntegral _ lit _) = dsExpr lit
+dsOverLit (HsFractional _ lit _) = dsExpr lit
+dsOverLit (HsIsString _ lit _) = dsExpr lit
\end{code}
\begin{code}
-- It only works for primitive types and strings;
-- others have been removed by tidy
hsLitKey (HsIntPrim i) = mkMachInt i
+hsLitKey (HsWordPrim w) = mkMachWord w
hsLitKey (HsCharPrim c) = MachChar c
hsLitKey (HsStringPrim s) = MachStr s
hsLitKey (HsFloatPrim f) = MachFloat f
hsLitKey (HsDoublePrim d) = MachDouble d
hsLitKey (HsString s) = MachStr s
+hsLitKey l = pprPanic "hsLitKey" (ppr l)
-hsOverLitKey :: HsOverLit a -> Bool -> Literal
+hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
-- Ditto for HsOverLit; the boolean indicates to negate
-hsOverLitKey (HsIntegral i _) False = MachInt i
-hsOverLitKey (HsIntegral i _) True = MachInt (-i)
-hsOverLitKey (HsFractional r _) False = MachFloat r
-hsOverLitKey (HsFractional r _) True = MachFloat (-r)
-hsOverLitKey (HsIsString s _) False = MachStr s
+hsOverLitKey (HsIntegral i _ _) False = MachInt i
+hsOverLitKey (HsIntegral i _ _) True = MachInt (-i)
+hsOverLitKey (HsFractional r _ _) False = MachFloat r
+hsOverLitKey (HsFractional r _ _) True = MachFloat (-r)
+hsOverLitKey (HsIsString s _ _) False = MachStr s
+hsOverLitKey l _ = pprPanic "hsOverLitKey" (ppr l)
-- negated string should never happen
\end{code}
\begin{code}
tidyLitPat :: HsLit -> Pat Id
-- Result has only the following HsLits:
--- HsIntPrim, HsCharPrim, HsFloatPrim
+-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
-- HsDoublePrim, HsStringPrim, HsString
-- * HsInteger, HsRat, HsInt can't show up in LitPats
-- * We get rid of HsChar right here
tidyLitPat lit = LitPat lit
----------------
-tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
- -> Type -> Pat Id
-tidyNPat over_lit mb_neg eq lit_ty
- | isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val)
- | isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
- | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
+tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
+tidyNPat over_lit mb_neg eq
+ | isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val)
+ | isWordTy (overLitType over_lit) = mk_con_pat wordDataCon (HsWordPrim int_val)
+ | isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val)
+ | isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
-- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
- | otherwise = NPat over_lit mb_neg eq lit_ty
+ | otherwise = NPat over_lit mb_neg eq
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
- mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty)
+ mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] (overLitType over_lit))
+
neg_lit = case (mb_neg, over_lit) of
(Nothing, _) -> over_lit
- (Just _, HsIntegral i s) -> HsIntegral (-i) s
- (Just _, HsFractional f s) -> HsFractional (-f) s
+ (Just _, HsIntegral i s ty) -> HsIntegral (-i) s ty
+ (Just _, HsFractional f s ty) -> HsFractional (-f) s ty
+ (Just _, HsIsString {}) -> panic "tidyNPat/neg_lit HsIsString"
int_val :: Integer
int_val = case neg_lit of
- HsIntegral i _ -> i
- HsFractional f _ -> panic "tidyNPat"
+ HsIntegral i _ _ -> i
+ HsFractional {} -> panic "tidyNPat/int_val HsFractional"
+ HsIsString {} -> panic "tidyNPat/int_val HsIsString"
rat_val :: Rational
rat_val = case neg_lit of
- HsIntegral i _ -> fromInteger i
- HsFractional f _ -> f
+ HsIntegral i _ _ -> fromInteger i
+ HsFractional f _ _ -> f
+ HsIsString {} -> panic "tidyNPat/rat_val HsIsString"
+{-
str_val :: FastString
str_val = case neg_lit of
- HsIsString s _ -> s
- _ -> error "tidyNPat"
+ HsIsString s _ _ -> s
+ _ -> error "tidyNPat"
+-}
\end{code}
= do { lit <- mkStringExprFS s
; let pred = mkApps (Var eq_str) [Var var, lit]
; return (mkGuardedMatchResult pred mr) }
+ wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
+
+matchLiterals [] _ _ = panic "matchLiterals []"
\end{code}
= do { match_results <- mapM (matchOneNPat vars ty) groups
; return (foldr1 combineMatchResults match_results) }
+matchOneNPat :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal
- = do { let NPat lit mb_neg eq_chk _ = firstPat eqn1
+ = do { let NPat lit mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
; let pred_expr = mkApps eq_expr [Var var, neg_lit]
; match_result <- match vars ty (shiftEqns (eqn1:eqns))
; return (mkGuardedMatchResult pred_expr match_result) }
+matchOneNPat vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
\end{code}
\begin{code}
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
- -- All NPlusKPats, for the *same* literal k
-matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
+-- All NPlusKPats, for the *same* literal k
+matchNPlusKPats (var:vars) ty (eqn1:eqns)
= do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
; ge_expr <- dsExpr ge
; minus_expr <- dsExpr minus
shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
= (wrapBind n n1, eqn { eqn_pats = pats })
-- The wrapBind is a no-op for the first equation
+ shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
+
+matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
\end{code}
projects / ghc-hetmet.git / blobdiff