-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Handler.Utils.I18n
  ( i18nWidgetFile, i18nHamletFile
  , i18nWidgetFiles
  , i18nMessage
  , authorizedI18n, authenticationRequiredI18n, unauthorizedI18n
  , _AuthorizedI18n, _AuthenticationRequiredI18n, _UnauthorizedI18n
  , pattern UnauthorizedI18n, pattern AuthorizedI18n, pattern AuthenticationRequiredI18n
  , module Utils.I18n
  ) where

import Import.NoFoundation
import Foundation.Type

import Utils.I18n

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)

import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty

import qualified Data.Map as Map

import System.Directory (listDirectory)
import Text.Hamlet (hamletFile)

-- | Produces: let ws = \case "de" -> <includeFile> <de-file-name>; ...
--             in selectLanguage availableTranslations >>= ws l 
--   D.h. Ergebnis hat Typ: MonadHandler m => m _
i18nFile :: (FilePath -> Q Exp) -> FilePath -> Q Exp
i18nFile includeFile basename = do
  -- Construct list of available translations (@de@, @en@, ...) at compile time
  let i18nDirectory = "templates" </> "i18n" </> basename
  availableFiles <- qRunIO $ listDirectory i18nDirectory
  let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . nubOrd $ pack . takeBaseName <$> availableFiles
  availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations

  -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
  ws <- newName "ws" -- Name for dispatch function
  letE
    [ funD ws $ [ clause [litP $ stringL l] (normalB . includeFile $ "i18n" </> basename </> l) []
                | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
                ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
    ] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
  
-- | Add language dependent template files
--
-- For large files which are translated as a whole.
--
-- Argument musst be a directory under @/templates@,
-- which contains a file for each language,
-- eg. @imprint@ for choosing between
-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
-- and @/templates/imprint/en.hamlet@
--
-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
-- for directories)
-- @$ stack clean@ is required so new translations show up
i18nWidgetFile :: FilePath -> Q Exp
i18nWidgetFile = i18nFile widgetFile

i18nHamletFile :: FilePath -> Q Exp
i18nHamletFile basename = [e|$(i18nFile' (hamletFile . ("templates" </>) . (<.> "hamlet")) basename) <$> getUrlRenderParams|]

i18nFile' :: (FilePath -> Q Exp) -> FilePath -> Q Exp
i18nFile' includeFile basename = do
  -- Construct list of available translations (@de@, @en@, ...) at compile time
  let i18nDirectory = "templates" </> "i18n" </> basename
  availableFiles <- qRunIO $ listDirectory i18nDirectory
  let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . nubOrd $ pack . takeBaseName <$> availableFiles
  availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations

  -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
  ws <- newName "ws" -- Name for dispatch function
  letE
    [ funD ws $ [ clause [litP $ stringL l] (normalB . includeFile $ "i18n" </> basename </> l) []
                | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
                ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
    ] [e|selectLanguage availableTranslations' >>= withUrlRenderer . $(varE ws)|]



i18nWidgetFiles :: FilePath -> Q Exp
i18nWidgetFiles basename = do
  availableTranslations' <- i18nWidgetFilesAvailable' basename

  -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
  ws <- newName "ws" -- Name for dispatch function
  letE
    [ funD ws $ [ clause [litP $ stringL kind, litP $ stringL l] (normalB [e|$(widgetFile $ "i18n" </> basename </> kind <.> l) :: WidgetFor UniWorX ()|]) []
                | (unpack -> kind, ls) <- Map.toList availableTranslations'
                , l <- unpack <$> NonEmpty.toList ls
                ] ++ [ clause [wildP, wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
    ] [e|imap (\kind ls -> selectLanguage ls >>= $(varE ws) kind) availableTranslations'|]


i18nMessage :: ( MonadHandler m
               , HandlerSite m ~ UniWorX
               , RenderMessage UniWorX msg
               )
            => msg -> m I18nText
i18nMessage = i18nMessageFor $ toList appLanguages

unauthorizedI18n :: ( MonadHandler m
                    , HandlerSite m ~ UniWorX
                    , RenderMessage UniWorX msg
                    )
                 => msg -> m I18nAuthResult
unauthorizedI18n = fmap (fmap Unauthorized) . i18nMessage

_UnauthorizedI18n :: Prism' I18nAuthResult I18nText
_UnauthorizedI18n = prism' (fmap Unauthorized) . traverse $ preview _Unauthorized

_AuthorizedI18n :: Prism' I18nAuthResult ()
_AuthorizedI18n = prism' (\() -> authorizedI18n) . traverse_ $ preview _Authorized
  
_AuthenticationRequiredI18n :: Prism' I18nAuthResult ()
_AuthenticationRequiredI18n = prism' (\() -> authenticationRequiredI18n) . traverse_ $ preview _AuthenticationRequired

authorizedI18n, authenticationRequiredI18n :: I18nAuthResult
authorizedI18n = opoint Authorized
authenticationRequiredI18n = opoint Authorized

pattern UnauthorizedI18n :: I18nText -> I18nAuthResult
pattern UnauthorizedI18n x <- (preview _UnauthorizedI18n -> Just x) where
  UnauthorizedI18n = review _UnauthorizedI18n

pattern AuthorizedI18n :: I18nAuthResult
pattern AuthorizedI18n <- (preview _AuthorizedI18n -> Just ()) where
  AuthorizedI18n = authorizedI18n

pattern AuthenticationRequiredI18n :: I18nAuthResult
pattern AuthenticationRequiredI18n <- (preview _AuthenticationRequiredI18n -> Just ()) where
  AuthenticationRequiredI18n = authenticationRequiredI18n