module Handler.Utils.I18n
  ( i18nWidgetFile
  , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles
  ) where

import Import

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

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

import qualified Data.Set as Set
import qualified Data.Map as Map

import qualified Data.Text as Text

import System.Directory (listDirectory)
import System.FilePath.Posix (takeBaseName)


-- | 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)|]

i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text))
i18nWidgetFilesAvailable' basename = do
  let i18nDirectory = "templates" </> "i18n" </> basename
  availableFiles <- qRunIO $ listDirectory i18nDirectory
  let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
      fileKinds :: Map Text [Text]
      fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
      toTranslation fName = listToMaybe . sortOn length . mapMaybe (flip Text.stripPrefix fName . (<>".")) $ map fst fileKinds'

  iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty

i18nWidgetFilesAvailable :: FilePath -> Q Exp
i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable'
  
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) :: Widget|]) []
                | (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'|]