{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Settings
  ( Settings (..),
    readSettings,
    writeSettings,
    SuggestedTag (..),
  )
where

import Data.Aeson qualified as A
import Data.Function (on)
import Data.List (nub)
import Data.Text qualified as T
import Data.Vector qualified as V
import Data.Yaml (decodeFileThrow, encodeFile)
import GHC.Generics (Generic)
import System.Directory (doesFileExist)
import System.Environment.XDG.BaseDir (getSystemConfigFiles, getUserConfigFile)
import Text.RE.TDFA.Text qualified as R

data Settings = Settings
  { suggestedTags :: [SuggestedTag],
    defaultLanguage :: String
  }
  deriving (Show, Generic)

instance Semigroup Settings where
  a <> b =
    Settings
      { suggestedTags = nub (a.suggestedTags <> b.suggestedTags),
        defaultLanguage = b.defaultLanguage
      }

instance Monoid Settings where
  mempty =
    Settings
      { suggestedTags =
          [ -- TODO Add `SuggestedTagByDate`
            --
            -- By having a dedicated constructor for dates wie can take the following improvements into account:
            --
            -- -   date formats that spell out the month name, ie. `1 Januar 1970` or `1 Jan 1970`
            -- -   perform minor corrections on OCR, ie. parse `0 1.01.1970`
            --
            -- @topic suggested-tags
            SuggestTagByRE
              "createdAt"
              [R.ed|${d}([0-9]{2})\.${m}([0-9]{2})\.${y}([0-9]{4})///${y}-${m}-${d}|],
            SuggestTagByTags "correspondent"
          ],
        defaultLanguage = "deu+eng"
      }

instance A.FromJSON Settings

instance A.ToJSON Settings

data SuggestedTag
  = SuggestTagByRE T.Text (R.SearchReplace R.RE T.Text)
  | SuggestTagByTags T.Text
  deriving (Show, Generic, Eq)

instance Show R.RE where
  show = R.reSource

instance Eq R.RE where
  (==) = (==) `on` show

instance (Eq re, Eq s) => Eq (R.SearchReplace re s) where
  a == b =
    ((==) `on` R.getSearch) a b && (((==) `on` R.getTemplate) a b)

instance A.FromJSON SuggestedTag

instance A.ToJSON SuggestedTag

instance A.FromJSON R.RE where
  parseJSON = A.withText "regular expression (POSIX)" (R.compileRegex . T.unpack)

instance A.ToJSON R.RE where
  toJSON = A.toJSON . R.reSource

instance (A.FromJSON re, A.FromJSON s) => A.FromJSON (R.SearchReplace re s) where
  parseJSON =
    A.withArray
      "regular search/replace expression (POSIX)"
      ( \a -> do
          re <- a `V.indexM` 0
          s <- a `V.indexM` 1
          R.SearchReplace <$> A.parseJSON re <*> A.parseJSON s
      )

instance (A.ToJSON re, A.ToJSON s) => A.ToJSON (R.SearchReplace re s) where
  toJSON (R.SearchReplace re s) =
    A.Array (V.fromList [A.toJSON re, A.toJSON s])

readSettings :: IO Settings
readSettings =
  fmap mconcat
    . mapM
      ( \fp ->
          doesFileExist fp >>= \case
            True -> decodeFileThrow fp
            False -> pure mempty
      )
    =<< concat
      <$> sequence
        [ getSystemConfigFiles "apaperless" "settings.yaml",
          ((: []) <$> getUserConfigFile "apaperless" "settings.yaml"),
          pure ["apaperless.yaml"]
        ]

writeSettings :: FilePath -> Settings -> IO ()
writeSettings =
  encodeFile