{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE QuasiQuotes #-}

module Navi.Args.TH
  ( defaultToml,
    gitData,
  )
where

import Control.Applicative (liftA3)
import Data.Text qualified as T
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Time.Clock.POSIX qualified as PosixTime
import Data.Time.Format qualified as Fmt
import Development.GitRev.Typed.OsString
  ( EnvError (MkEnvError),
    GitError,
    GitRevError (GitRevErrorEnv, GitRevErrorText),
    IndexUsed (IdxNotUsed),
  )
import Development.GitRev.Typed.OsString qualified as GRT
import FileSystem.OsString (OsString, osstr)
import FileSystem.OsString qualified as FS.OsString
import Language.Haskell.TH (Code, Q)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax (Lift (liftTyped))
import Navi.Prelude
import System.OsString qualified as OsString
import Text.Read qualified as TR

gitData :: Code Q (OsString, OsString, OsString)
gitData :: Code Q (OsString, OsString, OsString)
gitData = Q (Either (Errors GitRevError) (OsString, OsString, OsString))
-> Code Q (OsString, OsString, OsString)
toCode Q (Either (Errors GitRevError) (OsString, OsString, OsString))
qs
  where
    toCode :: Q (Either (Errors GitRevError) (OsString, OsString, OsString))
-> Code Q (OsString, OsString, OsString)
toCode = Q (OsString, OsString, OsString)
-> Code Q (OsString, OsString, OsString)
forall a. Lift a => Q a -> Code Q a
GRT.qToCode (Q (OsString, OsString, OsString)
 -> Code Q (OsString, OsString, OsString))
-> (Q (Either (Errors GitRevError) (OsString, OsString, OsString))
    -> Q (OsString, OsString, OsString))
-> Q (Either (Errors GitRevError) (OsString, OsString, OsString))
-> Code Q (OsString, OsString, OsString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Q (Either (Errors GitRevError) (OsString, OsString, OsString))
-> Q (OsString, OsString, OsString)
forall (f :: Type -> Type) e a.
(Exception e, Functor f) =>
f (Either e a) -> f a
GRT.projectError

    qs :: Q (Either (Errors GitRevError) (OsString, OsString, OsString))
qs =
      NonEmpty (Q (Either GitRevError (OsString, OsString, OsString)))
-> Q (Either (Errors GitRevError) (OsString, OsString, OsString))
forall e a. NonEmpty (Q (Either e a)) -> Q (Either (Errors e) a)
GRT.firstSuccessQ
        [ Q (Either GitError (OsString, OsString, OsString))
-> Q (Either GitRevError (OsString, OsString, OsString))
forall (f :: Type -> Type) (p :: Type -> Type -> Type) a.
(Bifunctor p, Functor f) =>
f (p GitError a) -> f (p GitRevError a)
GRT.embedGitError Q (Either GitError (OsString, OsString, OsString))
gitDataFromGitQ,
          OsString
-> Q (Either GitError (OsString, OsString, OsString))
-> Q (Either GitRevError (OsString, OsString, OsString))
forall a.
OsString -> Q (Either GitError a) -> Q (Either GitRevError a)
GRT.runGitInEnvDirQ [osstr|NAVI_HOME|] Q (Either GitError (OsString, OsString, OsString))
gitDataFromGitQ,
          Q (Either GitRevError (OsString, OsString, OsString))
Item
  (NonEmpty (Q (Either GitRevError (OsString, OsString, OsString))))
gitDataFromEnvQ
        ]

-- | Normal process, get info from git.
gitDataFromGitQ :: Q (Either GitError (OsString, OsString, OsString))
gitDataFromGitQ :: Q (Either GitError (OsString, OsString, OsString))
gitDataFromGitQ = do
  -- We use custom runGit rather than normal gitCommitDateQ because the
  -- latter uses --format=%cd e.g.
  --
  --     Thu May 1 14:05:35 2025 +1200
  --
  -- whereas we want --format=%cs i.e.
  --
  --     2025-05-01
  --
  -- We do this because we want consistency with nix, and unfortunately
  -- nix only gives us a local timestamp without any timezone information.
  -- So we throw away the timezone here too. Notice there is still a
  -- possibility of discrepancies because runGit implicitly includes zone
  -- info, though we live with it, since it's a minor issue.
  Either GitError OsString
d <-
    [OsString] -> IndexUsed -> Q (Either GitError OsString)
GRT.runGitQ
      [Item [OsString]
[osstr|log|], Item [OsString]
[osstr|HEAD|], Item [OsString]
[osstr|-1|], Item [OsString]
[osstr|--format=%cs|]]
      IndexUsed
IdxNotUsed
  Either GitError OsString
h <- Q (Either GitError OsString)
GRT.gitHashQ
  (OsString
 -> OsString -> OsString -> (OsString, OsString, OsString))
-> Either GitError OsString
-> Either GitError OsString
-> Either GitError OsString
-> Either GitError (OsString, OsString, OsString)
forall (f :: Type -> Type) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 (,,) Either GitError OsString
d Either GitError OsString
h (Either GitError OsString
 -> Either GitError (OsString, OsString, OsString))
-> Q (Either GitError OsString)
-> Q (Either GitError (OsString, OsString, OsString))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Either GitError OsString)
GRT.gitShortHashQ

-- | Backup for when we cannot use git e.g. nix. We instead get the data
-- from environment variables:
--
-- - NAVI_MODIFIED: unix time like "1746055623"
-- - NAVI_HASH: long hash
-- - NAVI_SHORT_HASH: short hash
--
-- We have to convert the unix time into the intended format
-- YYYY-MM-DD.
gitDataFromEnvQ :: Q (Either GitRevError (OsString, OsString, OsString))
gitDataFromEnvQ :: Q (Either GitRevError (OsString, OsString, OsString))
gitDataFromEnvQ = do
  let dateVar :: OsString
dateVar = [osstr|NAVI_MODIFIED|]
  Either GitRevError OsString
d <- Q (Either EnvError OsString) -> Q (Either GitRevError OsString)
forall (f :: Type -> Type) (p :: Type -> Type -> Type) a.
(Bifunctor p, Functor f) =>
f (p EnvError a) -> f (p GitRevError a)
GRT.embedEnvError (Q (Either EnvError OsString) -> Q (Either GitRevError OsString))
-> Q (Either EnvError OsString) -> Q (Either GitRevError OsString)
forall a b. (a -> b) -> a -> b
$ (Either EnvError OsString -> Either EnvError OsString)
-> Q (Either EnvError OsString) -> Q (Either EnvError OsString)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either EnvError OsString
-> (OsString -> Either EnvError OsString)
-> Either EnvError OsString
forall a b.
Either EnvError a -> (a -> Either EnvError b) -> Either EnvError b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= OsString -> OsString -> Either EnvError OsString
displayUnixTime OsString
dateVar) (OsString -> Q (Either EnvError OsString)
GRT.envValQ OsString
dateVar)
  Either GitRevError OsString
