photoname 5.4 → 5.5

raw patch · 16 files changed

+282/−263 lines, 16 filesdep +ansi-terminaldep +co-log-simpledep +prettyprinterdep −ansi-wl-pprintdep −hsloggerdep ~mtldep ~optparse-applicativedep ~regex-posixPVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal, co-log-simple, prettyprinter, text

Dependencies removed: ansi-wl-pprint, hslogger

Dependency ranges changed: mtl, optparse-applicative, regex-posix, tasty, tasty-hunit, tasty-quickcheck, unix

API changes (from Hackage documentation)

Files

• README.md +4/−4
• changelog.md +16/−0
• photoname.cabal +32/−28
• src/app/Photoname/Opts.hs +8/−8
• src/app/photoname.hs +36/−31
• src/lib/Photoname/Common.hs +11/−26
• src/lib/Photoname/CopyLink.hs +46/−33
• src/lib/Photoname/Date.hs +0/−1
• src/lib/Photoname/Exif.hs +0/−2
• src/lib/Photoname/Exiv2.hs +37/−30
• src/lib/Photoname/Links.hs +6/−8
• src/lib/Photoname/Log.hs +11/−57
• src/lib/Photoname/Monad.hs +40/−0
• src/tests/Photoname/Test/EndToEnd/Link.hs +24/−24
• stack.yaml +2/−2
• stack.yaml.lock +9/−9

@@ -15,12 +15,12 @@  ## Getting binaries -photoname is available for Linux in AppImage form [from github](https://github.com/dino-/photoname/releases)+photoname is available for Linux in AppImage form [from codeberg](https://codeberg.org/dinofp/photoname/releases)   ## Getting source -- Get the source with git: `$ git clone https://github.com/dino-/photoname.git`+- Get the source with git: `$ git clone https://codeberg.org/dinofp/photoname.git` - Download the cabalized source package [from Hackage](http://hackage.haskell.org/package/photoname)  And once you have it, building the usual way:@@ -29,13 +29,13 @@     $ stack test --ta all     $ stack run -If you're just looking, [browse the source](https://github.com/dino-/photoname)+If you're just looking, [browse the source](https://codeberg.org/dinofp/photoname)   ## Building for release  For Linux builds, I recommend using the excellent-[hsinstall](https://github.com/dino-/hsinstall) utility which will simplify+[hsinstall](https://codeberg.org/dinofp/hsinstall) utility which will simplify creation of an [AppImage](https://appimage.org/) executable.  

@@ -1,3 +1,19 @@+5.5 (2025-08-11)++  * Changed logging from hslogger to co-log-simple+  * Extensive redesign work because of the logging changes+  * Removed unused and duplicate LANGUAGE directives+  * Replaced remaining ++ with <>+  * Implemented hlint suggestions+  * Fixed formatting issues in the cabal file+  * Moved Stackage snapshot up to lts-22.6+++5.4 (2024-11-21)++  * Reverted lookup order of EXIF date tags++ 5.3 (2024-11-18)    * Now looking for the 3 EXIF tags when using exiv2

