Commit 088a9081 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc

parents 9be398a5 7e59d792
{-# LANGUAGE RecordWildCards, GADTs #-}
#if __GLASGOW_HASKELL__ < 701
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
module CmmLayoutStack (
cmmLayoutStack, setInfoTableStackMap, cmmSink
) where
......
......@@ -6,6 +6,9 @@
--
-----------------------------------------------------------------------------
{-# LANGUAGE GADTs #-}
#if __GLASGOW_HASKELL__ < 701
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
module CmmLint (
cmmLint, cmmLintGraph
) where
......
{-# LANGUAGE GADTs, DisambiguateRecordFields #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
#if __GLASGOW_HASKELL__ < 701
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
module CmmProcPoint
( ProcPointSet, Status(..)
......
#if __GLASGOW_HASKELL__ < 701
{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
#endif
module Hoopl (
module Compiler.Hoopl,
module Hoopl.Dataflow,
......
......@@ -16,6 +16,9 @@
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
#if __GLASGOW_HASKELL__ < 701
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
module Hoopl.Dataflow
( DataflowLattice(..), OldFact(..), NewFact(..), Fact, mkFactBase
......
......@@ -423,6 +423,7 @@ isGoodBreakExpr (HsApp {}) = True
isGoodBreakExpr (OpApp {}) = True
isGoodBreakExpr (NegApp {}) = True
isGoodBreakExpr (HsIf {}) = True
isGoodBreakExpr (HsMultiIf {}) = True
isGoodBreakExpr (HsCase {}) = True
isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
......@@ -458,6 +459,8 @@ addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) =
liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase ty mgs) =
liftM (HsLamCase ty) (addTickMatchGroup True mgs)
addTickHsExpr (HsApp e1 e2) =
liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
addTickHsExpr (OpApp e1 e2 fix e3) =
......@@ -494,6 +497,10 @@ addTickHsExpr (HsIf cnd e1 e2 e3) =
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsMultiIf ty alts)
= do { let isOneOfMany = case alts of [_] -> False; _ -> True
; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
; return $ HsMultiIf ty alts' }
addTickHsExpr (HsLet binds e) =
bindLocals (collectLocalBinders binds) $
liftM2 HsLet
......
......@@ -205,6 +205,15 @@ dsExpr (NegApp expr neg_expr)
dsExpr (HsLam a_Match)
= uncurry mkLams <$> matchWrapper LambdaExpr a_Match
dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty))
| isEmptyMatchGroup matches -- A Core 'case' is always non-empty
= -- So desugar empty HsLamCase to error call
mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "\\case"))
| otherwise
= do { arg_var <- newSysLocalDs arg
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
dsExpr (HsApp fun arg)
= mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
\end{code}
......@@ -328,6 +337,19 @@ dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
Just fun -> do { core_fun <- dsExpr fun
; return (mkCoreApps core_fun [pred,b1,b2]) }
Nothing -> return $ mkIfThenElse pred b1 b2 }
dsExpr (HsMultiIf res_ty alts)
| null alts
= mkErrorExpr
| otherwise
= do { match_result <- liftM (foldr1 combineMatchResults)
(mapM (dsGRHS IfAlt res_ty) alts)
; error_expr <- mkErrorExpr
; extractMatchResult match_result error_expr }
where
mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
(ptext (sLit "multi-way if"))
\end{code}
......
......@@ -6,7 +6,7 @@
Matching guarded right-hand-sides (GRHSs)
\begin{code}
module DsGRHSs ( dsGuarded, dsGRHSs ) where
module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where
#include "HsVersions.h"
......@@ -55,8 +55,8 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchCon
-> GRHSs Id -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do
match_results <- mapM (dsGRHS hs_ctx pats rhs_ty) grhss
dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
let
match_result1 = foldr1 combineMatchResults match_results
match_result2 = adjustMatchResultDs
......@@ -66,8 +66,8 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do
--
return match_result2
dsGRHS :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult
dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs))
dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult
dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
\end{code}
......
......@@ -864,6 +864,9 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l) = do { a <- repLiteral l; repLit a }
repE (HsLam (MatchGroup [m] _)) = repLambda m
repE (HsLamCase _ (MatchGroup ms _))
= do { ms' <- mapM repMatchTup ms
; repLamCase (nonEmptyCoreList ms') }
repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (OpApp e1 op _ e2) =
......@@ -878,14 +881,19 @@ repE (NegApp x _) = do
repE (HsPar x) = repLE x
repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; repCaseE arg (nonEmptyCoreList ms2) }
repE (HsCase e (MatchGroup ms _))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; repCaseE arg (nonEmptyCoreList ms2) }
repE (HsIf _ x y z) = do
a <- repLE x
b <- repLE y
c <- repLE z
repCond a b c
repE (HsMultiIf _ alts)
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) expr' }
repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e)
; z <- repLetE ds e2
......@@ -976,22 +984,22 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
repGuards [L _ (GRHS [] e)]
= do {a <- repLE e; repNormal a }
repGuards other
= do { zs <- mapM process other;
let {(xs, ys) = unzip zs};
gd <- repGuarded (nonEmptyCoreList ys);
wrapGenSyms (concat xs) gd }
where
process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
= do { x <- repLNormalGE e1 e2;
return ([], x) }
process (L _ (GRHS ss rhs))
= do (gs, ss') <- repLSts ss
rhs' <- addBinds gs $ repLE rhs
g <- repPatGE (nonEmptyCoreList ss') rhs'
return (gs, g)
= do { a <- repLE e
; repNormal a }
repGuards alts
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; body <- repGuarded (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) body }
repLGRHS :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
repLGRHS (L _ (GRHS [L _ (ExprStmt guard _ _ _)] rhs))
= do { guarded <- repLNormalGE guard rhs
; return ([], guarded) }
repLGRHS (L _ (GRHS stmts rhs))
= do { (gs, stmts') <- repLSts stmts
; rhs' <- addBinds gs $ repLE rhs
; guarded <- repPatGE (nonEmptyCoreList stmts') rhs'
; return (gs, guarded) }
repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
repFields (HsRecFields { rec_flds = flds })
......@@ -1455,6 +1463,9 @@ repApp (MkC x) (MkC y) = rep2 appEName [x,y]
repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
repLamCase (MkC ms) = rep2 lamCaseEName [ms]
repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repTup (MkC es) = rep2 tupEName [es]
......@@ -1464,6 +1475,9 @@ repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
repMultiIf (MkC alts) = rep2 multiIfEName [alts]
repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
......@@ -1893,9 +1907,9 @@ templateHaskellNames = [
clauseName,
-- Exp
varEName, conEName, litEName, appEName, infixEName,
infixAppName, sectionLName, sectionRName, lamEName,
infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
tupEName, unboxedTupEName,
condEName, letEName, caseEName, doEName, compEName,
condEName, multiIfEName, letEName, caseEName, doEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName,
-- FieldExp
......@@ -2058,8 +2072,9 @@ clauseName = libFun (fsLit "clause") clauseIdKey
-- data Exp = ...
varEName, conEName, litEName, appEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName,
letEName, caseEName, doEName, compEName :: Name
sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
doEName, compEName :: Name
varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey
litEName = libFun (fsLit "litE") litEIdKey
......@@ -2069,9 +2084,11 @@ infixAppName = libFun (fsLit "infixApp") infixAppIdKey
sectionLName = libFun (fsLit "sectionL") sectionLIdKey
sectionRName = libFun (fsLit "sectionR") sectionRIdKey
lamEName = libFun (fsLit "lamE") lamEIdKey
lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey
tupEName = libFun (fsLit "tupE") tupEIdKey
unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
condEName = libFun (fsLit "condE") condEIdKey
multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey
letEName = libFun (fsLit "letE") letEIdKey
caseEName = libFun (fsLit "caseE") caseEIdKey
doEName = libFun (fsLit "doE") doEIdKey
......@@ -2370,8 +2387,8 @@ clauseIdKey = mkPreludeMiscIdUnique 262
-- data Exp = ...
varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey,
condEIdKey,
sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
......@@ -2384,21 +2401,23 @@ infixAppIdKey = mkPreludeMiscIdUnique 275
sectionLIdKey = mkPreludeMiscIdUnique 276
sectionRIdKey = mkPreludeMiscIdUnique 277
lamEIdKey = mkPreludeMiscIdUnique 278
tupEIdKey = mkPreludeMiscIdUnique 279
unboxedTupEIdKey = mkPreludeMiscIdUnique 280
condEIdKey = mkPreludeMiscIdUnique 281
letEIdKey = mkPreludeMiscIdUnique 282
caseEIdKey = mkPreludeMiscIdUnique 283
doEIdKey = mkPreludeMiscIdUnique 284
compEIdKey = mkPreludeMiscIdUnique 285
fromEIdKey = mkPreludeMiscIdUnique 286
fromThenEIdKey = mkPreludeMiscIdUnique 287
fromToEIdKey = mkPreludeMiscIdUnique 288
fromThenToEIdKey = mkPreludeMiscIdUnique 289
listEIdKey = mkPreludeMiscIdUnique 290
sigEIdKey = mkPreludeMiscIdUnique 291
recConEIdKey = mkPreludeMiscIdUnique 292
recUpdEIdKey = mkPreludeMiscIdUnique 293
lamCaseEIdKey = mkPreludeMiscIdUnique 279
tupEIdKey = mkPreludeMiscIdUnique 280
unboxedTupEIdKey = mkPreludeMiscIdUnique 281
condEIdKey = mkPreludeMiscIdUnique 282
multiIfEIdKey = mkPreludeMiscIdUnique 283
letEIdKey = mkPreludeMiscIdUnique 284
caseEIdKey = mkPreludeMiscIdUnique 285
doEIdKey = mkPreludeMiscIdUnique 286
compEIdKey = mkPreludeMiscIdUnique 287
fromEIdKey = mkPreludeMiscIdUnique 288
fromThenEIdKey = mkPreludeMiscIdUnique 289
fromToEIdKey = mkPreludeMiscIdUnique 290
fromThenToEIdKey = mkPreludeMiscIdUnique 291
listEIdKey = mkPreludeMiscIdUnique 292
sigEIdKey = mkPreludeMiscIdUnique 293
recConEIdKey = mkPreludeMiscIdUnique 294
recUpdEIdKey = mkPreludeMiscIdUnique 295
-- type FieldExp = ...
fieldExpIdKey :: Unique
......
......@@ -88,6 +88,7 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
incomplete_flag :: HsMatchContext id -> Bool
incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags
incomplete_flag CaseAlt = wopt Opt_WarnIncompletePatterns dflags
incomplete_flag IfAlt = False
incomplete_flag LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags
incomplete_flag PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags
......
......@@ -482,6 +482,12 @@ cvtl e = wrapL (cvt e)
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
cvt (LamCaseE ms)
| null ms = failWith (ptext (sLit "Lambda-case expression with no alternatives"))
| otherwise = do { ms' <- mapM cvtMatch ms
; return $ HsLamCase placeHolderType
(mkMatchGroup ms')
}
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
......@@ -489,6 +495,10 @@ cvtl e = wrapL (cvt e)
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
; return $ HsIf (Just noSyntaxExpr) x' y' z' }
cvt (MultiIfE alts)
| null alts = failWith (ptext (sLit "Multi-way if-expression with no alternatives"))
| otherwise = do { alts' <- mapM cvtpair alts
; return $ HsMultiIf placeHolderType alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
; e' <- cvtl e; return $ HsLet ds' e' }
cvt (CaseE e ms)
......
......@@ -113,6 +113,8 @@ data HsExpr id
| HsLam (MatchGroup id) -- Currently always a single match
| HsLamCase PostTcType (MatchGroup id) -- Lambda-case
| HsApp (LHsExpr id) (LHsExpr id) -- Application
-- Operator applications:
......@@ -150,6 +152,8 @@ data HsExpr id
(LHsExpr id) -- then part
(LHsExpr id) -- else part
| HsMultiIf PostTcType [LGRHS id] -- Multi-way if
| HsLet (HsLocalBinds id) -- let(rec)
(LHsExpr id)
......@@ -448,6 +452,10 @@ ppr_expr (ExplicitTuple exprs boxity)
ppr_expr (HsLam matches)
= pprMatches (LambdaExpr :: HsMatchContext id) matches
ppr_expr (HsLamCase _ matches)
= sep [ sep [ptext (sLit "\\case {")],
nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
ppr_expr (HsCase expr matches)
= sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
......@@ -458,6 +466,12 @@ ppr_expr (HsIf _ e1 e2 e3)
ptext (sLit "else"),
nest 4 (ppr e3)]
ppr_expr (HsMultiIf _ alts)
= sep $ ptext (sLit "if") : map ppr_alt alts
where ppr_alt (L _ (GRHS guards expr)) =
sep [ char '|' <+> interpp'SP guards
, ptext (sLit "->") <+> pprDeeper (ppr expr) ]
-- special case: let ... in let ...
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
= sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
......@@ -1257,6 +1271,7 @@ data HsMatchContext id -- Context of a Match
= FunRhs id Bool -- Function binding for f; True <=> written infix
| LambdaExpr -- Patterns of a lambda
| CaseAlt -- Patterns and guards on a case alternative
| IfAlt -- Guards of a multi-way if alternative
| ProcExpr -- Patterns of a proc
| PatBindRhs -- A pattern binding eg [y] <- e = e
......@@ -1307,6 +1322,7 @@ isMonadCompExpr _ = False
matchSeparator :: HsMatchContext id -> SDoc
matchSeparator (FunRhs {}) = ptext (sLit "=")
matchSeparator CaseAlt = ptext (sLit "->")
matchSeparator IfAlt = ptext (sLit "->")
matchSeparator LambdaExpr = ptext (sLit "->")
matchSeparator ProcExpr = ptext (sLit "->")
matchSeparator PatBindRhs = ptext (sLit "=")
......@@ -1329,6 +1345,7 @@ pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for")
<+> quotes (ppr fun)
pprMatchContextNoun CaseAlt = ptext (sLit "case alternative")
pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative")
pprMatchContextNoun RecUpd = ptext (sLit "record-update construct")
pprMatchContextNoun ThPatQuote = ptext (sLit "Template Haskell pattern quotation")
pprMatchContextNoun PatBindRhs = ptext (sLit "pattern binding")
......@@ -1377,6 +1394,7 @@ pprStmtContext (TransStmtCtxt c)
matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
matchContextErrString (FunRhs fun _) = ptext (sLit "function") <+> ppr fun
matchContextErrString CaseAlt = ptext (sLit "case")
matchContextErrString IfAlt = ptext (sLit "multi-way if")
matchContextErrString PatBindRhs = ptext (sLit "pattern binding")
matchContextErrString RecUpd = ptext (sLit "record update")
matchContextErrString LambdaExpr = ptext (sLit "lambda")
......
......@@ -485,6 +485,8 @@ data ExtensionFlag
| Opt_NondecreasingIndentation
| Opt_RelaxedLayout
| Opt_TraditionalRecordSyntax
| Opt_LambdaCase
| Opt_MultiWayIf
deriving (Eq, Enum, Show)
-- | Contains not only a collection of 'DynFlag's but also a plethora of
......@@ -2162,6 +2164,8 @@ xFlags = [
( "NondecreasingIndentation", Opt_NondecreasingIndentation, nop ),
( "RelaxedLayout", Opt_RelaxedLayout, nop ),
( "TraditionalRecordSyntax", Opt_TraditionalRecordSyntax, nop ),
( "LambdaCase", Opt_LambdaCase, nop ),
( "MultiWayIf", Opt_MultiWayIf, nop ),
( "MonoLocalBinds", Opt_MonoLocalBinds, nop ),
( "RelaxedPolyRec", Opt_RelaxedPolyRec,
\ turn_on -> if not turn_on
......
......@@ -500,6 +500,7 @@ data Token
| ITdcolon
| ITequal
| ITlam
| ITlcase
| ITvbar
| ITlarrow
| ITrarrow
......@@ -979,23 +980,37 @@ splitQualName orig_buf len parens = split orig_buf orig_buf
varid :: Action
varid span buf len =
fs `seq`
case lookupUFM reservedWordsFM fs of
Just (keyword,0) -> do
maybe_layout keyword
return (L span keyword)
Just (keyword,exts) -> do
b <- extension (\i -> exts .&. i /= 0)
if b then do maybe_layout keyword
return (L span keyword)
else return (L span (ITvarid fs))
_other -> return (L span (ITvarid fs))
Just (ITcase, _) -> do
lambdaCase <- extension lambdaCaseEnabled
keyword <- if lambdaCase
then do
lastTk <- getLastTk
return $ case lastTk of
Just ITlam -> ITlcase
_ -> ITcase
else
return ITcase
maybe_layout keyword
return $ L span keyword
Just (keyword, 0) -> do
maybe_layout keyword
return $ L span keyword
Just (keyword, exts) -> do
extsEnabled <- extension $ \i -> exts .&. i /= 0
if extsEnabled
then do
maybe_layout keyword
return $ L span keyword
else
return $ L span $ ITvarid fs
Nothing ->
return $ L span $ ITvarid fs
where
fs = lexemeToFastString buf len
!fs = lexemeToFastString buf len
conid :: StringBuffer -> Int -> Token
conid buf len = ITconid fs
where fs = lexemeToFastString buf len
conid buf len = ITconid $! lexemeToFastString buf len
qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token
qvarsym buf len = ITqvarsym $! splitQualName buf len False
......@@ -1007,17 +1022,18 @@ varsym, consym :: Action
varsym = sym ITvarsym
consym = sym ITconsym
sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
-> P (RealLocated Token)
sym :: (FastString -> Token) -> Action
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword,exts) -> do
b <- extension exts
if b then return (L span keyword)
else return (L span $! con fs)
_other -> return (L span $! con fs)
Just (keyword, exts) -> do
extsEnabled <- extension exts
let !tk | extsEnabled = keyword
| otherwise = con fs
return $ L span tk
Nothing ->
return $ L span $! con fs
where
fs = lexemeToFastString buf len
!fs = lexemeToFastString buf len
-- Variations on the integral numeric literal.
tok_integral :: (Integer -> Token)
......@@ -1094,6 +1110,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
where f ITdo = pushLexState layout_do
f ITmdo = pushLexState layout_do
f ITof = pushLexState layout
f ITlcase = pushLexState layout
f ITlet = pushLexState layout
f ITwhere = pushLexState layout
f ITrec = pushLexState layout
......@@ -1522,6 +1539,7 @@ data PState = PState {
buffer :: StringBuffer,
dflags :: DynFlags,
messages :: Messages,
last_tk :: Maybe Token,
last_loc :: RealSrcSpan, -- pos of previous token
last_len :: !Int, -- len of previous token
loc :: RealSrcLoc, -- current loc (end of prev token + 1)
......@@ -1626,6 +1644,12 @@ setLastToken loc len = P $ \s -> POk s {
last_len=len
} ()
setLastTk :: Token -> P ()
setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
getLastTk :: P (Maybe Token)
getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
data AlexInput = AI RealSrcLoc StringBuffer
alexInputPrevChar :: AlexInput -> Char
......@@ -1841,6 +1865,10 @@ typeLiteralsBit :: Int
typeLiteralsBit = 28
explicitNamespacesBit :: Int
explicitNamespacesBit = 29
lambdaCaseBit :: Int
lambdaCaseBit = 30
multiWayIfBit :: Int
multiWayIfBit = 31
always :: Int -> Bool
......@@ -1890,6 +1918,10 @@ typeLiteralsEnabled flags = testBit flags typeLiteralsBit
explicitNamespacesEnabled :: Int -> Bool
explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit
lambdaCaseEnabled :: Int -> Bool
lambdaCaseEnabled flags = testBit flags lambdaCaseBit
multiWayIfEnabled :: Int -> Bool
multiWayIfEnabled flags = testBit flags multiWayIfBit
-- PState for parsing options pragmas
--
......@@ -1906,6 +1938,7 @@ mkPState flags buf loc =
buffer = buf,
dflags = flags,
messages = emptyMessages,
last_tk = Nothing,
last_loc = mkRealSrcSpan loc loc,
last_len = 0,
loc = loc,
......@@ -1949,6 +1982,8 @@ mkPState flags buf loc =
.|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags
.|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags
.|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags
.|. lambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags
.|. multiWayIfBit `setBitIf` xopt Opt_MultiWayIf flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
......@@ -2276,7 +2311,13 @@ lexToken = do
let span = mkRealSrcSpan loc1 end
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
t span buf bytes
lt <- t span buf bytes
case unLoc lt of
ITlineComment _ -> return lt
ITblockComment _ -> return lt
lt' -> do
setLastTk lt'
return lt
reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
reportLexError loc1 loc2 buf str
......
......@@ -55,7 +55,7 @@ import FastString
import Maybes ( orElse )
import Outputable
import Control.Monad ( unless )
import Control.Monad ( unless, liftM )
import GHC.Exts
import Data.Char
import Control.Monad ( mplus )
......@@ -275,6 +275,7 @@ incorrect.
'::' { L _ ITdcolon }
'=' { L _ ITequal }
'\\' { L _ ITlam }
'lcase' { L _ ITlcase }
'|' { L _ ITvbar }
'<-' { L _ ITlarrow }
'->' { L _ ITrarrow }