diff --git a/app/Commands/Base.hs b/app/Commands/Base.hs index 69ec57291f..5e6ebb96b8 100644 --- a/app/Commands/Base.hs +++ b/app/Commands/Base.hs @@ -8,7 +8,7 @@ module Commands.Base where import App -import CommonOptions +import CommonOptions hiding (ensureLn, writeFileEnsureLn) import GlobalOptions import Juvix.Compiler.Pipeline import Juvix.Prelude diff --git a/app/Commands/Compile.hs b/app/Commands/Compile.hs index 92fa1ebeb3..4ac419d4d4 100644 --- a/app/Commands/Compile.hs +++ b/app/Commands/Compile.hs @@ -35,5 +35,6 @@ writeCoreFile pa@Compile.PipelineArg {..} = do r <- runReader entryPoint . runError @JuvixError $ Core.toStored _pipelineArgModule case r of Left e -> exitJuvixError e - Right md -> - embed @IO (writeFile (toFilePath coreFile) (show $ Core.ppOutDefault (Core.disambiguateNames md ^. Core.moduleInfoTable))) + Right md -> do + let txt = show (Core.ppOutDefault (Core.disambiguateNames md ^. Core.moduleInfoTable)) + embed @IO $ writeFileEnsureLn coreFile txt diff --git a/app/Commands/Dev/Asm/Compile.hs b/app/Commands/Dev/Asm/Compile.hs index 79e701d7da..66f2b46402 100644 --- a/app/Commands/Dev/Asm/Compile.hs +++ b/app/Commands/Dev/Asm/Compile.hs @@ -31,7 +31,7 @@ runCommand opts = do let outputCell = Nockma.TermCell c outputText = Nockma.ppPrintOpts nockmaOpts outputCell outfile <- Compile.outputFile opts file - embed @IO (writeFileEnsureLn (toFilePath outfile) outputText) + embed @IO $ writeFileEnsureLn outfile outputText _ -> do case run $ runReader entryPoint $ runError $ asmToMiniC tab of Left err -> exitJuvixError err @@ -39,7 +39,7 @@ runCommand opts = do buildDir <- askBuildDir ensureDir buildDir cFile <- inputCFile file - embed @IO $ writeFileEnsureLn (toFilePath cFile) _resultCCode + embed @IO $ writeFileEnsureLn cFile _resultCCode outfile <- Compile.outputFile opts file Compile.runCommand opts diff --git a/app/Commands/Dev/Core/Compile/Base.hs b/app/Commands/Dev/Core/Compile/Base.hs index d330062644..4de135a7f5 100644 --- a/app/Commands/Dev/Core/Compile/Base.hs +++ b/app/Commands/Dev/Core/Compile/Base.hs @@ -56,7 +56,7 @@ runCPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa C.MiniCResult {..} <- getRight (run (runReader entryPoint (runError (coreToMiniC _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] C.MiniCResult)))) cFile <- inputCFile _pipelineArgFile - embed @IO (writeFile (toFilePath cFile) _resultCCode) + embed @IO $ writeFileEnsureLn cFile _resultCCode outfile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile Compile.runCommand _pipelineArgOptions @@ -87,7 +87,7 @@ runGebPipeline pa@PipelineArg {..} = do _lispPackageEntry = "*entry*" } Geb.Result {..} <- getRight (run (runReader entryPoint (runError (coreToGeb spec _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] Geb.Result)))) - embed @IO (writeFile (toFilePath gebFile) _resultCode) + embed @IO $ writeFileEnsureLn gebFile _resultCode runVampIRPipeline :: forall r. @@ -98,7 +98,7 @@ runVampIRPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa vampirFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile VampIR.Result {..} <- getRight (run (runReader entryPoint (runError (coreToVampIR _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] VampIR.Result)))) - embed @IO (writeFile (toFilePath vampirFile) _resultCode) + embed @IO $ writeFileEnsureLn vampirFile _resultCode runAsmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () runAsmPipeline pa@PipelineArg {..} = do @@ -111,7 +111,7 @@ runAsmPipeline pa@PipelineArg {..} = do $ _pipelineArgModule tab' <- getRight r let code = Asm.ppPrint tab' tab' - embed @IO (writeFile (toFilePath asmFile) code) + embed @IO $ writeFileEnsureLn asmFile code runTreePipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () runTreePipeline pa@PipelineArg {..} = do @@ -124,7 +124,7 @@ runTreePipeline pa@PipelineArg {..} = do $ _pipelineArgModule tab' <- getRight r let code = Tree.ppPrint tab' tab' - embed @IO (writeFile (toFilePath treeFile) code) + embed @IO $ writeFileEnsureLn treeFile code runNockmaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () runNockmaPipeline pa@PipelineArg {..} = do @@ -137,4 +137,4 @@ runNockmaPipeline pa@PipelineArg {..} = do $ _pipelineArgModule tab' <- getRight r let code = Nockma.ppSerialize tab' - embed @IO (writeFile (toFilePath nockmaFile) code) + embed @IO $ writeFileEnsureLn nockmaFile code diff --git a/app/Commands/Dev/Tree/Compile/Base.hs b/app/Commands/Dev/Tree/Compile/Base.hs index 3595673649..449c70991f 100644 --- a/app/Commands/Dev/Tree/Compile/Base.hs +++ b/app/Commands/Dev/Tree/Compile/Base.hs @@ -57,7 +57,7 @@ runCPipeline pa@PipelineArg {..} = do . runError @JuvixError $ treeToMiniC _pipelineArgTable cFile <- inputCFile _pipelineArgFile - embed @IO (writeFile (toFilePath cFile) _resultCCode) + embed @IO $ writeFileEnsureLn cFile _resultCCode outfile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile Compile.runCommand _pipelineArgOptions @@ -82,7 +82,7 @@ runAsmPipeline pa@PipelineArg {..} = do $ _pipelineArgTable tab' <- getRight r let code = Asm.ppPrint tab' tab' - embed @IO (writeFile (toFilePath asmFile) code) + embed @IO $ writeFileEnsureLn asmFile code runNockmaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () runNockmaPipeline pa@PipelineArg {..} = do @@ -95,4 +95,4 @@ runNockmaPipeline pa@PipelineArg {..} = do $ _pipelineArgTable tab' <- getRight r let code = Nockma.ppSerialize tab' - embed @IO (writeFile (toFilePath nockmaFile) code) + embed @IO $ writeFileEnsureLn nockmaFile code diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs index 6181544041..4f7be3a790 100644 --- a/app/Commands/Format.hs +++ b/app/Commands/Format.hs @@ -92,7 +92,7 @@ renderFormattedOutput target opts fInfo = do EditInPlace i@FormattedFileInfo {..} -> runTempFileIO . restoreFileOnError _formattedFileInfoPath - $ writeFile' _formattedFileInfoPath (i ^. formattedFileInfoContents) + $ writeFileEnsureLn' _formattedFileInfoPath (i ^. formattedFileInfoContents) NoEdit m -> case m of ReformattedFile ts -> renderStdOut ts InputPath p -> say (pack (toFilePath p)) diff --git a/src/Juvix/Compiler/Pipeline/Package.hs b/src/Juvix/Compiler/Pipeline/Package.hs index d6e6d5e69a..5a36f8edd1 100644 --- a/src/Juvix/Compiler/Pipeline/Package.hs +++ b/src/Juvix/Compiler/Pipeline/Package.hs @@ -138,7 +138,7 @@ writeGlobalPackage :: (Members '[Files] r) => Sem r () writeGlobalPackage = do packagePath <- globalPackageJuvix ensureDir' (parent packagePath) - writeFile' packagePath (renderPackageVersion currentPackageVersion (globalPackage packagePath)) + writeFileEnsureLn' packagePath (renderPackageVersion currentPackageVersion (globalPackage packagePath)) packageBasePackage :: Package packageBasePackage = diff --git a/src/Juvix/Data/Effect/Files/Base.hs b/src/Juvix/Data/Effect/Files/Base.hs index c262405b06..5f2d22a414 100644 --- a/src/Juvix/Data/Effect/Files/Base.hs +++ b/src/Juvix/Data/Effect/Files/Base.hs @@ -36,7 +36,7 @@ data Files m a where ReadFile' :: Path Abs File -> Files m Text ReadFileBS' :: Path Abs File -> Files m ByteString RemoveDirectoryRecursive' :: Path Abs Dir -> Files m () - WriteFile' :: Path Abs File -> Text -> Files m () + WriteFileEnsureLn' :: Path Abs File -> Text -> Files m () WriteFileBS :: Path Abs File -> ByteString -> Files m () RemoveFile' :: Path Abs File -> Files m () RenameFile' :: Path Abs File -> Path Abs File -> Files m () diff --git a/src/Juvix/Data/Effect/Files/IO.hs b/src/Juvix/Data/Effect/Files/IO.hs index bf6a23bd7d..5c967dda28 100644 --- a/src/Juvix/Data/Effect/Files/IO.hs +++ b/src/Juvix/Data/Effect/Files/IO.hs @@ -32,7 +32,7 @@ runFilesIO = interpret helper helper' = \case ReadFile' f -> readFile (toFilePath f) WriteFileBS p bs -> ByteString.writeFile (toFilePath p) bs - WriteFile' f txt -> writeFile (toFilePath f) txt + WriteFileEnsureLn' f txt -> writeFileEnsureLn f txt EnsureDir' p -> Path.ensureDir p DirectoryExists' p -> Path.doesDirExist p ReadFileBS' f -> ByteString.readFile (toFilePath f) diff --git a/src/Juvix/Data/Effect/Files/Pure.hs b/src/Juvix/Data/Effect/Files/Pure.hs index dbc12df6ce..2007e116ba 100644 --- a/src/Juvix/Data/Effect/Files/Pure.hs +++ b/src/Juvix/Data/Effect/Files/Pure.hs @@ -74,7 +74,7 @@ re cwd = reinterpret $ \case ReadFileBS' f -> encodeUtf8 <$> lookupFile' f EnsureDir' p -> ensureDirHelper p DirectoryExists' p -> isJust <$> lookupDir p - WriteFile' p t -> writeFileHelper p t + WriteFileEnsureLn' p t -> writeFileHelper p t WriteFileBS p t -> writeFileHelper p (decodeUtf8 t) RemoveDirectoryRecursive' p -> removeDirRecurHelper p ListDirRel p -> do @@ -163,7 +163,7 @@ writeFileHelper p contents = do (r, dirs, f) = destructAbsFile p go :: [Path Rel Dir] -> FSNode -> FSNode go = \case - [] -> set (dirFiles . at f) (Just contents) + [] -> set (dirFiles . at f) (Just (ensureLn contents)) (d : ds) -> over dirDirs (HashMap.alter (Just . helper) d) where helper :: Maybe FSNode -> FSNode diff --git a/src/Juvix/Extra/Files.hs b/src/Juvix/Extra/Files.hs index 8e1c81b84d..78d6a05edc 100644 --- a/src/Juvix/Extra/Files.hs +++ b/src/Juvix/Extra/Files.hs @@ -42,7 +42,7 @@ writeVersion :: forall r. (Members '[Reader OutputRoot, Files] r) => Sem r () writeVersion = do vf <- versionFile ensureDir' (parent vf) - writeFile' vf versionTag + writeFileEnsureLn' vf versionTag readVersion :: (Members '[Reader OutputRoot, Files] r) => Sem r (Maybe Text) readVersion = do diff --git a/src/Juvix/Prelude/Base.hs b/src/Juvix/Prelude/Base.hs index f62ef1f90e..79881ce5a9 100644 --- a/src/Juvix/Prelude/Base.hs +++ b/src/Juvix/Prelude/Base.hs @@ -150,7 +150,8 @@ import Data.Text qualified as Text import Data.Text.Encoding import Data.Text.IO hiding (appendFile, putStr, putStrLn, readFile, writeFile) import Data.Text.IO qualified as Text -import Data.Text.IO.Utf8 +import Data.Text.IO.Utf8 hiding (writeFile) +import Data.Text.IO.Utf8 qualified as Utf8 import Data.Traversable import Data.Tuple.Extra hiding (both) import Data.Type.Equality (type (~)) @@ -589,11 +590,14 @@ runInputInfinite s = return i ) -writeFileEnsureLn :: (MonadMask m, MonadIO m) => FilePath -> Text -> m () -writeFileEnsureLn p t = - let t' = case Text.unsnoc t of - Nothing -> t - Just (_, y) -> case y of - '\n' -> t - _ -> Text.snoc t '\n' - in writeFile p t' +ensureLn :: Text -> Text +ensureLn t = + case Text.unsnoc t of + Nothing -> t + Just (_, y) -> case y of + '\n' -> t + _ -> Text.snoc t '\n' + +writeFileEnsureLn :: (MonadMask m, MonadIO m) => Path Abs File -> Text -> m () +writeFileEnsureLn p = Utf8.writeFile (toFilePath p) +{-# INLINE writeFileEnsureLn #-} diff --git a/src/Juvix/Prelude/Trace.hs b/src/Juvix/Prelude/Trace.hs index a36ef87b99..6ec80c8799 100644 --- a/src/Juvix/Prelude/Trace.hs +++ b/src/Juvix/Prelude/Trace.hs @@ -9,6 +9,7 @@ import Debug.Trace hiding (trace, traceM, traceShow) import Debug.Trace qualified as T import GHC.IO (unsafePerformIO) import Juvix.Prelude.Base +import Juvix.Prelude.Path setDebugMsg :: Text -> Text setDebugMsg msg = "[debug] " <> fmsg <> "\n" @@ -33,19 +34,15 @@ traceShow :: (Show b) => b -> b traceShow b = traceLabel "" (pack . show $ b) b {-# WARNING traceShow "Using traceShow" #-} -traceToFile :: FilePath -> Text -> a -> a +traceToFile :: Path Abs File -> Text -> a -> a traceToFile fpath t a = - traceLabel (pack ("[" <> fpath <> "]")) t $ + traceLabel (pack ("[" <> toFilePath fpath <> "]")) t $ unsafePerformIO $ do - writeFile fpath t + writeFileEnsureLn fpath t return a {-# WARNING traceToFile "Using traceToFile" #-} -traceToFile' :: Text -> a -> a -traceToFile' = traceToFile "./juvix.log" -{-# WARNING traceToFile' "Using traceToFile'" #-} - -traceToFileM :: (Applicative m) => FilePath -> Text -> a -> m () +traceToFileM :: (Applicative m) => Path Abs File -> Text -> a -> m () traceToFileM fpath t a = pure (traceToFile fpath t a) $> () {-# WARNING traceToFileM "Using traceFileM" #-} diff --git a/test/Asm/Compile/Base.hs b/test/Asm/Compile/Base.hs index 3f66edb30a..88d5caa15d 100644 --- a/test/Asm/Compile/Base.hs +++ b/test/Asm/Compile/Base.hs @@ -21,7 +21,7 @@ asmCompileAssertion' optLevel tab mainFile expectedFile stdinText step = do withTempDir' ( \dirPath -> do let cFile = dirPath replaceExtension' ".c" (filename mainFile) - writeFile (toFilePath cFile) _resultCCode + writeFileEnsureLn cFile _resultCCode Runtime.clangAssertion optLevel cFile expectedFile stdinText step ) where diff --git a/test/Core/Compile/Base.hs b/test/Core/Compile/Base.hs index 70b00226f4..dcfd30267e 100644 --- a/test/Core/Compile/Base.hs +++ b/test/Core/Compile/Base.hs @@ -48,12 +48,12 @@ coreCompileAssertion' :: Assertion coreCompileAssertion' optLevel tab mainFile expectedFile stdinText step = do step "Translate to JuvixAsm" - case run $ runReader opts $ runError $ toStored' (moduleFromInfoTable tab) >>= toStripped' of + case run . runReader opts . runError $ toStored' (moduleFromInfoTable tab) >>= toStripped' of Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err))) Right m -> do let tab0 = computeCombinedInfoTable m assertBool "Check info table" (checkInfoTable tab0) - let tab' = Asm.fromTree $ Tree.fromCore $ Stripped.fromCore tab0 + let tab' = Asm.fromTree . Tree.fromCore $ Stripped.fromCore tab0 length (fromText (Asm.ppPrint tab' tab') :: String) `seq` Asm.asmCompileAssertion' optLevel tab' mainFile expectedFile stdinText step where diff --git a/test/VampIR/Core/Base.hs b/test/VampIR/Core/Base.hs index d3ce029ce0..303890c7d4 100644 --- a/test/VampIR/Core/Base.hs +++ b/test/VampIR/Core/Base.hs @@ -25,7 +25,7 @@ vampirAssertion' backend tab dataFile step = do case run (runReader defaultCoreOptions (runError @JuvixError (coreToVampIR' (moduleFromInfoTable tab)))) of Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err))) Right VampIR.Result {..} -> do - writeFile (toFilePath vampirFile) _resultCode + writeFileEnsureLn vampirFile _resultCode step "Check vamp-ir on path" assertCmdExists $(mkRelFile "vamp-ir")