@@ -1,17 +1,16 @@ cabal-version: 2.2  name: photoname-version: 5.4+version: 5.5 synopsis: Rename photo image files based on EXIF shoot date description: Command-line utility for renaming/moving photo image files based   on EXIF tags.-category: Application, Console-stability: stable-homepage: https://github.com/dino-/photoname-bug-reports: https://github.com/dino-/photoname/issues author: Dino Morelli maintainer: Dino Morelli <dino@ui3.info> copyright: 2007 Dino Morelli+category: Application, Console+homepage: https://codeberg.org/dinofp/photoname+bug-reports: https://codeberg.org/dinofp/photoname/issues license: ISC license-file: LICENSE build-type: Simple@@ -37,7 +36,7 @@  source-repository head   type: git-  location: https://github.com/dino-/photoname+  location: https://codeberg.org/dinofp/photoname.git  common lang   default-language: Haskell2010@@ -49,6 +48,8 @@     DeriveLift     DeriveTraversable     EmptyCase+    FlexibleContexts+    FlexibleInstances     GeneralizedNewtypeDeriving     ImportQualifiedPost     InstanceSigs@@ -58,6 +59,7 @@     MultiWayIf     NamedFieldPuns     NumericUnderscores+    OverloadedStrings     ScopedTypeVariables     StandaloneDeriving     TupleSections@@ -71,9 +73,10 @@     -Wredundant-constraints   build-depends:       base >=4.5 && <5.0-    , directory >= 1.3.6 && < 1.4-    , filepath >= 1.4.2 && < 1.5-    , unix >= 2.7.2 && < 2.8+    , co-log-simple >=1.1.0 && <2+    , directory >=1.3.6 && <1.4+    , filepath >=1.4.2 && <1.5+    , unix >=2.7.2 && <3  library   import: lang@@ -85,6 +88,7 @@     Photoname.Exiv2     Photoname.Links     Photoname.Log+    Photoname.Monad   other-modules:     Paths_photoname   autogen-modules:@@ -92,14 +96,15 @@   hs-source-dirs:     src/lib   build-depends:-      containers >= 0.6.5 && < 0.7-    , formatting >= 7.2.0 && < 7.3-    , hsexif >= 0.6.1 && < 0.7-    , hslogger >= 1.3.1 && < 1.4-    , mtl >= 2.2.2 && < 2.3-    , parsec >= 3.1.15 && < 3.2-    , process >= 1.6.16 && < 1.7-    , time >= 1.11.1 && < 1.13+      ansi-terminal >=1.0.2 && <2+    , containers >=0.6.5 && <0.7+    , formatting >=7.2.0 && <7.3+    , hsexif >=0.6.1 && <0.7+    , mtl >=2.3.1 && <2.4+    , parsec >=3.1.15 && <3.2+    , process >=1.6.16 && <1.7+    , text >=2.0.2 && <2.2+    , time >=1.11.1 && <1.13  executable photoname   import: lang@@ -112,12 +117,11 @@   hs-source-dirs:       src/app   build-depends:-      ansi-wl-pprint >= 0.6.9 && < 0.7-    , formatting >= 7.2.0 && < 7.3-    , heredoc >= 0.2.0 && < 0.3-    , hslogger >= 1.3.1 && < 1.4-    , optparse-applicative >= 0.17.1 && < 0.18+      formatting >=7.2.0 && <7.3+    , heredoc >=0.2.0 && <0.3+    , optparse-applicative >=0.17.1 && <0.19     , photoname+    , prettyprinter >=1.7.1 && <2  test-suite photoname-tests   import: lang@@ -131,9 +135,9 @@     src/tests   build-depends:       photoname-    , process >= 1.6.16 && < 1.7-    , regex-posix-    , tasty-    , tasty-hunit-    , tasty-quickcheck-    , time >= 1.11.1 && < 1.13+    , process >=1.6.16 && <1.7+    , regex-posix >=0.96.0.1 && <1+    , tasty >=1.4.3 && <1.6+    , tasty-hunit >=0.10.1 && <0.11+    , tasty-quickcheck >=0.10.2 && <0.12+    , time >=1.11.1 && <1.13

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes #-}  module Photoname.Opts    ( parseOpts@@ -6,16 +6,15 @@    where  import Data.Version (showVersion)-import Formatting ((%), (%+), formatToString, string)+import Formatting ((%), (%+), format, formatToString, string) import Options.Applicative import Paths_photoname (version)+import Prettyprinter (pretty) import System.Directory (doesFileExist) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr)-import System.Log (Priority (NOTICE)) import Text.Heredoc (here)-import Text.PrettyPrint.ANSI.Leijen qualified as Leijen  import Photoname.Common   ( Artist (..)@@ -29,6 +28,7 @@   , Options (..)   , ParentDir (..)   , Prefix (..)+  , Severity (..)   , Suffix (..)   , Verbosity (Verbose)   , defaultDateTimeFormat@@ -129,7 +129,7 @@         <> metavar "NUM"         <> help "Verbosity level. 0=quiet, 1=normal messages, 2=more info, 3=debug"         <> showDefault-        <> value (Verbose NOTICE)+        <> value (Verbose Notice)         )   <*> some ( strArgument         $ metavar "FILES..."@@ -144,7 +144,7 @@    confExists <- doesFileExist path     if confExists-      then map ("--" ++) . lines <$> readFile path+      then map ("--" <>) . lines <$> readFile path       else do         hPutStrLn stderr $ "Config file " <> path <> " does not exist!"         exitFailure@@ -185,8 +185,8 @@   footer' :: InfoMod a-footer' = footerDoc . Just . Leijen.string-  $ formatToString content defaultDateTimeFormat (showVersion version)+footer' = footerDoc . Just . pretty+  $ format content defaultDateTimeFormat (showVersion version)   where content = [here|OVERVIEW  This software is for renaming and storing your digital photos. It will attempt to construct a meaningful filename based on the EXIF shoot date in the file or possibly date/time info in the old filename, and optionally some other information.

