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

module Utils
  ( module Utils
  ) where

import ClassyPrelude.Yesod

import Data.List (foldl)
import Data.Foldable as Fold
import qualified Data.Char as Char

import Utils.DB as Utils
import Utils.Common as Utils
import Utils.DateTime as Utils

import Text.Blaze (Markup, ToMarkup)

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

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



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

tickmark :: IsString a => a
tickmark = fromString "✔"

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

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

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


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)


uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "camel-case-thing"
uncamel = ("theme-" ++) . reverse . foldl helper []
  where
    helper _   '.' = []
    helper acc  c
      | Char.isSpace c = acc
      | Char.isUpper c = Char.toLower c : '-' : acc
      | otherwise      = c : acc

camelSpace :: String -> String -- "Model.Theme.CamelCaseThing" -> "Camel Case Thing"
camelSpace = reverse . foldl helper []
  where
    helper _   '.' = []
    helper acc  c
      | Char.isSpace c = acc
      | Char.isUpper c = c : ' ' : acc
      | otherwise      = c : acc

-- Convert anything to Text, and I don't care how
class DisplayAble a where
  display :: a -> Text

instance DisplayAble Text where
  display = id

instance DisplayAble String where
  display = pack

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

-- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where
  display = pack . show



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


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


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

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

---------------
-- 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 op = do
  x <- mx
  case sc x of
    True  -> return x
    False -> op <$> pure x <*> my


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

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