{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult

module Utils
  ( module Utils
  ) where

import ClassyPrelude.Yesod

-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import Data.Foldable as Fold hiding (length)

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import Utils.DB as Utils
import Utils.TH as Utils
import Utils.DateTime as Utils
import Utils.PathPiece as Utils

import Text.Blaze (Markup, ToMarkup)

import Data.Char (isDigit)
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
import Numeric (showFFloat)

import Control.Lens
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
-- import qualified Data.List as List

import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Catch


import qualified Database.Esqueleto as E (Value, unValue)

import Language.Haskell.TH
import Instances.TH.Lift ()

import Text.Shakespeare.Text (st)



-----------
-- Yesod --
-----------

newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) }

getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
getMsgRenderer = do
  mr <- getMessageRender
  return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)


instance Monad FormResult where
  FormMissing        >>= _ = FormMissing
  (FormFailure errs) >>= _ = FormFailure errs
  (FormSuccess a)    >>= f = f a

guardAuthResult :: MonadHandler m => AuthResult -> m ()
guardAuthResult AuthenticationRequired = notAuthenticated
guardAuthResult (Unauthorized t) = permissionDenied t
guardAuthResult Authorized = return ()

data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route
  deriving (Eq, Ord, Typeable, Show)
instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)

unsupportedAuthPredicate :: ExpQ
unsupportedAuthPredicate = do
  logFunc <- logErrorS
  [e| \tag route -> do
        $(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|]
        unauthorizedI (UnsupportedAuthPredicate tag route)
    |]



---------------------
-- Text and String --
---------------------

tickmark :: IsString a => a
tickmark = fromString "✔"
-- Avoid annoying warnings:
tickmarkS :: String
tickmarkS = tickmark
tickmarkT :: Text
tickmarkT = tickmark

text2Html :: Text -> Html
text2Html = toHtml -- prevents ambiguous types

toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
  a -> WidgetT site m ()
toWgt = toWidget . toHtml

-- Convenience Functions to avoid type signatures:
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
                Text -> WidgetT site m ()
