Skip to content

Commit b186607

Browse files
wclrwclr
committed
Cut off update: warnings, build reason, log file
1 parent 31aba1a commit b186607

File tree

13 files changed

+1088
-898
lines changed

13 files changed

+1088
-898
lines changed

‎src/Language/PureScript/AST/SourcePos.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -116,3 +116,6 @@ widenSourceSpan (SourceSpan n1 s1 e1) (SourceSpan n2 s2 e2) =
116116

117117
widenSourceAnn :: SourceAnn -> SourceAnn -> SourceAnn
118118
widenSourceAnn (s1, _) (s2, _) = (widenSourceSpan s1 s2, [])
119+
120+
replaceSpanName :: String -> SourceSpan -> SourceSpan
121+
replaceSpanName name (SourceSpan _ sps spe) = SourceSpan name sps spe

‎src/Language/PureScript/Docs/Collect.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -96,7 +96,7 @@ compileForDocs outputDir inputFiles = do
9696
foreigns <- P.inferForeignModules filePathMap
9797
let makeActions =
9898
(P.buildMakeActions outputDir filePathMap foreigns False)
99-
{ P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "documentation for "
99+
{ P.progress = liftIO . maybe (pure ()) (TIO.hPutStr stdout . (<> "\n")) . P.renderProgressMessage "documentation for "
100100
}
101101
P.make makeActions (map snd ms)
102102
either throwError return result

‎src/Language/PureScript/Ide/Rebuild.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,7 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
8080
-- Rebuild the single module using the cached externs
8181
(result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $
8282
liftIO $ P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) do
83-
newExterns <- P.rebuildModule makeEnv externs m
83+
newExterns <- P.rebuildModule makeEnv externs (pwarnings, m)
8484
unless pureRebuild
8585
$ updateCacheDb codegenTargets outputDirectory file actualFile moduleName
8686
pure newExterns
@@ -166,7 +166,7 @@ rebuildModuleOpen
166166
-> m ()
167167
rebuildModuleOpen makeEnv externs m = void $ runExceptT do
168168
(openResult, _) <- liftIO $ P.runMake P.defaultOptions $
169-
P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m)
169+
P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (mempty, openModuleExports m)
170170
case openResult of
171171
Left _ ->
172172
throwError (GeneralError "Failed when rebuilding with open exports")
@@ -183,7 +183,7 @@ shushProgress ma =
183183
-- | Stops any kind of codegen
184184
shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
185185
shushCodegen ma =
186-
ma { P.codegen = \_ _ _ -> pure ()
186+
ma { P.codegen = \_ _ _ _ -> pure ()
187187
, P.ffiCodegen = \_ -> pure ()
188188
}
189189

‎src/Language/PureScript/Interactive.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -60,7 +60,7 @@ rebuild
6060
-> P.Module
6161
-> P.Make (P.ExternsFile, P.Environment)
6262
rebuild loadedExterns m = do
63-
externs <- P.rebuildModule buildActions loadedExterns m
63+
externs <- P.rebuildModule buildActions loadedExterns (mempty, m)
6464
return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs]))
6565
where
6666
buildActions :: P.MakeActions P.Make

‎src/Language/PureScript/Make.hs‎

Lines changed: 147 additions & 137 deletions
Large diffs are not rendered by default.

‎src/Language/PureScript/Make/Actions.hs‎

