{-| This module is based on hgold from hspec-golden-0.2.0.0, which is MIT licensed -}

module Test.Sandwich.Golden.Update (
  updateGolden
  , defaultDirGoldenTest
  ) where

import Control.Monad
import Data.Maybe
import Data.String.Interpolate
import System.Console.ANSI
import System.Directory
import System.Environment
import UnliftIO.Exception


defaultDirGoldenTest :: FilePath
defaultDirGoldenTest :: String
defaultDirGoldenTest = String
".golden"

updateGolden :: Maybe FilePath -> IO ()
updateGolden :: Maybe String -> IO ()
updateGolden (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
defaultDirGoldenTest -> String
dir) = do
  EnableColor
enableColor <- String -> IO (Maybe String)
lookupEnv String
"NO_COLOR" IO (Maybe String)
-> (Maybe String -> IO EnableColor) -> IO EnableColor
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> EnableColor -> IO EnableColor
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EnableColor
EnableColor
    Just String
_ -> EnableColor -> IO EnableColor
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EnableColor
DisableColor

  EnableColor -> SGR -> String -> IO ()
putStrLnColor EnableColor
enableColor SGR
green String
"Replacing golden with actual..."
  EnableColor -> String -> IO ()
go EnableColor
enableColor String
dir
  EnableColor -> SGR -> String -> IO ()
putStrLnColor EnableColor
enableColor SGR
green String
"Done!"

  where
    go :: EnableColor -> String -> IO ()
go EnableColor
enableColor String
dir' = String -> IO [String]
listDirectory String
dir' IO [String] -> ([String] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EnableColor -> String -> IO ()
processEntry EnableColor
enableColor)

    processEntry :: EnableColor -> String -> IO ()
processEntry EnableColor
enableColor (((String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/") String -> String -> String
forall a. [a] -> [a] -> [a]
++) -> String
entryInDir) = do
      Bool
isDir <- String -> IO Bool
doesDirectoryExist String
entryInDir
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isDir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        EnableColor -> String -> IO ()
mvActualToGolden EnableColor
enableColor String
entryInDir
        EnableColor -> String -> IO ()
go EnableColor
enableColor String
entryInDir

mvActualToGolden :: EnableColor -> FilePath -> IO ()
mvActualToGolden :: EnableColor -> String -> IO ()
mvActualToGolden EnableColor
enableColor String
testPath = do
  let actualFilePath :: String
actualFilePath = String
testPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/actual"
  let goldenFilePath :: String
goldenFilePath = String
testPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/golden"

  Bool
exists <- String -> IO Bool
doesFileExist String
actualFilePath
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStr [i|  #{goldenFilePath}|]
    EnableColor -> SGR -> String -> IO ()
putStrColor EnableColor
enableColor SGR
magenta String
" <-- "
    EnableColor -> SGR -> String -> IO ()
putStrLnColor EnableColor
enableColor SGR
red [i|#{actualFilePath}|]

    String -> String -> IO ()
renameFile String
actualFilePath String
goldenFilePath

green, red, magenta :: SGR
green :: SGR
green = ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Green
red :: SGR
red = ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Red
magenta :: SGR
magenta = ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Magenta

putStrColor :: EnableColor -> SGR -> String -> IO ()
putStrColor :: EnableColor -> SGR -> String -> IO ()
putStrColor EnableColor
EnableColor SGR
color String
s = IO () -> IO () -> IO () -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_ ([SGR] -> IO ()
setSGR [SGR
color]) ([SGR] -> IO ()
setSGR [SGR
Reset]) (String -> IO ()
putStr String
s)
putStrColor EnableColor
DisableColor SGR
_ String
s = String -> IO ()
putStr String
s

putStrLnColor :: EnableColor -> SGR -> String -> IO ()
putStrLnColor :: EnableColor -> SGR -> String -> IO ()
putStrLnColor EnableColor
EnableColor SGR
color String
s = IO () -> IO () -> IO () -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_ ([SGR] -> IO ()
setSGR [SGR
color]) ([SGR] -> IO ()
setSGR [SGR
Reset]) (String -> IO ()
putStrLn String
s)
putStrLnColor EnableColor
DisableColor SGR
_ String
s = String -> IO ()
putStrLn String
s

data EnableColor = EnableColor | DisableColor