module Handler.Utils.I18n
  ( i18nWidgetFile
  , 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)


-- | 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 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)) . List.nub $ 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 . widgetFile $ "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)|]

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