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.

13 files changed, 587 insertions, 17 deletions

diff --git a/package.yaml b/package.yaml
index cc5002d80f..2aa6bd9b58 100644
--- a/package.yaml
+++ b/package.yaml
@@ -15,8 +15,12 @@ category:            Game
 description:         Please see the README on GitHub at <https://github.com/glittershark/xanthous>
 
 dependencies:
-- QuickCheck
 - base
+
+- aeson
+- QuickCheck
+- quickcheck-text
+- quickcheck-instances
 - brick
 - checkers
 - classy-prelude
@@ -24,14 +28,24 @@ dependencies:
 - containers
 - data-default
 - deepseq
+- file-embed
 - generic-arbitrary
 - generic-monoid
 - groups
 - lens
+- megaparsec
+- MonadRandom
 - mtl
+- random
+- raw-strings-qq
+- reflection
+- stache
+- tomland
 - vty
+- yaml
 
 default-extensions:
+- BlockArguments
 - ConstraintKinds
 - DataKinds
 - DeriveAnyClass
@@ -51,13 +65,13 @@ default-extensions:
 - PolyKinds
 - RankNTypes
 - ScopedTypeVariables
+- TupleSections
 - TypeApplications
 - TypeFamilies
 - TypeOperators
 
 ghc-options:
 - -Wall
-- -threaded
 
 library:
   source-dirs: src
@@ -67,6 +81,10 @@ executable:
   main: Main.hs
   dependencies:
   - xanthous
+  ghc-options:
+  - -threaded
+  - -rtsopts
+  - -with-rtsopts=-N
 
 tests:
   test:
diff --git a/src/Data/Aeson/Generic/DerivingVia.hs b/src/Data/Aeson/Generic/DerivingVia.hs
new file mode 100644
index 0000000000..f387f1decc
--- /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 bf5ec68abb..ae88a746ce 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 3ca00afbbd..f30f753439 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 0000000000..4ff46ba3f5
--- /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 232eabf4ef..d2e378cd28 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 b769c4fe90..2097080975 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 0000000000..a3a1124f27
--- /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 0000000000..d383cf6196
--- /dev/null
+++ b/src/Xanthous/messages.yaml
@@ -0,0 +1 @@
+welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside?
diff --git a/test/Spec.hs b/test/Spec.hs
index c9f3150a74..6f955aa696 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -2,6 +2,8 @@ import Test.Prelude
 import qualified Xanthous.DataSpec
 import qualified Xanthous.Data.EntityMapSpec
 import qualified Xanthous.GameSpec
+import qualified Xanthous.MessageSpec
+import qualified Xanthous.OrphansSpec
 
 main :: IO ()
 main = defaultMain test
@@ -11,4 +13,6 @@ test = testGroup "Xanthous"
   [ Xanthous.DataSpec.test
   , Xanthous.Data.EntityMapSpec.test
   , Xanthous.GameSpec.test
+  , Xanthous.MessageSpec.test
+  , Xanthous.OrphansSpec.test
   ]
diff --git a/test/Xanthous/MessageSpec.hs b/test/Xanthous/MessageSpec.hs
new file mode 100644
index 0000000000..b681e537ef
--- /dev/null
+++ b/test/Xanthous/MessageSpec.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedLists #-}
+module Xanthous.MessageSpec ( main, test ) where
+
+import Test.Prelude
+import Xanthous.Messages
+import Data.Aeson
+import Text.Mustache
+import Control.Lens.Properties
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Messages"
+  [ testGroup "Message"
+    [ testGroup "JSON decoding"
+      [ testCase "Single"
+        $ decode "\"Test Single Template\""
+        @?= Just (Single
+                  $ compileMustacheText "template" "Test Single Template"
+                  ^?! _Right)
+      , testCase "Choice"
+        $ decode "[\"Choice 1\", \"Choice 2\"]"
+        @?= Just
+            (Choice
+            [ compileMustacheText "template" "Choice 1" ^?! _Right
+            , compileMustacheText "template" "Choice 2" ^?! _Right
+            ])
+      ]
+    ]
+  , localOption (QuickCheckTests 50)
+  . localOption (QuickCheckMaxSize 10)
+  $ testGroup "MessageMap"
+    [ testGroup "instance Ixed"
+        [ testProperty "traversal laws" $ \k ->
+            isTraversal $ ix @MessageMap k
+        , testCase "preview when exists" $
+          let
+            Right tpl = compileMustacheText "foo" "bar"
+            msg = Single tpl
+            mm = Nested $ [("foo", Direct msg)]
+          in mm ^? ix ["foo"] @?= Just msg
+        ]
+    , testGroup "lookupMessage"
+      [ testProperty "is equivalent to preview ix" $ \msgMap path ->
+          lookupMessage path msgMap === msgMap ^? ix path
+      ]
+    ]
+
+  , testGroup "Messages"
+    [ testCase "are all valid" $ messages `deepseq` pure ()
+    ]
+  ]
diff --git a/test/Xanthous/OrphansSpec.hs b/test/Xanthous/OrphansSpec.hs
new file mode 100644
index 0000000000..3fe79ee563
--- /dev/null
+++ b/test/Xanthous/OrphansSpec.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE BlockArguments #-}
+module Xanthous.OrphansSpec where
+
+import Test.Prelude
+import Xanthous.Orphans
+import Text.Mustache
+import Text.Megaparsec (errorBundlePretty)
+
+import Xanthous.Orphans ()
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Orphans"
+  [ localOption (QuickCheckTests 50)
+  . localOption (QuickCheckMaxSize 10)
+  $ testGroup "Template"
+    [ testProperty "ppTemplate / compileMustacheText " \tpl ->
+        let src = ppTemplate tpl
+            res :: Either String Template
+            res = over _Left errorBundlePretty
+                $ compileMustacheText (templateActual tpl) src
+            expected = templateCache tpl ^?! at (templateActual tpl)
+        in
+          counterexample (unpack src)
+          $ Right expected === do
+            (Template actual cache) <- res
+            maybe (Left "Template not found") Right $ cache ^? at actual
+    ]
+  ]
diff --git a/xanthous.cabal b/xanthous.cabal
index 162540b202..4fe938b40b 100644
--- a/xanthous.cabal
+++ b/xanthous.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: d069cdc1d0657c9b140465b8156b86722d399db49289c8352cccb2a70ab548e0
+-- hash: d86e44c1f3fe890c699f9af19ae10b013973d1cb6e79cc403d6e1c35a74c99c1
 
 name:           xanthous
 version:        0.1.0.0