h <- Int -> Either EnvError OsString -> Either GitRevError OsString
validateHash Int
40 (Either EnvError OsString -> Either GitRevError OsString)
-> Q (Either EnvError OsString) -> Q (Either GitRevError OsString)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> OsString -> Q (Either EnvError OsString)
GRT.envValQ [osstr|NAVI_HASH|]
  Either GitRevError OsString
sh <- Int -> Either EnvError OsString -> Either GitRevError OsString
validateHash Int
7 (Either EnvError OsString -> Either GitRevError OsString)
-> Q (Either EnvError OsString) -> Q (Either GitRevError OsString)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> OsString -> Q (Either EnvError OsString)
GRT.envValQ [osstr|NAVI_SHORT_HASH|]
  pure $ (OsString
 -> OsString -> OsString -> (OsString, OsString, OsString))
-> Either GitRevError OsString
-> Either GitRevError OsString
-> Either GitRevError OsString
-> Either GitRevError (OsString, OsString, OsString)
forall (f :: Type -> Type) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 (,,) Either GitRevError OsString
d Either GitRevError OsString
h Either GitRevError OsString
sh
  where
    validateHash :: Int -> Either EnvError OsString -> Either GitRevError OsString
    validateHash :: Int -> Either EnvError OsString -> Either GitRevError OsString
validateHash Int
n = Either EnvError (Either Text OsString)
-> Either GitRevError OsString
forall {c}. Either EnvError (Either Text c) -> Either GitRevError c
joinErrors (Either EnvError (Either Text OsString)
 -> Either GitRevError OsString)
-> (Either EnvError OsString
    -> Either EnvError (Either Text OsString))
