diff options
Diffstat (limited to 'src/Xanthous')
| -rw-r--r-- | src/Xanthous/App.hs | 4 | ||||
| -rw-r--r-- | src/Xanthous/Game.hs | 1 | ||||
| -rw-r--r-- | src/Xanthous/Messages.hs | 87 | ||||
| -rw-r--r-- | src/Xanthous/Orphans.hs | 135 | ||||
| -rw-r--r-- | src/Xanthous/Prelude.hs | 2 | ||||
| -rw-r--r-- | src/Xanthous/Random.hs | 40 | ||||
| -rw-r--r-- | src/Xanthous/messages.yaml | 1 |
7 files changed, 265 insertions, 5 deletions
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? |