ecstasy 0.2.0.1 → 0.2.1.0

raw patch · 5 files changed

+198/−28 lines, 5 filesdep +kan-extensionsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: kan-extensions

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• ecstasy.cabal +2/−2
• src/Data/Ecstasy.hs +4/−1
• src/Data/Ecstasy/Internal.hs +91/−4
• src/Data/Ecstasy/Internal/Deriving.hs +95/−21

@@ -1,5 +1,11 @@ # Revision history for ecstasy +## 0.2.1.0  -- 2018-05-15++* Added the 'surgery' function to introduce temporary effects.+* Significant performance improvements due to constructing monadic generic+    functions via 'Codensity'.+ ## 0.2.0.1  -- 2018-05-10  * Also export 'StorageType'.

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                ecstasy-version:             0.2.0.1+version:             0.2.1.0 synopsis:   A GHC.Generics based entity component system. @@ -39,6 +39,6 @@                  , Data.Ecstasy.Internal                  , Data.Ecstasy.Internal.Deriving   -- other-extensions:-  build-depends:       base >=4.9 && <5, containers, mtl, transformers+  build-depends:       base >=4.9 && <5, containers, mtl, transformers, kan-extensions   hs-source-dirs:      src   default-language:    Haskell2010

@@ -89,6 +89,9 @@   , Update (..)   , maybeToUpdate +  -- * Introducing effects+  , surgery+   -- * Miscellany   , Ent ()   , VTable (..)@@ -153,7 +156,7 @@ --              } --          } --    'runSystemT' storage $ do---      void $ 'createEntity' 'unchanged+--      void $ 'createEntity' 'newEntity' --        { stdout = Just "hello world" --        } -- @

@@ -6,6 +6,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MonoLocalBinds         #-} {-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE RankNTypes             #-} {-# LANGUAGE ScopedTypeVariables    #-} {-# LANGUAGE TupleSections          #-} {-# LANGUAGE TypeApplications       #-}@@ -16,10 +17,11 @@  import           Control.Arrow (first, second) import           Control.Monad (mzero, void)-import           Control.Monad.Trans.Class (lift)+import           Control.Monad.Codensity (lowerCodensity)+import           Control.Monad.Trans.Class (MonadTrans (..)) import           Control.Monad.Trans.Maybe (runMaybeT) import           Control.Monad.Trans.Reader (runReaderT, asks)-import           Control.Monad.Trans.State.Strict (modify, get, gets, evalStateT)+import           Control.Monad.Trans.State.Strict (StateT (..), modify, get, gets, evalStateT) import qualified Control.Monad.Trans.State.Strict as S import           Data.Ecstasy.Internal.Deriving import qualified Data.Ecstasy.Types as T@@ -55,7 +57,10 @@       -> SystemT world m (world 'FieldOf)   getEntity e = do     w <- SystemT $ gets snd-    lift . fmap to . gGetEntity @m (from w) $ T.unEnt e+    lift . lowerCodensity+         . fmap to+         . gGetEntity @m (from w)+         $ T.unEnt e   {-# INLINE getEntity #-}    ----------------------------------------------------------------------------@@ -77,7 +82,10 @@       -> SystemT world m ()   setEntity e s = do     w <- SystemT $ gets snd-    x <- lift . fmap to . gSetEntity (from s) (T.unEnt e) $ from w+    x <- lift . lowerCodensity+              . fmap to+              . gSetEntity (from s) (T.unEnt e)+              $ from w     SystemT . modify . second $ const x   {-# INLINE setEntity #-} @@ -90,6 +98,7 @@          )       => world ('WorldOf m)   defStorage = def @'True+  {-# INLINE defStorage #-}   class HasWorld' world where@@ -172,6 +181,84 @@                       (Rep (world 'FieldOf))          , Monad m          ) => HasWorld world m+++------------------------------------------------------------------------------+-- | Utilities for defining 'surgery'.+class StorageSurgeon t m world where+  ----------------------------------------------------------------------------+  -- | Hoist storage through a monad transformer.+  hoistStorage+    :: world ('WorldOf m)+    -> world ('WorldOf (t m))+  default hoistStorage+    :: ( Generic (world ('WorldOf m))+       , Generic (world ('WorldOf (t m)))+       , GHoistWorld t m+                     (Rep (world ('WorldOf m)))+                     (Rep (world ('WorldOf (t m))))+       , MonadTrans t+       )+    => world ('WorldOf m)+    -> world ('WorldOf (t m))+  hoistStorage = to . gHoistWorld @t @m . from+  {-# INLINE hoistStorage #-}++  ----------------------------------------------------------------------------+  -- | Grafts two worlds together, using data from the second argument and+  -- vtables from the first.+  graftStorage+    :: world ('WorldOf m)+    -> world ('WorldOf (t m))+    -> world ('WorldOf m)+  default graftStorage+    :: ( Generic (world ('WorldOf m))+       , Generic (world ('WorldOf (t m)))+       , GGraft (Rep (world ('WorldOf m)))+                (Rep (world ('WorldOf (t m))))+       )+    => world ('WorldOf m)+    -> world ('WorldOf (t m))+    -> world ('WorldOf m)+  graftStorage a b = to $ gGraft (from a) (from b)+  {-# INLINE graftStorage #-}+++instance ( Generic (world ('WorldOf m))+         , Generic (world ('WorldOf (t m)))+         , GHoistWorld t m (Rep (world ('WorldOf m)))+                           (Rep (world ('WorldOf (t m))))+         , GGraft (Rep (world ('WorldOf m)))+                  (Rep (world ('WorldOf (t m))))+         , MonadTrans t+         ) => StorageSurgeon t m world+++------------------------------------------------------------------------------+-- | Run a monad transformer /underneath/ a 'SystemT'.+--+-- Due to the recursive interactions between 'SystemT' and 'QueryT', we're+-- often unable to put a temporary monad transformer on the top of the stack.+-- As a result, often 'surgery' is our ony means of introducting ephemeral+-- effects.+--+-- @+-- draw :: 'SystemT' World IO [Graphics]+-- draw = fmap fst . 'surgery' runWriterT $+--   for_ thingsToRender $ \\thingy ->+--     tell [thingy]+-- @+surgery+    :: ( Monad (t m)+       , Monad m+       , StorageSurgeon t m world+       )+    => (forall x. t m x -> m (x, b))+    -> SystemT world (t m) a+    -> SystemT world m (b, a)+surgery f m = SystemT $ StateT $ \(i, s) -> do+  (((i', s'), a), b) <- f $ yieldSystemT (i, hoistStorage s) m+  pure ((b, a), (i', graftStorage s s'))   ------------------------------------------------------------------------------

