module Handler.Utils
  ( module Handler.Utils
  ) where

import Import

import Utils.Lens

import qualified Data.Text as T
-- import qualified Data.Set (Set)
import qualified Data.Set as Set
import Data.CaseInsensitive (original)
-- import qualified Data.CaseInsensitive as CI

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

import Text.Hamlet (shamletFile)

import Handler.Utils.DateTime as Handler.Utils
import Handler.Utils.Form as Handler.Utils
import Handler.Utils.Table as Handler.Utils
import Handler.Utils.Table.Pagination as Handler.Utils

import Handler.Utils.Zip        as Handler.Utils
import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
-- import Handler.Utils.Submission as Handler.Utils
import Handler.Utils.Sheet      as Handler.Utils
import Handler.Utils.Mail       as Handler.Utils

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

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


downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
downloadFiles = do
  mauth <- liftHandlerT maybeAuth
  case mauth of
    Just (Entity _ User{..}) -> return userDownloadFiles
    Nothing -> do
      UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
      return userDefaultDownloadFiles

tidFromText :: Text -> Maybe TermId
tidFromText = fmap TermKey . maybeRight . termFromText

simpleLink :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]

-- | toWidget-Version of @nameHtml@, for convenience
nameWidget :: Text    -- ^ userDisplayName
           -> Text    -- ^ userSurname
           -> Widget
nameWidget displayName surname = toWidget $ nameHtml displayName surname

-- | toWidget-Version of @nameEmailHtml@, for convenience
nameEmailWidget :: UserEmail -- ^ userEmail
                -> Text    -- ^ userDisplayName
                -> Text    -- ^ userSurname
                -> Widget
nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname

-- | uncurried Version for @nameEmailWidget@ needed in hamlet, where TH cannot be used
nameEmailWidget' :: (UserEmail, Text, Text)-> Widget
nameEmailWidget' = $(uncurryN 3) nameEmailWidget

-- | Show user's displayName, highlighting the surname if possible.
--   Otherwise appends the surname in parenthesis
nameHtml :: Text -> Text -> Html
nameHtml displayName surname
  | null surname = toHtml displayName
  | otherwise = case reverse $ T.splitOn surname displayName of
      [_notContained] -> [shamlet|$newline never
                            #{displayName} (
                            <b .surname>#{surname}
                            )|]
      (suffix:prefixes) ->
        let prefix = T.intercalate surname $ reverse prefixes
        in [shamlet|$newline never
              #{prefix}
              <b .surname>#{surname}
              #{suffix}
            |]
      [] -> error "Data.Text.splitOn returned empty list in violation of specification."

-- | Like nameHtml just show a users displayname with hightlighted surname,
--   but also wrap the name with a mailto-link
nameEmailHtml :: UserEmail -> Text -> Text -> Html
nameEmailHtml email displayName surname =
  wrapMailto email $ nameHtml displayName surname

-- | Wrap mailto around given Html using single hamlet-file for consistency
wrapMailto :: UserEmail -> Html -> Html
wrapMailto (original -> email) linkText
  | null email = linkText
  | otherwise  = $(shamletFile "templates/widgets/link-email.hamlet")

-- | Just show an email address in a standard way, for convenience inside hamlet files.
mailtoHtml :: UserEmail -> Html
mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")

-- | Generic i18n text for "edited at sometime by someone"
editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
editedByW fmt tm usr  = do
  ft <- handlerToWidget $ formatTime fmt tm
  [whamlet|_{MsgEditedBy usr ft}|]

-- | Prefix a message with a short course id,
--   eg. for window title bars, etc.
--   This function should help to make this consistent everywhere
prependCourseTitle :: (RenderMessage UniWorX msg) =>
  TermId -> SchoolId -> CourseShorthand -> msg -> UniWorXMessages
prependCourseTitle tid ssh csh msg = UniWorXMessages
  [ SomeMessage $ toPathPiece tid
  , SomeMessage dashText
  , SomeMessage $ toPathPiece ssh
  , SomeMessage dashText
  , SomeMessage csh
  , SomeMessage colonText
  , SomeMessage msg
  ]
 where
    dashText :: Text
    dashText = "-"

    colonText :: Text
    colonText = ":"

warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
warnTermDays tid times = do
  Term{..} <- get404 tid
  let alldays       = Set.map utctDay $ Set.fromList $ catMaybes times
      warnholidays  = Set.intersection alldays $ Set.fromList termHolidays
      outoftermdays = Set.filter (\d -> d < termStart        || d > termEnd       ) alldays
      outoflecture  = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
                        `Set.difference` outoftermdays -- out of term implies out of lecture-time
      warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid dt
  forM_ warnholidays  $ warnI MsgDayIsAHoliday
  forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
  forM_ outoftermdays $ warnI MsgDayIsOutOfTerm

-- | 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" </> 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 $ 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)|]