@@ -28,6 +28,7 @@ source-repository head
 
 library
   exposed-modules:
+      Data.Aeson.Generic.DerivingVia
       Main
       Xanthous.App
       Xanthous.Command
@@ -38,18 +39,22 @@ library
       Xanthous.Entities.SomeEntity
       Xanthous.Game
       Xanthous.Game.Draw
+      Xanthous.Messages
       Xanthous.Orphans
       Xanthous.Prelude
+      Xanthous.Random
       Xanthous.Resource
       Xanthous.Util
   other-modules:
       Paths_xanthous
   hs-source-dirs:
       src
-  default-extensions: ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators
-  ghc-options: -Wall -threaded
+  default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
+  ghc-options: -Wall
   build-depends:
-      QuickCheck
+      MonadRandom
+    , QuickCheck
+    , aeson
     , base
     , brick
     , checkers
@@ -58,17 +63,28 @@ library
     , containers
     , data-default
     , deepseq
+    , file-embed
     , generic-arbitrary
     , generic-monoid
     , groups
     , lens
+    , megaparsec
     , mtl
+    , quickcheck-instances
+    , quickcheck-text
+    , random
+    , raw-strings-qq
+    , reflection
+    , stache
+    , tomland
     , vty
+    , yaml
   default-language: Haskell2010
 
 executable xanthous
   main-is: Main.hs
   other-modules:
+      Data.Aeson.Generic.DerivingVia
       Xanthous.App
       Xanthous.Command
       Xanthous.Data
@@ -78,17 +94,21 @@ executable xanthous
       Xanthous.Entities.SomeEntity
       Xanthous.Game
       Xanthous.Game.Draw
+      Xanthous.Messages
       Xanthous.Orphans
       Xanthous.Prelude
+      Xanthous.Random
       Xanthous.Resource
       Xanthous.Util
       Paths_xanthous
   hs-source-dirs:
       src
-  default-extensions: ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators
-  ghc-options: -Wall -threaded
+  default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      QuickCheck
+      MonadRandom
+    , QuickCheck
+    , aeson
     , base
     , brick
     , checkers
@@ -97,13 +117,23 @@ executable xanthous
     , containers
     , data-default
     , deepseq
+    , file-embed
     , generic-arbitrary
     , generic-monoid
     , groups
     , lens
+    , megaparsec
     , mtl
+    , quickcheck-instances
+    , quickcheck-text
+    , random
+    , raw-strings-qq
+    , reflection
+    , stache
+    , tomland
     , vty
     , xanthous
+    , yaml
   default-language: Haskell2010
 
 test-suite test
@@ -114,13 +144,17 @@ test-suite test
       Xanthous.Data.EntityMapSpec
       Xanthous.DataSpec
       Xanthous.GameSpec
+      Xanthous.MessageSpec
+      Xanthous.OrphansSpec
       Paths_xanthous
   hs-source-dirs:
       test
-  default-extensions: ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators
-  ghc-options: -Wall -threaded -threaded -rtsopts -with-rtsopts=-N
+  default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      QuickCheck
+      MonadRandom
+    , QuickCheck
+    , aeson
     , base
     , brick
     , checkers
@@ -129,15 +163,25 @@ test-suite test
     , containers
     , data-default
     , deepseq
+    , file-embed
     , generic-arbitrary
     , generic-monoid
     , groups
     , lens
     , lens-properties
+    , megaparsec
     , mtl
+    , quickcheck-instances
+    , quickcheck-text
+    , random
+    , raw-strings-qq
+    , reflection
+    , stache
     , tasty
     , tasty-hunit
     , tasty-quickcheck
+    , tomland
     , vty
     , xanthous
+    , yaml
   default-language: Haskell2010