module Utils.Message
  ( MessageClass(..)
  , UnknownMessageClass(..)
  , Message(..)
  , 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)

import Text.Blaze (preEscapedText)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.HTML.SanitizeXSS (sanitizeBalance)


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"

data UnknownMessageClass = UnknownMessageClass !Text
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance Exception UnknownMessageClass


data Message = Message
  { messageClass :: MessageClass
  , messageContent :: Html
  }

instance Eq Message where
  a == b = ((==) `on` messageClass) a b && ((==) `on` renderHtml . messageContent) a b

instance Ord Message where
  a `compare` b = (compare `on` messageClass) a b `mappend` (compare `on` renderHtml . messageContent) a b

instance ToJSON Message where
  toJSON Message{..} = object
    [ "class" .= messageClass
    , "content" .= renderHtml messageContent
    ]

instance FromJSON Message where
  parseJSON = withObject "Message" $ \o -> do
    messageClass <- o .: "class"
    messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
    return Message{..}


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