{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-}

module Utils
  ( module Utils
  ) where

import ClassyPrelude.Yesod

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

import Utils.DB as Utils
import Utils.Common 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)


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



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


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