Lines changed: 173 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,14 @@
11
module Language.PureScript.Make.Actions
22
( MakeActions(..)
33
, RebuildPolicy(..)
4+
, RebuildReason(..)
45
, ProgressMessage(..)
56
, renderProgressMessage
7+
, renderProgressVerboseMessage
8+
, printProgress
9+
, progressWithFile
610
, buildMakeActions
11+
, makeOutputFilename
712
, checkForeignDecls
813
, cacheDbFile
914
, readCacheDb'
@@ -13,7 +18,7 @@ module Language.PureScript.Make.Actions
1318

1419
import Prelude
1520

16-
import Control.Monad (guard, unless, when)
21+
import Control.Monad (guard, unless, void, when)
1722
import Control.Monad.Error.Class (MonadError(..))
1823
import Control.Monad.IO.Class (MonadIO(..))
1924
import Control.Monad.Reader (asks)
@@ -31,7 +36,8 @@ import Data.Set qualified as S
3136
import Data.Text qualified as T
3237
import Data.Text.IO qualified as TIO
3338
import Data.Text.Encoding qualified as TE
34-
import Data.Time.Clock (UTCTime)
39+
import Data.Time (formatTime, defaultTimeLocale)
40+
import Data.Time.Clock (UTCTime, NominalDiffTime)
3541
import Data.Version (showVersion)
3642
import Language.JavaScript.Parser qualified as JS
3743
import Language.PureScript.AST (SourcePos(..))
@@ -44,10 +50,11 @@ import Language.PureScript.Crash (internalError)
4450
import Language.PureScript.CST qualified as CST
4551
import Language.PureScript.Docs.Prim qualified as Docs.Prim
4652
import Language.PureScript.Docs.Types qualified as Docs
47-
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage')
53+
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', nonEmpty, ErrorMessage (..), onErrorMessages, replaceSpanName, runMultipleErrors)
4854
import Language.PureScript.Externs (ExternsFile, externsFileName)
49-
import Language.PureScript.Make.Monad (Make, copyFile, getCurrentTime, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, setTimestamp, writeCborFile, writeJSONFile, writeTextFile)
55+
import Language.PureScript.Make.Monad (Make, copyFile, getCurrentTime, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readWarningsFile, readJSONFile, readTextFile, setTimestamp, writeCborFile, writeJSONFile, writeTextFile, removeFileIfExists)
5056
import Language.PureScript.Make.Cache (CacheDb, ContentHash, cacheDbIsCurrentVersion, fromCacheDbVersioned, normaliseForCache, toCacheDbVersioned)
57+
import Language.PureScript.Make.ExternsDiff qualified as ED
5158
import Language.PureScript.Names (Ident(..), ModuleName, runModuleName)
5259
import Language.PureScript.Options (CodegenTarget(..), Options(..))
5360
import Language.PureScript.Pretty.Common (SMap(..))
@@ -57,47 +64,115 @@ import SourceMap.Types (Mapping(..), Pos(..), SourceMapping(..))
5764
import System.Directory (getCurrentDirectory)
5865
import System.FilePath ((</>), makeRelative, splitPath, normalise, splitDirectories)
5966
import System.FilePath.Posix qualified as Posix
60-
import System.IO (stderr)
67+
import System.IO (stderr, IOMode (..))
68+
import Language.PureScript.AST.Declarations (ErrorMessageHint(..))
69+
import Control.Concurrent.Lifted (newMVar, putMVar, takeMVar)
70+
import GHC.IO.StdHandles (withFile)
71+
import GHC.IO.Handle (hFlush)
72+
import Numeric (showFFloat)
6173

6274
-- | Determines when to rebuild a module
6375
data RebuildPolicy
6476
-- | Never rebuild this module
6577
= RebuildNever
6678
-- | Always rebuild this module
6779
| RebuildAlways
80+
deriving (Show, Ord, Eq)
81+
82+
-- | Specifies reason for module compilation while incremental build.
83+
data RebuildReason
84+
-- | Compiled because of RebuildAlways policy
85+
= RebuildAlwaysPolicy
86+
-- | Compiled because of no previously built result available
87+
| NoCached
88+
-- | Compiled because of no previously built result for one of dependencies is available.
89+
| NoCachedDependency
90+
-- | Compiled because the module has changed since its previous compilation.
91+
| CacheOutdated
92+
-- | Compiled because has later dependency (that previously has been built after the module).
93+
| LaterDependency ModuleName
94+
-- | Compiled because of (the first found) changed reference in a dependency.
95+
| UpstreamRef ED.DiffRef
6896
deriving (Show, Eq, Ord)
6997

7098
-- | Progress messages from the make process
7199
data ProgressMessage
72-
= CompilingModule ModuleName (Maybe (Int, Int))
100+
= CompilingModule ModuleName (Maybe (Int, Int)) RebuildReason
73101
-- ^ Compilation started for the specified module
74102
| SkippingModule ModuleName (Maybe (Int, Int))
75-
deriving (Show, Eq, Ord)
103+
| ModuleCompiled ModuleName (Maybe (Int, Int)) NominalDiffTime (Maybe ED.ExternsDiff) MultipleErrors
104+
| ModuleFailed ModuleName (Maybe (Int, Int)) MultipleErrors
105+
deriving (Show)
76106

77-
-- | Render a progress message
78-
renderProgressMessage :: T.Text -> ProgressMessage -> T.Text
79-
renderProgressMessage infx msg = case msg of
80-
CompilingModule mn mi ->
107+
renderProgressIndex :: Maybe (Int, Int) -> T.Text
108+
renderProgressIndex = maybe "" $ \(start, end) ->
109+
let start' = T.pack (show start)
110+
end' = T.pack (show end)
111+
preSpace = T.replicate (T.length end' - T.length start') " "
112+
in "[" <> preSpace <> start' <> " of " <> end' <> "] "
113+
114+
sSuffix :: Int -> T.Text
115+
sSuffix n = if n > 1 then "s" else ""
116+
117+
renderProgressVerboseMessage :: T.Text -> ProgressMessage -> T.Text
118+
renderProgressVerboseMessage infx msg = case msg of
119+
CompilingModule mn mi br ->
81120
T.concat
82121
[ renderProgressIndex mi
83122
, "Compiling "
84123
, infx
85124
, runModuleName mn
125+
, (flip (<>) ")" . (<>) " (rebuild reason: " . T.pack . show) br
86126
]
87127
SkippingModule mn mi ->
88128
T.concat
89-
[renderProgressIndex mi
129+
[ renderProgressIndex mi
90130
, "Skipping "
91131
, infx
92132
, runModuleName mn
93133
]
94-
where
95-
renderProgressIndex :: Maybe (Int, Int) -> T.Text
96-
renderProgressIndex = maybe "" $ \(start, end) ->
97-
let start' = T.pack (show start)
98-
end' = T.pack (show end)
99-
preSpace = T.replicate (T.length end' - T.length start') " "
100-
in "[" <> preSpace <> start' <> " of " <> end' <> "] "
134+
ModuleCompiled mn mi time extDiff warnings ->
135+
T.concat
136+
[ renderProgressIndex mi
137+
, "Compiled "
138+
, infx
139+
, runModuleName mn
140+
, " in " <> (T.pack . toMs) time <> " ms"
141+
, if nonEmpty warnings
142+
then
143+
" with "
144+
<> (T.pack . show) wLen
145+
<> " warning"
146+
<> sSuffix wLen
147+
else ""
148+
, maybe "" (flip (<>) ")" . (<>) " (changed refs: " . T.pack . show . ED.edRefs) extDiff
149+
]
150+
where
151+
wLen = length $ runMultipleErrors warnings
152+
toMs ndt = showFFloat (Just 3) (realToFrac ndt * 1000 :: Double) ""
153+
ModuleFailed mn mi errors ->
154+
T.concat
155+
[ renderProgressIndex mi
156+
, "Failed to compile "
157+
, infx
158+
, runModuleName mn
159+
, " with " <> (T.pack . show) eLen <> " error" <> sSuffix eLen
160+
]
161+
where
162+
eLen = length $ runMultipleErrors errors
163+
164+
-- | Render a progress message
165+
-- infix in used, i.g in docs generation.
166+
renderProgressMessage :: T.Text -> ProgressMessage -> Maybe T.Text
167+
renderProgressMessage infx msg = case msg of
168+
CompilingModule mn mi _ ->
169+
Just $ T.concat
170+
[ renderProgressIndex mi
171+
, "Compiling "
172+
, infx
173+
, runModuleName mn
174+
]
175+
_ -> Nothing
101176

102177
-- | Actions that require implementations when running in "make" mode.
103178
--
@@ -119,13 +194,17 @@ data MakeActions m = MakeActions
119194
-- externs file, or if any of the requested codegen targets were not produced
120195
-- the last time this module was compiled, this function must return Nothing;
121196
-- this indicates that the module will have to be recompiled.
122-
, updateOutputTimestamp :: ModuleName -> m Bool
197+
, updateOutputTimestamp :: ModuleName -> Maybe UTCTime -> m Bool
123198
-- ^ Updates the modification time of existing output files to mark them as
124199
-- actual.
125200
, readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile)
126201
-- ^ Read the externs file for a module as a string and also return the actual
127202
-- path for the file.
128-
, codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
203+
, readWarnings :: (ModuleName, FilePath) -> m (FilePath, Maybe MultipleErrors)
204+
-- ^ Read the file with cached warnings for a module and also return the
205+
-- actual path for the warnings file. It also requires module's filePath to place
206+
-- it in source spans to personalize warnings.
207+
, codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> MultipleErrors -> SupplyT m ()
129208
-- ^ Run the code generator for the module and write any required output files.
130209
, ffiCodegen :: CF.Module CF.Ann -> m ()
131210
-- ^ Check ffi and print it in the output directory.
@@ -149,6 +228,20 @@ data MakeActions m = MakeActions
149228
cacheDbFile :: FilePath -> FilePath
150229
cacheDbFile = (</> "cache-db.json")
151230

231+
warningsFileName :: FilePath
232+
warningsFileName = "warnings.cbor"
233+
234+
replaceSpanNameInErrors :: FilePath -> MultipleErrors -> MultipleErrors
235+
replaceSpanNameInErrors fp =
236+
onErrorMessages replace
237+
where
238+
replaceSpan = replaceSpanName fp
239+
replaceHint = \case
240+
PositionedError ss -> PositionedError (replaceSpan <$> ss)
241+
RelatedPositions ss -> RelatedPositions (replaceSpan <$> ss)
242+
h -> h
243+
replace (ErrorMessage hints e) = ErrorMessage (replaceHint <$> hints) e
244+
152245
readCacheDb'
153246
:: (MonadIO m, MonadError MultipleErrors m)
154247
=> FilePath
@@ -179,6 +272,42 @@ writePackageJson' outputDir = writeJSONFile (outputDir </> "package.json") $ obj
179272
[ "type" .= String "module"
180273
]
181274

275+
makeOutputFilename :: FilePath -> ModuleName -> String -> FilePath
276+
makeOutputFilename outputDir mn fn =
277+
let filePath = T.unpack (runModuleName mn)
278+
in outputDir </> filePath </> fn
279+
280+
printProgress :: ProgressMessage -> Make ()
281+
printProgress = liftIO . maybe (pure ()) (TIO.hPutStr stderr . (<> "\n")) . renderProgressMessage ""
282+
283+
toLogTime :: UTCTime -> T.Text
284+
toLogTime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S.%3q"
285+
286+
withLogTime :: UTCTime -> T.Text -> T.Text
287+
withLogTime time =
288+
(<>) (toLogTime time <> " - ")
289+
290+
progressWithFile :: FilePath -> Bool -> Make (ProgressMessage -> Make())
291+
progressWithFile logFilePath cleanFile = do
292+
lock <- newMVar ()
293+
let mode = if cleanFile then WriteMode else AppendMode
294+
curTime <- getCurrentTime
295+
let initMsg = "Starting new build"
296+
liftIO $ withFile logFilePath mode $ \handle ->
297+
TIO.hPutStrLn handle (withLogTime curTime initMsg)
298+
pure (logToFile lock)
299+
where
300+
-- TODO: what is better to use sync output vs hFlush handle?
301+
logToFile lock pm = void $ liftIO $ do
302+
takeMVar lock
303+
--msg <- getLogMessage pm
304+
curTime <- getCurrentTime
305+
let msg = withLogTime curTime (renderProgressVerboseMessage "" pm)
306+
liftIO $ withFile logFilePath AppendMode $ \handle -> do
307+
TIO.hPutStrLn handle msg
308+
hFlush handle
309+
putMVar lock ()
310+
182311
-- | A set of make actions that read and write modules from the given directory.
183312
buildMakeActions
184313
:: FilePath
@@ -196,6 +325,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
196325
getOutputTimestamp
197326
updateOutputTimestamp
198327
readExterns
328+
readWarnings
199329
codegen
200330
ffiCodegen
201331
progress
@@ -223,9 +353,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
223353
return $ Right $ M.fromList pathsWithInfo
224354

225355
outputFilename :: ModuleName -> String -> FilePath
226-
outputFilename mn fn =
227-
let filePath = T.unpack (runModuleName mn)
228-
in outputDir </> filePath </> fn
356+
outputFilename = makeOutputFilename outputDir
229357

230358
targetFilename :: ModuleName -> CodegenTarget -> FilePath
231359
targetFilename mn = \case
@@ -262,33 +390,44 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
262390
then Just externsTimestamp
263391
else Nothing
264392

265-
updateOutputTimestamp :: ModuleName -> Make Bool
266-
updateOutputTimestamp mn = do
267-
curTime <- getCurrentTime
393+
updateOutputTimestamp :: ModuleName -> Maybe UTCTime -> Make Bool
394+
updateOutputTimestamp mn mbTime = do
395+
curTime <- maybe getCurrentTime pure mbTime
268396
ok <- setTimestamp (outputFilename mn externsFileName) curTime
269-
-- Then update timestamps of all actual codegen targets.
397+
_ <- setTimestamp (outputFilename mn warningsFileName) curTime
398+
-- then update all actual codegen targets
270399
codegenTargets <- asks optionsCodegenTargets
271400
let outputPaths = fmap (targetFilename mn) (S.toList codegenTargets)
272401
results <- traverse (flip setTimestamp curTime) outputPaths
273-
-- If something goes wrong (any of targets doesn't exit, a file system
274-
-- error), return False.
402+
-- if something goes wrong, something failed to update, return Nothing
275403
pure $ and (ok : results)
276404

277405
readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile)
278406
readExterns mn = do
279407
let path = outputDir </> T.unpack (runModuleName mn) </> externsFileName
280408
(path, ) <$> readExternsFile path
281409

