diff options
author | Griffin Smith <grfn@gws.fyi> | 2020-06-28T20·43-0400 |
---|---|---|
committer | glittershark <grfn@gws.fyi> | 2020-06-28T23·38+0000 |
commit | 6c7e14d2dcd3a3b124dc035e8feb8e79534cd66a (patch) | |
tree | f551473902e566c03746a8dd2014634a48a2c434 /users | |
parent | 20bc4aa10dffcbcc42139afafa10aa5f7a5090bb (diff) |
feat(xan): Use Witherable in the prelude r/1110
Install the witherable library, expose it in the prelude, and update all call sites that are broken by that change. This is a really nice library, and basically the ideal abstraction layer for what it does. Change-Id: I640e099318c1ecce0ad483bc336c379698bdab88 Reviewed-on: https://cl.tvl.fyi/c/depot/+/725 Reviewed-by: glittershark <grfn@gws.fyi>
Diffstat (limited to 'users')
7 files changed, 30 insertions, 6 deletions
diff --git a/users/glittershark/xanthous/package.yaml b/users/glittershark/xanthous/package.yaml index 5f43171e38d1..5321b1fd3ce5 100644 --- a/users/glittershark/xanthous/package.yaml +++ b/users/glittershark/xanthous/package.yaml @@ -71,6 +71,7 @@ dependencies: - text-zipper - vector - vty +- witherable - yaml - zlib diff --git a/users/glittershark/xanthous/src/Xanthous/Data.hs b/users/glittershark/xanthous/src/Xanthous/Data.hs index 3cb74bdca9fd..67173cc89646 100644 --- a/users/glittershark/xanthous/src/Xanthous/Data.hs +++ b/users/glittershark/xanthous/src/Xanthous/Data.hs @@ -387,8 +387,11 @@ data Neighbors a = Neighbors , _bottomRight :: a } deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData, CoArbitrary, Function) + deriving anyclass (NFData, CoArbitrary, Function, MonoFoldable) deriving Arbitrary via GenericArbitrary (Neighbors a) + +type instance Element (Neighbors a) = a + makeFieldsNoPrefix ''Neighbors instance Applicative Neighbors where diff --git a/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs b/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs index bd9af369e01c..2e6d48062a45 100644 --- a/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs +++ b/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs @@ -35,6 +35,7 @@ newtype VectorBag a = VectorBag (Vector a) , Semigroup , Arbitrary , CoArbitrary + , Filterable ) makeWrapped ''VectorBag @@ -59,6 +60,11 @@ instance AsEmpty (VectorBag a) where (VectorBag Empty) -> Just () _ -> Nothing +instance Witherable VectorBag where + wither f (VectorBag v) = VectorBag <$> wither f v + witherM f (VectorBag v) = VectorBag <$> witherM f v + filterA p (VectorBag v) = VectorBag <$> filterA p v + {- TODO: , Ixed diff --git a/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs b/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs index 0f47729d6871..2998db7f7bf9 100644 --- a/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs +++ b/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs @@ -28,7 +28,7 @@ module Xanthous.Messages.Template where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding - (many, concat, try, elements, some, parts) + (many, concat, try, elements, some, parts, Filter) -------------------------------------------------------------------------------- import Test.QuickCheck hiding (label) import Test.QuickCheck.Instances.Text () @@ -113,7 +113,7 @@ instance Eq Template where instance Arbitrary Template where arbitrary = sized . fix $ \gen n -> - let leaves = [ Literal . filter (`notElem` ['\\', '{']) <$> arbitrary + let leaves = [ Literal . pack . filter (`notElem` ['\\', '{']) <$> arbitrary , Subst <$> arbitrary ] subtree = gen $ n `div` 2 diff --git a/users/glittershark/xanthous/src/Xanthous/Prelude.hs b/users/glittershark/xanthous/src/Xanthous/Prelude.hs index 9a4ca0149f1a..b4f13332467e 100644 --- a/users/glittershark/xanthous/src/Xanthous/Prelude.hs +++ b/users/glittershark/xanthous/src/Xanthous/Prelude.hs @@ -7,7 +7,9 @@ module Xanthous.Prelude , module Control.Lens , module Data.Void , module Control.Comonad + , module Data.Witherable + , (&!) -- * Classy-Prelude addons , ninsertSet @@ -16,12 +18,15 @@ module Xanthous.Prelude ) where -------------------------------------------------------------------------------- import ClassyPrelude hiding - (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say) + ( return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say + , catMaybes, filter, mapMaybe, hashNub, ordNub + ) import Data.Kind import GHC.TypeLits hiding (Text) import Control.Lens hiding (levels, Level) import Data.Void import Control.Comonad +import Data.Witherable -------------------------------------------------------------------------------- ninsertSet @@ -34,3 +39,7 @@ ndeleteSet x = deleteSet x . toNullable toVector :: (MonoFoldable (f a), Element (f a) ~ a) => f a -> Vector a toVector = fromList . toList + +infixl 1 &! +(&!) :: a -> (a -> b) -> b +(&!) = flip ($!) diff --git a/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs b/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs index 8ea5186c5050..2a3873c3b016 100644 --- a/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs +++ b/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs @@ -62,7 +62,7 @@ test = testGroup "Xanthous.Messages.Template" ] ] where - genLiteral = filter (`notElem` ['\\', '{']) <$> arbitrary + genLiteral = pack . filter (`notElem` ['\\', '{']) <$> arbitrary parseCase name input expected = testCase name $ testParse template input @?= Right expected testParse p = over _Left errorBundlePretty . runParser p "<test>" diff --git a/users/glittershark/xanthous/xanthous.cabal b/users/glittershark/xanthous/xanthous.cabal index 6d0b7b1093a2..63649a89a897 100644 --- a/users/glittershark/xanthous/xanthous.cabal +++ b/users/glittershark/xanthous/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0486cac7957fae1f9badffdd082f0c5eb5910eb8c066569123b0f57bc6fa0d8b +-- hash: 88019942f93977e08b513ce6991401694c431b7b2b7b1b5d2afccb3f0afb26ed name: xanthous version: 0.1.0.0 @@ -53,6 +53,7 @@ library Xanthous.Entities.Entities Xanthous.Entities.Environment Xanthous.Entities.Item + Xanthous.Entities.Marker Xanthous.Entities.Raws Xanthous.Entities.RawTypes Xanthous.Game @@ -143,6 +144,7 @@ library , tomland , vector , vty + , witherable , yaml , zlib default-language: Haskell2010 @@ -174,6 +176,7 @@ executable xanthous Xanthous.Entities.Entities Xanthous.Entities.Environment Xanthous.Entities.Item + Xanthous.Entities.Marker Xanthous.Entities.Raws Xanthous.Entities.RawTypes Xanthous.Game @@ -263,6 +266,7 @@ executable xanthous , tomland , vector , vty + , witherable , xanthous , yaml , zlib @@ -355,6 +359,7 @@ test-suite test , tomland , vector , vty + , witherable , xanthous , yaml , zlib |