sr-extra-1.64: Extra/IO.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS -Wall #-}

module Extra.IO
    ( -- * IO functions to write files and notice when they change.
      testAndWriteDotNew
    , testAndWriteBackup
    , testAndWriteFile
    , testAndWrite
    , writeFileWithBackup
    , findHaskellFiles
    , timeComputation
    ) where

import Control.Exception as E (IOException, throw, try)
import Control.Monad (when)
import Control.Monad.Trans (liftIO, MonadIO)
import Data.Monoid ((<>))
import Data.Text as Text (length, take, Text)
import Data.Text.IO as Text (readFile, writeFile)
import Data.Time (getCurrentTime, diffUTCTime, getCurrentTime, NominalDiffTime)
import Extra.Log (alog)
import Extra.Text (diffText)
import System.Directory (getCurrentDirectory, removeFile, renameFile)
import System.FilePath.Find as Find
    ((==?), (&&?), always, extension, fileType, FileType(RegularFile), find)
import System.IO.Error (isDoesNotExistError)
import System.Log.Logger ({-logM,-} Priority(DEBUG, ERROR))

testAndWriteDotNew :: FilePath -> Text -> IO ()
testAndWriteDotNew dest new = testAndWrite writeDotNew dest new

testAndWriteBackup :: FilePath -> Text -> IO ()
testAndWriteBackup dest new = testAndWrite (\dest' _ new' -> writeFileWithBackup dest' new') dest new

testAndWriteFile :: FilePath -> Text -> IO ()
testAndWriteFile = testAndWriteDotNew
{-# DEPRECATED testAndWriteFile "Use testAndWriteDotNew" #-}

-- | See if the new Paths code matches the old, if not write it to a
-- file with the suffix ".new" and throw an error so the new code can
-- be inspected and checked in.  If the new file does match, the
-- existing .new file is removed.
testAndWrite :: (FilePath -> Text -> Text -> IO ()) -> FilePath -> Text -> IO ()
testAndWrite changeAction dest new = do
  here <- getCurrentDirectory
  alog "Extra.IO" DEBUG ("testAndWriteFile " <> show dest <> " " <> show (shorten 50 new) <> " (cwd=" <> show here <> ")")
  removeFileMaybe (dest <> ".new")
  try (Text.readFile dest >>= \old ->
       when (old /= new) (changeAction dest old new)) >>=
    either (\(e :: IOException) ->
              case isDoesNotExistError e of
                True -> do
                  alog "Extra.IO" DEBUG "testAndWriteFile - no existing version"
                  Text.writeFile dest new
                False -> do
                  alog "Extra.IO" ERROR ("testAndWriteFile " <> show dest <> " - IOException " ++ show e)
                  throw e)
           return

-- | Shorten a string to a maximum length by replacing its suffix with "..."
shorten :: Int -> Text -> Text
shorten n t | n <= 3 = Text.take n t -- no room for an ellipsis
shorten n t | Text.length t > n - 3 = Text.take (n - 3) t <> "..."
shorten _ t = t

-- | If the new file does not match the old, write it to file.new and error.
writeDotNew :: FilePath -> Text -> Text -> IO ()
writeDotNew dest old new = do
  alog "Extra.IO" DEBUG ("testAndWriteFile - mismatch, writing " <> show (dest <> ".new"))
  Text.writeFile (dest <> ".new") new
  error ("Generated " <> dest <> ".new does not match existing " <> dest <> ":\n" <>
         diffText (dest, old) (dest <> ".new", new) <>
         "\nIf these changes look reasonable move " <> dest <> ".new to " <> dest <> " and retry.")


-- | Rename existing file with suffix "~" and write a new file
writeFileWithBackup :: FilePath -> Text -> IO ()
writeFileWithBackup dest text = do
  removeFileMaybe (dest <> "~")
  renameFileMaybe dest (dest <> "~")
  removeFileMaybe dest
  Text.writeFile dest text

-- | Remove a file if it exists
removeFileMaybe :: FilePath -> IO ()
removeFileMaybe p =
    try (removeFile p) >>=
    either (\(e :: IOException) -> case isDoesNotExistError e of
                                     True -> pure ()
                                     False -> throw e) pure

-- | Rename a file if it exists
renameFileMaybe :: FilePath -> FilePath -> IO ()
renameFileMaybe oldpath newpath =
    try (renameFile oldpath newpath) >>=
    either (\(e :: IOException) -> case isDoesNotExistError e of
                                     True -> pure ()
                                     False -> throw e) pure

-- | Find all regular files with extension .hs
findHaskellFiles :: FilePath -> IO [FilePath]
findHaskellFiles dir = find always (Find.extension ==? ".hs" &&? fileType ==? RegularFile) dir

-- | Perform an IO operation and return the elapsed time along with the result.
timeComputation :: MonadIO m => m r -> m (r, NominalDiffTime)
timeComputation a = do
  !start <- liftIO getCurrentTime
  !r <- a
  !end <- liftIO getCurrentTime
  return (r, diffUTCTime end start)