[Git][ghc/ghc][wip/gc/progress-to-eventlog] 11 commits: Correct off by one error in ghci +c
Ben Gamari
gitlab at gitlab.haskell.org
Fri Apr 26 05:03:31 UTC 2019
Ben Gamari pushed to branch wip/gc/progress-to-eventlog at Glasgow Haskell Compiler / GHC
Commits:
1a7a329b by Matthew Pickering at 2019-04-22T18:37:30Z
Correct off by one error in ghci +c
Fixes #16569
- - - - -
51655fd8 by Alp Mestanogullari at 2019-04-22T18:44:11Z
Hadrian: use the testsuite driver's config.haddock arg more correctly
4 haddock tests assume that .haddock files have been produced, by using the
'req_haddock' modifier. The testsuite driver assumes that this condition is
satisfied if 'config.haddock' is non-empty, but before this patch Hadrian was
always passing the path to where the haddock executable should be, regardless
of whether it is actually there or not.
Instead, we now pass an empty config.haddock when we can't find all of
<build root>/docs/html/libraries/<pkg>/<pkg>.haddock>, where <pkg> ranges over
array, base, ghc-prim, process and template-haskell, and pass the path
to haddock when all those file exists. This has the (desired) effect of skipping
the 4 tests (marked as 'missing library') when the docs haven't been built,
and running the haddock tests when they have.
- - - - -
1959bad3 by Vladislav Zavialov at 2019-04-22T18:50:18Z
Stop misusing EWildPat in pattern match coverage checking
EWildPat is a constructor of HsExpr used in the parser to represent
wildcards in ambiguous positions:
* in expression context, EWildPat is turned into hsHoleExpr (see rnExpr)
* in pattern context, EWildPat is turned into WildPat (see checkPattern)
Since EWildPat exists solely for the needs of the parser, we could
remove it by improving the parser.
However, EWildPat has also been used for a different purpose since
8a50610: to represent patterns that the coverage checker cannot handle.
Not only this is a misuse of EWildPat, it also stymies the removal of
EWildPat.
- - - - -
6a491726 by Fraser Tweedale at 2019-04-23T13:27:30Z
osReserveHeapMemory: handle signed rlim_t
rlim_t is a signed type on FreeBSD, and the build fails with a
sign-compare error. Add explicit (unsigned) cast to handle this
case.
- - - - -
ab9b3ace by Alexandre Baldé at 2019-04-23T13:33:37Z
Fix error message for './configure' regarding '--with-ghc' [skip ci]
- - - - -
465f8f48 by Ben Gamari at 2019-04-24T16:19:24Z
gitlab-ci: source-tarball job should have no dependencies
- - - - -
0fc69416 by Vladislav Zavialov at 2019-04-25T18:28:56Z
Introduce MonadP, make PV a newtype
Previously we defined type PV = P,
this had the downside that if we wanted to change PV,
we would have to modify P as well.
Now PV is free to evolve independently from P.
The common operations addError, addFatalError, getBit, addAnnsAt,
were abstracted into a class called MonadP.
- - - - -
f85efdec by Vladislav Zavialov at 2019-04-25T18:28:56Z
checkPattern error hint is PV context
There is a hint added to error messages reported in checkPattern.
Instead of passing it manually, we put it in a ReaderT environment inside PV.
- - - - -
4e228267 by Ömer Sinan Ağacan at 2019-04-25T18:35:09Z
Minor RTS refactoring:
- Remove redundant casting in evacuate_static_object
- Remove redundant parens in STATIC_LINK
- Fix a typo in GC.c
- - - - -
ea96d6f4 by Ben Gamari at 2019-04-26T05:03:23Z
ErrUtils: Emit progress messages to eventlog
- - - - -
a80aa49c by Ben Gamari at 2019-04-26T05:03:23Z
Emit GHC timing events to eventlog
- - - - -
19 changed files:
- .gitlab-ci.yml
- compiler/deSugar/Check.hs
- compiler/main/ErrUtils.hs
- compiler/parser/Lexer.x
- compiler/parser/Parser.y
- compiler/parser/RdrHsSyn.hs
- configure.ac
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- hadrian/src/Settings/Builders/RunTest.hs
- includes/rts/storage/ClosureMacros.h
- rts/posix/OSMem.c
- rts/sm/Evac.c
- rts/sm/GC.c
- + testsuite/tests/ghci/scripts/T16569.hs
- + testsuite/tests/ghci/scripts/T16569.script
- + testsuite/tests/ghci/scripts/T16569.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/ghci/should_run/T15369.stdout
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -144,6 +144,7 @@ lint-release-changelogs:
- ./boot
- ./configure $CONFIGURE_ARGS
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx binary-dist
+ - hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx test
- mv _build/bindist/ghc*.tar.xz ghc.tar.xz
cache:
key: hadrian
@@ -746,6 +747,7 @@ source-tarball:
tags:
- x86_64-linux
image: ghcci/x86_64-linux-deb9:0.2
+ dependencies: []
only:
- tags
artifacts:
=====================================
compiler/deSugar/Check.hs
=====================================
@@ -157,7 +157,9 @@ data PmPat :: PatTy -> * where
PmNLit :: { pm_lit_id :: Id
, pm_lit_not :: [PmLit] } -> PmPat 'VA
PmGrd :: { pm_grd_pv :: PatVec
- , pm_grd_expr :: PmExpr } -> PmPat 'PAT
+ , pm_grd_expr :: PmExpr } -> PmPat 'PAT
+ -- | A fake guard pattern (True <- _) used to represent cases we cannot handle.
+ PmFake :: PmPat 'PAT
instance Outputable (PmPat a) where
ppr = pprPmPatDebug
@@ -928,24 +930,11 @@ truePattern :: Pattern
truePattern = nullaryConPattern (RealDataCon trueDataCon)
{-# INLINE truePattern #-}
--- | A fake guard pattern (True <- _) used to represent cases we cannot handle
-fake_pat :: Pattern
-fake_pat = PmGrd { pm_grd_pv = [truePattern]
- , pm_grd_expr = PmExprOther (EWildPat noExt) }
-{-# INLINE fake_pat #-}
-
--- | Check whether a guard pattern is generated by the checker (unhandled)
-isFakeGuard :: [Pattern] -> PmExpr -> Bool
-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
- | c == trueDataCon = True
- | otherwise = False
-isFakeGuard _pats _e = False
-
-- | Generate a `canFail` pattern vector of a specific type
mkCanFailPmPat :: Type -> DsM PatVec
mkCanFailPmPat ty = do
var <- mkPmVar ty
- return [var, fake_pat]
+ return [var, PmFake]
vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern
-- ADT constructor pattern => no existentials, no local constraints
@@ -1295,7 +1284,7 @@ translateGuards fam_insts guards = do
then pure all_guards
else do
kept <- filterM shouldKeep all_guards
- pure (fake_pat : kept)
+ pure (PmFake : kept)
-- | Check whether a pattern can fail to match
cantFailPattern :: Pattern -> DsM Bool
@@ -1377,7 +1366,7 @@ cases:
expressivity in our warnings.
Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*
- @fake_pat@: @True <- _ at . That is, we record that there is a possibility
+ @PmFake@: @True <- _ at . That is, we record that there is a possibility
of failure but we minimize it to a True/False. This generates a single
warning and much smaller uncovered sets.
@@ -1421,7 +1410,7 @@ in the pattern bind case). Hence, we safely drop them.
Additionally, top-level guard translation (performed by @translateGuards@)
replaces guards that cannot be reasoned about (like the ones we described in
-1-4) with a single @fake_pat@ to record the possibility of failure to match.
+1-4) with a single @PmFake@ to record the possibility of failure to match.
Note [Translate CoPats]
~~~~~~~~~~~~~~~~~~~~~~~
@@ -1457,6 +1446,7 @@ pmPatType (PmNLit { pm_lit_id = x }) = idType x
pmPatType (PmGrd { pm_grd_pv = pv })
= ASSERT(patVecArity pv == 1) (pmPatType p)
where Just p = find ((==1) . patternArity) pv
+pmPatType PmFake = pmPatType truePattern
-- | Information about a conlike that is relevant to coverage checking.
-- It is called an \"inhabitation candidate\" since it is a value which may
@@ -1679,7 +1669,7 @@ mkGuard pv e = do
let expr = hsExprToPmExpr e
tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr])
if | res -> pure (PmGrd pv expr)
- | PmExprOther {} <- expr -> pure fake_pat
+ | PmExprOther {} <- expr -> pure PmFake
| otherwise -> pure (PmGrd pv expr)
-- | Create a term equality of the form: `(False ~ (x ~ lit))`
@@ -1753,6 +1743,7 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
, pm_con_tvs = tvs, pm_con_dicts = dicts
, pm_con_args = coercePatVec args }]
coercePmPat (PmGrd {}) = [] -- drop the guards
+coercePmPat PmFake = [] -- drop the guards
-- | Check whether a 'ConLike' has the /single match/ property, i.e. whether
-- it is the only possible match in the given context. See also
@@ -1765,7 +1756,7 @@ singleMatchConstructor cl tys =
Note [Single match constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When translating pattern guards for consumption by the checker, we desugar
-every pattern guard that might fail ('cantFailPattern') to 'fake_pat'
+every pattern guard that might fail ('cantFailPattern') to 'PmFake'
(True <- _). Which patterns can't fail? Exactly those that only match on
'singleMatchConstructor's.
@@ -2023,13 +2014,15 @@ pmcheck [] guards vva@(ValVec [] _)
| otherwise = pmcheckGuardsI guards vva
-- Guard
-pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)
- -- short-circuit if the guard pattern is useless.
- -- we just have two possible outcomes: fail here or match and recurse
- -- none of the two contains any useful information about the failure
- -- though. So just have these two cases but do not do all the boilerplate
- | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva
- | otherwise = do
+pmcheck (PmFake : ps) guards vva =
+ -- short-circuit if the guard pattern is useless.
+ -- we just have two possible outcomes: fail here or match and recurse
+ -- none of the two contains any useful information about the failure
+ -- though. So just have these two cases but do not do all the boilerplate
+ forces . mkCons vva <$> pmcheckI ps guards vva
+pmcheck (p : ps) guards (ValVec vas delta)
+ | PmGrd { pm_grd_pv = pv, pm_grd_expr = e } <- p
+ = do
y <- liftD $ mkPmId (pmPatType p)
let tm_state = extendSubst y e (delta_tm_cs delta)
delta' = delta { delta_tm_cs = tm_state }
@@ -2182,6 +2175,7 @@ pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva
= pmcheckHdI p ps guards (PmVar x) vva
-- Impossible: handled by pmcheck
+pmcheckHd PmFake _ _ _ _ = panic "pmcheckHd: Fake"
pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"
{-
@@ -2742,6 +2736,7 @@ pprPmPatDebug (PmLit li) = text "PmLit" <+> ppr li
pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl
pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)
<+> ppr ge
+pprPmPatDebug PmFake = text "PmFake"
pprPatVec :: PatVec -> SDoc
pprPatVec ps = hang (text "Pattern:") 2
=====================================
compiler/main/ErrUtils.hs
=====================================
@@ -81,6 +81,7 @@ import Data.IORef
import Data.Maybe ( fromMaybe )
import Data.Ord
import Data.Time
+import Debug.Trace
import Control.Monad
import Control.Monad.IO.Class
import System.IO
@@ -608,9 +609,10 @@ fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
compilationProgressMsg :: DynFlags -> String -> IO ()
-compilationProgressMsg dflags msg
- = ifVerbose dflags 1 $
- logOutput dflags (defaultUserStyle dflags) (text msg)
+compilationProgressMsg dflags msg = do
+ traceEventIO $ "GHC progress: " ++ msg
+ ifVerbose dflags 1 $
+ logOutput dflags (defaultUserStyle dflags) (text msg)
showPass :: DynFlags -> String -> IO ()
showPass dflags what
@@ -651,10 +653,12 @@ withTiming getDFlags what force_result action
if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
then do liftIO $ logInfo dflags (defaultUserStyle dflags)
$ text "***" <+> what <> colon
+ liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:started:" <+> what
alloc0 <- liftIO getAllocationCounter
start <- liftIO getCPUTime
!r <- action
() <- pure $ force_result r
+ liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:finished:" <+> what
end <- liftIO getCPUTime
alloc1 <- liftIO getAllocationCounter
-- recall that allocation counter counts down
=====================================
compiler/parser/Lexer.x
=====================================
@@ -50,16 +50,17 @@
module Lexer (
Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
+ MonadP(..),
getRealSrcLoc, getPState, withThisPackage,
failLocMsgP, srcParseFail,
getErrorMessages, getMessages,
popContext, pushModuleContext, setLastToken, setSrcLoc,
activeContext, nextIsEOF,
getLexState, popLexState, pushLexState,
- ExtBits(..), getBit,
- addWarning, addError, addFatalError,
+ ExtBits(..),
+ addWarning,
lexTokenStream,
- addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
+ AddAnn,mkParensApiAnn,
commentToAnnotation
) where
@@ -2276,11 +2277,6 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
-- stored in a @Word64 at .
type ExtsBitmap = Word64
--- | Check if a given flag is currently set in the bitmap.
-getBit :: ExtBits -> P Bool
-getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
- in b `seq` POk s b
-
xbit :: ExtBits -> ExtsBitmap
xbit = bit . fromEnum
@@ -2474,34 +2470,59 @@ mkPStatePure options buf loc =
annotations_comments = []
}
--- | Add a non-fatal error. Use this when the parser can produce a result
--- despite the error.
---
--- For example, when GHC encounters a @forall@ in a type,
--- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
--- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
--- the accumulator.
+-- | An mtl-style class for monads that support parsing-related operations.
+-- For example, sometimes we make a second pass over the parsing results to validate,
+-- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume
+-- input but can report parsing errors, check for extension bits, and accumulate
+-- parsing annotations. Both P and PV are instances of MonadP.
--
--- Control flow wise, non-fatal errors act like warnings: they are added
--- to the accumulator and parsing continues. This allows GHC to report
--- more than one parse error per file.
+-- MonadP grants us convenient overloading. The other option is to have separate operations
+-- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on.
--
-addError :: SrcSpan -> SDoc -> P ()
-addError srcspan msg
- = P $ \s at PState{messages=m} ->
- let
- m' d =
- let (ws, es) = m d
- errormsg = mkErrMsg d srcspan alwaysQualify msg
- es' = es `snocBag` errormsg
- in (ws, es')
- in POk s{messages=m'} ()
-
--- | Add a fatal error. This will be the last error reported by the parser, and
--- the parser will not produce any result, ending in a 'PFailed' state.
-addFatalError :: SrcSpan -> SDoc -> P a
-addFatalError span msg =
- addError span msg >> P PFailed
+class Monad m => MonadP m where
+ -- | Add a non-fatal error. Use this when the parser can produce a result
+ -- despite the error.
+ --
+ -- For example, when GHC encounters a @forall@ in a type,
+ -- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
+ -- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
+ -- the accumulator.
+ --
+ -- Control flow wise, non-fatal errors act like warnings: they are added
+ -- to the accumulator and parsing continues. This allows GHC to report
+ -- more than one parse error per file.
+ --
+ addError :: SrcSpan -> SDoc -> m ()
+ -- | Add a fatal error. This will be the last error reported by the parser, and
+ -- the parser will not produce any result, ending in a 'PFailed' state.
+ addFatalError :: SrcSpan -> SDoc -> m a
+ -- | Check if a given flag is currently set in the bitmap.
+ getBit :: ExtBits -> m Bool
+ -- | Given a location and a list of AddAnn, apply them all to the location.
+ addAnnsAt :: SrcSpan -> [AddAnn] -> m ()
+ addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct
+ -> AnnKeywordId -- The first two parameters are the key
+ -> SrcSpan -- The location of the keyword itself
+ -> m ()
+
+instance MonadP P where
+ addError srcspan msg
+ = P $ \s at PState{messages=m} ->
+ let
+ m' d =
+ let (ws, es) = m d
+ errormsg = mkErrMsg d srcspan alwaysQualify msg
+ es' = es `snocBag` errormsg
+ in (ws, es')
+ in POk s{messages=m'} ()
+ addFatalError span msg =
+ addError span msg >> P PFailed
+ getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
+ in b `seq` POk s b
+ addAnnsAt loc anns = mapM_ (\a -> a loc) anns
+ addAnnotation l a v = do
+ addAnnotationOnly l a v
+ allocateComments l
-- | Add a warning to the accumulator.
-- Use 'getMessages' to get the accumulated warnings.
@@ -3042,23 +3063,11 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
-- function, and then it can be discharged using the 'ams' function.
type AddAnn = SrcSpan -> P ()
-addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct
- -> AnnKeywordId -- The first two parameters are the key
- -> SrcSpan -- The location of the keyword itself
- -> P ()
-addAnnotation l a v = do
- addAnnotationOnly l a v
- allocateComments l
-
addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
addAnnotationOnly l a v = P $ \s -> POk s {
annotations = ((l,a), [v]) : annotations s
} ()
--- |Given a location and a list of AddAnn, apply them all to the location.
-addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
-addAnnsAt loc anns = mapM_ (\a -> a loc) anns
-
-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'AddAnn' values for the opening and closing bordering on the start
-- and end of the span
=====================================
compiler/parser/Parser.y
=====================================
@@ -2396,8 +2396,8 @@ decl_no_th :: { LHsDecl GhcPs }
| '!' aexp rhs {% runExpCmdP $2 >>= \ $2 ->
do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)
; l = comb2 $1 $> };
- (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
- hintBangPat (comb2 $1 $2) (unLoc e) ;
+ (ann, r) <- checkValDef SrcStrict e Nothing $3 ;
+ runPV $ hintBangPat (comb2 $1 $2) (unLoc e) ;
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
-- [FunBind vs PatBind]
@@ -2410,7 +2410,7 @@ decl_no_th :: { LHsDecl GhcPs }
_ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
return $! (sL l $ ValD noExt r) } }
- | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
+ | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3;
let { l = comb2 $1 $> };
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
@@ -2582,8 +2582,8 @@ exp :: { ExpCmdP }
infixexp :: { ExpCmdP }
: exp10 { $1 }
| infixexp qop exp10 { ExpCmdP $
- runExpCmdP $1 >>= \ $1 ->
- runExpCmdP $3 >>= \ $3 ->
+ runExpCmdPV $1 >>= \ $1 ->
+ runExpCmdPV $3 >>= \ $3 ->
ams (sLL $1 $> (ecOpApp $1 $2 $3))
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
@@ -2670,13 +2670,13 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
fexp :: { ExpCmdP }
: fexp aexp {% runExpCmdP $2 >>= \ $2 ->
- checkBlockArguments $2 >>= \_ ->
+ runPV (checkBlockArguments $2) >>= \_ ->
return $ ExpCmdP $
- runExpCmdP $1 >>= \ $1 ->
+ runExpCmdPV $1 >>= \ $1 ->
checkBlockArguments $1 >>= \_ ->
return (sLL $1 $> (ecHsApp $1 $2)) }
| fexp TYPEAPP atype {% runExpCmdP $1 >>= \ $1 ->
- checkBlockArguments $1 >>= \_ ->
+ runPV (checkBlockArguments $1) >>= \_ ->
fmap ecFromExp $
ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3))
[mj AnnAt $2] }
@@ -2699,7 +2699,7 @@ aexp :: { ExpCmdP }
| '\\' apat apats '->' exp
{ ExpCmdP $
- runExpCmdP $5 >>= \ $5 ->
+ runExpCmdPV $5 >>= \ $5 ->
ams (sLL $1 $> $ ecHsLam (mkMatchGroup FromSource
[sLL $1 $> $ Match { m_ext = noExt
, m_ctxt = LambdaExpr
@@ -2707,12 +2707,12 @@ aexp :: { ExpCmdP }
, m_grhss = unguardedGRHSs $5 }]))
[mj AnnLam $1, mu AnnRarrow $4] }
| 'let' binds 'in' exp { ExpCmdP $
- runExpCmdP $4 >>= \ $4 ->
+ runExpCmdPV $4 >>= \ $4 ->
ams (sLL $1 $> $ ecHsLet (snd (unLoc $2)) $4)
(mj AnnLet $1:mj AnnIn $3
:(fst $ unLoc $2)) }
| '\\' 'lcase' altslist
- {% $3 >>= \ $3 ->
+ {% runPV $3 >>= \ $3 ->
fmap ecFromExp $
ams (sLL $1 $> $ HsLamCase noExt
(mkMatchGroup FromSource (snd $ unLoc $3)))
@@ -2720,8 +2720,8 @@ aexp :: { ExpCmdP }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% runExpCmdP $2 >>= \ $2 ->
return $ ExpCmdP $
- runExpCmdP $5 >>= \ $5 ->
- runExpCmdP $8 >>= \ $8 ->
+ runExpCmdPV $5 >>= \ $5 ->
+ runExpCmdPV $8 >>= \ $8 ->
checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
ams (sLL $1 $> $ ecHsIf $2 $5 $8)
(mj AnnIf $1:mj AnnThen $4
@@ -2746,13 +2746,13 @@ aexp :: { ExpCmdP }
ams (cL (comb2 $1 $2)
(ecHsDo (mapLoc snd $2)))
(mj AnnDo $1:(fst $ unLoc $2)) }
- | 'mdo' stmtlist {% $2 >>= \ $2 ->
+ | 'mdo' stmtlist {% runPV $2 >>= \ $2 ->
fmap ecFromExp $
ams (cL (comb2 $1 $2)
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| 'proc' aexp '->' exp
- {% (checkPattern empty <=< runExpCmdP) $2 >>= \ p ->
+ {% (checkPattern <=< runExpCmdP) $2 >>= \ p ->
runExpCmdP $4 >>= \ $4 at cmd ->
fmap ecFromExp $
ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd))
@@ -2788,7 +2788,7 @@ aexp2 :: { ExpCmdP }
-- correct Haskell (you'd have to write '((+ 3), (4 -))')
-- but the less cluttered version fell out of having texps.
| '(' texp ')' { ExpCmdP $
- runExpCmdP $2 >>= \ $2 ->
+ runExpCmdPV $2 >>= \ $2 ->
ams (sLL $1 $> (ecHsPar $2)) [mop $1,mcp $3] }
| '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
; fmap ecFromExp $
@@ -2825,7 +2825,7 @@ aexp2 :: { ExpCmdP }
(if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
| '[t|' ktype '|]' {% fmap ecFromExp $
ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
- | '[p|' infixexp '|]' {% (checkPattern empty <=< runExpCmdP) $2 >>= \p ->
+ | '[p|' infixexp '|]' {% (checkPattern <=< runExpCmdP) $2 >>= \p ->
fmap ecFromExp $
ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
[mo $1,mu AnnCloseQ $3] }
@@ -3022,12 +3022,12 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau
amsL (comb2 $1 $>) (fst $ unLoc $3) >>
return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }
| squals ',' qual
- {% $3 >>= \ $3 ->
+ {% runPV $3 >>= \ $3 ->
addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| transformqual {% ams $1 (fst $ unLoc $1) >>
return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
- | qual {% $1 >>= \ $1 ->
+ | qual {% runPV $1 >>= \ $1 ->
return $ sL1 $1 [$1] }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
-- | '{|' pquals '|}' { sL1 $1 [$2] }
@@ -3068,11 +3068,11 @@ guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) }
guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
- : guardquals1 ',' qual {% $3 >>= \ $3 ->
+ : guardquals1 ',' qual {% runPV $3 >>= \ $3 ->
addAnnotation (gl $ head $ unLoc $1) AnnComma
(gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
- | qual {% $1 >>= \ $1 ->
+ | qual {% runPV $1 >>= \ $1 ->
return $ sL1 $1 [$1] }
-----------------------------------------------------------------------------
@@ -3126,7 +3126,7 @@ alt_rhs :: { forall b. ExpCmdI b => PV (Located ([AddAnn],GRHSs GhcPs (Located (
return $ sLL alt $> (fst $ unLoc $2, GRHSs noExt (unLoc alt) (snd $ unLoc $2)) }
ralt :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) }
- : '->' exp { runExpCmdP $2 >>= \ $2 ->
+ : '->' exp { runExpCmdPV $2 >>= \ $2 ->
ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
[mu AnnRarrow $1] }
| gdpats { $1 >>= \gdpats ->
@@ -3142,14 +3142,14 @@ gdpats :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]
-- generate the open brace in addition to the vertical bar in the lexer, and
-- we don't need it.
ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
- : '{' gdpats '}' {% $2 >>= \ $2 ->
+ : '{' gdpats '}' {% runPV $2 >>= \ $2 ->
return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2) }
- | gdpats close {% $1 >>= \ $1 ->
+ | gdpats close {% runPV $1 >>= \ $1 ->
return $ sL1 $1 ([],unLoc $1) }
gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) }
: '|' guardquals '->' exp
- { runExpCmdP $4 >>= \ $4 ->
+ { runExpCmdPV $4 >>= \ $4 ->
ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
[mj AnnVbar $1,mu AnnRarrow $3] }
@@ -3158,26 +3158,26 @@ gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) }
-- Bangs inside are parsed as infix operator applications, so that
-- we parse them right when bang-patterns are off
pat :: { LPat GhcPs }
-pat : exp {% (checkPattern empty <=< runExpCmdP) $1 }
+pat : exp {% (checkPattern <=< runExpCmdP) $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
- amms (checkPattern empty (sLL $1 $> (SectionR noExt
+ amms (checkPattern (sLL $1 $> (SectionR noExt
(sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
bindpat :: { LPat GhcPs }
bindpat : exp {% runExpCmdP $1 >>= \ $1 ->
- checkPattern
- (text "Possibly caused by a missing 'do'?") $1 }
+ -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn
+ checkPattern_msg (text "Possibly caused by a missing 'do'?") $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
- amms (checkPattern
- (text "Possibly caused by a missing 'do'?")
+ -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn
+ amms (checkPattern_msg (text "Possibly caused by a missing 'do'?")
(sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
apat :: { LPat GhcPs }
-apat : aexp {% (checkPattern empty <=< runExpCmdP) $1 }
+apat : aexp {% (checkPattern <=< runExpCmdP) $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
- amms (checkPattern empty
+ amms (checkPattern
(sLL $1 $> (SectionR noExt
(sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
@@ -3229,12 +3229,12 @@ stmts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b
-- For typing stmts at the GHCi prompt, where
-- the input may consist of just comments.
maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }
- : stmt {% fmap Just $1 }
+ : stmt {% fmap Just (runPV $1) }
| {- nothing -} { Nothing }
-- For GHC API.
e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
- : stmt {% $1 }
+ : stmt {% runPV $1 }
stmt :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
: qual { $1 }
@@ -3243,10 +3243,10 @@ stmt :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
(mj AnnRec $1:(fst $ unLoc $2)) }
qual :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
- : bindpat '<-' exp { runExpCmdP $3 >>= \ $3 ->
+ : bindpat '<-' exp { runExpCmdPV $3 >>= \ $3 ->
ams (sLL $1 $> $ mkBindStmt $1 $3)
[mu AnnLarrow $2] }
- | exp { runExpCmdP $1 >>= \ $1 ->
+ | exp { runExpCmdPV $1 >>= \ $1 ->
return $ sL1 $1 $ mkBodyStmt $1 }
| 'let' binds { ams (sLL $1 $> $ LetStmt noExt (snd $ unLoc $2))
(mj AnnLet $1:(fst $ unLoc $2)) }
@@ -4037,7 +4037,7 @@ am a (b,s) = do
-- as any annotations that may arise in the binds. This will include open
-- and closing braces if they are used to delimit the let expressions.
--
-ams :: Located a -> [AddAnn] -> P (Located a)
+ams :: MonadP m => Located a -> [AddAnn] -> m (Located a)
ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
amsL :: SrcSpan -> [AddAnn] -> P ()
=====================================
compiler/parser/RdrHsSyn.hs
=====================================
@@ -15,6 +15,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module RdrHsSyn (
mkHsOpApp,
@@ -53,10 +54,10 @@ module RdrHsSyn (
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
+ checkPattern_msg,
bang_RDR,
isBangRdr,
isTildeRdr,
- checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
@@ -88,7 +89,9 @@ module RdrHsSyn (
-- Expression/command ambiguity resolution
PV,
- ExpCmdP(ExpCmdP, runExpCmdP),
+ runPV,
+ ExpCmdP(ExpCmdP, runExpCmdPV),
+ runExpCmdP,
ExpCmdI(..),
ecFromExp,
ecFromCmd,
@@ -127,6 +130,7 @@ import Data.List
import DynFlags ( WarningFlag(..) )
import Control.Monad
+import Control.Monad.Trans.Reader
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import qualified Data.Monoid as Monoid
@@ -970,11 +974,11 @@ checkTyClHdr is_cls ty
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
-checkExpBlockArguments :: LHsExpr GhcPs -> P ()
-checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
+checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
+checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
where
- checkExpr :: LHsExpr GhcPs -> P ()
+ checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr expr = case unLoc expr of
HsDo _ DoExpr _ -> check "do block" expr
HsDo _ MDoExpr _ -> check "mdo block" expr
@@ -986,7 +990,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
HsProc {} -> check "proc expression" expr
_ -> return ()
- checkCmd :: LHsCmd GhcPs -> P ()
+ checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd cmd = case unLoc cmd of
HsCmdLam {} -> check "lambda command" cmd
HsCmdCase {} -> check "case command" cmd
@@ -995,7 +999,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
HsCmdDo {} -> check "do command" cmd
_ -> return ()
- check :: (HasSrcSpan a, Outputable a) => String -> a -> P ()
+ check :: (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check element a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
@@ -1052,38 +1056,39 @@ checkNoDocs msg ty = go ty
-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.
-checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
-checkPattern msg e = checkLPat msg e
+checkPattern :: LHsExpr GhcPs -> P (LPat GhcPs)
+checkPattern = runPV . checkLPat
-checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
-checkPatterns msg es = mapM (checkPattern msg) es
+checkPattern_msg :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
+checkPattern_msg msg = runPV_msg msg . checkLPat
-checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
-checkLPat msg e@(dL->L l _) = checkPat msg l e []
+checkLPat :: LHsExpr GhcPs -> PV (LPat GhcPs)
+checkLPat e@(dL->L l _) = checkPat l e []
-checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
- -> P (LPat GhcPs)
-checkPat _ loc (dL->L l e@(HsVar _ (dL->L _ c))) args
+checkPat :: SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
+ -> PV (LPat GhcPs)
+checkPat loc (dL->L l e@(HsVar _ (dL->L _ c))) args
| isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
| not (null args) && patIsRec c =
- patFail (text "Perhaps you intended to use RecursiveDo") l e
-checkPat msg loc e args -- OK to let this happen even if bang-patterns
+ localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
+ patFail l e
+checkPat loc e args -- OK to let this happen even if bang-patterns
-- are not enabled, because there is no valid
-- non-bang-pattern parse of (C ! e)
| Just (e', args') <- splitBang e
- = do { args'' <- checkPatterns msg args'
- ; checkPat msg loc e' (args'' ++ args) }
-checkPat msg loc (dL->L _ (HsApp _ f e)) args
- = do p <- checkLPat msg e
- checkPat msg loc f (p : args)
-checkPat msg loc (dL->L _ e) []
- = do p <- checkAPat msg loc e
+ = do { args'' <- mapM checkLPat args'
+ ; checkPat loc e' (args'' ++ args) }
+checkPat loc (dL->L _ (HsApp _ f e)) args
+ = do p <- checkLPat e
+ checkPat loc f (p : args)
+checkPat loc (dL->L _ e) []
+ = do p <- checkAPat loc e
return (cL loc p)
-checkPat msg loc e _
- = patFail msg loc (unLoc e)
+checkPat loc e _
+ = patFail loc (unLoc e)
-checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
-checkAPat msg loc e0 = do
+checkAPat :: SrcSpan -> HsExpr GhcPs -> PV (Pat GhcPs)
+checkAPat loc e0 = do
nPlusKPatterns <- getBit NPlusKPatternsBit
case e0 of
EWildPat _ -> return (WildPat noExt)
@@ -1104,16 +1109,16 @@ checkAPat msg loc e0 = do
SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x)
| bang == bang_RDR
-> do { hintBangPat loc e0
- ; e' <- checkLPat msg e
+ ; e' <- checkLPat e
; addAnnotation loc AnnBang lb
; return (BangPat noExt e') }
- ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt))
- EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n)
+ ELazyPat _ e -> checkLPat e >>= (return . (LazyPat noExt))
+ EAsPat _ n e -> checkLPat e >>= (return . (AsPat noExt) n)
-- view pattern is well-formed if the pattern is
- EViewPat _ expr patE -> checkLPat msg patE >>=
+ EViewPat _ expr patE -> checkLPat patE >>=
(return . (\p -> ViewPat noExt expr p))
- ExprWithTySig _ e t -> do e <- checkLPat msg e
+ ExprWithTySig _ e t -> do e <- checkLPat e
return (SigPat noExt e t)
-- n+k patterns
@@ -1124,34 +1129,34 @@ checkAPat msg loc e0 = do
-> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r
| isDataOcc (rdrNameOcc c) -> do
- l <- checkLPat msg l
- r <- checkLPat msg r
+ l <- checkLPat l
+ r <- checkLPat r
return (ConPatIn (cL cl c) (InfixCon l r))
- OpApp {} -> patFail msg loc e0
+ OpApp {} -> patFail loc e0
- ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
+ ExplicitList _ _ es -> do ps <- mapM checkLPat es
return (ListPat noExt ps)
- HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt))
+ HsPar _ e -> checkLPat e >>= (return . (ParPat noExt))
ExplicitTuple _ es b
- | all tupArgPresent es -> do ps <- mapM (checkLPat msg)
+ | all tupArgPresent es -> do ps <- mapM checkLPat
[e | (dL->L _ (Present _ e)) <- es]
return (TuplePat noExt ps b)
| otherwise -> addFatalError loc (text "Illegal tuple section in pattern:"
$$ ppr e0)
ExplicitSum _ alt arity expr -> do
- p <- checkLPat msg expr
+ p <- checkLPat expr
return (SumPat noExt p alt arity)
RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
- -> do fs <- mapM (checkPatField msg) fs
+ -> do fs <- mapM checkPatField fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsSpliceE _ s | not (isTypedSplice s)
-> return (SplicePat noExt s)
- _ -> patFail msg loc e0
+ _ -> patFail loc e0
placeHolderPunRhs :: LHsExpr GhcPs
-- The RHS of a punned record field will be filled in by the renamer
@@ -1169,15 +1174,13 @@ isBangRdr (Unqual occ) = occNameFS occ == fsLit "!"
isBangRdr _ = False
isTildeRdr = (==eqTyCon_RDR)
-checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
- -> P (LHsRecField GhcPs (LPat GhcPs))
-checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
- return (cL l (fld { hsRecFieldArg = p }))
+checkPatField :: LHsRecField GhcPs (LHsExpr GhcPs)
+ -> PV (LHsRecField GhcPs (LPat GhcPs))
+checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld)
+ return (cL l (fld { hsRecFieldArg = p }))
-patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
-patFail msg loc e = addFatalError loc err
- where err = text "Parse error in pattern:" <+> ppr e
- $$ msg
+patFail :: SrcSpan -> HsExpr GhcPs -> PV a
+patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
patIsRec :: RdrName -> Bool
patIsRec e = e == mkUnqual varName (fsLit "rec")
@@ -1186,28 +1189,26 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
---------------------------------------------------------------------------
-- Check Equation Syntax
-checkValDef :: SDoc
- -> SrcStrictness
+checkValDef :: SrcStrictness
-> LHsExpr GhcPs
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkValDef msg _strictness lhs (Just sig) grhss
+checkValDef _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
- = checkPatBind msg (cL (combineLocs lhs sig)
+ = checkPatBind (cL (combineLocs lhs sig)
(ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss
-checkValDef msg strictness lhs Nothing g@(dL->L l (_,grhss))
+checkValDef strictness lhs Nothing g@(dL->L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
- checkFunBind msg strictness ann (getLoc lhs)
+ checkFunBind strictness ann (getLoc lhs)
fun is_infix pats (cL l grhss)
- Nothing -> checkPatBind msg lhs g }
+ Nothing -> checkPatBind lhs g }
-checkFunBind :: SDoc
- -> SrcStrictness
+checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
@@ -1215,8 +1216,8 @@ checkFunBind :: SDoc
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
- = do ps <- checkPatterns msg pats
+checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
+ = do ps <- mapM checkPattern pats
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
@@ -1241,12 +1242,11 @@ makeFunBind fn ms
fun_co_fn = idHsWrapper,
fun_tick = [] }
-checkPatBind :: SDoc
- -> LHsExpr GhcPs
+checkPatBind :: LHsExpr GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkPatBind msg lhs (dL->L _ (_,grhss))
- = do { lhs <- checkPattern msg lhs
+checkPatBind lhs (dL->L _ (_,grhss))
+ = do { lhs <- checkPattern lhs
; return ([],PatBind noExt lhs grhss
([],[])) }
@@ -1284,7 +1284,7 @@ checkValSigLhs lhs@(dL->L l _)
checkDoAndIfThenElse'
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
- => a -> Bool -> b -> Bool -> c -> P ()
+ => a -> Bool -> b -> Bool -> c -> PV ()
checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
@@ -1876,7 +1876,10 @@ checkMonadComp = do
-- See Note [Parser-Validator]
-- See Note [Ambiguous syntactic categories]
newtype ExpCmdP =
- ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
+ ExpCmdP { runExpCmdPV :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
+
+runExpCmdP :: ExpCmdI b => ExpCmdP -> P (Located (b GhcPs))
+runExpCmdP p = runPV (runExpCmdPV p)
ecFromExp :: LHsExpr GhcPs -> ExpCmdP
ecFromExp a = ExpCmdP (ecFromExp' a)
@@ -1910,7 +1913,7 @@ class ExpCmdI b where
checkBlockArguments :: Located (b GhcPs) -> PV ()
-- | Check if -XDoAndIfThenElse is enabled.
checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)
- -> Bool -> Located (b GhcPs) -> P ()
+ -> Bool -> Located (b GhcPs) -> PV ()
instance ExpCmdI HsCmd where
ecFromCmd' = return
@@ -2661,7 +2664,30 @@ failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
-----------------------------------------------------------------------------
-- Misc utils
-type PV = P -- See Note [Parser-Validator]
+-- See Note [Parser-Validator] and Note [Parser-Validator ReaderT SDoc]
+newtype PV a = PV (ReaderT SDoc P a)
+ deriving (Functor, Applicative, Monad)
+
+runPV :: PV a -> P a
+runPV (PV m) = runReaderT m empty
+
+runPV_msg :: SDoc -> PV a -> P a
+runPV_msg msg (PV m) = runReaderT m msg
+
+localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a
+localPV_msg f (PV m) = PV (local f m)
+
+instance MonadP PV where
+ addError srcspan msg =
+ PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg)
+ addFatalError srcspan msg =
+ PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg)
+ getBit ext =
+ PV $ ReaderT $ \_ -> getBit ext
+ addAnnsAt loc anns =
+ PV $ ReaderT $ \_ -> addAnnsAt loc anns
+ addAnnotation l a v =
+ PV $ ReaderT $ \_ -> addAnnotation l a v
{- Note [Parser-Validator]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2693,8 +2719,50 @@ not consume any input, but may fail or use other effects. Thus we have:
-}
+{- Note [Parser-Validator ReaderT SDoc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A PV computation is parametrized by a hint for error messages, which can be set
+depending on validation context. We use this in checkPattern to fix #984.
+
+Consider this example, where the user has forgotten a 'do':
+
+ f _ = do
+ x <- computation
+ case () of
+ _ ->
+ result <- computation
+ case () of () -> undefined
+
+GHC parses it as follows:
+
+ f _ = do
+ x <- computation
+ (case () of
+ _ ->
+ result) <- computation
+ case () of () -> undefined
+
+Note that this fragment is parsed as a pattern:
+
+ case () of
+ _ ->
+ result
+
+We attempt to detect such cases and add a hint to the error messages:
+
+ T984.hs:6:9:
+ Parse error in pattern: case () of { _ -> result }
+ Possibly caused by a missing 'do'?
+
+The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed
+via ReaderT SDoc in PV. When validating in a context other than 'bindpat' (a
+pattern to the left of <-), we set the hint to 'empty' and it has no effect on
+the error messages.
+
+-}
+
-- | Hint about bang patterns, assuming @BangPatterns@ is off.
-hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
+hintBangPat :: SrcSpan -> HsExpr GhcPs -> PV ()
hintBangPat span e = do
bang_on <- getBit BangPatBit
unless bang_on $
=====================================
configure.ac
=====================================
@@ -168,7 +168,7 @@ then
$WithGhc is a development snapshot of GHC, version $GhcVersion.
Bootstrapping using this version of GHC is not supported, and may not
work. Use --enable-bootstrap-with-devel-snapshot to try it anyway,
- or --with-ghc to specify a different GHC to use.])
+ or 'GHC=' to specify a different GHC to use.])
fi
fi
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -2146,7 +2146,9 @@ parseSpanArg s = do
let fs = mkFastString fp
span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)
- (mkRealSrcLoc fs el ec)
+ -- End column of RealSrcSpan is the column
+ -- after the end of the span.
+ (mkRealSrcLoc fs el (ec + 1))
return (span',trailer)
where
@@ -2192,7 +2194,9 @@ showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
sl = srcSpanStartLine spn
sc = srcSpanStartCol spn
el = srcSpanEndLine spn
- ec = srcSpanEndCol spn
+ -- The end column is the column after the end of the span see the
+ -- RealSrcSpan module
+ ec = let ec' = srcSpanEndCol spn in if ec' == 0 then 0 else ec' - 1
-----------------------------------------------------------------------------
-- | @:kind@ command
=====================================
ghc/GHCi/UI/Info.hs
=====================================
@@ -75,6 +75,9 @@ data SpanInfo = SpanInfo
-- locality, definition location, etc.
}
+instance Outputable SpanInfo where
+ ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i
+
-- | Test whether second span is contained in (or equal to) first span.
-- This is basically 'containsSpan' for 'SpanInfo'
containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -147,6 +147,7 @@ getTestArgs = do
bindir <- expr $ getBinaryDirectory (testCompiler args)
compiler <- expr $ getCompilerPath (testCompiler args)
globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
+ haveDocs <- areDocsPresent
let configFileArg= ["--config-file=" ++ (testConfigFile args)]
testOnlyArg = map ("--only=" ++) (testOnly args ++ testEnvTargets)
onlyPerfArg = if testOnlyPerf args
@@ -169,7 +170,9 @@ getTestArgs = do
wayArgs = map ("--way=" ++) (testWays args)
compilerArg = ["--config", "compiler=" ++ show (compiler)]
ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
- haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
+ haddockArg = if haveDocs
+ then [ "--config", "haddock=" ++ show (bindir -/- "haddock") ]
+ else [ "--config", "haddock=" ]
hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
inTreeArg = [ "-e", "config.in_tree_compiler=" ++
@@ -181,6 +184,17 @@ getTestArgs = do
++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
+ where areDocsPresent = expr $ do
+ root <- buildRoot
+ and <$> traverse doesFileExist (docFiles root)
+
+ docFiles root =
+ [ root -/- "docs" -/- "html" -/- "libraries" -/- p -/- (p ++ ".haddock")
+ -- list of packages from
+ -- utils/haddock/haddock-test/src/Test/Haddock/Config.hs
+ | p <- [ "array", "base", "ghc-prim", "process", "template-haskell" ]
+ ]
+
-- | Set speed for test
setTestSpeed :: TestSpeed -> String
setTestSpeed TestSlow = "0"
=====================================
includes/rts/storage/ClosureMacros.h
=====================================
@@ -184,8 +184,8 @@ STATIC_LINK(const StgInfoTable *info, StgClosure *p)
case IND_STATIC:
return IND_STATIC_LINK(p);
default:
- return &(p)->payload[info->layout.payload.ptrs +
- info->layout.payload.nptrs];
+ return &p->payload[info->layout.payload.ptrs +
+ info->layout.payload.nptrs];
}
}
=====================================
rts/posix/OSMem.c
=====================================
@@ -546,10 +546,12 @@ void *osReserveHeapMemory(void *startAddressPtr, W_ *len)
#if defined(HAVE_SYS_RESOURCE_H) && defined(HAVE_SYS_TIME_H)
struct rlimit limit;
+ /* rlim_t is signed on some platforms, including FreeBSD;
+ * explicitly cast to avoid sign compare error */
if (!getrlimit(RLIMIT_AS, &limit)
&& limit.rlim_cur > 0
- && *len > limit.rlim_cur) {
- *len = limit.rlim_cur;
+ && *len > (unsigned) limit.rlim_cur) {
+ *len = (unsigned) limit.rlim_cur;
}
#endif
=====================================
rts/sm/Evac.c
=====================================
@@ -333,7 +333,7 @@ evacuate_static_object (StgClosure **link_field, StgClosure *q)
StgWord link = (StgWord)*link_field;
// See Note [STATIC_LINK fields] for how the link field bits work
- if ((((StgWord)(link)&STATIC_BITS) | prev_static_flag) != 3) {
+ if (((link & STATIC_BITS) | prev_static_flag) != 3) {
StgWord new_list_head = (StgWord)q | static_flag;
#if !defined(THREADED_RTS)
*link_field = gct->static_objects;
=====================================
rts/sm/GC.c
=====================================
@@ -281,7 +281,7 @@ GarbageCollect (uint32_t collect_gen,
// lose locality by moving cached data into another CPU's cache
// (this effect can be quite significant).
//
- // We could have a more complex way to deterimine whether to do
+ // We could have a more complex way to determine whether to do
// work stealing or not, e.g. it might be a good idea to do it
// if the heap is big. For now, we just turn it on or off with
// a flag.
=====================================
testsuite/tests/ghci/scripts/T16569.hs
=====================================
@@ -0,0 +1,4 @@
+module T16569 where
+
+main :: IO ()
+main = putStrLn (case (undefined :: Int) of _ -> undefined)
=====================================
testsuite/tests/ghci/scripts/T16569.script
=====================================
@@ -0,0 +1,3 @@
+:set +c
+:l T16569.hs
+::type-at T16569.hs 4 8 4 59
=====================================
testsuite/tests/ghci/scripts/T16569.stdout
=====================================
@@ -0,0 +1,2 @@
+Collecting type info for 1 module(s) ...
+ :: IO ()
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -295,3 +295,4 @@ test('T16089', normal, ghci_script, ['T16089.script'])
test('T14828', normal, ghci_script, ['T14828.script'])
test('T16376', normal, ghci_script, ['T16376.script'])
test('T16527', normal, ghci_script, ['T16527.script'])
+test('T16569', normal, ghci_script, ['T16569.script'])
=====================================
testsuite/tests/ghci/should_run/T15369.stdout
=====================================
@@ -1,8 +1,8 @@
Collecting type info for 1 module(s) ...
-T15369.hs:(3,1)-(3,2): GHC.Types.Int
-T15369.hs:(3,5)-(3,6): GHC.Types.Int
-T15369.hs:(3,1)-(3,2): GHC.Types.Int
-T15369.hs:(3,5)-(3,6): GHC.Types.Int
+T15369.hs:(3,1)-(3,1): GHC.Types.Int
+T15369.hs:(3,5)-(3,5): GHC.Types.Int
+T15369.hs:(3,1)-(3,1): GHC.Types.Int
+T15369.hs:(3,5)-(3,5): GHC.Types.Int
Collecting type info for 1 module(s) ...
-T15369.hs:(3,1)-(3,2): GHC.Types.Double
-T15369.hs:(3,5)-(3,6): GHC.Types.Double
+T15369.hs:(3,1)-(3,1): GHC.Types.Double
+T15369.hs:(3,5)-(3,5): GHC.Types.Double
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/afc8045082270ff17b0754cbe106e96f81038959...a80aa49c81ab8227ab022aae66607a502041582c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/afc8045082270ff17b0754cbe106e96f81038959...a80aa49c81ab8227ab022aae66607a502041582c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190426/a577a698/attachment-0001.html>
More information about the ghc-commits
mailing list