Skip to content
Commits on Source (11)
Hide whitespace changes
Inline Side-by-side
.gitlab-ci.yml
View file @ a80aa49c
......@@ -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
View file @ a80aa49c
......@@ -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/main/ErrUtils.hs
View file @ a80aa49c
......@@ -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
View file @ a80aa49c
......@@ -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 @ a80aa49c
......@@ -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 @ a80aa49c
......@@ -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
View file @ a80aa49c
......@@ -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
View file @ a80aa49c
......@@ -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 @ a80aa49c
......@@ -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 @ a80aa49c
......@@ -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 @ a80aa49c
......@@ -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 @ a80aa49c
......@@ -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 @ a80aa49c
......@@ -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 @ a80aa49c
......@@ -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 @ a80aa49c
module T16569 where
main :: IO ()
main = putStrLn (case (undefined :: Int) of _ -> undefined)
testsuite/tests/ghci/scripts/T16569.script 0 → 100644
View file @ a80aa49c
:set +c
:l T16569.hs
::type-at T16569.hs 4 8 4 59
testsuite/tests/ghci/scripts/T16569.stdout 0 → 100644
View file @ a80aa49c
Collecting type info for 1 module(s) ...
:: IO ()
testsuite/tests/ghci/scripts/all.T
View file @ a80aa49c
......@@ -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
View file @ a80aa49c
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