Skip to content

Commit 7f03cad

Browse files
snoybergsnoyberg
committed
Use CallStack for Stack.PrettyPrint commercialhaskell#3373 
1 parent b23794a commit 7f03cad

12 files changed

Lines changed: 88 additions & 75 deletions

File tree

‎src/Stack/Build/ConstructPlan.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -216,7 +216,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage
216216
else do
217217
planDebug $ show errs
218218
stackYaml <- view stackYamlL
219-
$prettyError $ pprintExceptions errs stackYaml parents (wantedLocalPackages locals)
219+
prettyError $ pprintExceptions errs stackYaml parents (wantedLocalPackages locals)
220220
throwM $ ConstructPlanFailed "Plan construction failed."
221221
where
222222
ctx econfig getVersions0 lp = Ctx

‎src/Stack/Build/Execute.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -970,7 +970,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
970970
warnCustomNoDeps =
971971
case (taskType, packageBuildType package) of
972972
(TTFiles lp Local, Just C.Custom) | lpWanted lp -> do
973-
$prettyWarnL $
973+
prettyWarnL $
974974
[ flow "Package"
975975
, display $ packageName package
976976
, flow "uses a custom Cabal build, but does not use a custom-setup stanza"
@@ -990,7 +990,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
990990
case mdeps of
991991
Just x -> return x
992992
Nothing -> do
993-
$prettyWarnS "In getPackageArgs: custom-setup in use, but no dependency map present"
993+
prettyWarnS "In getPackageArgs: custom-setup in use, but no dependency map present"
994994
return Map.empty
995995
matchedDeps <- forM (Map.toList customSetupDeps) $ \(name, range) -> do
996996
let matches (PackageIdentifier name' version) =
@@ -1362,7 +1362,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
13621362
":" <> line <>
13631363
indent 4 (mconcat $ intersperse line $ map (styleGood . fromString . C.display) modules)
13641364
forM_ mlocalWarnings $ \(cabalfp, warnings) -> do
1365-
unless (null warnings) $ $prettyWarn $
1365+
unless (null warnings) $ prettyWarn $
13661366
"The following modules should be added to exposed-modules or other-modules in" <+>
13671367
display cabalfp <> ":" <> line <>
13681368
indent 4 (mconcat $ map showModuleWarning warnings) <>

‎src/Stack/Build/Haddock.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,7 @@ openHaddocksInBrowser bco pkgLocations buildTargets = do
8282
", but that file is missing. Opening doc index instead."
8383
getDocIndex
8484
_ -> getDocIndex
85-
$prettyInfo $ "Opening" <+> display docFile <+> "in the browser."
85+
prettyInfo $ "Opening" <+> display docFile <+> "in the browser."
8686
_ <- liftIO $ openBrowser (toFilePath docFile)
8787
return ()
8888

‎src/Stack/Coverage.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -265,7 +265,7 @@ generateHpcReportForTargets opts = do
265265
forM_ mreportPath $ \reportPath ->
266266
if hroptsOpenBrowser opts
267267
then do
268-
$prettyInfo $ "Opening" <+> display reportPath <+> "in the browser."
268+
prettyInfo $ "Opening" <+> display reportPath <+> "in the browser."
269269
void $ liftIO $ openBrowser (toFilePath reportPath)
270270
else displayReportPath report reportPath
271271

@@ -442,7 +442,7 @@ findPackageFieldForBuiltPackage pkgDir pkgId field = do
442442
displayReportPath :: (HasAnsiAnn (Ann a), Display a, HasRunner env)
443443
=> Text -> a -> RIO env ()
444444
displayReportPath report reportPath =
445-
$prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> display reportPath
445+
prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> display reportPath
446446

447447
findExtraTixFiles :: HasEnvConfig env => RIO env [Path Abs File]
448448
findExtraTixFiles = do

‎src/Stack/Ghci.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -198,18 +198,18 @@ findFileTargets locals fileTargets = do
198198
results <- forM foundFileTargetComponents $ \(fp, xs) ->
199199
case xs of
200200
[] -> do
201-
$prettyWarn $
201+
prettyWarn $
202202
"Couldn't find a component for file target" <+>
203203
display fp <>
204204
". Attempting to load anyway."
205205
return $ Left fp
206206
[x] -> do
207-
$prettyInfo $
207+
prettyInfo $
208208
"Using configuration for" <+> display x <+>
209209
"to load" <+> display fp
210210
return $ Right (fp, x)
211211
(x:_) -> do
212-
$prettyWarn $
212+
prettyWarn $
213213
"Multiple components contain file target" <+>
214214
display fp <> ":" <+>
215215
mconcat (intersperse ", " (map display xs)) <> line <>
@@ -283,8 +283,8 @@ buildDepsAndInitialSteps GhciOpts{..} targets0 = do
283283
case eres of
284284
Right () -> return ()
285285
Left err -> do
286-
$prettyError $ fromString (show err)
287-
$prettyWarn "Build failed, but optimistically launching GHCi anyway"
286+
prettyError $ fromString (show err)
287+
prettyWarn "Build failed, but optimistically launching GHCi anyway"
288288

289289
checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName]
290290
checkAdditionalPackages pkgs = forM pkgs $ \name -> do

‎src/Stack/Image.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -93,7 +93,7 @@ stageExesInDir opts dir = do
9393
case mcontents of
9494
Just (files, dirs)
9595
| not (null files) || not (null dirs) -> liftIO $ copyDirRecur srcBinPath destBinPath
96-
_ -> $prettyWarn "The project's local bin dir contains no files, so no executables will be added to the docker image."
96+
_ -> prettyWarn "The project's local bin dir contains no files, so no executables will be added to the docker image."
9797
logInfo ""
9898

9999
Just exes ->

‎src/Stack/Package.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -264,7 +264,7 @@ packageFromPackageDescription packageConfig pkgFlags pkg =
264264
-- constitute the package. This is primarily used for dirtiness
265265
-- checking during build, as well as use by "stack ghci"
266266
pkgFiles = GetPackageFiles $
267-
\cabalfp -> $debugBracket ("getPackageFiles" <+> display cabalfp) $ do
267+
\cabalfp -> debugBracket ("getPackageFiles" <+> display cabalfp) $ do
268268
let pkgDir = parent cabalfp
269269
distDir <- distDirFromDir pkgDir
270270
(componentModules,componentFiles,dataFiles',warnings) <-

‎src/Stack/Prelude.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,7 @@ import Data.Vector as X (Vector)
8585
import Data.Void as X (Void, absurd)
8686
import Data.Word as X
8787
import GHC.Generics as X (Generic)
88+
import GHC.Stack as X (HasCallStack)
8889
import Lens.Micro as X (Getting)
8990
import Lens.Micro.Mtl as X (view)
9091
import Path as X (Abs, Dir, File, Path, Rel,

‎src/Stack/PrettyPrint.hs‎

Lines changed: 66 additions & 54 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,6 @@
11
{-# LANGUAGE NoImplicitPrelude #-}
22
{-# OPTIONS_GHC -fno-warn-orphans #-}
33
{-# LANGUAGE FlexibleContexts #-}
4-
{-# LANGUAGE TemplateHaskell #-}
54
{-# LANGUAGE FlexibleInstances #-}
65
{-# LANGUAGE OverloadedStrings #-}
76

@@ -12,7 +11,7 @@ module Stack.PrettyPrint
1211
-- * Logging based on pretty-print typeclass
1312
, prettyDebug, prettyInfo, prettyWarn, prettyError
1413
, prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL
15-
, prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS
14+
, prettyWarnS, prettyErrorS
1615
-- * Semantic styling functions
1716
-- | These are preferred to styling or colors directly, so that we can
1817
-- encourage consistency.
@@ -37,7 +36,6 @@ module Stack.PrettyPrint
3736
import Stack.Prelude
3837
import Data.List (intersperse)
3938
import qualified Data.Text as T
40-
import Language.Haskell.TH
4139
import Stack.Types.Config
4240
import Stack.Types.Package
4341
import Stack.Types.PackageIdentifier
@@ -48,48 +46,65 @@ import qualified System.Clock as Clock
4846
import Text.PrettyPrint.Leijen.Extended
4947

5048
displayWithColor
51-
:: (HasRunner env, MonadReader env m, Display a, HasAnsiAnn (Ann a))
52-
=> a -> m T.Text
49+
:: (HasRunner env, Display a, HasAnsiAnn (Ann a))
50+
=> a -> RIO env T.Text
5351
displayWithColor x = do
5452
useAnsi <- liftM logUseColor $ view logOptionsL
5553
return $ if useAnsi then displayAnsi x else displayPlain x
5654

5755
-- TODO: switch to using implicit callstacks once 7.8 support is dropped
5856

59-
prettyWith :: LogLevel -> ExpQ -> Q Exp
60-
prettyWith level f = do
61-
loc <- location
62-
[e| monadLoggerLog loc "" level <=< displayWithColor . $f |]
57+
prettyWith :: (HasRunner env, HasCallStack, Display b, HasAnsiAnn (Ann b))
58+
=> LogLevel -> (a -> b) -> a -> RIO env ()
59+
prettyWith level f = logOther level <=< displayWithColor . f
6360

6461
-- Note: I think keeping this section aligned helps spot errors, might be
6562
-- worth keeping the alignment in place.
66-
prettyDebugWith, prettyInfoWith, prettyWarnWith, prettyErrorWith :: ExpQ -> Q Exp
67-
prettyDebugWith = prettyWith LevelDebug
68-
prettyInfoWith = prettyWith LevelInfo
69-
prettyWarnWith f = prettyWith LevelWarn
70-
[| (line <>) . (styleWarning "Warning:" <+>) .
71-
indentAfterLabel . $f |]
63+
prettyDebugWith, prettyInfoWith
64+
:: (HasCallStack, HasRunner env, Display b, HasAnsiAnn (Ann b))
65+
=> (a -> b) -> a -> RIO env ()
66+
prettyDebugWith = prettyWith LevelDebug
67+
prettyInfoWith = prettyWith LevelInfo
68+
69+
prettyWarnWith, prettyErrorWith
70+
:: (HasCallStack, HasRunner env)
71+
=> (a -> Doc AnsiAnn) -> a -> RIO env ()
72+
prettyWarnWith f = prettyWith LevelWarn
73+
((line <>) . (styleWarning "Warning:" <+>) .
74+
indentAfterLabel . f)
7275
prettyErrorWith f = prettyWith LevelError
73-
[| (line <>) . (styleError "Error:" <+>) .
74-
indentAfterLabel . $f |]
75-
76-
prettyDebug, prettyInfo, prettyWarn, prettyError :: Q Exp
77-
prettyDebug = prettyDebugWith [| id |]
78-
prettyInfo = prettyInfoWith [| id |]
79-
prettyWarn = prettyWarnWith [| id |]
80-
prettyError = prettyErrorWith [| id |]
81-
82-
prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL :: Q Exp
83-
prettyDebugL = prettyDebugWith [| fillSep |]
84-
prettyInfoL = prettyInfoWith [| fillSep |]
85-
prettyWarnL = prettyWarnWith [| fillSep |]
86-
prettyErrorL = prettyErrorWith [| fillSep |]
87-
88-
prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS :: Q Exp
89-
prettyDebugS = prettyDebugWith [| flow |]
90-
prettyInfoS = prettyInfoWith [| flow |]
91-
prettyWarnS = prettyWarnWith [| flow |]
92-
prettyErrorS = prettyErrorWith [| flow |]
76+
((line <>) . (styleError "Error:" <+>) .
77+
indentAfterLabel . f)
78+
79+
prettyDebug, prettyInfo
80+
:: (HasCallStack, HasRunner env, Display b, HasAnsiAnn (Ann b))
81+
=> b -> RIO env ()
82+
prettyDebug = prettyDebugWith id
83+
prettyInfo = prettyInfoWith id
84+
85+
prettyWarn, prettyError
86+
:: (HasCallStack, HasRunner env)
87+
=> Doc AnsiAnn -> RIO env ()
88+
prettyWarn = prettyWarnWith id
89+
prettyError = prettyErrorWith id
90+
91+
prettyDebugL, prettyInfoL
92+
:: (HasCallStack, HasRunner env, HasAnsiAnn a)
93+
=> [Doc a] -> RIO env ()
94+
prettyDebugL = prettyDebugWith fillSep
95+
prettyInfoL = prettyInfoWith fillSep
96+
97+
prettyWarnL, prettyErrorL
98+
:: (HasCallStack, HasRunner env)
99+
=> [Doc AnsiAnn] -> RIO env ()
100+
prettyWarnL = prettyWarnWith fillSep
101+
prettyErrorL = prettyErrorWith fillSep
102+
103+
prettyWarnS, prettyErrorS
104+
:: (HasCallStack, HasRunner env)
105+
=> String -> RIO env ()
106+
prettyWarnS = prettyWarnWith flow
107+
prettyErrorS = prettyErrorWith flow
93108
-- End of aligned section
94109

95110
-- | Use after a label and before the rest of what's being labelled for
@@ -107,25 +122,22 @@ wordDocs = map fromString . words
107122
flow :: String -> Doc a
108123
flow = fillSep . wordDocs
109124

110-
debugBracket :: Q Exp
111-
debugBracket = do
112-
loc <- location
113-
[e| \msg f -> do
114-
let output = monadLoggerLog loc "" LevelDebug <=< displayWithColor
115-
output $ "Start: " <> msg
116-
start <- liftIO $ Clock.getTime Clock.Monotonic
117-
x <- f `catch` \ex -> do
118-
end <- liftIO $ Clock.getTime Clock.Monotonic
119-
let diff = Clock.diffTimeSpec start end
120-
output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+>
121-
msg <> line <>
122-
"Exception thrown: " <> fromString (show ex)
123-
throwIO (ex :: SomeException)
124-
end <- liftIO $ Clock.getTime Clock.Monotonic
125-
let diff = Clock.diffTimeSpec start end
126-
output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg
127-
return x
128-
|]
125+
debugBracket :: (HasCallStack, HasRunner env) => Doc AnsiAnn -> RIO env a -> RIO env a
126+
debugBracket msg f = do
127+
let output = logDebug <=< displayWithColor
128+
output $ "Start: " <> msg
129+
start <- liftIO $ Clock.getTime Clock.Monotonic
130+
x <- f `catch` \ex -> do
131+
end <- liftIO $ Clock.getTime Clock.Monotonic
132+
let diff = Clock.diffTimeSpec start end
133+
output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+>
134+
msg <> line <>
135+
"Exception thrown: " <> fromString (show ex)
136+
throwIO (ex :: SomeException)
137+
end <- liftIO $ Clock.getTime Clock.Monotonic
138+
let diff = Clock.diffTimeSpec start end
139+
output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg
140+
return x
129141

130142
-- | Style an 'AnsiDoc' as an error. Should be used sparingly, not to style
131143
-- entire long messages. For example, it's used to style the "Error:"

‎src/Stack/Setup.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1023,7 +1023,7 @@ installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir =
10231023
Right _ -> return ()
10241024
Left ex -> do
10251025
logError (T.pack (show (ex :: ReadProcessException)))
1026-
$prettyError $
1026+
prettyError $
10271027
hang 2
10281028
("Error encountered while" <+> step <+> "GHC with" <> line <>
10291029
styleShell (fromString (unwords (cmd : args))) <> line <>

0 commit comments

Comments
 (0)