1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Messages
( Message(..)
, resolve
, MessageMap(..)
, lookupMessage
-- * Game messages
, messages
, render
, lookup
, message
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (lookup)
--------------------------------------------------------------------------------
import Control.Monad.Random.Class (MonadRandom)
import Data.Aeson (FromJSON, ToJSON, toJSON)
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"
|