410+
readWarnings :: (ModuleName, FilePath) -> Make (FilePath, Maybe MultipleErrors)
411+
readWarnings (mn, fp) = do
412+
let path = outputDir </> T.unpack (runModuleName mn) </> warningsFileName
413+
(path, ) . fmap (replaceSpanNameInErrors fp) <$> readWarningsFile path
414+
282415
outputPrimDocs :: Make ()
283416
outputPrimDocs = do
284417
codegenTargets <- asks optionsCodegenTargets
285418
when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} ->
286419
writeJSONFile (outputFilename modName "docs.json") docsMod
287420

288-
codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
289-
codegen m docs exts = do
421+
codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> MultipleErrors -> SupplyT Make ()
422+
codegen m docs exts warnings = do
290423
let mn = CF.moduleName m
291424
lift $ writeCborFile (outputFilename mn externsFileName) exts
425+
let warningsFile = outputFilename mn warningsFileName
426+
lift $ if nonEmpty warnings then
427+
-- Remove spanName from the errors
428+
writeCborFile warningsFile (replaceSpanNameInErrors "" warnings)
429+
else
430+
removeFileIfExists warningsFile
292431
codegenTargets <- lift $ asks optionsCodegenTargets
293432
when (S.member CoreFn codegenTargets) $ do
294433
let coreFnFile = targetFilename mn CoreFn
@@ -354,7 +493,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
354493
requiresForeign = not . null . CF.moduleForeign
355494

356495
progress :: ProgressMessage -> Make ()
357-
progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage ""
496+
progress msg = do
497+
printProgress msg
358498

359499
readCacheDb :: Make CacheDb
360500
readCacheDb = readCacheDb' outputDir

0 commit comments

Comments
 (0)