@@ -1,20 +1,28 @@-{-# LANGUAGE OverloadedRecordDot, OverloadedStrings #-}+{-# LANGUAGE OverloadedRecordDot #-} -import Control.Monad (filterM, forM_, when)-import Formatting ((%), (%+), formatToString, string)+import Colog.Simple (logNotice)+-- import Colog.Simple (logTest)+import Control.Monad (filterM, when)+import Formatting ((%), sformat, string) import Data.Functor ((<&>))+import System.IO+  ( BufferMode (NoBuffering)+  , hSetBuffering+  , stderr, stdout+  ) import System.Posix (FileStatus, getFileStatus, isRegularFile)  import Photoname.Common (CopySwitch (v),   Extension (Extension, UseExistingExtension), Links, MoveSwitch (v),   NoActionSwitch (v), Options (copy, extension, links, move, noAction, paths,-  verbosity), Ph, SrcPath (SrcPath, v), liftIO, runRename)+  verbosity), SrcPath (SrcPath)) import Photoname.CopyLink (createNewLink) import Photoname.Date (PhDate, parseExifDate, parseFilenameDate) import Photoname.Exif (getExifDate) import Photoname.Exiv2 (getExifDateWithExiv2, setArtist, setExifDate) import Photoname.Links (describeHardLinkPolicy, linksTest)-import Photoname.Log (errorM, initLogging, lname, noticeM)+import Photoname.Log (logger)+import Photoname.Monad (Env (..), Ph, liftIO, runRename) import Photoname.Opts (parseOpts)  @@ -29,11 +37,14 @@  processFile :: SrcPath -> Ph () processFile srcPath = do-  liftIO . noticeM lname $ "----------"+  logNotice "------------------------------------------------------------"   imageDate <- acquireDate srcPath-  destPath <- createNewLink imageDate srcPath-  setExifDate imageDate destPath-  setArtist destPath+  mbDestPath <- createNewLink imageDate srcPath+  case mbDestPath of+    (Just destPath) -> do+      setExifDate imageDate destPath+      setArtist destPath+    Nothing -> pure ()   -- Get rid of anything not a regular file or with a number of links that@@ -51,33 +62,27 @@ -- Figure out and execute what the user wants based on the supplied args. main :: IO () main = do-   opts <- parseOpts--   initLogging $ verbosity opts--   -- Notify user of the switches that will be in effect.-   when opts.noAction.v $-      noticeM lname "No-action mode, nothing will be changed"+  mapM_ (flip hSetBuffering NoBuffering) [stderr, stdout]+  opts <- parseOpts+  runRename (Env opts (logger . verbosity $ opts)) $ do+    -- Notify user of the switches that will be in effect.+    when opts.noAction.v $+      logNotice "No-action mode, nothing will be changed" -   when opts.copy.v $-      noticeM lname "Files will be copied instead of the default of hard linking"+    when opts.copy.v $+      logNotice "Files will be copied instead of the default of hard linking" -   case opts.extension of-      Extension ext -> noticeM lname $ formatToString ("The extension '" % string % "' will be used for all files") ext+    case opts.extension of+      Extension ext -> logNotice $ sformat ("The extension '" % string % "' will be used for all files") ext       UseExistingExtension -> pure () -   when opts.move.v $-      noticeM lname "Removing original links after new links are in place"+    when opts.move.v $+      logNotice "Removing original links after new links are in place" -   describeHardLinkPolicy $ links opts+    describeHardLinkPolicy . links $ opts -   actualPaths <- filterWantedFiles (links opts) (paths opts)+    actualPaths <- liftIO $ filterWantedFiles (links opts) (paths opts) -   -- Do the link manipulations, and report any errors.-   forM_ actualPaths $ \srcPath -> do-      result <- runRename opts $ processFile srcPath-      either-        (errorM lname . formatToString ("** Processing" %+ string % ":" %+ string) srcPath.v)-        pure result+    mapM_ processFile actualPaths -   -- Perhaps we should get an ExitCode back from all this above?+    -- logTest

@@ -12,50 +12,42 @@   , NoDirsSwitch (..)   , ParentDir (..)   , Options (..)-  , Ph   , Prefix (..)+  , Severity (..)   , SrcPath (..)   , Suffix (..)   , Verbosity (..)   , defaultDateTimeFormat   , readVerbosity-  , runRename--  -- Re-exporting:-  , MonadError-  , ask, asks-  , liftIO-  , throwError   )   where -import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)-import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)-import Control.Monad.Trans (liftIO)+import Colog.Simple (Severity (Debug, Info, Notice)) import Data.Time.LocalTime (LocalTime)-import System.Log.Logger (Priority (..)) import System.Posix (CNlink)   defaultDateTimeFormat :: String defaultDateTimeFormat = "%Y%m%d-%H%M%S" + data Verbosity   = Quiet-  | Verbose Priority+  | Verbose Severity  instance Show Verbosity where   show Quiet = "0"-  show (Verbose NOTICE) = "1"-  show (Verbose INFO) = "2"-  show (Verbose DEBUG) = "3"+  show (Verbose Notice) = "1"+  show (Verbose Info) = "2"+  show (Verbose Debug) = "3"   show _ = "Should never see this, invalid verbosity level being shown" + readVerbosity :: String -> Either String Verbosity readVerbosity "0" = Right   Quiet-readVerbosity "1" = Right $ Verbose NOTICE-readVerbosity "2" = Right $ Verbose INFO-readVerbosity "3" = Right $ Verbose DEBUG+readVerbosity "1" = Right $ Verbose Notice+readVerbosity "2" = Right $ Verbose Info+readVerbosity "3" = Right $ Verbose Debug readVerbosity _   = Left    "Invalid verbosity level, expecting 0-3"  @@ -104,10 +96,3 @@ newtype SrcPath = SrcPath { v :: FilePath }  newtype DestPath = DestPath FilePath---type Ph a = ReaderT Options (ExceptT String IO) a---runRename :: Options -> Ph a -> IO (Either String a)-runRename env action = runExceptT $ runReaderT action env

