From 2fd3e4c9ad28b77a0d167ceefe879ca80ee1ee04 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 1 Sep 2019 13:54:27 -0400 Subject: 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. --- package.yaml | 22 ++++- src/Data/Aeson/Generic/DerivingVia.hs | 160 ++++++++++++++++++++++++++++++++++ src/Xanthous/App.hs | 4 +- src/Xanthous/Game.hs | 1 - src/Xanthous/Messages.hs | 87 ++++++++++++++++++ src/Xanthous/Orphans.hs | 135 +++++++++++++++++++++++++++- src/Xanthous/Prelude.hs | 2 + src/Xanthous/Random.hs | 40 +++++++++ src/Xanthous/messages.yaml | 1 + test/Spec.hs | 4 + test/Xanthous/MessageSpec.hs | 53 +++++++++++ test/Xanthous/OrphansSpec.hs | 31 +++++++ xanthous.cabal | 64 +++++++++++--- 13 files changed, 587 insertions(+), 17 deletions(-) create mode 100644 src/Data/Aeson/Generic/DerivingVia.hs create mode 100644 src/Xanthous/Messages.hs create mode 100644 src/Xanthous/Random.hs create mode 100644 src/Xanthous/messages.yaml create mode 100644 test/Xanthous/MessageSpec.hs create mode 100644 test/Xanthous/OrphansSpec.hs diff --git a/package.yaml b/package.yaml index cc5002d80ff8..2aa6bd9b58d8 100644 --- a/package.yaml +++ b/package.yaml @@ -15,8 +15,12 @@ category: Game description: Please see the README on GitHub at 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 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? diff --git a/test/Spec.hs b/test/Spec.hs index c9f3150a744a..6f955aa6964d 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 000000000000..b681e537efe6 --- /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 000000000000..3fe79ee56313 --- /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 162540b202cc..4fe938b40bac 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 -- cgit 1.4.1