-> Either EnvError OsString
-> Either GitRevError OsString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (OsString -> Either Text OsString)
-> Either EnvError OsString
-> Either EnvError (Either Text OsString)
forall a b. (a -> b) -> Either EnvError a -> Either EnvError b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> OsString -> Either Text OsString
validateHash' Int
n)

    joinErrors :: Either EnvError (Either Text c) -> Either GitRevError c
joinErrors = (EnvError -> GitRevError)
-> (Text -> GitRevError)
-> Either EnvError (Either Text c)
-> Either GitRevError c
forall (p :: Type -> Type -> Type) a1 a2 b c.
(Bifunctor p, forall a. Monad (p a)) =>
(a1 -> b) -> (a2 -> b) -> p a1 (p a2 c) -> p b c
GRT.joinFirst EnvError -> GitRevError
GitRevErrorEnv Text -> GitRevError
GitRevErrorText

    validateHash' :: Int -> OsString -> Either Text OsString
    validateHash' :: Int -> OsString -> Either Text OsString
validateHash' Int
n OsString
str
      | Int
strLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n Bool -> Bool -> Bool
&& Int
strLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
dirtyLen =
          Text -> Either Text OsString
forall a b. a -> Either a b
Left
            (Text -> Either Text OsString) -> Text -> Either Text OsString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
              [ Text
Item [Text]
"Expected hash length ",
                Int -> Text
forall a. Show a => a -> Text
showt Int
n,
                Text
Item [Text]
" or ",
                Int -> Text
forall a. Show a => a -> Text
showt Int
dirtyLen,
                Text
Item [Text]
", received ",
                Int -> Text
forall a. Show a => a -> Text
showt Int
strLen,
                Text
Item [Text]
": ",
                [Char] -> Text
packText (OsString -> [Char]
FS.OsString.decodeLenient OsString
str)
              ]
      | OsString -> Bool
hasInvalidChar OsString
str =
          Text -> Either Text OsString
forall a b. a -> Either a b
Left
            (Text -> Either Text OsString) -> Text -> Either Text OsString
forall a b. (a -> b) -> a -> b
$ Text
"Invalid char in hash: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
packText (OsString -> [Char]
FS.OsString.decodeLenient OsString
str)
      | Bool
otherwise = OsString -> Either Text OsString
forall a b. b -> Either a b
Right OsString
str
      where
        strLen :: Int
strLen = OsString -> Int
OsString.length OsString
str
        dirtyLen :: Int
dirtyLen = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6

    hasInvalidChar :: OsString -> Bool
    hasInvalidChar :: OsString -> Bool
hasInvalidChar OsString
str =
      -- We allow dirty hashes to have invalid chars, due to the '-dirty'
      -- suffix.
      let hasNonHexChar :: Bool
hasNonHexChar =
            (OsChar -> Bool) -> OsString -> Bool
OsString.any
              (Bool -> Bool
not (Bool -> Bool) -> (OsChar -> Bool) -> OsChar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (\OsChar
c -> OsChar -> OsString -> Bool
OsString.elem OsChar
c [osstr|0123456789abcdefABCDEF|]))
              OsString
str
          isDirty :: Bool
isDirty = [osstr|-dirty|] OsString -> OsString -> Bool
`OsString.isSuffixOf` OsString
str
       in Bool
hasNonHexChar Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isDirty

displayUnixTime :: OsString -> OsString -> Either EnvError OsString
displayUnixTime :: OsString -> OsString -> Either EnvError OsString
displayUnixTime OsString
var OsString
unixTimeOsStr = do
  [Char]
unixTimeStr <-
    (EncodingException -> EnvError)
-> Either EncodingException [Char] -> Either EnvError [Char]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Char] -> EncodingException -> EnvError
forall e. Exception e => [Char] -> e -> EnvError
mapEx [Char]
"Error decoding to String: ")
      (Either EncodingException [Char] -> Either EnvError [Char])
-> Either EncodingException [Char] -> Either EnvError [Char]
forall a b. (a -> b) -> a -> b
$ OsString -> Either EncodingException [Char]
FS.OsString.decode OsString
unixTimeOsStr

  Integer
unixSeconds <-
    ([Char] -> EnvError)
-> Either [Char] Integer -> Either EnvError Integer
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\[Char]
s -> [Char] -> EnvError
mapEnvError ([Char] -> EnvError) -> [Char] -> EnvError
forall a b. (a -> b) -> a -> b
$ [Char]
"Error reading seconds: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s)
      (Either [Char] Integer -> Either EnvError Integer)