@@ -1,13 +1,16 @@-{-# LANGUAGE OverloadedRecordDot, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedRecordDot #-}  module Photoname.CopyLink    ( createNewLink    )    where +import Colog.Simple (logNotice, logWarning) import Control.Exception (try) import Control.Monad (unless, when) import Data.Time.LocalTime (LocalTime)+import Formatting ((%+), sformat, string)+ import GHC.IO.Exception (IOException) import System.Directory (copyFile, createDirectoryIfMissing) import System.FilePath ((</>), (<.>), takeDirectory, takeExtension)@@ -17,47 +20,57 @@   Extension (Extension, UseExistingExtension), MoveSwitch (v),   NoActionSwitch (v), NoDirsSwitch (NoDirsSwitch), ParentDir (ParentDir),   Options (copy, formatter, extension, move, noAction, noDirs, parentDir, prefix, suffix),-  Ph, Prefix (Prefix), SrcPath (SrcPath), Suffix (Suffix), ask, asks, liftIO,-  throwError)+  Prefix (Prefix), SrcPath (SrcPath), Suffix (Suffix)) import Photoname.Date (PhDate (ExifDate, FilenameDate, NoDateFound),   formatDateHyphens, formatYear)-import Photoname.Log (lname, noticeM, warningM)+import Photoname.Monad (Env (envOptions), Ph, asks, liftIO)  -createNewLink :: PhDate -> SrcPath -> Ph DestPath-createNewLink imageDate srcPath@(SrcPath srcFp) = do-  opts <- ask+createNewLink :: PhDate -> SrcPath -> Ph (Maybe DestPath) +createNewLink NoDateFound (SrcPath srcFp) = do+  logWarning $ sformat ("Could not extract any date information from" %+ string) srcFp+  pure Nothing++createNewLink (ExifDate lt) srcPath = createNewLink' srcPath lt++createNewLink (FilenameDate lt) srcPath = createNewLink' srcPath lt+++createNewLink' :: SrcPath -> LocalTime -> Ph (Maybe DestPath)+createNewLink' srcPath@(SrcPath srcFp) lt = do+  opts <- asks envOptions+   let ext = case opts.extension of         (Extension ext') -> ext'         UseExistingExtension -> takeExtension srcFp -  destPath@(DestPath destFp) <- case imageDate of-    ExifDate lt -> buildDatePath lt ext-    FilenameDate lt -> buildDatePath lt ext-    NoDateFound -> throwError "Could not extract any date information"+  destPath@(DestPath destFp) <- buildDatePath lt ext    -- Check for existence of the target file-  exists <- liftIO $ fileExist destFp-  when exists $ throwError $ "Destination " ++ destFp ++ " exists!"--  -- Display what will be done-  liftIO $ noticeM lname $ srcFp ++ " -> " ++ destFp+  targetExists <- liftIO $ fileExist destFp+  if targetExists+    then do+      logWarning $ sformat ("Destination" %+ string %+ "exists!") destFp+      pure Nothing+    else do+      -- Display what will be done+      logNotice $ sformat (string %+ "->" %+ string) srcFp destFp -  unless opts.noAction.v $ do-    -- Make the target dir-    liftIO $ createDirectoryIfMissing True $ takeDirectory destFp+      unless opts.noAction.v $ do+        -- Make the target dir+        liftIO $ createDirectoryIfMissing True $ takeDirectory destFp -    -- Make the new file-    if opts.copy.v-      then liftIO $ copyFile srcFp destFp-      else tryHardLink srcPath destPath+        -- Make the new file+        if opts.copy.v+          then liftIO $ copyFile srcFp destFp+          else tryHardLink srcPath destPath -    -- If user has specified, remove the original link-    when opts.move.v $-       liftIO $ removeLink srcFp+        -- If user has specified, remove the original link+        when opts.move.v $+           liftIO $ removeLink srcFp -  pure destPath+      pure $ Just destPath   tryHardLink :: SrcPath -> DestPath -> Ph ()@@ -67,7 +80,7 @@   where     failureHandler :: IOException -> Ph ()     failureHandler _ = do-      liftIO $ warningM lname "Hard link failed, attempting to copy instead"+      logWarning "Hard link failed, attempting to copy instead"       liftIO $ copyFile srcFp destFp  @@ -77,13 +90,13 @@ -} buildDatePath :: LocalTime -> FilePath -> Ph DestPath buildDatePath date ext = do-   (Prefix prefixStr) <- asks prefix-   (Suffix suffixStr) <- asks suffix-   dateFormatter <- asks formatter+   (Prefix prefixStr) <- asks $ prefix . envOptions+   (Suffix suffixStr) <- asks $ suffix . envOptions+   dateFormatter <- asks $ formatter . envOptions    let fileName = prefixStr <> dateFormatter date <> suffixStr -   (ParentDir parentDir') <- asks parentDir-   (NoDirsSwitch noDirs') <- asks noDirs+   (ParentDir parentDir') <- asks $ parentDir . envOptions+   (NoDirsSwitch noDirs') <- asks $ noDirs . envOptions    pure . DestPath $ if noDirs'       then parentDir' </> fileName <.> ext       else parentDir' </> formatYear date </>

@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-{-# LANGUAGE FlexibleContexts #-}  module Photoname.Date   ( PhDate (..)

@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- module Photoname.Exif   ( getExifDate   )

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Photoname.Exiv2   ( getExifDateWithExiv2   , setArtist@@ -7,23 +5,27 @@   )   where +import Colog.Simple (logDebug, logInfo, logNotice) import Control.Exception import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO) import Data.Char (isSpace) import Data.Monoid (First (..))-import Formatting ((%), (%+), formatToString, string)+import Data.Text (Text)+import Data.Text qualified as TS+import Formatting ((%), (%+), formatToString, string, text) import GHC.IO.Exception import System.Process hiding (proc) import qualified System.Process as Proc  import Photoname.Common (Artist (Artist), DestPath (DestPath),-  NoActionSwitch (NoActionSwitch), Options (artist, noAction), Ph,-  SrcPath (SrcPath), asks, liftIO)+  NoActionSwitch (NoActionSwitch), Options (artist, noAction),+  SrcPath (SrcPath)) import Photoname.Date (PhDate (FilenameDate), formatDateForExif)-import Photoname.Log (LogFunction, debugM, infoM, lname, noticeM)+import Photoname.Monad (Env (envOptions), Ph, asks, liftIO)  +type LogFunction = Text -> Ph ()+ data Reading data Writing @@ -37,9 +39,9 @@ -- System.Process.proc BUT they look odd when logged by our code. This function -- will put quotes around any space-containing arguments purely for human -- readability.-commandToString :: Command rw -> String-commandToString (Command _ program' arguments) =-  unwords $ program' : map quoteAsNeeded arguments+commandToText :: Command rw -> Text+commandToText (Command _ program' arguments) =+  TS.pack . unwords $ program' : map quoteAsNeeded arguments   where     quoteAsNeeded str = if ' ' `elem` str       then "'" <> str <> "'"@@ -49,25 +51,24 @@ proc (Command _ program' arguments) = Proc.proc program' arguments  -logCommand :: MonadIO m => Command rw -> m ()+logCommand :: Command rw -> Ph () logCommand command@(Command logFunction _ _) =-  liftIO . logFunction lname . commandToString $ command-+  logFunction . commandToText $ command   -- For Writing (or "destructive") commands, we need to check if the user has -- chosen no-action behavior before executing-execWritingCommand :: Command Writing -> Ph (Either String String)+execWritingCommand :: Command Writing -> Ph (Maybe String) execWritingCommand command = do   logCommand command-  (NoActionSwitch noAction') <- asks noAction+  (NoActionSwitch noAction') <- asks $ noAction . envOptions   if noAction'-    then pure $ Left ""+    then pure Nothing     else execCommand command   -- For Reading (or "non-destructive") commands, we just log it and do it-execReadingCommand :: Command Reading -> Ph (Either String String)+execReadingCommand :: Command Reading -> Ph (Maybe String) execReadingCommand command = logCommand command >> execCommand command  @@ -75,12 +76,19 @@ stripTrailingWhitespace = reverse . dropWhile isSpace . reverse  -execCommand :: Command rw -> Ph (Either String String)-execCommand command = liftIO $ do-  eResult <- postProcess =<< try (readCreateProcessWithExitCode (proc command) "")-  either (\msg -> debugM lname $ "** Command failed: " <> stripTrailingWhitespace msg)-    (\output -> debugM lname $ "Command succeeded, output: " <> stripTrailingWhitespace output) eResult-  pure eResult+execCommand :: Command rw -> Ph (Maybe String)+execCommand command = do+  eResult <- liftIO $ postProcess =<< try (readCreateProcessWithExitCode (proc command) "")+  either handleFailure handleSuccess eResult+  where+    handleFailure msg = do+      let msg' = formatToString (text %+ string) "** Command failed:" (stripTrailingWhitespace msg)+      logDebug . TS.pack $ msg'+      pure Nothing+    handleSuccess output = do+      let output' = formatToString (text %+ string) "Command succeeded, output:" (stripTrailingWhitespace output)+      logDebug . TS.pack $ output'+      pure . Just $ output'   program :: FilePath@@ -97,14 +105,14 @@  setArtist :: DestPath -> Ph () setArtist (DestPath destFp) = do-  artist' <- asks artist+  artist' <- asks $ artist . envOptions    case artist' of     Nothing -> pure ()     Just (Artist "") -> void $ execWritingCommand $-      Command noticeM program ["--Modify", "del Exif.Image.Artist", destFp]+      Command logNotice program ["--Modify", "del Exif.Image.Artist", destFp]     Just (Artist artistInfo) -> void $ execWritingCommand $-      Command noticeM program ["--Modify", "set Exif.Image.Artist " <> artistInfo, destFp]+      Command logNotice program ["--Modify", "set Exif.Image.Artist " <> artistInfo, destFp]   getExifDateWithExiv2 :: SrcPath -> Ph (Maybe String)@@ -118,15 +126,14 @@   ["Exif.Photo.DateTimeOriginal", "Exif.Photo.DateTimeDigitized", "Exif.Image.DateTime"]    where-    mbResult tag = do-      eResult <- execReadingCommand $ Command infoM program ["--Print", "v", "--grep", tag, srcFp]-      pure . either (const Nothing) Just $ eResult+    mbResult tag =+      execReadingCommand $ Command logInfo program ["--Print", "v", "--grep", tag, srcFp]   setExifDate :: PhDate -> DestPath -> Ph ()  setExifDate (FilenameDate lt) (DestPath destFp) =-  void $ execWritingCommand . Command noticeM program $+  void $ execWritingCommand . Command logNotice program $     [ "--Modify", "set Exif.Image.DateTime Ascii " <> formatDateForExif lt     , "--Modify", "set Exif.Photo.UserComment charset=Ascii DateTime is a guess", destFp     ]

@@ -1,16 +1,15 @@-{-# LANGUAGE OverloadedStrings #-}- module Photoname.Links   ( describeHardLinkPolicy   , linksTest   )   where -import Formatting ((%+), formatToString, int)+import Colog.Simple (logNotice)+import Formatting ((%+), sformat, int) import System.Posix (FileStatus, linkCount)  import Photoname.Common (Links (Exactly, NoLimit))-import Photoname.Log (lname, noticeM)+import Photoname.Monad (Ph)   linksTest :: Links -> FileStatus -> Bool@@ -18,10 +17,9 @@ linksTest NoLimit                   _          = True  -describeHardLinkPolicy :: Links -> IO ()+describeHardLinkPolicy :: Links -> Ph () describeHardLinkPolicy l = case l of-  Exactly 1 -> noticeM lname "Only processing files with 1 hard link"-  Exactly n -> noticeM lname $ formatToString+  Exactly 1 -> logNotice "Only processing files with 1 hard link"+  Exactly n -> logNotice $ sformat     ("Only processing files with" %+ int %+ "hard links") (toInteger n)   NoLimit   -> pure ()-

@@ -1,64 +1,18 @@ module Photoname.Log-  ( LogFunction-  , initLogging-  , lname-  , logTest--  -- Re-exported from System.Log-  , debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM+  ( logger   )   where -import Data.Functor ((<&>))-import System.IO (Handle, stdout)-import System.Log.Formatter (simpleLogFormatter)-import System.Log.Handler (setFormatter)-import System.Log.Handler.Simple (GenericHandler, streamHandler)-import System.Log.Logger-  ( Priority (DEBUG)-  , alertM, criticalM, debugM, emergencyM, errorM, infoM, noticeM, warningM-  , rootLoggerName, setHandlers, setLevel, updateGlobalLogger-  )--import Photoname.Common (Verbosity (Quiet, Verbose))---type LogFunction = String -> String -> IO ()---lname :: String-lname = rootLoggerName---initLogging :: Verbosity -> IO ()-initLogging verbosity = do-  updateGlobalLogger lname . setHandlers =<< handlers verbosity-  case verbosity of-    Quiet -> pure ()-    Verbose loggerLevel -> updateGlobalLogger lname $ setLevel loggerLevel---handlers :: Verbosity -> IO [GenericHandler Handle]--handlers Quiet  = pure []---- Under the maximum verbosity (-v3), also display the logging Priority-handlers (Verbose DEBUG) = do-  h <- streamHandler stdout DEBUG <&>-    flip setFormatter (simpleLogFormatter "$prio: $msg")-  pure [h]+import Colog.Simple (LogAction, Message, Severity(Debug), (%), (%+), msg, msgc,+  sevc, stack, logTextStdout)+import Colog.Simple qualified+import Control.Monad.Trans (MonadIO) -handlers (Verbose _) = sequence [streamHandler stdout DEBUG]+import Photoname.Common (Verbosity (..))  --- Test function to generate every kind of log message-logTest :: IO ()-logTest = do-  debugM     lname "log test message DEBUG 1 of 8"-  infoM      lname "log test message INFO 2 of 8"-  noticeM    lname "log test message NOTICE 3 of 8"-  warningM   lname "log test message WARNING 4 of 8"-  errorM     lname "log test message ERROR 5 of 8"-  criticalM  lname "log test message CRITICAL 6 of 8"-  alertM     lname "log test message ALERT 7 of 8"-  emergencyM lname "log test message EMERGENCY 8 of 8"+-- Wrapper to set up logging based on desired verbosity+logger :: MonadIO m => Verbosity -> LogAction m Message+logger  Quiet          = mempty+logger (Verbose Debug) = Colog.Simple.logger (sevc % stack %+ msg) logTextStdout Debug+logger (Verbose sev)   = Colog.Simple.logger msgc logTextStdout sev

@@ -0,0 +1,40 @@+{-# LANGUAGE DerivingStrategies #-}++module Photoname.Monad+  ( Env (..)+  , Ph+  , runRename++  -- Re-exporting:+  , ask, asks+  , liftIO+  )+  where++import Colog.Simple (HasLog (..), LogAction, Message)+import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)+import Control.Monad.Trans (MonadIO, liftIO)++import Photoname.Common (Options)+++data Env m = Env+  { envOptions :: !Options+  , envLogAction :: !(LogAction m Message)+  }++instance HasLog (Env m) Message m where+  getLogAction :: Env m -> LogAction m Message+  getLogAction = envLogAction+  {-# INLINE getLogAction #-}++  setLogAction :: LogAction m Message -> Env m -> Env m+  setLogAction newLogAction env = env { envLogAction = newLogAction }+  {-# INLINE setLogAction #-}+++newtype Ph a = Ph { unPh :: ReaderT (Env Ph) IO a }+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Env Ph))++runRename :: Env Ph -> Ph a -> IO a+runRename env action = runReaderT (unPh action) env

@@ -46,7 +46,7 @@ testLinkDigitized = testCase "tests for DateTimeDigitized" $ do    -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--parent-dir=" ++ parentDir, oldPath ]+      [ "--parent-dir=" <> parentDir, oldPath ]    waitForProcess procH     -- Check that the correct output path exists@@ -71,7 +71,7 @@     -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--parent-dir=" ++ parentDir, digitizedOldPath ]+      [ "--parent-dir=" <> parentDir, digitizedOldPath ]    waitForProcess procH     -- Check that the correct output path exists@@ -97,7 +97,7 @@     -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--parent-dir=" ++ parentDir, dateOldPath ]+      [ "--parent-dir=" <> parentDir, dateOldPath ]    waitForProcess procH     -- Check that the correct output path exists@@ -120,12 +120,12 @@ testNoDate = testCase "test for no date in the file" $ do    -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--parent-dir=" ++ parentDir, Util.resourcesPath </> "noDate.jpg" ]+      [ "--parent-dir=" <> parentDir, Util.resourcesPath </> "noDate.jpg" ]    waitForProcess procH     -- Test output to stdout    assertBool "no EXIF: correct output"-      (output =~ "\\*\\* Processing util/resources/test/noDate.jpg: Could not extract any date information" :: Bool)+      (output =~ ("Could not extract any date information from util/resources/test/noDate.jpg" :: String) :: Bool)   testMove :: TestTree@@ -137,7 +137,7 @@     -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--move", "--parent-dir=" ++ parentDir, newOldPath ]+      [ "--move", "--parent-dir=" <> parentDir, newOldPath ]    waitForProcess procH     -- Check that the correct output path exists@@ -168,19 +168,19 @@ testLinkNoAction' label switch = testCase label $ do    -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ switch, "--parent-dir=" ++ parentDir, oldPath ]+      [ switch, "--parent-dir=" <> parentDir, oldPath ]    waitForProcess procH     -- Check that the correct output path exists    existsNew <- fileExist parentDir-   Util.assertFalse (label ++ ": existence of new link") existsNew+   Util.assertFalse (label <> ": existence of new link") existsNew     -- Check that old path still exists    existsOld <- fileExist oldPath-   assertBool (label ++ ": existence of old link") existsOld+   assertBool (label <> ": existence of old link") existsOld     -- Test output to stdout-   assertBool (label ++ ": correct output")+   assertBool (label <> ": correct output")       (output =~ newLinkPathDate :: Bool)  @@ -197,22 +197,22 @@ testLinkQuiet' label switch = testCase label $ do    -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ switch, "--parent-dir=" ++ parentDir, oldPath ]+      [ switch, "--parent-dir=" <> parentDir, oldPath ]    waitForProcess procH     -- Check that the correct output path exists    existsNew <- fileExist newLinkPathDate-   assertBool (label ++ ": existence of new link") existsNew+   assertBool (label <> ": existence of new link") existsNew     -- Check that old path still exists    existsOld <- fileExist oldPath-   assertBool (label ++ ": existence of old link") existsOld+   assertBool (label <> ": existence of old link") existsOld     -- Remove files and dirs that were created    removeDirectoryRecursive parentDir     -- Test output to stdout-   Util.assertFalse (label ++ ": no output")+   Util.assertFalse (label <> ": no output")       (output =~ newLinkPathDate :: Bool)  @@ -222,11 +222,11 @@     -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--parent-dir=" ++ parentDir, "--suffix=" ++ suffix, oldPath ]+      [ "--parent-dir=" <> parentDir, "--suffix=" <> suffix, oldPath ]    waitForProcess procH     let newLinkPath = parentDir </>-         ("2003/2003-09-02/20030902-114303" ++ suffix) <.> "jpg"+         ("2003/2003-09-02/20030902-114303" <> suffix) <.> "jpg"     -- Check that the correct output path exists    existsNew <- fileExist newLinkPath@@ -250,7 +250,7 @@    -- Run the program with known input data   (output, procH) <- Util.getBinaryOutput-    [ "--parent-dir=" ++ parentDir, "--prefix=" ++ prefix, oldPath ]+    [ "--parent-dir=" <> parentDir, "--prefix=" <> prefix, oldPath ]   waitForProcess procH    let newLinkPath = parentDir </>@@ -276,36 +276,36 @@ testNoExif = testCase "test for a file without any EXIF data" $ do    -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--parent-dir=" ++ parentDir, Util.resourcesPath </> "noExif.jpg" ]+      [ "--parent-dir=" <> parentDir, Util.resourcesPath </> "noExif.jpg" ]    waitForProcess procH     -- Test output to stdout    assertBool "no EXIF: correct output"-      (output =~ "\\*\\* Processing util/resources/test/noExif.jpg: Could not extract any date information" :: Bool)+      (output =~ ("Could not extract any date information from util/resources/test/noExif.jpg" :: String) :: Bool)   testNotAnImage :: TestTree testNotAnImage = testCase "test for a file that isn't an image" $ do    -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--parent-dir=" ++ parentDir, Util.resourcesPath </> "notAnImage.txt" ]+      [ "--parent-dir=" <> parentDir, Util.resourcesPath </> "notAnImage.txt" ]    waitForProcess procH     -- Test output to stdout    assertBool "no EXIF: correct output"-      (output =~ "\\*\\* Processing util/resources/test/notAnImage.txt: Could not extract any date information" :: Bool)+      (output =~ ("Could not extract any date information from util/resources/test/notAnImage.txt" :: String) :: Bool)   testDirForFile :: TestTree testDirForFile = testCase "test when a directory is passed instead of a file" $ do    -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--parent-dir=" ++ parentDir, Util.resourcesPath ]+      [ "--parent-dir=" <> parentDir, Util.resourcesPath ]    waitForProcess procH     -- Test output to stdout    assertBool "dir as file to change: correct output"-      (output =~ "" :: Bool)+      (output =~ ("" :: String) :: Bool)   testLinkFilenameDate :: TestTree@@ -318,7 +318,7 @@     -- Run the program with known input data    (output, procH) <- Util.getBinaryOutput-      [ "--parent-dir=" ++ parentDir, newOldPath ]+      [ "--parent-dir=" <> parentDir, newOldPath ]    waitForProcess procH     -- Check that the correct output path exists

@@ -1,10 +1,10 @@-resolver: lts-21.25+snapshot: lts-22.6  packages: - .  extra-deps:-- hsexif-0.6.1.10+- co-log-simple-1.1.0  flags:   hsexif:

@@ -1,19 +1,19 @@ # This file was autogenerated by Stack. # You should not edit this file by hand. # For more information, please see the documentation at:-#   https://docs.haskellstack.org/en/stable/lock_files+#   https://docs.haskellstack.org/en/stable/topics/lock_files  packages: - completed:-    hackage: hsexif-0.6.1.10@sha256:f002993b7953186a9e13869efe830ce951b900ee504afdbc297950f3b88fc3e3,2276+    hackage: co-log-simple-1.1.0@sha256:8cc7c99d60d0c6088e76e2548f7621737ae7e26f1237c181ead009ee9763c951,1767     pantry-tree:-      sha256: 25066251bd371301fa2d8e693d5e84828ceee2a02e2ee7f1523065fc2cbf72db-      size: 1120+      sha256: 918c592895abf6aeb758343c9c9090b3c92ba20b31f2e24f53b7f62aa572b5a0+      size: 579   original:-    hackage: hsexif-0.6.1.10+    hackage: co-log-simple-1.1.0 snapshots: - completed:-    sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd-    size: 640086-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml-  original: lts-21.25+    sha256: 1b4c2669e26fa828451830ed4725e4d406acc25a1fa24fcc039465dd13d7a575+    size: 714100+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/6.yaml+  original: lts-22.6