diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Data/Aeson/Generic/DerivingVia.hs | 160 | ||||
| -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 |
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? |