extensible 0.4.2 → 0.4.3

raw patch · 19 files changed

+167/−64 lines, 19 filesdep +StateVardep +freer-effectsdep −freerPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: StateVar, freer-effects

Dependencies removed: freer

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +2/−0
• benchmarks/eff-comparison.hs +1/−1
• examples/records.hs +1/−1
• extensible.cabal +8/−2
• src/Data/Extensible/Class.hs +2/−0
• src/Data/Extensible/Dictionary.hs +6/−0
• src/Data/Extensible/Effect.hs +31/−21
• src/Data/Extensible/Field.hs +4/−2
• src/Data/Extensible/HList.hs +1/−1
• src/Data/Extensible/Internal.hs +15/−15
• src/Data/Extensible/Label.hs +7/−4
• src/Data/Extensible/Match.hs +2/−1
• src/Data/Extensible/Nullable.hs +4/−1
• src/Data/Extensible/Record.hs +1/−1
• src/Data/Extensible/Struct.hs +30/−0
• src/Data/Extensible/Sum.hs +5/−2
• src/Data/Extensible/Tangle.hs +8/−4
• src/Data/Extensible/Wrapper.hs +28/−8

@@ -1,3 +1,14 @@+0.4.3+-------------------------------------------------+* Added `WrappedPointer`+* Added `NFData` and `Generic` instances for `Comp`+* Added a `Semigroup` instance for `h :* xs` and `Membership xs x`+* Added `Prod`+* Added `peelEff0`+* Changed the `IsLabel` instance so that a function is always inferred as an optic+* `Data.Extensible.Class` now exports `compareMembership`+* Renamed `runMembership` to `leadership`+ 0.4.2 ------------------------------------------------- * Made `newFrom` strict

@@ -6,4 +6,6 @@  This package provides extensible poly-kinded records, variants and effects. +Several tutorials can be found at [School of Haskell](https://www.schoolofhaskell.com/user/fumieval/extensible).+ Bug reports and contributions are welcome!

@@ -111,6 +111,6 @@     , bench "mtl-RWS" $ nf (\m -> runRWS m 0 1) testMTL     , bench "exteff" $ nf runExtEff testExtEff     , bench "effin" $ nf runEffin testEffin-    , bench "freer" $ nf runFreer testFreer+    , bench "freer-effects" $ nf runFreer testFreer     ]   ]

