Add 'users/glittershark/xanthous/' from commit '53b56744f4335c038724a1bcffc27a7eb8cf6a6d' r/978

git-subtree-dir: users/glittershark/xanthous
git-subtree-mainline: 91f53f02d8479303910abfd3f3690d3ef27e6c4b
git-subtree-split: 53b56744f4335c038724a1bcffc27a7eb8cf6a6d

1 files changed, 107 insertions, 0 deletions

diff --git a/users/glittershark/xanthous/src/Xanthous/Messages.hs b/users/glittershark/xanthous/src/Xanthous/Messages.hs
new file mode 100644
index 000000000000..2b1b3da1e8c1
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Messages.hs
@@ -0,0 +1,107 @@
+{-# 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"