X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FMatchLit.lhs;h=31d3c28b2e8670991a9a7a14744a8e6f26011aef;hp=3c10c1c985d4d81b87bf2d8ae1b9a7678908f920;hb=6821c8a47c0fc61a2d989d368f926cc0ded776e9;hpb=37507b3a4342773030ef538599363a5aff8b666a diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 3c10c1c..31d3c28 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -1,9 +1,18 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[MatchLit]{Pattern-matching literal patterns} + +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 @@ -17,24 +26,21 @@ import DsMonad import DsUtils import HsSyn -import Id ( Id, idType ) +import Id import CoreSyn -import TyCon ( tyConDataCons ) -import DataCon ( DataCon ) -import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy, - isFloatTy, isDoubleTy, isStringTy ) -import Type ( Type ) -import PrelNames ( ratioTyConKey ) -import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon ) -import PrelNames ( eqStringName ) -import Unique ( hasKey ) -import Literal ( mkMachInt, Literal(..) ) -import SrcLoc ( noLoc ) -import Ratio ( numerator, denominator ) -import SrcLoc ( Located(..), unLoc ) +import TyCon +import DataCon +import TcType +import Type +import PrelNames +import TysWiredIn +import Unique +import Literal +import SrcLoc +import Ratio import Outputable -import Util ( mapAndUnzip ) -import FastString ( lengthFS, unpackFS ) +import Util +import FastString \end{code} %************************************************************************ @@ -60,32 +66,34 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. \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) 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 (HsIntegral _ lit _) = dsExpr lit +dsOverLit (HsFractional _ lit _) = dsExpr lit +dsOverLit (HsIsString _ lit _) = dsExpr lit \end{code} \begin{code} @@ -96,6 +104,7 @@ hsLitKey :: HsLit -> Literal -- 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 @@ -104,10 +113,12 @@ hsLitKey (HsString s) = MachStr s hsOverLitKey :: 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 (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 +-- negated string should never happen \end{code} %************************************************************************ @@ -119,7 +130,7 @@ hsOverLitKey (HsFractional r _) True = MachFloat (-r) \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 @@ -133,30 +144,37 @@ tidyLitPat (HsString s) 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) - | otherwise = NPat over_lit mb_neg eq lit_ty +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 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 int_val :: Integer int_val = case neg_lit of - HsIntegral i _ -> i - HsFractional f _ -> panic "tidyNPat" + HsIntegral i _ _ -> i + HsFractional f _ _ -> panic "tidyNPat" rat_val :: Rational rat_val = case neg_lit of - HsIntegral i _ -> fromInteger i - HsFractional f _ -> f + HsIntegral i _ _ -> fromInteger i + HsFractional f _ _ -> f + + str_val :: FastString + str_val = case neg_lit of + HsIsString s _ _ -> s + _ -> error "tidyNPat" \end{code} @@ -173,7 +191,8 @@ matchLiterals :: [Id] -> DsM MatchResult matchLiterals (var:vars) ty sub_groups - = do { -- Deal with each group + = ASSERT( all notNull sub_groups ) + do { -- Deal with each group ; alts <- mapM match_group sub_groups -- Combine results. For everything except String @@ -216,7 +235,7 @@ matchNPats vars ty groups ; return (foldr1 combineMatchResults match_results) } 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 @@ -256,7 +275,7 @@ matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns) ; lit_expr <- dsOverLit lit ; let pred_expr = mkApps ge_expr [Var var, lit_expr] minusk_expr = mkApps minus_expr [Var var, lit_expr] - (wraps, eqns') = mapAndUnzip (shift n1) eqns + (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) ; match_result <- match vars ty eqns' ; return (mkGuardedMatchResult pred_expr $ mkCoLetMatchResult (NonRec n1 minusk_expr) $