@@ -1,4 +1,4 @@-{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies, FlexibleContexts, OverloadedLabels #-} import Data.Extensible import Control.Lens 

@@ -1,5 +1,5 @@ name:                extensible-version:             0.4.2+version:             0.4.3 synopsis:            Extensible, efficient, optics-friendly data types and effects homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues@@ -51,6 +51,8 @@     Data.Extensible.TH   default-extensions: TypeOperators     , DeriveDataTypeable+    , DeriveGeneric+    , GeneralizedNewtypeDeriving     , KindSignatures     , ConstraintKinds     , DataKinds@@ -73,6 +75,7 @@     , transformers     , mtl     , monad-skeleton >= 0.1.2+    , StateVar   hs-source-dirs:      src   ghc-options: -Wall   default-language:    Haskell2010@@ -82,6 +85,7 @@   main-is: effects.hs   build-depends: base, extensible   hs-source-dirs: tests+  default-language:    Haskell2010  benchmark records   type:           exitcode-stdio-1.0@@ -89,10 +93,12 @@   ghc-options:    -O2   hs-source-dirs: benchmarks   build-depends: base, lens, criterion, extensible+  default-language:    Haskell2010  benchmark eff-comparison   type:           exitcode-stdio-1.0   main-is:        eff-comparison.hs   ghc-options:    -O2   hs-source-dirs: benchmarks-  build-depends: base, criterion, extensible, extensible-effects, effin, freer, mtl+  build-depends: base, criterion, extensible, extensible-effects, effin, freer-effects, mtl+  default-language:    Haskell2010

@@ -22,6 +22,8 @@   -- * Membership   , Membership   , mkMembership+  , compareMembership+  , leadership   -- * Member   , Member(..)   , remember

@@ -25,6 +25,7 @@ import Data.Extensible.Internal.Rig import Data.Constraint import Data.Extensible.Wrapper+import Data.Semigroup  -- | Reify a collection of dictionaries, as you wish. library :: forall c xs. Forall c xs => Comp Dict c :* xs@@ -46,6 +47,11 @@   compare xs ys = henumerateFor (Proxy :: Proxy (Instance1 Ord h)) xs     (\i r -> (hlookup i xs `compare` hlookup i ys) `mappend` r) mempty   {-# INLINE compare #-}++instance WrapForall Semigroup h xs => Semigroup (h :* xs) where+  (<>) = hzipWith3 (\(Comp Dict) -> (<>))+    (library :: Comp Dict (Instance1 Semigroup h) :* xs)+  {-# INLINE (<>) #-}  instance WrapForall Monoid h xs => Monoid (h :* xs) where   mempty = hrepeatFor (Proxy :: Proxy (Instance1 Monoid h)) mempty

@@ -25,6 +25,7 @@   , peelEff   , Rebinder   , rebindEff0+  , peelEff0   , rebindEff1   , peelEff1   , rebindEff2@@ -84,10 +85,13 @@ import Data.Extensible.Class import Data.Functor.Identity import Data.Profunctor.Unsafe -- Trustworthy since 7.8+import Data.Typeable (Typeable) --- | A unit of named effects.+-- | A unit of named effects. This is a variant of @(':|')@ specialised for+-- 'Type -> Type'. data Instruction (xs :: [Assoc k (* -> *)]) a where   Instruction :: !(Membership xs kv) -> AssocValue kv a -> Instruction xs a+  deriving Typeable  -- | The extensible operational monad type Eff xs = Skeleton (Instruction xs)@@ -126,13 +130,20 @@ peelEff pass ret wrap = go where   go m = case debone m of     Return a -> ret a-    Instruction i t :>>= k -> runMembership i+    Instruction i t :>>= k -> leadership i       (\Refl -> wrap t (go . k))       (\j -> pass (Instruction j t) (go . k)) {-# INLINE peelEff #-} +-- | 'peelEff' specialised for continuations with no argument+peelEff0 :: forall k t xs a r. (a -> Eff xs r) -- ^ return the result+  -> (forall x. t x -> (x -> Eff xs r) -> Eff xs r) -- ^ Handle the foremost type of an action+  -> Eff (k >: t ': xs) a -> Eff xs r+peelEff0 = peelEff rebindEff0+{-# INLINE peelEff0 #-}+ -- | 'peelEff' specialised for 1-argument continuation-peelEff1 :: (a -> b -> Eff xs r) -- ^ return the result+peelEff1 :: forall k t xs a b r. (a -> b -> Eff xs r) -- ^ return the result   -> (forall x. t x -> (x -> b -> Eff xs r) -> b -> Eff xs r) -- ^ Handle the foremost type of an action   -> Eff (k >: t ': xs) a -> b -> Eff xs r peelEff1 = peelEff rebindEff1@@ -144,17 +155,17 @@ -- | A common value for the second argument of 'peelEff'. Binds an instruction -- directly. rebindEff0 :: Rebinder xs (Eff xs r)-rebindEff0 i k = boned (i :>>= k)+rebindEff0 i k = boned $ i :>>= k  -- | A pre-defined value for the second argument of 'peelEff'. -- Preserves the argument of the continuation. rebindEff1 :: Rebinder xs (a -> Eff xs r)-rebindEff1 i k a = boned (i :>>= flip k a)+rebindEff1 i k a = boned $ i :>>= flip k a  -- | A pre-defined value for the second argument of 'peelEff'. -- Preserves two arguments of the continuation. rebindEff2 :: Rebinder xs (a -> b -> Eff xs r)-rebindEff2 i k a b = boned (i :>>= \x -> k x a b)+rebindEff2 i k a b = boned $ i :>>= \x -> k x a b  -- | Reveal the final result of 'Eff'. leaveEff :: Eff '[] a -> a@@ -166,12 +177,13 @@ retractEff :: forall k m a. Monad m => Eff '[k >: m] a -> m a retractEff m = case debone m of   Return a -> return a-  Instruction i t :>>= k -> runMembership i+  Instruction i t :>>= k -> leadership i     (\Refl -> t >>= retractEff . k)-    (error "Impossible")+    $ error "Impossible"  -- | Transformation between effects newtype Interpreter f g = Interpreter { runInterpreter :: forall a. g a -> f a }+  deriving Typeable  -- | Process an 'Eff' action using a record of 'Interpreter's. handleEff :: RecordOf (Interpreter m) xs -> Eff xs a -> MonadView m (Eff xs) a@@ -196,7 +208,7 @@  -- | Create a 'Field' of a 'Interpreter' for an 'Action'. (@!?) :: FieldName k -> Function xs (f a) -> Field (Interpreter f) (k ':> Action xs a)-_ @!? f = Field $ Interpreter (runAction f)+_ @!? f = Field $ Interpreter $ runAction f infix 1 @!?  -- | Specialised version of 'peelEff' for 'Action's.@@ -210,14 +222,14 @@ peelAction pass ret wrap = go where   go m = case debone m of     Return a -> ret a-    Instruction i t :>>= k -> runMembership i+    Instruction i t :>>= k -> leadership i       (\Refl -> case t of         (_ :: Action ps q x) ->           let run :: forall t. Function t ((q -> r) -> r) -> Action t q x -> r               run f AResult = f (go . k)               run f (AArgument x a) = run (f x) a           in run wrap t)-      (\j -> pass (Instruction j t) (go . k))+      $ \j -> pass (Instruction j t) (go . k) {-# INLINE peelAction #-}  -- | Non continuation-passing variant of 'peelAction'.@@ -226,14 +238,14 @@ peelAction0 wrap = go where   go m = case debone m of     Return a -> return a-    Instruction i t :>>= k -> runMembership i+    Instruction i t :>>= k -> leadership i       (\Refl -> case t of         (_ :: Action ps q x) ->           let run :: forall t. Function t (Eff xs q) -> Action t q x -> Eff xs a               run f AResult = f >>= go . k               run f (AArgument x a) = run (f x) a           in run wrap t)-      (\j -> rebindEff0 (Instruction j t) (go . k))+      $ \j -> rebindEff0 (Instruction j t) (go . k) {-# INLINE peelAction0 #-}  -- | The reader monad is characterised by a type equality between the result@@ -267,7 +279,7 @@  -- | Run the frontal reader effect. runReaderEff :: forall k r xs a. Eff (k >: ReaderEff r ': xs) a -> r -> Eff xs a-runReaderEff m r = peelEff rebindEff0 return (\Refl k -> k r) m+runReaderEff m r = peelEff0 return (\Refl k -> k r) m {-# INLINE runReaderEff #-}  -- | Get the current state.@@ -370,8 +382,7 @@  -- | Run an effect which may fail in the name of @k@. runMaybeEff :: forall k xs a. Eff (k >: MaybeEff ': xs) a -> Eff xs (Maybe a)-runMaybeEff = peelEff rebindEff0 (return . Just)-  (\_ _ -> return Nothing)+runMaybeEff = peelEff0 (return . Just) $ \_ _ -> return Nothing {-# INLINE runMaybeEff #-}  -- | Throwing an exception@@ -395,13 +406,12 @@  -- | Run the frontal Either effect. runEitherEff :: forall k e xs a. Eff (k >: EitherEff e ': xs) a -> Eff xs (Either e a)-runEitherEff = peelEff rebindEff0 (return . Right)-  (\(Const e) _ -> return $ Left e)+runEitherEff = peelEff0 (return . Right) $ \(Const e) _ -> return $ Left e {-# INLINE runEitherEff #-}  -- | Put a milestone on a computation. tickEff :: Associate k Identity xs => Proxy k -> Eff xs ()-tickEff k = liftEff k (Identity ())+tickEff k = liftEff k $ Identity () {-# INLINE tickEff #-}  -- | Run a computation until 'tickEff'.@@ -409,6 +419,6 @@   -> Eff xs (Either a (Eff (k >: Identity ': xs) a)) runIterEff m = case debone m of   Return a -> return (Left a)-  Instruction i t :>>= k -> runMembership i+  Instruction i t :>>= k -> leadership i     (\Refl -> return $ Right $ k $ runIdentity t)-    (\j -> boned $ Instruction j t :>>= runIterEff . k)+    $ \j -> boned $ Instruction j t :>>= runIterEff . k

@@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}-{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 800@@ -57,7 +57,9 @@ import Data.Extensible.Wrapper import Data.Functor.Identity import Data.Semigroup+import Data.Typeable (Typeable) import Foreign.Storable (Storable)+import GHC.Generics (Generic) import GHC.TypeLits hiding (Nat)  -- | Take the type of the key@@ -82,7 +84,7 @@ -- @'Field' :: (v -> *) -> Assoc k v -> *@ -- newtype Field (h :: v -> *) (kv :: Assoc k v) = Field { getField :: h (AssocValue kv) }-+  deriving (Typeable, Generic) #define ND_Field(c) deriving instance c (h (AssocValue kv)) => c (Field h kv)  ND_Field(Eq)

@@ -44,5 +44,5 @@ hlength = go 0 where   go :: Int -> HList h xs -> Int   go n HNil = n-  go n (HCons _ xs) = let n' = n + 1 in go n' xs+  go n (HCons _ xs) = let !n' = n + 1 in go n' xs {-# INLINE hlength #-}

@@ -2,7 +2,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, FunctionalDependencies #-}-{-# LANGUAGE ScopedTypeVariables, BangPatterns, StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- |@@ -20,9 +21,11 @@   , getMemberId   , mkMembership   , reifyMembership-  , runMembership+  , leadership   , compareMembership   , impossibleMembership+  , here+  , navNext   -- * Member class   , Member(..)   , remember@@ -44,10 +47,6 @@   -- * Sugar   , Elaborate   , Elaborated(..)-  -- * Tree navigation-  , NavHere(..)-  , here-  , navNext   -- * Miscellaneous   , Nat(..)   , KnownPosition(..)@@ -57,6 +56,7 @@   , module Data.Type.Equality   , module Data.Proxy   ) where+import Control.DeepSeq (NFData) import Data.Type.Equality import Data.Proxy #if !MIN_VERSION_base(4,8,0)@@ -68,6 +68,7 @@ import Data.Typeable import Language.Haskell.TH hiding (Pred) import Data.Bits+import Data.Semigroup (Semigroup(..))  -- | Generates a 'Membership' that corresponds to the given ordinal (0-origin). mkMembership :: Int -> Q Exp@@ -81,7 +82,7 @@     $ conT ''Membership `appT` pure t `appT` varT (names !! n)  -- | The position of @x@ in the type level set @xs@.-newtype Membership (xs :: [k]) (x :: k) = Membership { getMemberId :: Int } deriving Typeable+newtype Membership (xs :: [k]) (x :: k) = Membership { getMemberId :: Int } deriving (Typeable, NFData)  newtype Remembrance xs x r = Remembrance (Member xs x => r) @@ -142,11 +143,14 @@ instance Ord (Membership xs x) where   compare _ _ = EQ +instance Semigroup (Membership xs x) where+  x <> _ = x+ -- | Embodies a type equivalence to ensure that the 'Membership' points the first element.-runMembership :: Membership (y ': xs) x -> (x :~: y -> r) -> (Membership xs x -> r) -> r-runMembership (Membership 0) l _ = l (unsafeCoerce Refl)-runMembership (Membership n) _ r = r (Membership (n - 1))-{-# INLINE runMembership #-}+leadership :: Membership (y ': xs) x -> (x :~: y -> r) -> (Membership xs x -> r) -> r+leadership (Membership 0) l _ = l (unsafeCoerce Refl)+leadership (Membership n) _ r = r (Membership (n - 1))+{-# INLINE leadership #-}  -- | Compare two 'Membership's. compareMembership :: Membership xs x -> Membership xs y -> Either Ordering (x :~: y)@@ -158,10 +162,6 @@ -- | There is no 'Membership' of an empty list. impossibleMembership :: Membership '[] x -> r impossibleMembership _ = error "Impossible"---- | Ensure that the first element of @xs@ is @x@-data NavHere xs x where-  Here :: NavHere (x ': xs) x  -- | The 'Membership' points the first element here :: Membership (x ': xs) x

@@ -19,7 +19,6 @@ import Data.Proxy import GHC.OverloadedLabels import Data.Extensible.Wrapper-import Data.Extensible.Internal.Rig  instance k ~ l => IsLabel k (Proxy l) where #if __GLASGOW_HASKELL__ >= 802@@ -32,12 +31,16 @@ 訊 :: Proxy k -> FieldOptic k 訊 = itemAssoc -instance (Extensible f p t+instance (Extensible f p e   , Associate k v xs   , Labelling k p   , Wrapper h-  , rep ~ Repr h v)-  => IsLabel k (Optic' p f (t (Field h) xs) rep) where+  , rep ~ Repr h v+  , s ~ e (Field h) xs+  , s ~ t+  , rep ~ rep'+  )+  => IsLabel k (p rep (f rep') -> p s (f t)) where #if __GLASGOW_HASKELL__ >= 802   fromLabel = itemAssoc (Proxy :: Proxy k) #else

@@ -23,6 +23,7 @@ import Data.Extensible.Wrapper import Data.Typeable (Typeable) import Data.Profunctor.Unsafe+import GHC.Generics (Generic)  -- | Retrieve the contents so that they matches and pass both to the given function. matchWith :: (forall x. f x -> g x -> r) -> f :* xs -> g :| xs -> r@@ -46,7 +47,7 @@ infix 0 `caseOf`  -- | Turn a wrapper type into a clause for it.-newtype Match h r x = Match { runMatch :: h x -> r } deriving Typeable+newtype Match h r x = Match { runMatch :: h x -> r } deriving (Typeable, Generic)  instance Wrapper h => Wrapper (Match h r) where   type Repr (Match h r) x = Repr h x -> r

@@ -16,6 +16,7 @@   , Nullable(..)   , mapNullable) where +import Control.DeepSeq (NFData) import Data.Extensible.Class import Data.Extensible.Product import Data.Extensible.Sum@@ -26,9 +27,11 @@ import qualified Data.Extensible.Struct as S import Data.Profunctor.Unsafe import Data.Semigroup+import GHC.Generics (Generic)  -- | Wrapped Maybe-newtype Nullable h x = Nullable { getNullable :: Maybe (h x) } deriving (Show, Eq, Ord, Typeable)+newtype Nullable h x = Nullable { getNullable :: Maybe (h x) }+  deriving (Show, Eq, Ord, Typeable, Generic, NFData)  instance Wrapper h => Wrapper (Nullable h) where   type Repr (Nullable h) x = Maybe (Repr h x)

@@ -1,4 +1,4 @@-{-# LANGUAGE LambdaCase, TemplateHaskell, TypeFamilies, DeriveFunctor #-}+{-# LANGUAGE LambdaCase, TemplateHaskell, TypeFamilies #-} ------------------------------------------------------------------------ -- | -- Module      :  Data.Extensible.Record

@@ -21,6 +21,8 @@   , newRepeat   , newFor   , newFromHList+  , WrappedPointer(..)+  , (-$>)   -- ** Atomic operations   , atomicModify   , atomicModify'@@ -39,19 +41,26 @@   , toHList) where  import GHC.Prim+import Control.Monad+import Control.Monad.IO.Class import Control.Monad.Primitive import Control.Monad.ST import Data.Constraint import Data.Extensible.Class import Data.Extensible.Internal+import Data.Extensible.Internal.Rig+import Data.Extensible.Wrapper import Control.Comonad import Data.Profunctor.Rep import Data.Profunctor.Sieve+import qualified Data.StateVar as V+import Data.Typeable (Typeable) import qualified Data.Extensible.HList as L import GHC.Types  -- | Mutable type-indexed struct. data Struct s (h :: k -> *) (xs :: [k]) = Struct (SmallMutableArray# s Any)+  deriving Typeable  -- | Write a value in a 'Struct'. set :: PrimMonad m => Struct (PrimState m) h xs -> Membership xs x -> h x -> m ()@@ -101,6 +110,27 @@   => Struct (PrimState m) h xs -> Membership xs x -> (h x -> h x) -> m (h x) atomicModify'_ s i f = atomicModify_ s i f >>= (return $!) {-# INLINE atomicModify'_ #-}++-- | A pointer to an element in a 'Struct'.+data WrappedPointer s h a where+  WrappedPointer :: !(Struct s h xs)+    -> !(Membership xs x)+    -> WrappedPointer s h (Repr h x)++instance (s ~ RealWorld, Wrapper h) => V.HasGetter (WrappedPointer s h a) a where+  get (WrappedPointer s i) = liftIO $ view _Wrapper <$> get s i++instance (s ~ RealWorld, Wrapper h) => V.HasSetter (WrappedPointer s h a) a where+  WrappedPointer s i $= v = liftIO $ set s i $ review _Wrapper v++instance (s ~ RealWorld, Wrapper h) => V.HasUpdate (WrappedPointer s h a) a a where+  WrappedPointer s i $~ f = liftIO $ void $ atomicModify_ s i $ over _Wrapper f+  WrappedPointer s i $~! f = liftIO $ void $ atomicModify'_ s i $ over _Wrapper f++-- | Get a 'WrappedPointer' from a name.+(-$>) :: forall k h xs v s. (Associate k v xs) => Struct s h xs -> Proxy k -> WrappedPointer s h (Repr h (k ':> v))+s -$> _ = WrappedPointer s (association :: Membership xs (k ':> v))+{-# INLINE (-$>) #-}  -- | Create a new 'Struct' using the supplied initializer. new :: forall h m xs. (PrimMonad m, Generate xs)

@@ -70,8 +70,11 @@ {-# INLINE strikeAt #-}  -- | /O(1)/ Naive pattern match-(<:|) :: (h x -> r) -> (h :| xs -> r) -> h :| (x ': xs) -> r-(<:|) r c = \(EmbedAt i h) -> runMembership i+(<:|) :: (h x -> r)+    -> (h :| xs -> r)+    -> h :| (x ': xs)+    -> r+(<:|) r c = \(EmbedAt i h) -> leadership i   (\Refl -> r h)   (\j -> c (EmbedAt j h)) infixr 1 <:|

@@ -1,4 +1,4 @@-{-# LANGUAGE PolyKinds, KindSignatures, TypeOperators, DataKinds, Rank2Types, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------ -- | -- Module      :  Data.Extensible.Struct@@ -20,6 +20,7 @@ import Data.Extensible.Internal.Rig import Data.Extensible.Nullable import Data.Extensible.Wrapper+import Data.Semigroup  -- | @'TangleT' h xs m@ is the monad of computations that may depend on the elements in 'xs'. newtype TangleT h xs m a = TangleT@@ -29,13 +30,16 @@ instance MonadTrans (TangleT h xs) where   lift = TangleT . lift +instance (Monad m, Semigroup a) => Semigroup (TangleT h xs m a) where+  (<>) = liftA2 (<>)+ instance (Monad m, Monoid a) => Monoid (TangleT h xs m a) where-    mempty = pure mempty-    mappend = liftA2 mappend+  mempty = pure mempty+  mappend = liftA2 mappend  -- | Hitch an element associated to the 'FieldName' through a wrapper. lasso :: forall k v m h xs. (Monad m, Associate k v xs, Wrapper h)-    => FieldName k -> TangleT h xs m (Repr h (k ':> v))+  => FieldName k -> TangleT h xs m (Repr h (k ':> v)) lasso _ = view _Wrapper <$> hitchAt (association :: Membership xs (k ':> v)) {-# INLINE lasso #-} 

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE DeriveTraversable, StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -15,13 +15,16 @@   , Const'(..)   , Comp(..)   , comp+  , Prod(..)   ) where +import Control.DeepSeq import Data.Typeable (Typeable) import Data.Proxy (Proxy(..)) import Data.Profunctor.Unsafe (Profunctor(..)) import Data.Functor.Identity (Identity(..))-import Data.Extensible.Internal.Rig (Optic', withIso)+import Data.Extensible.Internal.Rig+import GHC.Generics (Generic)  -- | The extensible data types should take @k -> *@ as a parameter. -- This class allows us to take a shortcut for direct representation.@@ -47,16 +50,21 @@   {-# INLINE _Wrapper #-}  instance Wrapper Maybe where-    type Repr Maybe a = Maybe a-    _Wrapper = id+  type Repr Maybe a = Maybe a+  _Wrapper = id  instance Wrapper [] where-    type Repr [] a = [a]-    _Wrapper = id+  type Repr [] a = [a]+  _Wrapper = id  -- | Poly-kinded composition-newtype Comp (f :: j -> *) (g :: i -> j) (a :: i) = Comp { getComp :: f (g a) } deriving (Show, Eq, Ord, Typeable)+newtype Comp (f :: j -> *) (g :: i -> j) (a :: i) = Comp { getComp :: f (g a) }+  deriving (Show, Eq, Ord, Typeable, NFData, Generic) +deriving instance (Functor f, Functor g) => Functor (Comp f g)+deriving instance (Foldable f, Foldable g) => Foldable (Comp f g)+deriving instance (Traversable f, Traversable g) => Traversable (Comp f g)+ -- | Wrap a result of 'fmap' comp :: Functor f => (a -> g b) -> f a -> Comp f g b comp f = Comp #. fmap f@@ -68,7 +76,8 @@   {-# INLINE _Wrapper #-}  -- | Poly-kinded Const-newtype Const' a x = Const' { getConst' :: a } deriving (Show, Eq, Ord, Typeable)+newtype Const' a x = Const' { getConst' :: a }+  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Functor, Foldable, Traversable)  instance Wrapper (Const' a) where   type Repr (Const' a) b = a@@ -79,3 +88,14 @@   type Repr Proxy x = ()   _Wrapper = dimap (const ()) (fmap (const Proxy))   {-# INLINE _Wrapper #-}++-- | Poly-kinded product+data Prod f g a = Prod (f a) (g a)+  deriving (Show, Eq, Ord, Typeable, Generic, Functor, Foldable, Traversable)++instance (NFData (f a), NFData (g a)) => NFData (Prod f g a)++instance (Wrapper f, Wrapper g) => Wrapper (Prod f g) where+  type Repr (Prod f g) a = (Repr f a, Repr g a)+  _Wrapper = dimap (\(Prod f g) -> (view _Wrapper f, view _Wrapper g))+    $ fmap (\(a, b) -> review _Wrapper a `Prod` review _Wrapper b)