text2widget t = [whamlet|#{t}|]

citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
                (CI Text) -> WidgetT site m ()
citext2widget t = [whamlet|#{CI.original t}|]

str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
                String -> WidgetT site m ()
str2widget s = [whamlet|#{s}|]

display2widget ::  (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) =>
                a -> WidgetT site m ()
display2widget = text2widget . display

withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)


-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
{- (not so sure we really want to get rid of display?!) DEPRECATED display "Create RenderMessage Instances instead!" -}
class DisplayAble a where
  display :: a -> Text
  -- Default definitions for types belonging to Show (allows empty instance declarations)
  default display :: Show a => a -> Text
  display = pack . show

instance DisplayAble Text where
  display = id

instance DisplayAble String where
  display = pack

instance DisplayAble Int
instance DisplayAble Int64
instance DisplayAble Integer

instance DisplayAble Rational where
  display r = showFFloat (Just 2) (rat2float r) ""
      & pack
      & dropWhileEnd ('0'==)
      & dropWhileEnd ('.'==)
    where
      rat2float :: Rational -> Double
      rat2float = fromRational

instance DisplayAble a => DisplayAble (Maybe a) where
  display Nothing  = ""
  display (Just x) = display x

instance DisplayAble a => DisplayAble (E.Value a) where
  display = display . E.unValue

instance DisplayAble a => DisplayAble (CI a) where
  display = display . CI.original

{- We do not want DisplayAble for every Show-Class:
   We want to explicitly verify that the resulting text can be displayed to the User!
   For example: UTCTime values were shown without proper format rendering!
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
  display = pack . show
-}

textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercent x = lz <> (pack $ show rx) <> "%"
 where
   round' :: Double -> Int -- avoids annoying warning
   round' = round
   rx :: Double
   rx = fromIntegral (round' $ 1000.0*x) / 10.0
   lz = if rx < 10.0 then "0" else ""

stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounterCI = CI.map stepTextCounter

stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounter text
    | (Just i) <- readMay number =
        let iplus1 = tshow (succ i :: Int)
            zeroip = justifyRight (length number) '0' iplus1
        in  prefix <> zeroip <> suffix
    | otherwise = text
  where -- no splitWhile nor findEnd in Data.Text
    suffix =                        takeWhileEnd (not . isDigit) text
    number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
    prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text

-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo  Ue3bung00322 34 (H)"
-- ["12",".ProMo  Ue","3","bung","00322"," ","34"," (H)"]


------------
-- Tuples --
------------

fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x
snd3 :: (a,b,c) -> b
snd3 (_,y,_) = y
trd3 :: (a,b,c) -> c
trd3 (_,_,z) = z

-- Further projections are available via TemplateHaskell, defined in Utils.Common:
-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
-- snd3 = $(projNI 3 2)



-----------
-- Lists --
-----------

-- notNull = not . null

lastMaybe :: [a] -> Maybe a
lastMaybe []    = Nothing
lastMaybe [h]   = Just h
lastMaybe (_:t) = lastMaybe t

lastMaybe' :: [a] -> Maybe a
lastMaybe' l = fmap snd $ l ^? _Snoc


mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
mergeAttrs = mergeAttrs' `on` sort
  where
    special = [ ("class", \v1 v2 -> v1 <> " " <> v2)
              ]

    mergeAttrs' (x1@(n1, v1):xs1) (x2@(n2, v2):xs2)
      | Just merge <- lookup n1 special
      , n2 == n1
      = mergeAttrs' ((n1, merge v1 v2) : xs1) xs2
      | Just _ <- lookup n1 special
      , n1 < n2
      = x2 : mergeAttrs' (x1:xs1) xs2
      | otherwise = x1 : mergeAttrs' xs1 (x2:xs2)
    mergeAttrs' [] xs2 = xs2
    mergeAttrs' xs1 [] = xs1



----------
-- Maps --
----------

infixl 5 !!!


(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
(!!!) m k = (fromMaybe mempty) $ Map.lookup k m

groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l]

partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
partMap = Map.fromListWith mappend

invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
invertMap = groupMap . map swap . Map.toList



-----------
-- Maybe --
-----------

toMaybe :: Bool -> a -> Maybe a
toMaybe True  = Just
toMaybe False = const Nothing

toNothing :: a -> Maybe b
toNothing = const Nothing

toNothingS :: String -> Maybe b
toNothingS = const Nothing

maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
maybeAdd (Just x) (Just y) = Just (x + y)
maybeAdd Nothing y  = y
maybeAdd x Nothing  = x

maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty (Just x) f = f x
maybeEmpty Nothing  _ = mempty

whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x
whenIsJust Nothing  _ = return ()

ifJustM :: Monad m => b -> Maybe a -> (a -> m b) -> m b
ifJustM dft Nothing _  = return dft
ifJustM _ (Just x) act = act x

maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM dft act mb = mb >>= maybe dft act

maybeT :: Monad m => m a -> MaybeT m a -> m a
maybeT x m = runMaybeT m >>= maybe x return

catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
catchIfMaybeT p act = catchIf p (lift act) (const mzero)

mcons :: Maybe a -> [a] -> [a]
mcons Nothing  xs = xs
mcons (Just x) xs = x:xs

newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom

instance Eq a  => Eq (NTop (Maybe a)) where
  (NTop x) == (NTop y) = x == y

instance Ord a => Ord (NTop (Maybe a)) where
  compare (NTop Nothing)  (NTop Nothing) = EQ
  compare (NTop Nothing)  _              = GT
  compare _               (NTop Nothing) = LT
  compare (NTop (Just x)) (NTop (Just y)) = compare x y



------------
-- Either --
------------

maybeLeft  :: Either a b -> Maybe a
maybeLeft  (Left a) = Just a
maybeLeft  _ = Nothing

maybeRight :: Either a b -> Maybe b
maybeRight (Right b) = Just b
maybeRight _ = Nothing

whenIsLeft  :: Monad m => Either a b -> (a -> m ()) -> m ()
whenIsLeft (Left   x) f = f x
whenIsLeft (Right  _) _ = return ()

whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m ()
whenIsRight (Right x) f = f x
whenIsRight (Left  _) _ = return ()


---------------
-- Exception --
---------------

maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
maybeExceptT err act = lift act >>= maybe (throwE err) return

maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return

whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
whenExceptT b err = when b $ throwE err

whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
whenMExceptT b err = when b $ lift err >>= throwE

guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
guardExceptT b err = unless b $ throwE err

guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
guardMExceptT b err = unless b $ lift err >>= throwE

exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
exceptT f g = either f g <=< runExceptT

catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)



------------
-- Monads --
------------

shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
shortCircuitM sc mx my bop = do
  x <- mx
  case sc x of
    True  -> return x
    False -> bop <$> pure x <*> my


guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f

assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = x >>= assertM' f

assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
assertM' f x = x <$ guard (f x)

-- Some Utility Functions from Agda.Utils.Monad
-- | Monadic if-then-else.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM c m m' =
    do  b <- c
        if b then m else m'

-- | @ifNotM mc = ifM (not <$> mc)@
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM c = flip $ ifM c

-- | Lazy monadic conjunction.
and2M :: Monad m => m Bool -> m Bool -> m Bool
and2M ma mb = ifM ma mb (return False)

andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM = Fold.foldr and2M (return True)

allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
allM xs f = andM $ fmap f xs

-- | Lazy monadic disjunction.
or2M :: Monad m => m Bool -> m Bool -> m Bool
or2M ma mb = ifM ma (return True) mb

orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
orM = Fold.foldr or2M (return False)

anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
anyM xs f = orM $ fmap f xs