Commit b74c73b8 authored by ian@well-typed.com's avatar ian@well-typed.com

Whitespace only in deSugar/MatchLit.lhs

parent 50902887
......@@ -6,16 +6,9 @@
Pattern-matching literal patterns
\begin{code}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
tidyLitPat, tidyNPat,
matchLiterals, matchNPlusKPats, matchNPats ) where
tidyLitPat, tidyNPat,
matchLiterals, matchNPlusKPats, matchNPats ) where
#include "HsVersions.h"
......@@ -32,7 +25,7 @@ import CoreSyn
import MkCore
import TyCon
import DataCon
import TcHsSyn ( shortCutLit )
import TcHsSyn ( shortCutLit )
import TcType
import PrelNames
import TysWiredIn
......@@ -48,11 +41,11 @@ import FastString
\end{code}
%************************************************************************
%* *
Desugaring literals
[used to be in DsExpr, but DsMeta needs it,
and it's nice to avoid a loop]
%* *
%* *
Desugaring literals
[used to be in DsExpr, but DsMeta needs it,
and it's nice to avoid a loop]
%* *
%************************************************************************
We give int/float literals type @Integer@ and @Rational@, respectively.
......@@ -90,7 +83,7 @@ dsLit (HsRat r ty) = do
denom <- mkIntegerExpr (denominator (fl_value r))
return (mkConApp ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
(ratio_data_con, integer_ty)
= case tcSplitTyConApp ty of
(tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(head (tyConDataCons tycon), i_ty)
......@@ -101,18 +94,18 @@ dsOverLit lit = do dflags <- getDynFlags
dsOverLit' dflags lit
dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr
-- Post-typechecker, the SyntaxExpr field of an OverLit contains
-- Post-typechecker, the SyntaxExpr field of an OverLit contains
-- (an expression for) the literal value itself
dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = witness, ol_type = ty })
| not rebindable
, Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut]
| otherwise = dsExpr witness
, Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut]
| otherwise = dsExpr witness
\end{code}
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
The type checker tries to do this short-cutting as early as possible, but
The type checker tries to do this short-cutting as early as possible, but
because of unification etc, more information is available to the desugarer.
And where it's possible to generate the correct literal right away, it's
much better do do so.
......@@ -122,8 +115,8 @@ much better do do so.
hsLitKey :: DynFlags -> HsLit -> Literal
-- Get a Core literal to use (only) a grouping key
-- Hence its type doesn't need to match the type of the original literal
-- (and doesn't for strings)
-- It only works for primitive types and strings;
-- (and doesn't for strings)
-- It only works for primitive types and strings;
-- others have been removed by tidy
hsLitKey dflags (HsIntPrim i) = mkMachInt dflags i
hsLitKey dflags (HsWordPrim w) = mkMachWord dflags w
......@@ -149,46 +142,46 @@ litValKey (HsIsString s) neg = ASSERT( not neg) MachStr (fastStringToByteStr
\end{code}
%************************************************************************
%* *
Tidying lit pats
%* *
%* *
Tidying lit pats
%* *
%************************************************************************
\begin{code}
tidyLitPat :: HsLit -> Pat Id
-- Result has only the following HsLits:
-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
-- HsDoublePrim, HsStringPrim, HsString
-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
-- HsDoublePrim, HsStringPrim, HsString
-- * HsInteger, HsRat, HsInt can't show up in LitPats
-- * We get rid of HsChar right here
tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
tidyLitPat (HsString s)
| lengthFS s <= 1 -- Short string literals only
| lengthFS s <= 1 -- Short string literals only
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
(mkNilPat stringTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
(mkNilPat stringTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
tidyLitPat lit = LitPat lit
----------------
tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat
-- We need this argument because tidyNPat is called
-- both by Match and by Check, but they tidy LitPats
-- slightly differently; and we must desugar
-- literals consistently (see Trac #5117)
-> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat
-- We need this argument because tidyNPat is called
-- both by Match and by Check, but they tidy LitPats
-- slightly differently; and we must desugar
-- literals consistently (see Trac #5117)
-> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
-> Pat Id
tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
-- False: Take short cuts only if the literal is not using rebindable syntax
--
-- Once that is settled, look for cases where the type of the
-- entire overloaded literal matches the type of the underlying literal,
-- and in that case take the short cut
-- NB: Watch out for wierd cases like Trac #3382
-- f :: Int -> Int
-- f "blah" = 4
-- which might be ok if we hvae 'instance IsString Int'
--
-- False: Take short cuts only if the literal is not using rebindable syntax
--
-- Once that is settled, look for cases where the type of the
-- entire overloaded literal matches the type of the underlying literal,
-- and in that case take the short cut
-- NB: Watch out for wierd cases like Trac #3382
-- f :: Int -> Int
-- f "blah" = 4
-- which might be ok if we hvae 'instance IsString Int'
--
| isIntTy ty, Just int_lit <- mb_int_lit = mk_con_pat intDataCon (HsIntPrim int_lit)
| isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit)
......@@ -201,55 +194,55 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
(Nothing, HsIntegral i) -> Just i
(Just _, HsIntegral i) -> Just (-i)
_ -> Nothing
(Nothing, HsIntegral i) -> Just i
(Just _, HsIntegral i) -> Just (-i)
_ -> Nothing
mb_rat_lit :: Maybe FractionalLit
mb_rat_lit = case (mb_neg, val) of
(Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i))
(Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i)))
(Nothing, HsFractional f) -> Just f
(Just _, HsFractional f) -> Just (negateFractionalLit f)
_ -> Nothing
(Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i))
(Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i)))
(Nothing, HsFractional f) -> Just f
(Just _, HsFractional f) -> Just (negateFractionalLit f)
_ -> Nothing
mb_str_lit :: Maybe FastString
mb_str_lit = case (mb_neg, val) of
(Nothing, HsIsString s) -> Just s
_ -> Nothing
(Nothing, HsIsString s) -> Just s
_ -> Nothing
tidyNPat _ over_lit mb_neg eq
tidyNPat _ over_lit mb_neg eq
= NPat over_lit mb_neg eq
\end{code}
%************************************************************************
%* *
Pattern matching on LitPat
%* *
%* *
Pattern matching on LitPat
%* *
%************************************************************************
\begin{code}
matchLiterals :: [Id]
-> Type -- Type of the whole case expression
-> [[EquationInfo]] -- All PgLits
-> DsM MatchResult
-> Type -- Type of the whole case expression
-> [[EquationInfo]] -- All PgLits
-> DsM MatchResult
matchLiterals (var:vars) ty sub_groups
= ASSERT( notNull sub_groups && all notNull sub_groups )
do { -- Deal with each group
; alts <- mapM match_group sub_groups
-- Combine results. For everything except String
-- we can use a case expression; for String we need
-- a chain of if-then-else
; if isStringTy (idType var) then
do { eq_str <- dsLookupGlobalId eqStringName
; mrs <- mapM (wrap_str_guard eq_str) alts
; return (foldr1 combineMatchResults mrs) }
else
return (mkCoPrimCaseMatchResult var ty alts)
}
do { -- Deal with each group
; alts <- mapM match_group sub_groups
-- Combine results. For everything except String
-- we can use a case expression; for String we need
-- a chain of if-then-else
; if isStringTy (idType var) then
do { eq_str <- dsLookupGlobalId eqStringName
; mrs <- mapM (wrap_str_guard eq_str) alts
; return (foldr1 combineMatchResults mrs) }
else
return (mkCoPrimCaseMatchResult var ty alts)
}
where
match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
match_group eqns
......@@ -259,14 +252,14 @@ matchLiterals (var:vars) ty sub_groups
return (hsLitKey dflags hs_lit, match_result)
wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
-- Equality check for string literals
-- Equality check for string literals
wrap_str_guard eq_str (MachStr s, mr)
= do { -- We now have to convert back to FastString. Perhaps there
-- should be separate MachBytes and MachStr constructors?
s' <- liftIO $ mkFastStringByteString s
; lit <- mkStringExprFS s'
; let pred = mkApps (Var eq_str) [Var var, lit]
; return (mkGuardedMatchResult pred mr) }
= do { -- We now have to convert back to FastString. Perhaps there
-- should be separate MachBytes and MachStr constructors?
s' <- liftIO $ mkFastStringByteString s
; 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 []"
......@@ -274,42 +267,42 @@ matchLiterals [] _ _ = panic "matchLiterals []"
%************************************************************************
%* *
Pattern matching on NPat
%* *
%* *
Pattern matching on NPat
%* *
%************************************************************************
\begin{code}
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
= do { let NPat lit mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
Just neg -> do { neg_expr <- dsExpr neg
; return (App neg_expr lit_expr) }
; eq_expr <- dsExpr eq_chk
; let pred_expr = mkApps eq_expr [Var var, neg_lit]
; match_result <- match vars ty (shiftEqns (eqn1:eqns))
; return (mkGuardedMatchResult pred_expr match_result) }
matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
= do { let NPat lit mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
Just neg -> do { neg_expr <- dsExpr neg
; return (App neg_expr lit_expr) }
; eq_expr <- dsExpr eq_chk
; let pred_expr = mkApps eq_expr [Var var, neg_lit]
; match_result <- match vars ty (shiftEqns (eqn1:eqns))
; return (mkGuardedMatchResult pred_expr match_result) }
matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
\end{code}
%************************************************************************
%* *
Pattern matching on n+k patterns
%* *
%* *
Pattern matching on n+k patterns
%* *
%************************************************************************
For an n+k pattern, we use the various magic expressions we've been given.
We generate:
\begin{verbatim}
if ge var lit then
let n = sub var lit
in <expr-for-a-successful-match>
let n = sub var lit
in <expr-for-a-successful-match>
else
<try-next-pattern-or-whatever>
<try-next-pattern-or-whatever>
\end{verbatim}
......@@ -317,22 +310,22 @@ We generate:
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- 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
; 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) (eqn1:eqns)
; match_result <- match vars ty eqns'
; return (mkGuardedMatchResult pred_expr $
mkCoLetMatchResult (NonRec n1 minusk_expr) $
adjustMatchResult (foldr1 (.) wraps) $
match_result) }
= do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
; ge_expr <- dsExpr ge
; minus_expr <- dsExpr minus
; 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) (eqn1:eqns)
; match_result <- match vars ty eqns'
; return (mkGuardedMatchResult pred_expr $
mkCoLetMatchResult (NonRec n1 minusk_expr) $
adjustMatchResult (foldr1 (.) wraps) $
match_result) }
where
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
= (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))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment