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.

8 files changed, 425 insertions, 5 deletions

diff --git a/src/Data/Aeson/Generic/DerivingVia.hs b/src/Data/Aeson/Generic/DerivingVia.hs
new file mode 100644
index 000000000000..f387f1deccb1
--- /dev/null
+++ b/src/Data/Aeson/Generic/DerivingVia.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE ConstraintKinds, DataKinds, DeriveGeneric, DerivingVia    #-}
+{-# LANGUAGE ExplicitNamespaces, FlexibleContexts, FlexibleInstances   #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses  #-}
+{-# LANGUAGE PolyKinds, ScopedTypeVariables, StandaloneDeriving        #-}
+{-# LANGUAGE TypeApplications, TypeFamilies, TypeInType, TypeOperators #-}
+{-# LANGUAGE UndecidableInstances                                      #-}
+{-# OPTIONS_GHC -Wall #-}
+-- | https://gist.github.com/konn/27c00f784dd883ec2b90eab8bc84a81d
+module Data.Aeson.Generic.DerivingVia
+     ( StrFun(..), Setting(..), SumEncoding'(..), DefaultOptions, WithOptions(..)
+     , -- Utility type synonyms to save ticks (') before promoted data constructors
+       type Drop, type CamelTo2, type UserDefined
+     , type TaggedObj, type UntaggedVal, type ObjWithSingleField, type TwoElemArr
+     , type FieldLabelModifier
+     , type ConstructorTagModifier
+     , type AllNullaryToStringTag
+     , type OmitNothingFields
+     , type SumEnc
+     , type UnwrapUnaryRecords
+     , type TagSingleConstructors
+     )
+  where
+
+import           Prelude
+import           Data.Aeson      (FromJSON (..), GFromJSON, GToJSON,
+                                  ToJSON (..))
+import           Data.Aeson      (Options (..), Zero, camelTo2,
+                                  genericParseJSON)
+import           Data.Aeson      (defaultOptions, genericToJSON)
+import qualified Data.Aeson      as Aeson
+import           Data.Kind       (Constraint, Type)
+import           Data.Proxy      (Proxy (..))
+import           Data.Reflection (Reifies (..))
+import           GHC.Generics    (Generic, Rep)
+import           GHC.TypeLits    (KnownNat, KnownSymbol, natVal, symbolVal)
+import           GHC.TypeLits    (Nat, Symbol)
+
+newtype WithOptions options a = WithOptions { runWithOptions :: a }
+
+data StrFun = Drop     Nat
+            | CamelTo2 Symbol
+            | forall p. UserDefined p
+
+type Drop = 'Drop
+type CamelTo2 = 'CamelTo2
+type UserDefined = 'UserDefined
+
+type family Demoted a where
+  Demoted Symbol  = String
+  Demoted StrFun  = String -> String
+  Demoted [a]     = [Demoted a]
+  Demoted Setting = Options -> Options
+  Demoted SumEncoding' = Aeson.SumEncoding
+  Demoted a = a
+
+data SumEncoding' = TaggedObj {tagFieldName' :: Symbol, contentsFieldName :: Symbol }
+                  | UntaggedVal
+                  | ObjWithSingleField
+                  | TwoElemArr
+
+type TaggedObj          = 'TaggedObj
+type UntaggedVal        = 'UntaggedVal
+type ObjWithSingleField = 'ObjWithSingleField
+type TwoElemArr         = 'TwoElemArr
+
+data Setting = FieldLabelModifier     [StrFun]
+             | ConstructorTagModifier [StrFun]
+             | AllNullaryToStringTag  Bool
+             | OmitNothingFields      Bool
+             | SumEnc                 SumEncoding'
+             | UnwrapUnaryRecords     Bool
+             | TagSingleConstructors  Bool
+
+type FieldLabelModifier     = 'FieldLabelModifier
+type ConstructorTagModifier = 'ConstructorTagModifier
+type AllNullaryToStringTag  = 'AllNullaryToStringTag
+type OmitNothingFields      = 'OmitNothingFields
+type SumEnc                 = 'SumEnc
+type UnwrapUnaryRecords     = 'UnwrapUnaryRecords
+type TagSingleConstructors  = 'TagSingleConstructors
+
+class Demotable (a :: k) where
+  demote :: proxy a -> Demoted k
+
+type family All (p :: Type -> Constraint) (xs :: [k]) :: Constraint where
+  All p '[] = ()
+  All p (x ': xs) = (p x, All p xs)
+
+instance Reifies f (String -> String) => Demotable ('UserDefined f) where
+  demote _ = reflect @f Proxy
+
+instance KnownSymbol sym => Demotable sym where
+  demote = symbolVal
+
+instance (KnownSymbol s, KnownSymbol t) => Demotable ('TaggedObj s t) where
+  demote _ = Aeson.TaggedObject (symbolVal @s Proxy) (symbolVal @t Proxy)
+
+instance Demotable 'UntaggedVal where
+  demote _ = Aeson.UntaggedValue
+
+instance Demotable 'ObjWithSingleField where
+  demote _ = Aeson.ObjectWithSingleField
+
+instance Demotable 'TwoElemArr where
+  demote _ = Aeson.TwoElemArray
+
+instance Demotable xs => Demotable ('FieldLabelModifier xs) where
+  demote _ o = o { fieldLabelModifier = foldr (.) id (demote (Proxy @xs)) }
+
+instance Demotable xs => Demotable ('ConstructorTagModifier xs) where
+  demote _ o = o { constructorTagModifier = foldr (.) id (demote (Proxy @xs)) }
+
+instance Demotable b => Demotable ('AllNullaryToStringTag b) where
+  demote _ o = o { allNullaryToStringTag = demote (Proxy @b) }
+
+instance Demotable b => Demotable ('OmitNothingFields b) where
+  demote _ o = o { omitNothingFields = demote (Proxy @b) }
+
+instance Demotable b => Demotable ('UnwrapUnaryRecords b) where
+  demote _ o = o { unwrapUnaryRecords = demote (Proxy @b) }
+
+instance Demotable b => Demotable ('TagSingleConstructors b) where
+  demote _ o = o { tagSingleConstructors = demote (Proxy @b) }
+
+instance Demotable b => Demotable ('SumEnc b) where
+  demote _ o = o { sumEncoding = demote (Proxy @b) }
+
+instance Demotable 'True where
+  demote _ = True
+
+instance Demotable 'False where
+  demote _ = False
+
+instance KnownNat n => Demotable ('Drop n) where
+  demote _ = drop (fromIntegral $ natVal (Proxy :: Proxy n))
+
+instance KnownSymbol sym => Demotable ('CamelTo2 sym) where
+  demote _ = camelTo2 $ head $ symbolVal @sym Proxy
+
+instance {-# OVERLAPPING #-} Demotable ('[] :: [k]) where
+  demote _ = []
+
+instance (Demotable (x :: k), Demotable (xs :: [k])) => Demotable (x ': xs) where
+  demote _ = demote (Proxy @x) : demote (Proxy @xs)
+
+type DefaultOptions = ('[] :: [Setting])
+
+reflectOptions :: forall xs proxy. Demotable (xs :: [Setting]) => proxy xs -> Options
+reflectOptions pxy = foldr (.) id (demote pxy) defaultOptions
+
+instance (Demotable (options :: [Setting])) => Reifies options Options where
+  reflect = reflectOptions
+
+instance (Generic a, GToJSON Zero (Rep a), Reifies (options :: k) Options)
+       => ToJSON (WithOptions options a) where
+  toJSON = genericToJSON (reflect (Proxy @options)) . runWithOptions
+
+instance (Generic a, GFromJSON Zero (Rep a), Reifies (options :: k) Options)
+       => FromJSON (WithOptions options a) where
+  parseJSON = fmap WithOptions . genericParseJSON (reflect (Proxy @options))
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index bf5ec68abb0d..ae88a746cec6 100644
--- a/src/Xanthous/App.hs
+++ b/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"
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index 3ca00afbbda1..f30f7534392f 100644
--- a/src/Xanthous/Game.hs
+++ b/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
 
diff --git a/src/Xanthous/Messages.hs b/src/Xanthous/Messages.hs
new file mode 100644
index 000000000000..4ff46ba3f5e7
--- /dev/null
+++ b/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"
diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs
index 232eabf4efb1..d2e378cd2817 100644
--- a/src/Xanthous/Orphans.hs
+++ b/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
diff --git a/src/Xanthous/Prelude.hs b/src/Xanthous/Prelude.hs
index b769c4fe9007..20970809754b 100644
--- a/src/Xanthous/Prelude.hs
+++ b/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
diff --git a/src/Xanthous/Random.hs b/src/Xanthous/Random.hs
new file mode 100644
index 000000000000..a3a1124f2780
--- /dev/null
+++ b/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 @[_]
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
new file mode 100644
index 000000000000..d383cf619603
--- /dev/null
+++ b/src/Xanthous/messages.yaml
@@ -0,0 +1 @@
+welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside?