Prettify logs more

default.nix

@@ -169,7 +169,7 @@ rec
 
       pushd $(mktemp -d)
       ${pkgs.termtosvg}/bin/termtosvg \
-          -g 82x26 -M 500 -m 500 -t window_frame \
+          -g 82x26 -M 500 -m 500 -t window_frame_js \
           -c '${niv-svg-cmds}' $site/niv.svg
 
       echo done rendering

package.yaml

@@ -32,6 +32,7 @@ dependencies:
     - mtl
     - optparse-applicative
     - process
+    - profunctors
     - string-qq
     - text
     - unliftio

script/gen

@@ -3,6 +3,7 @@
 #!nix-shell -I nixpkgs=./nix
 #!nix-shell -p nix
 #!nix-shell --keep SSL_CERT_FILE
+#!nix-shell --keep GITHUB_TOKEN
 #!nix-shell --pure
 
 set -euo pipefail

src/Niv/Cli.hs

@@ -65,7 +65,7 @@ getSources = do
 
     warnIfOutdated
     -- TODO: if doesn't exist: run niv init
-    putStrLn $ "Reading sources file"
+    say $ "Reading sources file"
     decodeFileStrict pathNixSourcesJson >>= \case
       Just (Aeson.Object obj) ->
         fmap (Sources . mconcat) $
@@ -167,7 +167,7 @@ parseCmdInit = Opts.info (pure cmdInit <**> Opts.helper) $ mconcat desc
 
 cmdInit :: IO ()
 cmdInit = do
-    job "initializing" $ do
+    job "Initializing" $ do
 
       -- Writes all the default files
       -- a path, a "create" function and an update function for each file.
@@ -177,17 +177,17 @@ cmdInit = do
           , \path content -> do
               if shouldUpdateNixSourcesNix content
               then do
-                putStrLn "Updating sources.nix"
+                say "Updating sources.nix"
                 B.writeFile path initNixSourcesNixContent
-              else putStrLn "Not updating sources.nix"
+              else say "Not updating sources.nix"
           )
         , ( pathNixSourcesJson
           , \path -> do
               createFile path initNixSourcesJsonContent
               -- Imports @niv@ and @nixpkgs@ (19.03)
-              putStrLn "Importing 'niv' ..."
+              say "Importing 'niv' ..."
               cmdAdd Nothing (PackageName "nmattia/niv", PackageSpec HMS.empty)
-              putStrLn "Importing 'nixpkgs' ..."
+              say "Importing 'nixpkgs' ..."
               cmdAdd
                 (Just (PackageName "nixpkgs"))
                 ( PackageName "NixOS/nixpkgs-channels"
@@ -201,10 +201,10 @@ cmdInit = do
     createFile path content = do
       let dir = takeDirectory path
       Dir.createDirectoryIfMissing True dir
-      putStrLn $ "Creating " <> path
+      say $ "Creating " <> path
       B.writeFile path content
     dontCreateFile :: FilePath -> IO ()
-    dontCreateFile path = putStrLn $ "Not creating " <> path
+    dontCreateFile path = say $ "Not creating " <> path
 
 -------------------------------------------------------------------------------
 -- ADD
@@ -234,36 +234,37 @@ parseCmdAdd =
       ]
 
 cmdAdd :: Maybe PackageName -> (PackageName, PackageSpec) -> IO ()
-cmdAdd mPackageName (PackageName str, cliSpec) = do
+cmdAdd mPackageName (PackageName str, cliSpec) =
+    job ("Adding package " <> T.unpack str)  $ do
 
-    -- Figures out the owner and repo
-    let (packageName, defaultSpec) = case T.span (/= '/') str of
-          ( owner@(T.null -> False)
-            , T.uncons -> Just ('/', repo@(T.null -> False))) -> do
-            (PackageName repo, HMS.fromList [ "owner" .= owner, "repo" .= repo ])
-          _ -> (PackageName str, HMS.empty)
+      -- Figures out the owner and repo
+      let (packageName, defaultSpec) = case T.span (/= '/') str of
+            ( owner@(T.null -> False)
+              , T.uncons -> Just ('/', repo@(T.null -> False))) -> do
+              (PackageName repo, HMS.fromList [ "owner" .= owner, "repo" .= repo ])
+            _ -> (PackageName str, HMS.empty)
 
-    sources <- unSources <$> getSources
+      sources <- unSources <$> getSources
 
-    let packageName' = fromMaybe packageName mPackageName
+      let packageName' = fromMaybe packageName mPackageName
 
-    when (HMS.member packageName' sources) $
-      abortCannotAddPackageExists packageName'
+      when (HMS.member packageName' sources) $
+        abortCannotAddPackageExists packageName'
 
-    let defaultSpec' = PackageSpec $ defaultSpec
+      let defaultSpec' = PackageSpec $ defaultSpec
 
-    let initialSpec = specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec'
+      let initialSpec = specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec'
 
-    eFinalSpec <- fmap attrsToSpec <$> tryEvalUpdate
-      initialSpec
-      (githubUpdate nixPrefetchURL githubLatestRev githubRepo)
+      eFinalSpec <- fmap attrsToSpec <$> tryEvalUpdate
+        initialSpec
+        (githubUpdate nixPrefetchURL githubLatestRev githubRepo)
 
-    case eFinalSpec of
-      Left e -> abortUpdateFailed [(packageName', e)]
-      Right finalSpec -> do
-        putStrLn $ "Writing new sources file"
-        setSources $ Sources $
-          HMS.insert packageName' finalSpec sources
+      case eFinalSpec of
+        Left e -> abortUpdateFailed [(packageName', e)]
+        Right finalSpec -> do
+          say $ "Writing new sources file"
+          setSources $ Sources $
+            HMS.insert packageName' finalSpec sources
 
 -------------------------------------------------------------------------------
 -- SHOW
@@ -279,7 +280,7 @@ parseCmdShow =
 cmdShow :: Maybe PackageName -> IO ()
 cmdShow = \case
     Just packageName -> do
-      putStrLn $ "Showing package " <> T.unpack (unPackageName packageName)
+      tsay $ "Showing package " <> unPackageName packageName
 
       sources <- unSources <$> getSources
 
@@ -289,21 +290,21 @@ cmdShow = \case
             let attrValue = case attrValValue of
                   Aeson.String str -> str
                   _ -> "<barabajagal>"
-            putStrLn $ "  " <> T.unpack attrName <> ": " <> T.unpack attrValue
+            tsay $ "  " <> attrName <> ": " <> attrValue
         Nothing -> abortCannotShowNoSuchPackage packageName
 
     Nothing -> do
-      putStrLn $ "Showing sources file"
+      say $ "Showing sources file"
 
       sources <- unSources <$> getSources
 
       forWithKeyM_ sources $ \key (PackageSpec spec) -> do
-        T.putStrLn $ "Package: " <> unPackageName key
+        tsay $ "Updating " <> tbold (unPackageName key)
         forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do
           let attrValue = case attrValValue of
                 Aeson.String str -> str
-                _ -> "<barabajagal>"
-          putStrLn $ "  " <> T.unpack attrName <> ": " <> T.unpack attrValue
+                _ -> tfaint "<barabajagal>"
+          tsay $ "  " <> attrName <> ": " <> attrValue
 
 -------------------------------------------------------------------------------
 -- UPDATE
@@ -358,7 +359,7 @@ cmdUpdate = \case
 
       esources' <- forWithKeyM sources $
         \packageName defaultSpec -> do
-          T.putStrLn $ "Package: " <> unPackageName packageName
+          tsay $ "Package: " <> unPackageName packageName
           let initialSpec = specToFreeAttrs defaultSpec
           finalSpec <- fmap attrsToSpec <$> tryEvalUpdate
             initialSpec
@@ -402,7 +403,7 @@ parseCmdModify =
 
 cmdModify :: (PackageName, PackageSpec) -> IO ()
 cmdModify (packageName, cliSpec) = do
-    T.putStrLn $ "Modifying package: " <> unPackageName packageName
+    tsay $ "Modifying package: " <> unPackageName packageName
     sources <- unSources <$> getSources
 
     finalSpec <- case HMS.lookup packageName sources of
@@ -438,7 +439,7 @@ parseCmdDrop =
 cmdDrop :: PackageName -> [T.Text] -> IO ()
 cmdDrop packageName = \case
     [] -> do
-      T.putStrLn $ "Dropping package: " <> unPackageName packageName
+      tsay $ "Dropping package: " <> unPackageName packageName
       sources <- unSources <$> getSources
 
       when (not $ HMS.member packageName sources) $
@@ -447,9 +448,8 @@ cmdDrop packageName = \case
       setSources $ Sources $
         HMS.delete packageName sources
     attrs -> do
-      putStrLn $ "Dropping attributes :" <>
-        (T.unpack (T.intercalate " " attrs))
-      T.putStrLn $ "In package: " <> unPackageName packageName
+      tsay $ "Dropping attributes :" <> T.intercalate " " attrs
+      tsay $ "In package: " <> unPackageName packageName
       sources <- unSources <$> getSources
 
       packageSpec <- case HMS.lookup packageName sources of

src/Niv/Logger.hs

@@ -5,36 +5,66 @@
 
 module Niv.Logger where
 
-import qualified System.Console.ANSI as ANSI
-import Data.String (IsString)
+import Control.Monad
+import Data.Profunctor
+import System.IO.Unsafe (unsafePerformIO)
+import qualified Data.Text as T
 import UnliftIO
+import qualified System.Console.ANSI as ANSI
 
+-- XXX: this assumes as single thread
 job :: String -> IO () -> IO ()
 job str act = do
     say (bold str)
-    tryAny act >>= \case
-      Right () -> say $ green "Done" <> ": " <> Log str
-      Left e -> say $ red "ERROR" <> ":\n" <> Log (show e)
+    indent
+    tryAny act <* deindent >>= \case
+        Right () -> say $ green "Done" <> ": " <> str
+        Left e -> say $ red "ERROR" <> ":\n" <> show e
+  where
+    indent = void $ atomicModifyIORef jobStack (\x -> (x + 1, undefined))
+    deindent = void $ atomicModifyIORef jobStack (\x -> (x - 1, undefined))
 
-newtype Log = Log { unLog :: String }
-  deriving newtype (Semigroup, Monoid, IsString)
+jobStackSize :: IO Int
+jobStackSize = readIORef jobStack
 
-say :: Log -> IO ()
-say = putStrLn . unLog
+jobStack :: IORef Int
+jobStack = unsafePerformIO $ newIORef 0
+{-# NOINLINE jobStackSize #-}
 
-green :: String -> Log
-green str = Log $
+tsay :: T.Text -> IO ()
+tsay = say . T.unpack
+
+say :: String -> IO ()
+say msg = do
+    stackSize <- jobStackSize
+    let indent = replicate (stackSize * 2) ' '
+    putStrLn $ indent <> msg
+
+green :: String -> String
+green str =
     ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>
     ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green] <>
     str <> ANSI.setSGRCode [ANSI.Reset]
 
-red :: String -> Log
-red str = Log $
+red :: String -> String
+red str =
     ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red] <>
     str <> ANSI.setSGRCode [ANSI.Reset]
 
-bold :: String -> Log
-bold str = Log $
+tbold :: T.Text -> T.Text
+tbold = dimap T.unpack T.pack bold
+
+bold :: String -> String
+bold str =
     ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>
     ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] <>
     str <> ANSI.setSGRCode [ANSI.Reset]
+
+tfaint :: T.Text -> T.Text
+tfaint = dimap T.unpack T.pack faint
+
+faint :: String -> String
+faint str =
+    ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.FaintIntensity] <>
+    ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] <>
+    str <> ANSI.setSGRCode [ANSI.Reset]