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.
This commit is contained in:
parent
4ef19aa35a
commit
2fd3e4c9ad
13 changed files with 587 additions and 17 deletions
22
package.yaml
22
package.yaml
|
@ -15,8 +15,12 @@ category: Game
|
||||||
description: Please see the README on GitHub at <https://github.com/glittershark/xanthous>
|
description: Please see the README on GitHub at <https://github.com/glittershark/xanthous>
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
- QuickCheck
|
|
||||||
- base
|
- base
|
||||||
|
|
||||||
|
- aeson
|
||||||
|
- QuickCheck
|
||||||
|
- quickcheck-text
|
||||||
|
- quickcheck-instances
|
||||||
- brick
|
- brick
|
||||||
- checkers
|
- checkers
|
||||||
- classy-prelude
|
- classy-prelude
|
||||||
|
@ -24,14 +28,24 @@ dependencies:
|
||||||
- containers
|
- containers
|
||||||
- data-default
|
- data-default
|
||||||
- deepseq
|
- deepseq
|
||||||
|
- file-embed
|
||||||
- generic-arbitrary
|
- generic-arbitrary
|
||||||
- generic-monoid
|
- generic-monoid
|
||||||
- groups
|
- groups
|
||||||
- lens
|
- lens
|
||||||
|
- megaparsec
|
||||||
|
- MonadRandom
|
||||||
- mtl
|
- mtl
|
||||||
|
- random
|
||||||
|
- raw-strings-qq
|
||||||
|
- reflection
|
||||||
|
- stache
|
||||||
|
- tomland
|
||||||
- vty
|
- vty
|
||||||
|
- yaml
|
||||||
|
|
||||||
default-extensions:
|
default-extensions:
|
||||||
|
- BlockArguments
|
||||||
- ConstraintKinds
|
- ConstraintKinds
|
||||||
- DataKinds
|
- DataKinds
|
||||||
- DeriveAnyClass
|
- DeriveAnyClass
|
||||||
|
@ -51,13 +65,13 @@ default-extensions:
|
||||||
- PolyKinds
|
- PolyKinds
|
||||||
- RankNTypes
|
- RankNTypes
|
||||||
- ScopedTypeVariables
|
- ScopedTypeVariables
|
||||||
|
- TupleSections
|
||||||
- TypeApplications
|
- TypeApplications
|
||||||
- TypeFamilies
|
- TypeFamilies
|
||||||
- TypeOperators
|
- TypeOperators
|
||||||
|
|
||||||
ghc-options:
|
ghc-options:
|
||||||
- -Wall
|
- -Wall
|
||||||
- -threaded
|
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: src
|
source-dirs: src
|
||||||
|
@ -67,6 +81,10 @@ executable:
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
dependencies:
|
dependencies:
|
||||||
- xanthous
|
- xanthous
|
||||||
|
ghc-options:
|
||||||
|
- -threaded
|
||||||
|
- -rtsopts
|
||||||
|
- -with-rtsopts=-N
|
||||||
|
|
||||||
tests:
|
tests:
|
||||||
test:
|
test:
|
||||||
|
|
160
src/Data/Aeson/Generic/DerivingVia.hs
Normal file
160
src/Data/Aeson/Generic/DerivingVia.hs
Normal file
|
@ -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))
|
|
@ -4,7 +4,7 @@ import Xanthous.Prelude
|
||||||
import Brick hiding (App)
|
import Brick hiding (App)
|
||||||
import qualified Brick
|
import qualified Brick
|
||||||
import Graphics.Vty.Attributes (defAttr)
|
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
|
||||||
import Xanthous.Game.Draw (drawGame)
|
import Xanthous.Game.Draw (drawGame)
|
||||||
|
@ -32,4 +32,4 @@ handleEvent game _ = continue game
|
||||||
handleCommand :: Command -> GameState -> EventM Name (Next GameState)
|
handleCommand :: Command -> GameState -> EventM Name (Next GameState)
|
||||||
handleCommand Quit = halt
|
handleCommand Quit = halt
|
||||||
handleCommand (Move dir) = continue . (characterPosition %~ move dir)
|
handleCommand (Move dir) = continue . (characterPosition %~ move dir)
|
||||||
handleCommand _ = undefined
|
handleCommand _ = error "unimplemented"
|
||||||
|
|
|
@ -16,7 +16,6 @@ import Test.QuickCheck.Arbitrary
|
||||||
import Xanthous.Data.EntityMap (EntityMap, EntityID)
|
import Xanthous.Data.EntityMap (EntityMap, EntityID)
|
||||||
import qualified Xanthous.Data.EntityMap as EntityMap
|
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||||
import Xanthous.Data (Positioned, Position(..), positioned, position)
|
import Xanthous.Data (Positioned, Position(..), positioned, position)
|
||||||
import Xanthous.Entities
|
|
||||||
import Xanthous.Entities.SomeEntity
|
import Xanthous.Entities.SomeEntity
|
||||||
import Xanthous.Entities.Character
|
import Xanthous.Entities.Character
|
||||||
|
|
||||||
|
|
87
src/Xanthous/Messages.hs
Normal file
87
src/Xanthous/Messages.hs
Normal file
|
@ -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"
|
|
@ -1,10 +1,23 @@
|
||||||
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
{-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
|
{-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
|
||||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
{-# 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.
|
instance forall s a.
|
||||||
( Cons s s a a
|
( Cons s s a a
|
||||||
|
@ -21,3 +34,121 @@ instance forall s a.
|
||||||
yon ns = case ns ^? _Cons of
|
yon ns = case ns ^? _Cons of
|
||||||
Nothing -> Left ns
|
Nothing -> Left ns
|
||||||
Just (a, ns') -> Right (a, 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
|
||||||
|
|
|
@ -4,6 +4,7 @@ module Xanthous.Prelude
|
||||||
, Constraint
|
, Constraint
|
||||||
, module GHC.TypeLits
|
, module GHC.TypeLits
|
||||||
, module Control.Lens
|
, module Control.Lens
|
||||||
|
, module Data.Void
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import ClassyPrelude hiding
|
import ClassyPrelude hiding
|
||||||
|
@ -11,3 +12,4 @@ import ClassyPrelude hiding
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
import GHC.TypeLits hiding (Text)
|
import GHC.TypeLits hiding (Text)
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
|
import Data.Void
|
||||||
|
|
40
src/Xanthous/Random.hs
Normal file
40
src/Xanthous/Random.hs
Normal file
|
@ -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 @[_]
|
1
src/Xanthous/messages.yaml
Normal file
1
src/Xanthous/messages.yaml
Normal file
|
@ -0,0 +1 @@
|
||||||
|
welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside?
|
|
@ -2,6 +2,8 @@ import Test.Prelude
|
||||||
import qualified Xanthous.DataSpec
|
import qualified Xanthous.DataSpec
|
||||||
import qualified Xanthous.Data.EntityMapSpec
|
import qualified Xanthous.Data.EntityMapSpec
|
||||||
import qualified Xanthous.GameSpec
|
import qualified Xanthous.GameSpec
|
||||||
|
import qualified Xanthous.MessageSpec
|
||||||
|
import qualified Xanthous.OrphansSpec
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = defaultMain test
|
main = defaultMain test
|
||||||
|
@ -11,4 +13,6 @@ test = testGroup "Xanthous"
|
||||||
[ Xanthous.DataSpec.test
|
[ Xanthous.DataSpec.test
|
||||||
, Xanthous.Data.EntityMapSpec.test
|
, Xanthous.Data.EntityMapSpec.test
|
||||||
, Xanthous.GameSpec.test
|
, Xanthous.GameSpec.test
|
||||||
|
, Xanthous.MessageSpec.test
|
||||||
|
, Xanthous.OrphansSpec.test
|
||||||
]
|
]
|
||||||
|
|
53
test/Xanthous/MessageSpec.hs
Normal file
53
test/Xanthous/MessageSpec.hs
Normal file
|
@ -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 ()
|
||||||
|
]
|
||||||
|
]
|
31
test/Xanthous/OrphansSpec.hs
Normal file
31
test/Xanthous/OrphansSpec.hs
Normal file
|
@ -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
|
||||||
|
]
|
||||||
|
]
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: d069cdc1d0657c9b140465b8156b86722d399db49289c8352cccb2a70ab548e0
|
-- hash: d86e44c1f3fe890c699f9af19ae10b013973d1cb6e79cc403d6e1c35a74c99c1
|
||||||
|
|
||||||
name: xanthous
|
name: xanthous
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -28,6 +28,7 @@ source-repository head
|
||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
|
Data.Aeson.Generic.DerivingVia
|
||||||
Main
|
Main
|
||||||
Xanthous.App
|
Xanthous.App
|
||||||
Xanthous.Command
|
Xanthous.Command
|
||||||
|
@ -38,18 +39,22 @@ library
|
||||||
Xanthous.Entities.SomeEntity
|
Xanthous.Entities.SomeEntity
|
||||||
Xanthous.Game
|
Xanthous.Game
|
||||||
Xanthous.Game.Draw
|
Xanthous.Game.Draw
|
||||||
|
Xanthous.Messages
|
||||||
Xanthous.Orphans
|
Xanthous.Orphans
|
||||||
Xanthous.Prelude
|
Xanthous.Prelude
|
||||||
|
Xanthous.Random
|
||||||
Xanthous.Resource
|
Xanthous.Resource
|
||||||
Xanthous.Util
|
Xanthous.Util
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_xanthous
|
Paths_xanthous
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
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
|
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
|
ghc-options: -Wall
|
||||||
build-depends:
|
build-depends:
|
||||||
QuickCheck
|
MonadRandom
|
||||||
|
, QuickCheck
|
||||||
|
, aeson
|
||||||
, base
|
, base
|
||||||
, brick
|
, brick
|
||||||
, checkers
|
, checkers
|
||||||
|
@ -58,17 +63,28 @@ library
|
||||||
, containers
|
, containers
|
||||||
, data-default
|
, data-default
|
||||||
, deepseq
|
, deepseq
|
||||||
|
, file-embed
|
||||||
, generic-arbitrary
|
, generic-arbitrary
|
||||||
, generic-monoid
|
, generic-monoid
|
||||||
, groups
|
, groups
|
||||||
, lens
|
, lens
|
||||||
|
, megaparsec
|
||||||
, mtl
|
, mtl
|
||||||
|
, quickcheck-instances
|
||||||
|
, quickcheck-text
|
||||||
|
, random
|
||||||
|
, raw-strings-qq
|
||||||
|
, reflection
|
||||||
|
, stache
|
||||||
|
, tomland
|
||||||
, vty
|
, vty
|
||||||
|
, yaml
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
executable xanthous
|
executable xanthous
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Data.Aeson.Generic.DerivingVia
|
||||||
Xanthous.App
|
Xanthous.App
|
||||||
Xanthous.Command
|
Xanthous.Command
|
||||||
Xanthous.Data
|
Xanthous.Data
|
||||||
|
@ -78,17 +94,21 @@ executable xanthous
|
||||||
Xanthous.Entities.SomeEntity
|
Xanthous.Entities.SomeEntity
|
||||||
Xanthous.Game
|
Xanthous.Game
|
||||||
Xanthous.Game.Draw
|
Xanthous.Game.Draw
|
||||||
|
Xanthous.Messages
|
||||||
Xanthous.Orphans
|
Xanthous.Orphans
|
||||||
Xanthous.Prelude
|
Xanthous.Prelude
|
||||||
|
Xanthous.Random
|
||||||
Xanthous.Resource
|
Xanthous.Resource
|
||||||
Xanthous.Util
|
Xanthous.Util
|
||||||
Paths_xanthous
|
Paths_xanthous
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
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
|
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
|
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
QuickCheck
|
MonadRandom
|
||||||
|
, QuickCheck
|
||||||
|
, aeson
|
||||||
, base
|
, base
|
||||||
, brick
|
, brick
|
||||||
, checkers
|
, checkers
|
||||||
|
@ -97,13 +117,23 @@ executable xanthous
|
||||||
, containers
|
, containers
|
||||||
, data-default
|
, data-default
|
||||||
, deepseq
|
, deepseq
|
||||||
|
, file-embed
|
||||||
, generic-arbitrary
|
, generic-arbitrary
|
||||||
, generic-monoid
|
, generic-monoid
|
||||||
, groups
|
, groups
|
||||||
, lens
|
, lens
|
||||||
|
, megaparsec
|
||||||
, mtl
|
, mtl
|
||||||
|
, quickcheck-instances
|
||||||
|
, quickcheck-text
|
||||||
|
, random
|
||||||
|
, raw-strings-qq
|
||||||
|
, reflection
|
||||||
|
, stache
|
||||||
|
, tomland
|
||||||
, vty
|
, vty
|
||||||
, xanthous
|
, xanthous
|
||||||
|
, yaml
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
test-suite test
|
test-suite test
|
||||||
|
@ -114,13 +144,17 @@ test-suite test
|
||||||
Xanthous.Data.EntityMapSpec
|
Xanthous.Data.EntityMapSpec
|
||||||
Xanthous.DataSpec
|
Xanthous.DataSpec
|
||||||
Xanthous.GameSpec
|
Xanthous.GameSpec
|
||||||
|
Xanthous.MessageSpec
|
||||||
|
Xanthous.OrphansSpec
|
||||||
Paths_xanthous
|
Paths_xanthous
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
test
|
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
|
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 -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
QuickCheck
|
MonadRandom
|
||||||
|
, QuickCheck
|
||||||
|
, aeson
|
||||||
, base
|
, base
|
||||||
, brick
|
, brick
|
||||||
, checkers
|
, checkers
|
||||||
|
@ -129,15 +163,25 @@ test-suite test
|
||||||
, containers
|
, containers
|
||||||
, data-default
|
, data-default
|
||||||
, deepseq
|
, deepseq
|
||||||
|
, file-embed
|
||||||
, generic-arbitrary
|
, generic-arbitrary
|
||||||
, generic-monoid
|
, generic-monoid
|
||||||
, groups
|
, groups
|
||||||
, lens
|
, lens
|
||||||
, lens-properties
|
, lens-properties
|
||||||
|
, megaparsec
|
||||||
, mtl
|
, mtl
|
||||||
|
, quickcheck-instances
|
||||||
|
, quickcheck-text
|
||||||
|
, random
|
||||||
|
, raw-strings-qq
|
||||||
|
, reflection
|
||||||
|
, stache
|
||||||
, tasty
|
, tasty
|
||||||
, tasty-hunit
|
, tasty-hunit
|
||||||
, tasty-quickcheck
|
, tasty-quickcheck
|
||||||
|
, tomland
|
||||||
, vty
|
, vty
|
||||||
, xanthous
|
, xanthous
|
||||||
|
, yaml
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
Loading…
Reference in a new issue