[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Correct off by one error in ghci +c
Marge Bot
gitlab at gitlab.haskell.org
Mon Apr 22 14:01:22 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
636c778e by Matthew Pickering at 2019-04-22T14:01:15Z
Correct off by one error in ghci +c
Fixes #16569
- - - - -
726aee19 by Alp Mestanogullari at 2019-04-22T14:01:17Z
Hadrian: use the testsuite driver's config.haddock arg more correctly
4 haddock tests assume that .haddock files have been produced, by using the
'req_haddock' modifier. The testsuite driver assumes that this condition is
satisfied if 'config.haddock' is non-empty, but before this patch Hadrian was
always passing the path to where the haddock executable should be, regardless
of whether it is actually there or not.
Instead, we now pass an empty config.haddock when we can't find all of
<build root>/docs/html/libraries/<pkg>/<pkg>.haddock>, where <pkg> ranges over
array, base, ghc-prim, process and template-haskell, and pass the path
to haddock when all those file exists. This has the (desired) effect of skipping
the 4 tests (marked as 'missing library') when the docs haven't been built,
and running the haddock tests when they have.
- - - - -
56501590 by Vladislav Zavialov at 2019-04-22T14:01:18Z
Stop misusing EWildPat in pattern match coverage checking
EWildPat is a constructor of HsExpr used in the parser to represent
wildcards in ambiguous positions:
* in expression context, EWildPat is turned into hsHoleExpr (see rnExpr)
* in pattern context, EWildPat is turned into WildPat (see checkPattern)
Since EWildPat exists solely for the needs of the parser, we could
remove it by improving the parser.
However, EWildPat has also been used for a different purpose since
8a50610: to represent patterns that the coverage checker cannot handle.
Not only this is a misuse of EWildPat, it also stymies the removal of
EWildPat.
- - - - -
10 changed files:
- .gitlab-ci.yml
- compiler/deSugar/Check.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- hadrian/src/Settings/Builders/RunTest.hs
- + testsuite/tests/ghci/scripts/T16569.hs
- + testsuite/tests/ghci/scripts/T16569.script
- + testsuite/tests/ghci/scripts/T16569.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/ghci/should_run/T15369.stdout
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -144,6 +144,7 @@ lint-release-changelogs:
- ./boot
- ./configure $CONFIGURE_ARGS
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx binary-dist
+ - hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx test
- mv _build/bindist/ghc*.tar.xz ghc.tar.xz
cache:
key: hadrian
=====================================
compiler/deSugar/Check.hs
=====================================
@@ -157,7 +157,9 @@ data PmPat :: PatTy -> * where
PmNLit :: { pm_lit_id :: Id
, pm_lit_not :: [PmLit] } -> PmPat 'VA
PmGrd :: { pm_grd_pv :: PatVec
- , pm_grd_expr :: PmExpr } -> PmPat 'PAT
+ , pm_grd_expr :: PmExpr } -> PmPat 'PAT
+ -- | A fake guard pattern (True <- _) used to represent cases we cannot handle.
+ PmFake :: PmPat 'PAT
instance Outputable (PmPat a) where
ppr = pprPmPatDebug
@@ -928,24 +930,11 @@ truePattern :: Pattern
truePattern = nullaryConPattern (RealDataCon trueDataCon)
{-# INLINE truePattern #-}
--- | A fake guard pattern (True <- _) used to represent cases we cannot handle
-fake_pat :: Pattern
-fake_pat = PmGrd { pm_grd_pv = [truePattern]
- , pm_grd_expr = PmExprOther (EWildPat noExt) }
-{-# INLINE fake_pat #-}
-
--- | Check whether a guard pattern is generated by the checker (unhandled)
-isFakeGuard :: [Pattern] -> PmExpr -> Bool
-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
- | c == trueDataCon = True
- | otherwise = False
-isFakeGuard _pats _e = False
-
-- | Generate a `canFail` pattern vector of a specific type
mkCanFailPmPat :: Type -> DsM PatVec
mkCanFailPmPat ty = do
var <- mkPmVar ty
- return [var, fake_pat]
+ return [var, PmFake]
vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern
-- ADT constructor pattern => no existentials, no local constraints
@@ -1295,7 +1284,7 @@ translateGuards fam_insts guards = do
then pure all_guards
else do
kept <- filterM shouldKeep all_guards
- pure (fake_pat : kept)
+ pure (PmFake : kept)
-- | Check whether a pattern can fail to match
cantFailPattern :: Pattern -> DsM Bool
@@ -1377,7 +1366,7 @@ cases:
expressivity in our warnings.
Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*
- @fake_pat@: @True <- _ at . That is, we record that there is a possibility
+ @PmFake@: @True <- _ at . That is, we record that there is a possibility
of failure but we minimize it to a True/False. This generates a single
warning and much smaller uncovered sets.
@@ -1421,7 +1410,7 @@ in the pattern bind case). Hence, we safely drop them.
Additionally, top-level guard translation (performed by @translateGuards@)
replaces guards that cannot be reasoned about (like the ones we described in
-1-4) with a single @fake_pat@ to record the possibility of failure to match.
+1-4) with a single @PmFake@ to record the possibility of failure to match.
Note [Translate CoPats]
~~~~~~~~~~~~~~~~~~~~~~~
@@ -1457,6 +1446,7 @@ pmPatType (PmNLit { pm_lit_id = x }) = idType x
pmPatType (PmGrd { pm_grd_pv = pv })
= ASSERT(patVecArity pv == 1) (pmPatType p)
where Just p = find ((==1) . patternArity) pv
+pmPatType PmFake = pmPatType truePattern
-- | Information about a conlike that is relevant to coverage checking.
-- It is called an \"inhabitation candidate\" since it is a value which may
@@ -1679,7 +1669,7 @@ mkGuard pv e = do
let expr = hsExprToPmExpr e
tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr])
if | res -> pure (PmGrd pv expr)
- | PmExprOther {} <- expr -> pure fake_pat
+ | PmExprOther {} <- expr -> pure PmFake
| otherwise -> pure (PmGrd pv expr)
-- | Create a term equality of the form: `(False ~ (x ~ lit))`
@@ -1753,6 +1743,7 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
, pm_con_tvs = tvs, pm_con_dicts = dicts
, pm_con_args = coercePatVec args }]
coercePmPat (PmGrd {}) = [] -- drop the guards
+coercePmPat PmFake = [] -- drop the guards
-- | Check whether a 'ConLike' has the /single match/ property, i.e. whether
-- it is the only possible match in the given context. See also
@@ -1765,7 +1756,7 @@ singleMatchConstructor cl tys =
Note [Single match constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When translating pattern guards for consumption by the checker, we desugar
-every pattern guard that might fail ('cantFailPattern') to 'fake_pat'
+every pattern guard that might fail ('cantFailPattern') to 'PmFake'
(True <- _). Which patterns can't fail? Exactly those that only match on
'singleMatchConstructor's.
@@ -2023,13 +2014,15 @@ pmcheck [] guards vva@(ValVec [] _)
| otherwise = pmcheckGuardsI guards vva
-- Guard
-pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)
- -- short-circuit if the guard pattern is useless.
- -- we just have two possible outcomes: fail here or match and recurse
- -- none of the two contains any useful information about the failure
- -- though. So just have these two cases but do not do all the boilerplate
- | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva
- | otherwise = do
+pmcheck (PmFake : ps) guards vva =
+ -- short-circuit if the guard pattern is useless.
+ -- we just have two possible outcomes: fail here or match and recurse
+ -- none of the two contains any useful information about the failure
+ -- though. So just have these two cases but do not do all the boilerplate
+ forces . mkCons vva <$> pmcheckI ps guards vva
+pmcheck (p : ps) guards (ValVec vas delta)
+ | PmGrd { pm_grd_pv = pv, pm_grd_expr = e } <- p
+ = do
y <- liftD $ mkPmId (pmPatType p)
let tm_state = extendSubst y e (delta_tm_cs delta)
delta' = delta { delta_tm_cs = tm_state }
@@ -2182,6 +2175,7 @@ pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva
= pmcheckHdI p ps guards (PmVar x) vva
-- Impossible: handled by pmcheck
+pmcheckHd PmFake _ _ _ _ = panic "pmcheckHd: Fake"
pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"
{-
@@ -2742,6 +2736,7 @@ pprPmPatDebug (PmLit li) = text "PmLit" <+> ppr li
pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl
pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)
<+> ppr ge
+pprPmPatDebug PmFake = text "PmFake"
pprPatVec :: PatVec -> SDoc
pprPatVec ps = hang (text "Pattern:") 2
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -2146,7 +2146,9 @@ parseSpanArg s = do
let fs = mkFastString fp
span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)
- (mkRealSrcLoc fs el ec)
+ -- End column of RealSrcSpan is the column
+ -- after the end of the span.
+ (mkRealSrcLoc fs el (ec + 1))
return (span',trailer)
where
@@ -2192,7 +2194,9 @@ showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
sl = srcSpanStartLine spn
sc = srcSpanStartCol spn
el = srcSpanEndLine spn
- ec = srcSpanEndCol spn
+ -- The end column is the column after the end of the span see the
+ -- RealSrcSpan module
+ ec = let ec' = srcSpanEndCol spn in if ec' == 0 then 0 else ec' - 1
-----------------------------------------------------------------------------
-- | @:kind@ command
=====================================
ghc/GHCi/UI/Info.hs
=====================================
@@ -75,6 +75,9 @@ data SpanInfo = SpanInfo
-- locality, definition location, etc.
}
+instance Outputable SpanInfo where
+ ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i
+
-- | Test whether second span is contained in (or equal to) first span.
-- This is basically 'containsSpan' for 'SpanInfo'
containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -147,6 +147,7 @@ getTestArgs = do
bindir <- expr $ getBinaryDirectory (testCompiler args)
compiler <- expr $ getCompilerPath (testCompiler args)
globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
+ haveDocs <- areDocsPresent
let configFileArg= ["--config-file=" ++ (testConfigFile args)]
testOnlyArg = map ("--only=" ++) (testOnly args ++ testEnvTargets)
onlyPerfArg = if testOnlyPerf args
@@ -169,7 +170,9 @@ getTestArgs = do
wayArgs = map ("--way=" ++) (testWays args)
compilerArg = ["--config", "compiler=" ++ show (compiler)]
ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
- haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
+ haddockArg = if haveDocs
+ then [ "--config", "haddock=" ++ show (bindir -/- "haddock") ]
+ else [ "--config", "haddock=" ]
hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
inTreeArg = [ "-e", "config.in_tree_compiler=" ++
@@ -181,6 +184,17 @@ getTestArgs = do
++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
+ where areDocsPresent = expr $ do
+ root <- buildRoot
+ and <$> traverse doesFileExist (docFiles root)
+
+ docFiles root =
+ [ root -/- "docs" -/- "html" -/- "libraries" -/- p -/- (p ++ ".haddock")
+ -- list of packages from
+ -- utils/haddock/haddock-test/src/Test/Haddock/Config.hs
+ | p <- [ "array", "base", "ghc-prim", "process", "template-haskell" ]
+ ]
+
-- | Set speed for test
setTestSpeed :: TestSpeed -> String
setTestSpeed TestSlow = "0"
=====================================
testsuite/tests/ghci/scripts/T16569.hs
=====================================
@@ -0,0 +1,4 @@
+module T16569 where
+
+main :: IO ()
+main = putStrLn (case (undefined :: Int) of _ -> undefined)
=====================================
testsuite/tests/ghci/scripts/T16569.script
=====================================
@@ -0,0 +1,3 @@
+:set +c
+:l T16569.hs
+::type-at T16569.hs 4 8 4 59
=====================================
testsuite/tests/ghci/scripts/T16569.stdout
=====================================
@@ -0,0 +1,2 @@
+Collecting type info for 1 module(s) ...
+ :: IO ()
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -295,3 +295,4 @@ test('T16089', normal, ghci_script, ['T16089.script'])
test('T14828', normal, ghci_script, ['T14828.script'])
test('T16376', normal, ghci_script, ['T16376.script'])
test('T16527', normal, ghci_script, ['T16527.script'])
+test('T16569', normal, ghci_script, ['T16569.script'])
=====================================
testsuite/tests/ghci/should_run/T15369.stdout
=====================================
@@ -1,8 +1,8 @@
Collecting type info for 1 module(s) ...
-T15369.hs:(3,1)-(3,2): GHC.Types.Int
-T15369.hs:(3,5)-(3,6): GHC.Types.Int
-T15369.hs:(3,1)-(3,2): GHC.Types.Int
-T15369.hs:(3,5)-(3,6): GHC.Types.Int
+T15369.hs:(3,1)-(3,1): GHC.Types.Int
+T15369.hs:(3,5)-(3,5): GHC.Types.Int
+T15369.hs:(3,1)-(3,1): GHC.Types.Int
+T15369.hs:(3,5)-(3,5): GHC.Types.Int
Collecting type info for 1 module(s) ...
-T15369.hs:(3,1)-(3,2): GHC.Types.Double
-T15369.hs:(3,5)-(3,6): GHC.Types.Double
+T15369.hs:(3,1)-(3,1): GHC.Types.Double
+T15369.hs:(3,5)-(3,5): GHC.Types.Double
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/757b0f4749a9e72033cb3b78cb07e0056be5b3c5...5650159008f03837ce1991277062b973589bb474
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/757b0f4749a9e72033cb3b78cb07e0056be5b3c5...5650159008f03837ce1991277062b973589bb474
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190422/98580ad0/attachment-0001.html>
More information about the ghc-commits
mailing list