Skip to content
Commits on Source (22)
Hide whitespace changes
Inline Side-by-side
.gitlab-ci.yml
View file @ 4e228267
......@@ -125,7 +125,8 @@ lint-changelogs:
lint-release-changelogs:
extends: .lint-changelogs
only:
- tags
refs:
- /ghc-[0-9]+\.[0-9]+\.[0-9]+-.*/
############################################################
......@@ -143,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
......@@ -457,6 +459,27 @@ release-x86_64-linux-deb8:
when: always
expire_in: 2 week
#################################
# x86_64-linux-centos7
#################################
release-x86_64-linux-centos7:
extends: .validate-linux
stage: full-build
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-centos7:$DOCKER_REV"
variables:
# The sphinx release shipped with Centos 7 fails to build out documentation
BUILD_SPHINX_HTML: "NO"
BUILD_SPHINX_PDF: "NO"
TEST_ENV: "x86_64-linux-centos7"
BIN_DIST_PREP_TAR_COMP: "bindistprep/ghc-x86_64-centos7-linux.tar.xz"
only:
- tags
cache:
key: linux-x86_64-centos7
artifacts:
when: always
expire_in: 2 week
#################################
# x86_64-linux-fedora27
......@@ -604,6 +627,8 @@ release-i386-windows:
MSYSTEM: MINGW32
BUILD_FLAVOUR: "perf"
CONFIGURE_ARGS: "--target=i386-unknown-mingw32"
# Due to #15934
BUILD_PROF_LIBS: "NO"
cache:
key: "i386-windows-$WINDOWS_TOOLCHAIN_VERSION"
......@@ -615,6 +640,8 @@ nightly-i386-windows:
variables:
MSYSTEM: MINGW32
CONFIGURE_ARGS: "--target=i386-unknown-mingw32"
# Due to #15934
BUILD_PROF_LIBS: "NO"
cache:
key: "i386-windows-$WINDOWS_TOOLCHAIN_VERSION"
......@@ -688,6 +715,11 @@ doc-tarball:
dependencies:
- validate-x86_64-linux-deb9
- validate-x86_64-windows
variables:
LINUX_BINDIST: "ghc-x86_64-deb9-linux.tar.xz"
WINDOWS_BINDIST: "ghc-x86_64-mingw32.tar.xz"
# Due to Windows allow_failure
allow_failure: true
artifacts:
paths:
- haddock.html.tar.xz
......@@ -696,8 +728,17 @@ doc-tarball:
- index.html
- "*.pdf"
script:
- |
if [ ! -f "$LINUX_BINDIST" ]; then
echo "Error: $LINUX_BINDIST does not exist. Did the Debian 9 job fail?"
exit 1
fi
if [ ! -f "$WINDOWS_BINDIST" ]; then
echo "Error: $WINDOWS_BINDIST does not exist. Did the 64-bit Windows job fail?"
exit 1
fi
- rm -Rf docs
- bash -ex distrib/mkDocs/mkDocs ghc-x86_64-deb9-linux.tar.xz ghc-x86_64-mingw32.tar.xz
- bash -ex distrib/mkDocs/mkDocs $LINUX_BINDIST $WINDOWS_BINDIST
- ls -lh
- mv docs/*.tar.xz docs/index.html .
......@@ -706,6 +747,7 @@ source-tarball:
tags:
- x86_64-linux
image: ghcci/x86_64-linux-deb9:0.2
dependencies: []
only:
- tags
artifacts:
......@@ -764,6 +806,8 @@ pages:
dependencies:
- doc-tarball
image: ghcci/x86_64-linux-deb9:0.2
# Due to Windows allow_failure
allow_failure: true
tags:
- x86_64-linux
script:
......
compiler/deSugar/Check.hs
View file @ 4e228267
......@@ -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 <- _@. That is, we record that there is a possibility
@PmFake@: @True <- _@. 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/parser/Lexer.x
View file @ 4e228267
......@@ -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@.
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@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@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
View file @ 4e228267
......@@ -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@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
View file @ 4e228267
......@@ -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 $
......
compiler/prelude/primops.txt.pp
View file @ 4e228267
......@@ -1133,7 +1133,18 @@ primop ThawArrayOp "thawArray#" GenPrimOp
primop CasArrayOp "casArray#" GenPrimOp
MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #)
{Unsafe, machine-level atomic compare and swap on an element within an Array.}
{Given an array, an offset, the expected old value, and
the new value, perform an atomic compare and swap (i.e. write the new
value if the current value and the old value are the same pointer).
Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns
the element at the offset after the operation completes. This means that
on a success the new value is returned, and on a failure the actual old
value (not the expected one) is returned. Implies a full memory barrier.
The use of a pointer equality on a lifted value makes this function harder
to use correctly than {\tt casIntArray\#}. All of the difficulties
of using {\tt reallyUnsafePtrEquality\#} correctly apply to
{\tt casArray\#} as well.
}
with
out_of_line = True
has_side_effects = True
......@@ -1298,7 +1309,8 @@ primop ThawSmallArrayOp "thawSmallArray#" GenPrimOp
primop CasSmallArrayOp "casSmallArray#" GenPrimOp
SmallMutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #)
{Unsafe, machine-level atomic compare and swap on an element within an array.}
{Unsafe, machine-level atomic compare and swap on an element within an array.
See the documentation of {\tt casArray\#}.}
with
out_of_line = True
has_side_effects = True
......@@ -1562,13 +1574,13 @@ primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp
primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
{Read integer; offset in words.}
{Read integer; offset in machine words.}
with has_side_effects = True
can_fail = True
primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp
MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
{Read word; offset in words.}
{Read word; offset in machine words.}
with has_side_effects = True
can_fail = True
......@@ -1942,21 +1954,21 @@ primop SetByteArrayOp "setByteArray#" GenPrimOp
primop AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
{Given an array and an offset in Int units, read an element. The
{Given an array and an offset in machine words, read an element. The
index is assumed to be in bounds. Implies a full memory barrier.}
with has_side_effects = True
can_fail = True
primop AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
{Given an array and an offset in Int units, write an element. The
{Given an array and an offset in machine words, write an element. The
index is assumed to be in bounds. Implies a full memory barrier.}
with has_side_effects = True
can_fail = True
primop CasByteArrayOp_Int "casIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #)
{Given an array, an offset in Int units, the expected old value, and
{Given an array, an offset in machine words, the expected old value, and
the new value, perform an atomic compare and swap i.e. write the new
value if the current value matches the provided old value. Returns
the value of the element before the operation. Implies a full memory
......@@ -1966,7 +1978,7 @@ primop CasByteArrayOp_Int "casIntArray#" GenPrimOp
primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)
{Given an array, and offset in Int units, and a value to add,
{Given an array, and offset in machine words, and a value to add,
atomically add the value to the element. Returns the value of the
element before the operation. Implies a full memory barrier.}
with has_side_effects = True
......@@ -1974,7 +1986,7 @@ primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp
primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)
{Given an array, and offset in Int units, and a value to subtract,
{Given an array, and offset in machine words, and a value to subtract,
atomically substract the value to the element. Returns the value of
the element before the operation. Implies a full memory barrier.}
with has_side_effects = True
......@@ -1982,7 +1994,7 @@ primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp
primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)
{Given an array, and offset in Int units, and a value to AND,
{Given an array, and offset in machine words, and a value to AND,
atomically AND the value to the element. Returns the value of the
element before the operation. Implies a full memory barrier.}
with has_side_effects = True
......@@ -1990,7 +2002,7 @@ primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp
primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)
{Given an array, and offset in Int units, and a value to NAND,
{Given an array, and offset in machine words, and a value to NAND,
atomically NAND the value to the element. Returns the value of the
element before the operation. Implies a full memory barrier.}
with has_side_effects = True
......@@ -1998,7 +2010,7 @@ primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp
primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)
{Given an array, and offset in Int units, and a value to OR,
{Given an array, and offset in machine words, and a value to OR,
atomically OR the value to the element. Returns the value of the
element before the operation. Implies a full memory barrier.}
with has_side_effects = True
......@@ -2006,7 +2018,7 @@ primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp
primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp
MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)
{Given an array, and offset in Int units, and a value to XOR,
{Given an array, and offset in machine words, and a value to XOR,
atomically XOR the value to the element. Returns the value of the
element before the operation. Implies a full memory barrier.}
with has_side_effects = True
......
configure.ac
View file @ 4e228267
......@@ -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
......
docs/users_guide/8.10.1-notes.rst
View file @ 4e228267
......@@ -97,3 +97,43 @@ Build system
Included libraries
------------------
The package database provided with this distribution also contains a number of
packages other than GHC itself. See the changelogs provided with these packages
for further change information.
.. ghc-package-list::
libraries/array/array.cabal: Dependency of ``ghc`` library
libraries/base/base.cabal: Core library
libraries/binary/binary.cabal: Dependency of ``ghc`` library
libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library
libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility
libraries/containers/containers.cabal: Dependency of ``ghc`` library
libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library
libraries/directory/directory.cabal: Dependency of ``ghc`` library
libraries/filepath/filepath.cabal: Dependency of ``ghc`` library
compiler/ghc.cabal: The compiler itself
libraries/ghci/ghci.cabal: The REPL interface
libraries/ghc-boot/ghc-boot.cabal: Internal compiler library
libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library
libraries/ghc-compact/ghc-compact.cabal: Core library
libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library
libraries/ghc-prim/ghc-prim.cabal: Core library
libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable
libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable
libraries/integer-gmp/integer-gmp.cabal: Core library
libraries/libiserv/libiserv.cabal: Internal compiler library
libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library
libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library
libraries/pretty/pretty.cabal: Dependency of ``ghc`` library
libraries/process/process.cabal: Dependency of ``ghc`` library
libraries/stm/stm.cabal: Dependency of ``haskeline`` library
libraries/template-haskell/template-haskell.cabal: Core library
libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library
libraries/text/text.cabal: Dependency of ``Cabal`` library
libraries/time/time.cabal: Dependency of ``ghc`` library
libraries/transformers/transformers.cabal: Dependency of ``ghc`` library
libraries/unix/unix.cabal: Dependency of ``ghc`` library
libraries/Win32/Win32.cabal: Dependency of ``ghc`` library
libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable
docs/users_guide/8.8.1-notes.rst
View file @ 4e228267
......@@ -212,6 +212,7 @@ for further change information.
libraries/libiserv/libiserv.cabal: Internal compiler library
libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library
libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library
libraries/pretty/pretty.cabal: Dependency of ``ghc`` library
libraries/process/process.cabal: Dependency of ``ghc`` library
libraries/stm/stm.cabal: Dependency of ``haskeline`` library
libraries/template-haskell/template-haskell.cabal: Core library
......
ghc/GHCi/UI.hs
View file @ 4e228267
......@@ -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
View file @ 4e228267
......@@ -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
View file @ 4e228267
......@@ -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
View file @ 4e228267
......@@ -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
View file @ 4e228267
......@@ -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
View file @ 4e228267
......@@ -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
View file @ 4e228267
......@@ -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 → 100644
View file @ 4e228267
module T16569 where
main :: IO ()
main = putStrLn (case (undefined :: Int) of _ -> undefined)
testsuite/tests/ghci/scripts/T16569.script 0 → 100644
View file @ 4e228267
:set +c
:l T16569.hs
::type-at T16569.hs 4 8 4 59
testsuite/tests/ghci/scripts/T16569.stdout 0 → 100644
View file @ 4e228267
Collecting type info for 1 module(s) ...
:: IO ()
testsuite/tests/ghci/scripts/all.T
View file @ 4e228267
......@@ -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'])