2edb963b97
git-subtree-dir: users/glittershark/xanthous git-subtree-mainline:91f53f02d8git-subtree-split:53b56744f4
107 lines
3.6 KiB
Haskell
107 lines
3.6 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
--------------------------------------------------------------------------------
|
|
module Xanthous.Messages
|
|
( Message(..)
|
|
, resolve
|
|
, MessageMap(..)
|
|
, lookupMessage
|
|
|
|
-- * Game messages
|
|
, messages
|
|
, render
|
|
, lookup
|
|
, message
|
|
, message_
|
|
) where
|
|
--------------------------------------------------------------------------------
|
|
import Xanthous.Prelude hiding (lookup)
|
|
--------------------------------------------------------------------------------
|
|
import Control.Monad.Random.Class (MonadRandom)
|
|
import Data.Aeson (FromJSON, ToJSON, toJSON)
|
|
import qualified Data.Aeson as JSON
|
|
import Data.Aeson.Generic.DerivingVia
|
|
import Data.FileEmbed
|
|
import Data.List.NonEmpty
|
|
import Test.QuickCheck hiding (choose)
|
|
import Test.QuickCheck.Arbitrary.Generic
|
|
import Test.QuickCheck.Instances.UnorderedContainers ()
|
|
import Text.Mustache
|
|
import qualified Data.Yaml as Yaml
|
|
--------------------------------------------------------------------------------
|
|
import Xanthous.Random
|
|
import Xanthous.Orphans ()
|
|
--------------------------------------------------------------------------------
|
|
|
|
data Message = Single Template | Choice (NonEmpty Template)
|
|
deriving stock (Show, Eq, Ord, Generic)
|
|
deriving anyclass (CoArbitrary, Function, NFData)
|
|
deriving (ToJSON, FromJSON)
|
|
via WithOptions '[ SumEnc UntaggedVal ]
|
|
Message
|
|
|
|
instance Arbitrary Message where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
resolve :: MonadRandom m => Message -> m Template
|
|
resolve (Single t) = pure t
|
|
resolve (Choice ts) = choose ts
|
|
|
|
data MessageMap = Direct Message | Nested (HashMap Text MessageMap)
|
|
deriving stock (Show, Eq, Ord, Generic)
|
|
deriving anyclass (CoArbitrary, Function, NFData)
|
|
deriving (ToJSON, FromJSON)
|
|
via WithOptions '[ SumEnc UntaggedVal ]
|
|
MessageMap
|
|
|
|
instance Arbitrary MessageMap where
|
|
arbitrary = frequency [ (10, Direct <$> arbitrary)
|
|
, (1, Nested <$> arbitrary)
|
|
]
|
|
|
|
lookupMessage :: [Text] -> MessageMap -> Maybe Message
|
|
lookupMessage [] (Direct msg) = Just msg
|
|
lookupMessage (k:ks) (Nested m) = lookupMessage ks =<< m ^. at k
|
|
lookupMessage _ _ = Nothing
|
|
|
|
type instance Index MessageMap = [Text]
|
|
type instance IxValue MessageMap = Message
|
|
instance Ixed MessageMap where
|
|
ix [] f (Direct msg) = Direct <$> f msg
|
|
ix (k:ks) f (Nested m) = case m ^. at k of
|
|
Just m' -> ix ks f m' <&> \m'' ->
|
|
Nested $ m & at k ?~ m''
|
|
Nothing -> pure $ Nested m
|
|
ix _ _ m = pure m
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
rawMessages :: ByteString
|
|
rawMessages = $(embedFile "src/Xanthous/messages.yaml")
|
|
|
|
messages :: MessageMap
|
|
messages
|
|
= either (error . Yaml.prettyPrintParseException) id
|
|
$ Yaml.decodeEither' rawMessages
|
|
|
|
render :: (MonadRandom m, ToJSON params) => Message -> params -> m Text
|
|
render msg params = do
|
|
tpl <- resolve msg
|
|
pure . toStrict . renderMustache tpl $ toJSON params
|
|
|
|
lookup :: [Text] -> Message
|
|
lookup path = fromMaybe notFound $ messages ^? ix path
|
|
where notFound
|
|
= Single
|
|
$ compileMustacheText "template" "Message not found"
|
|
^?! _Right
|
|
|
|
message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text
|
|
message path params = maybe notFound (`render` params) $ messages ^? ix path
|
|
where
|
|
notFound = pure "Message not found"
|
|
|
|
message_ :: (MonadRandom m) => [Text] -> m Text
|
|
message_ path = maybe notFound (`render` JSON.object []) $ messages ^? ix path
|
|
where
|
|
notFound = pure "Message not found"
|