66 lines
2.2 KiB
Haskell
66 lines
2.2 KiB
Haskell
module Utils.Message
|
|
( MessageClass(..)
|
|
, addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
|
|
) where
|
|
|
|
|
|
import Data.Universe
|
|
import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
|
|
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
|
|
|
|
$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = toLower
|
|
} ''MessageClass
|
|
|
|
instance PathPiece MessageClass where
|
|
toPathPiece = $(nullaryToPathPiece ''MessageClass [toLower])
|
|
fromPathPiece = finiteFromPathPiece
|
|
|
|
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))
|