Implement messages

Implement messages almost the same as in the Rust version, only with
YAML instead of TOML this time, and a regular old mustache template
instead of something handrolled. Besides that, pretty much everything
here is the same.

src/Xanthous/App.hs

@@ -4,7 +4,7 @@ import Xanthous.Prelude
 import Brick hiding (App)
 import qualified Brick
 import Graphics.Vty.Attributes (defAttr)
-import Graphics.Vty.Input.Events (Event(EvResize, EvKey))
+import Graphics.Vty.Input.Events (Event(EvKey))
 
 import Xanthous.Game
 import Xanthous.Game.Draw (drawGame)
@@ -32,4 +32,4 @@ handleEvent game _ = continue game
 handleCommand :: Command -> GameState -> EventM Name (Next GameState)
 handleCommand Quit = halt
 handleCommand (Move dir) = continue . (characterPosition %~ move dir)
-handleCommand _ = undefined
+handleCommand _ = error "unimplemented"

src/Xanthous/Game.hs

@@ -16,7 +16,6 @@ import Test.QuickCheck.Arbitrary
 import Xanthous.Data.EntityMap (EntityMap, EntityID)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import Xanthous.Data (Positioned, Position(..), positioned, position)
-import Xanthous.Entities
 import Xanthous.Entities.SomeEntity
 import Xanthous.Entities.Character
 

src/Xanthous/Messages.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Xanthous.Messages
+  ( Message(..)
+  , resolve
+  , MessageMap(..)
+  , lookupMessage
+
+    -- * Game messages
+  , messages
+  , message
+  ) where
+
+import Xanthous.Prelude
+import Data.List.NonEmpty
+import Test.QuickCheck hiding (choose)
+import Test.QuickCheck.Arbitrary.Generic
+import Test.QuickCheck.Instances.UnorderedContainers ()
+import Text.Mustache
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson.Generic.DerivingVia
+import Data.FileEmbed
+import qualified Data.Yaml as Yaml
+import Data.Aeson (toJSON)
+import Control.Monad.Random.Class (MonadRandom)
+
+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
+
+message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text
+message path params = maybe notFound renderMessage $ messages ^? ix path
+  where
+    renderMessage msg = do
+      tpl <- resolve msg
+      pure . toStrict . renderMustache tpl $ toJSON params
+    notFound = pure "Message not found"

src/Xanthous/Orphans.hs

@@ -1,10 +1,23 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 -- |
 
-module Xanthous.Orphans () where
+module Xanthous.Orphans
+  ( ppTemplate
+  ) where
 
-import Xanthous.Prelude
+import Xanthous.Prelude hiding (elements)
+import Text.Mustache
+import Test.QuickCheck
+import Data.Text.Arbitrary ()
+import Text.Megaparsec (errorBundlePretty)
+import Text.Megaparsec.Pos
+import Text.Mustache.Type ( showKey )
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Aeson
 
 instance forall s a.
   ( Cons s s a a
@@ -21,3 +34,121 @@ instance forall s a.
       yon ns = case ns ^? _Cons of
         Nothing -> Left ns
         Just (a, ns') -> Right (a, ns')
+
+instance Arbitrary PName where
+  arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])
+
+instance Arbitrary Key where
+  arbitrary = Key <$> listOf1 arbSafeText
+    where arbSafeText = pack <$> listOf1 (elements ['a'..'z'])
+  shrink (Key []) = error "unreachable"
+  shrink k@(Key [_]) = pure k
+  shrink (Key (p:ps)) = Key . (p :) <$> shrink ps
+
+instance Arbitrary Pos where
+  arbitrary = mkPos . succ . abs <$> arbitrary
+  shrink (unPos -> 1) = []
+  shrink (unPos -> x) = mkPos <$> [x..1]
+
+instance Arbitrary Node where
+  arbitrary = sized node
+    where
+      node n | n > 0 = oneof $ leaves ++ branches (n `div` 2)
+      node _ = oneof leaves
+      branches n =
+        [ Section <$> arbitrary <*> subnodes n
+        , InvertedSection <$> arbitrary <*> subnodes n
+        ]
+      subnodes = fmap concatTextBlocks . listOf . node
+      leaves =
+        [ TextBlock . pack <$> listOf1 (elements ['a'..'z'])
+        , EscapedVar <$> arbitrary
+        , UnescapedVar <$> arbitrary
+        -- TODO fix pretty-printing of mustache partials
+        -- , Partial <$> arbitrary <*> arbitrary
+        ]
+  shrink = genericShrink
+
+concatTextBlocks :: [Node] -> [Node]
+concatTextBlocks [] = []
+concatTextBlocks [x] = [x]
+concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs)
+  = concatTextBlocks $ TextBlock (txt₁ <> txt₂) : concatTextBlocks xs
+concatTextBlocks (x : xs) = x : concatTextBlocks xs
+
+instance Arbitrary Template where
+  arbitrary = do
+    template <- concatTextBlocks <$> arbitrary
+    templateName <- arbitrary
+    rest <- arbitrary
+    pure $ Template
+      { templateActual = templateName
+      , templateCache = rest & at templateName ?~ template
+      }
+  shrink (Template actual cache) =
+    let Just tpl = cache ^. at actual
+    in do
+      cache' <- shrink cache
+      tpl' <- shrink tpl
+      actual' <- shrink actual
+      pure $ Template
+        { templateActual = actual'
+        , templateCache = cache' & at actual' ?~ tpl'
+        }
+
+instance CoArbitrary Template where
+  coarbitrary = coarbitrary . ppTemplate
+
+instance Function Template where
+  function = functionMap ppTemplate parseTemplatePartial
+    where
+      parseTemplatePartial txt
+        = compileMustacheText "template" txt ^?! _Right
+
+instance Arbitrary a => Arbitrary (NonEmpty a) where
+  arbitrary = do
+    x <- arbitrary
+    xs <- arbitrary
+    pure $ x :| xs
+
+instance CoArbitrary a => CoArbitrary (NonEmpty a) where
+  coarbitrary = coarbitrary . toList
+
+instance Function a => Function (NonEmpty a) where
+  function = functionMap toList NonEmpty.fromList
+
+ppNode :: Map PName [Node] -> Node -> Text
+ppNode _ (TextBlock txt) = txt
+ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}"
+ppNode ctx (Section k body) =
+  let sk = showKey k
+  in "{{#" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
+ppNode _ (UnescapedVar k) = "{{{" <> showKey k <> "}}}"
+ppNode ctx (InvertedSection k body) =
+  let sk = showKey k
+  in "{{^" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}"
+ppNode _ (Partial n _) = "{{> " <> unPName n <> "}}"
+
+ppTemplate :: Template -> Text
+ppTemplate (Template actual cache) =
+  case cache ^. at actual of
+    Nothing -> error "Template not found?"
+    Just nodes -> foldMap (ppNode cache) nodes
+
+instance ToJSON Template where
+  toJSON = String . ppTemplate
+
+instance FromJSON Template where
+  parseJSON
+    = withText "Template"
+    $ either (fail . errorBundlePretty) pure
+    . compileMustacheText "template"
+
+instance CoArbitrary Text where
+  coarbitrary = coarbitrary . unpack
+
+instance Function Text where
+  function = functionMap unpack pack
+
+deriving anyclass instance NFData Node
+deriving anyclass instance NFData Template

src/Xanthous/Prelude.hs

@@ -4,6 +4,7 @@ module Xanthous.Prelude
   , Constraint
   , module GHC.TypeLits
   , module Control.Lens
+  , module Data.Void
   ) where
 
 import ClassyPrelude hiding
@@ -11,3 +12,4 @@ import ClassyPrelude hiding
 import Data.Kind
 import GHC.TypeLits hiding (Text)
 import Control.Lens
+import Data.Void

src/Xanthous/Random.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Xanthous.Random
+  ( Choose(..)
+  , ChooseElement(..)
+  ) where
+
+import Xanthous.Prelude
+import Data.List.NonEmpty (NonEmpty)
+import System.Random
+import Control.Monad.Random.Class (MonadRandom(getRandomR))
+
+class Choose a where
+  type RandomResult a
+  choose :: MonadRandom m => a -> m (RandomResult a)
+
+newtype ChooseElement a = ChooseElement a
+
+instance MonoFoldable a => Choose (ChooseElement a) where
+  type RandomResult (ChooseElement a) = Maybe (Element a)
+  choose (ChooseElement xs) = do
+    chosenIdx <- getRandomR (0, olength xs - 1)
+    let pick _ (Just x) = Just x
+        pick (x, i) Nothing
+          | i == chosenIdx = Just x
+          | otherwise = Nothing
+    pure $ ofoldr pick Nothing $ zip (toList xs) [0..]
+
+instance MonoFoldable a => Choose (NonNull a) where
+  type RandomResult (NonNull a) = Element a
+  choose
+    = fmap (fromMaybe (error "unreachable")) -- why not lol
+    . choose
+    . ChooseElement
+    . toNullable
+
+instance Choose (NonEmpty a) where
+  type RandomResult (NonEmpty a) = a
+  choose = choose . fromNonEmpty @[_]

src/Xanthous/messages.yaml

@@ -0,0 +1 @@
+welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside?