module Utils.Message
  ( MessageClass(..)
  , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
  ) where


import Data.Universe
import Utils.PathPiece
import Data.Aeson
import Data.Aeson.TH

import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
import ClassyPrelude.Yesod hiding (addMessage, addMessageI)

import Text.Hamlet

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


data MessageClass = Error | Warning | Info | Success
  deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift)

instance Universe MessageClass
instance Finite   MessageClass

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece
  } ''MessageClass

nullaryPathPiece ''MessageClass camelToPathPiece
derivePersistField "MessageClass"


addMessage :: MonadHandler m => MessageClass-> Html -> m ()
addMessage mc  = ClassyPrelude.Yesod.addMessage  (toPathPiece mc)

addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)

addMessageIHamlet :: ( MonadHandler m
                     , RenderMessage (HandlerSite m) msg
                     , HandlerSite m ~ site
                     ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m ()
addMessageIHamlet mc iHamlet = do
  mr <- getMessageRender
  ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)

addMessageFile :: MessageClass -> FilePath -> ExpQ
addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]

addMessageWidget :: forall m site.
                    ( MonadHandler m
                    , HandlerSite m ~ site
                    , Yesod site
                    ) => MessageClass -> WidgetT site IO () -> m ()
-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
addMessageWidget mc wgt = do
  PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
  addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))