-> Either [Char] Integer -> Either EnvError Integer
forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> Either [Char] a
TR.readEither @Integer [Char]
unixTimeStr

  let posixTime :: POSIXTime
posixTime = forall a. Num a => Integer -> a
fromInteger @POSIXTime Integer
unixSeconds
      utcTime :: UTCTime
utcTime = POSIXTime -> UTCTime
PosixTime.posixSecondsToUTCTime POSIXTime
posixTime
      utcFormatted :: [Char]
utcFormatted = TimeLocale -> [Char] -> UTCTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
Fmt.formatTime TimeLocale
Fmt.defaultTimeLocale [Char]
"%Y-%m-%d" UTCTime
utcTime

  (EncodingException -> EnvError)
-> Either EncodingException OsString -> Either EnvError OsString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Char] -> EncodingException -> EnvError
forall e. Exception e => [Char] -> e -> EnvError
mapEx [Char]
"Error endecoding to OsString: ")
    (Either EncodingException OsString -> Either EnvError OsString)
-> Either EncodingException OsString -> Either EnvError OsString
forall a b. (a -> b) -> a -> b
$ [Char] -> Either EncodingException OsString
FS.OsString.encode [Char]
utcFormatted
  where
    mapEx :: forall e. (Exception e) => String -> e -> EnvError
    mapEx :: forall e. Exception e => [Char] -> e -> EnvError
mapEx [Char]
s = [Char] -> EnvError
mapEnvError ([Char] -> EnvError) -> (e -> [Char]) -> e -> EnvError
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ([Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (e -> [Char]) -> e -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. e -> [Char]
forall e. Exception e => e -> [Char]
displayException

    mapEnvError :: String -> EnvError
    mapEnvError :: [Char] -> EnvError
mapEnvError [Char]
str =
      MkEnvError
        { OsString
var :: OsString
var :: OsString
var,
          value :: Maybe OsString
value = OsString -> Maybe OsString
forall a. a -> Maybe a
Just OsString
unixTimeOsStr,
          reason :: OsString
reason = [Char] -> OsString
FS.OsString.encodeLenient [Char]
str
        }

defaultToml :: Code Q Text
defaultToml :: Code Q Text
defaultToml = IO Text -> Code Q Text
forall a. (HasCallStack, Lift a) => IO a -> Code Q a
liftIOToTH (IO Text -> Code Q Text) -> IO Text -> Code Q Text
forall a b. (a -> b) -> a -> b
$ do
  Text
contents <- OsString -> IO Text
forall (m :: Type -> Type).
(HasCallStack, MonadFileReader m, MonadThrow m) =>
OsString -> m Text
readFileUtf8ThrowM [ospPathSep|examples/config.toml|]
  Text -> IO Text
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
    (Text -> IO Text) -> (Text -> Text) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Text] -> Text
T.unlines
    ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
prependComment
    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> [Text]
T.lines
    (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
contents
  where
    prependComment :: Text -> Text
prependComment Text
l =
      if Text -> Bool
T.null Text
l
        then Text
l
        else Text
"# " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l

-- | Binds an IO action to TH.
bindIOToTH :: (HasCallStack, Lift b) => ((HasCallStack) => a -> IO b) -> a -> Code Q b
bindIOToTH :: forall b a.
(HasCallStack, Lift b) =>
(HasCallStack => a -> IO b) -> a -> Code Q b
bindIOToTH HasCallStack => a -> IO b
f a
x = Q b -> (b -> Code Q b) -> Code Q b
forall (m :: Type -> Type) a b.
Monad m =>
m a -> (a -> Code m b) -> Code m b
TH.bindCode (IO b -> Q b
forall a. IO a -> Q a
TH.runIO (a -> IO b
HasCallStack => a -> IO b
f a
x)) b -> Code Q b
forall t (m :: Type -> Type). (Lift t, Quote m) => t -> Code m t
forall (m :: Type -> Type). Quote m => b -> Code m b
liftTyped

-- | Lifts an IO action to TH.
liftIOToTH :: (HasCallStack, Lift a) => IO a -> Code Q a
liftIOToTH :: forall a. (HasCallStack, Lift a) => IO a -> Code Q a
liftIOToTH IO a
m = (HasCallStack => () -> IO a) -> () -> Code Q a
forall b a.
(HasCallStack, Lift b) =>
(HasCallStack => a -> IO b) -> a -> Code Q b
bindIOToTH (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
m) ()