@@ -12,6 +12,8 @@  module Data.Ecstasy.Internal.Deriving where +import           Control.Monad.Codensity+import           Control.Monad.Trans.Class (MonadTrans (..)) import           Data.Ecstasy.Types (Update (..), VTable (..), Ent (..)) import           Data.IntMap (IntMap) import qualified Data.IntMap as I@@ -20,6 +22,57 @@ import           GHC.TypeLits  +------------------------------------------------------------------------------+-- | Utility class for implementing 'Data.Ecstasy.Internal.hoistStorage'.+class GHoistWorld (t :: (* -> *) -> * -> *) (m :: * -> *) a b where+  gHoistWorld :: a x -> b x++instance {-# OVERLAPPING #-} (MonadTrans t, Functor (t m), Monad m)+    => GHoistWorld t m (K1 i (VTable m a)) (K1 i' (VTable (t m) a)) where+  gHoistWorld (K1 (VTable g s)) = K1 $ VTable (fmap lift g) (fmap (fmap lift) s)+  {-# INLINE gHoistWorld #-}++instance {-# OVERLAPPABLE #-} GHoistWorld t m (K1 i a) (K1 i' a) where+  gHoistWorld (K1 a) = K1 a+  {-# INLINE gHoistWorld #-}++instance (Functor (t m), GHoistWorld t m f f')+    => GHoistWorld t m (M1 i c f) (M1 i' c' f') where+  gHoistWorld (M1 a) = M1 $ gHoistWorld @t @m a+  {-# INLINE gHoistWorld #-}++instance (Applicative (t m), GHoistWorld t m a c, GHoistWorld t m b d)+    => GHoistWorld t m (a :*: b) (c :*: d) where+  gHoistWorld (a :*: b) = gHoistWorld @t @m a :*: gHoistWorld @t @m b+  {-# INLINE gHoistWorld #-}+++------------------------------------------------------------------------------+-- | Utility class for implementing 'Data.Ecstasy.Internal.graftStorage'.+class GGraft a b where+  gGraft :: a x -> b x -> a x++instance {-# OVERLAPPING #-} GGraft (K1 i (VTable m a))+                                    (K1 i' (VTable (t m) a)) where+  gGraft a _ = a+  {-# INLINE gGraft #-}++instance GGraft (K1 i a) (K1 i' a) where+  gGraft _ (K1 a) = K1 a+  {-# INLINE gGraft #-}++instance (GGraft f f') => GGraft (M1 i c f) (M1 i' c' f') where+  gGraft (M1 a) (M1 e) = M1 $ gGraft a e+  {-# INLINE gGraft #-}++instance (GGraft a c, GGraft b d) => GGraft (a :*: b) (c :*: d) where+  gGraft (a :*: b) (c :*: d) = gGraft a c :*: gGraft b d+  {-# INLINE gGraft #-}++++------------------------------------------------------------------------------+-- | Utility class for implementing 'Data.Ecstasy.Internal.convertSetter'. class GConvertSetter a b where   gConvertSetter :: a x -> b x @@ -36,45 +89,56 @@   gConvertSetter (K1 Nothing)  = K1 Unset   {-# INLINE gConvertSetter #-} -instance GConvertSetter f f' => GConvertSetter (M1 i c f) (M1 i' c' f') where+instance GConvertSetter f f'+    => GConvertSetter (M1 i c f) (M1 i' c' f') where   gConvertSetter (M1 a) = M1 $ gConvertSetter a   {-# INLINE gConvertSetter #-} -instance (GConvertSetter a c , GConvertSetter b d) => GConvertSetter (a :*: b) (c :*: d) where+instance (GConvertSetter a c, GConvertSetter b d)+    => GConvertSetter (a :*: b) (c :*: d) where   gConvertSetter (a :*: b) = gConvertSetter a :*: gConvertSetter b   {-# INLINE gConvertSetter #-}  +------------------------------------------------------------------------------+-- | Utility class for implementing 'Data.Ecstasy.Internal.getEntity'. class GGetEntity m a b where-  gGetEntity :: a x -> Int -> m (b x)+  gGetEntity :: a x -> Int -> Codensity m (b x) -instance (Applicative m)-      => GGetEntity m (K1 i (VTable m a)) (K1 i' (Maybe a)) where-  gGetEntity (K1 (VTable vget _)) e = fmap K1 $ vget $ Ent e+instance (Monad m)+    => GGetEntity m (K1 i (VTable m a)) (K1 i' (Maybe a)) where+  gGetEntity (K1 (VTable vget _)) e = lift $ fmap K1 $ vget $ Ent e   {-# INLINE gGetEntity #-} -instance Applicative m => GGetEntity m (K1 i (IntMap a)) (K1 i' (Maybe a)) where+instance Applicative m+    => GGetEntity m (K1 i (IntMap a)) (K1 i' (Maybe a)) where   gGetEntity (K1 a) e = pure . K1 $ I.lookup e $ a   {-# INLINE gGetEntity #-} -instance Applicative m => GGetEntity m (K1 i (Maybe (Int, a))) (K1 i' (Maybe a)) where+instance Applicative m+    => GGetEntity m (K1 i (Maybe (Int, a))) (K1 i' (Maybe a)) where   gGetEntity (K1 (Just (e', a))) e | e == e' = pure . K1 $ Just a   gGetEntity _ _ = pure $ K1 Nothing   {-# INLINE gGetEntity #-} -instance (Functor m, GGetEntity m f f') => GGetEntity m (M1 i c f) (M1 i' c' f') where+instance (Functor m, GGetEntity m f f')+    => GGetEntity m (M1 i c f) (M1 i' c' f') where   gGetEntity (M1 a) e = fmap M1 $ gGetEntity a e   {-# INLINE gGetEntity #-} -instance (Applicative m, GGetEntity m a c , GGetEntity m b d) => GGetEntity m (a :*: b) (c :*: d) where+instance (Applicative m, GGetEntity m a c, GGetEntity m b d)+    => GGetEntity m (a :*: b) (c :*: d) where   gGetEntity (a :*: b) e = (:*:) <$> gGetEntity a e <*> gGetEntity b e   {-# INLINE gGetEntity #-}  +------------------------------------------------------------------------------+-- | Utility class for implementing 'Data.Ecstasy.Internal.setEntity'. class GSetEntity m a b where-  gSetEntity :: a x -> Int -> b x -> m (b x)+  gSetEntity :: a x -> Int -> b x -> Codensity m (b x) -instance Applicative m => GSetEntity m (K1 i (Update a)) (K1 i' (Maybe (Int, a))) where+instance Applicative m+    => GSetEntity m (K1 i (Update a)) (K1 i' (Maybe (Int, a))) where   gSetEntity (K1 (Set a)) e _ = pure . K1 $ Just (e, a)   gSetEntity (K1 Unset) e (K1 (Just (e', b))) =     pure $ if e == e'@@ -83,24 +147,28 @@   gSetEntity _  _ (K1 b) = pure $ K1 b   {-# INLINE gSetEntity #-} -instance (Applicative m)-      => GSetEntity m (K1 i (Update a)) (K1 i' (VTable m a)) where+instance (Monad m)+    => GSetEntity m (K1 i (Update a)) (K1 i' (VTable m a)) where   gSetEntity (K1 a) e (K1 z@(VTable _ vset)) =-    vset (Ent e) a *> pure (K1 z)+    lift (vset (Ent e) a) *> pure (K1 z)   {-# INLINE gSetEntity #-} -instance Applicative m => GSetEntity m (K1 i (Update a)) (K1 i' (IntMap a)) where+instance Applicative m+    => GSetEntity m (K1 i (Update a)) (K1 i' (IntMap a)) where   gSetEntity (K1 Keep) _ (K1 b) = pure $ K1 b   gSetEntity (K1 (Set a)) e (K1 b) = pure . K1 $ I.alter (const $ Just a) e b   gSetEntity (K1 Unset) e (K1 b) = pure . K1 $ I.alter (const Nothing) e b   {-# INLINE gSetEntity #-} -instance (Functor m, GSetEntity m f f') => GSetEntity m (M1 i c f) (M1 i' c' f') where+instance (Functor m, GSetEntity m f f')+    => GSetEntity m (M1 i c f) (M1 i' c' f') where   gSetEntity (M1 a) e (M1 b) = fmap M1 $ gSetEntity a e b   {-# INLINE gSetEntity #-} -instance (Applicative m, GSetEntity m a c, GSetEntity m b d) => GSetEntity m (a :*: b) (c :*: d) where-  gSetEntity (a :*: b) e (c :*: d) = (:*:) <$> gSetEntity a e c <*> gSetEntity b e d+instance (Applicative m, GSetEntity m a c, GSetEntity m b d)+    => GSetEntity m (a :*: b) (c :*: d) where+  gSetEntity (a :*: b) e (c :*: d) = (:*:) <$> gSetEntity a e c+                                           <*> gSetEntity b e d   {-# INLINE gSetEntity #-}  @@ -109,6 +177,10 @@ {-# INLINE def #-}  +------------------------------------------------------------------------------+-- | Utility class for implementing various defaults. The 'keep' parameter is+-- used to statically describe whether or not to keep the previous value when+-- dealing with 'Update' fields. class GDefault (keep :: Bool) f where   gdef :: f a @@ -133,7 +205,8 @@   {-# INLINE gdef #-}  instance {-# OVERLAPPING #-} (Applicative m, KnownSymbol sym)-      => GDefault keep (M1 S ('MetaSel ('Just sym) x y z) (K1 i (VTable m a))) where+    => GDefault keep (M1 S ('MetaSel ('Just sym) x y z)+                     (K1 i (VTable m a))) where   gdef = M1 $ K1 $ VTable (const err) (const $ const err)     where       err :: err@@ -148,7 +221,8 @@   gdef = M1 $ gdef @keep   {-# INLINE gdef #-} -instance (GDefault keep a, GDefault keep b) => GDefault keep (a :*: b) where+instance (GDefault keep a, GDefault keep b)+    => GDefault keep (a :*: b) where   gdef = gdef @keep :*: gdef @keep   {-# INLINE gdef #-}