extensible 0.4.3 → 0.4.4

raw patch · 14 files changed

+116/−229 lines, 14 filesdep −criteriondep −effindep −extensible-effectsdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: criterion, effin, extensible-effects, freer-effects, lens

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• .gitignore +1/−0
• CHANGELOG.md +10/−0
• benchmarks/eff-comparison.hs +0/−116
• benchmarks/records.hs +0/−76
• extensible.cabal +2/−18
• src/Data/Extensible/Class.hs +0/−10
• src/Data/Extensible/Dictionary.hs +4/−0
• src/Data/Extensible/Effect.hs +37/−3
• src/Data/Extensible/Effect/Default.hs +28/−1
• src/Data/Extensible/Field.hs +14/−0
• src/Data/Extensible/Match.hs +3/−1
• src/Data/Extensible/Record.hs +1/−1
• src/Data/Extensible/TH.hs +7/−2
• src/Data/Extensible/Wrapper.hs +9/−1

@@ -10,6 +10,7 @@ cabal.sandbox.config cabal.config .stack-work+.bash_history  # ========================= # Operating System Files

@@ -1,3 +1,13 @@+0.4.4+-------------------------------------------------+* Added `contEff` and `runContEff`+* Added `castEff`+* Added `evalStateEff`+* Added `Semigroup` and `Monoid` instances for `Match`, `Comp`, `Prod`+* Added `evalStateDef`, `execStateDef`, and `execWriterDef`+* Added `mkFieldAs`+* Added a `Bounded` instance for `:*`+ 0.4.3 ------------------------------------------------- * Added `WrappedPointer`

@@ -1,116 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DataKinds, TypeOperators #-}-{-# OPTIONS_GHC -ddump-simpl -dsuppress-all #-}-import Data.Void---- extensible-effects-import qualified Control.Eff as ExtEff-import qualified Control.Eff.Reader.Strict as ExtEff-import qualified Control.Eff.Writer.Strict as ExtEff-import qualified Control.Eff.State.Strict as ExtEff---- effin-import qualified Control.Effect as Effin-import qualified Control.Effect.Reader as Effin-import qualified Control.Effect.Writer as Effin-import qualified Control.Effect.State as Effin---- freer-import qualified Control.Monad.Freer as Freer-import qualified Control.Monad.Freer.Reader as Freer-import qualified Control.Monad.Freer.Writer as Freer-import qualified Control.Monad.Freer.State as Freer--import Control.Monad.Reader-import Control.Monad.State.Strict-import Control.Monad.Writer.Strict-import Control.Monad.RWS.Strict--import Data.Extensible.Effect-import Data.Extensible.Effect.Default--import Criterion.Main--testExtEff :: (ExtEff.Member (ExtEff.Reader Int) r-  , ExtEff.Member (ExtEff.State Int) r-  , ExtEff.Member (ExtEff.Writer (Sum Int)) r)-  => ExtEff.Eff r ()-testExtEff = replicateM_ 100 $ do-  r :: Int <- ExtEff.ask-  s <- ExtEff.get-  ExtEff.tell (Sum s)-  ExtEff.put $! s + r--runExtEff :: ExtEff.Eff-  ( ExtEff.Reader Int-  ExtEff.:> ExtEff.State Int-  ExtEff.:> ExtEff.Writer (Sum Int)-  ExtEff.:> Void) a -> (Sum Int, (Int, a))-runExtEff = ExtEff.run-  . ExtEff.runMonoidWriter-  . ExtEff.runState 0-  . flip ExtEff.runReader 1--testEffin :: (Effin.EffectReader Int l-  , Effin.EffectState Int l-  , Effin.EffectWriter (Sum Int) l)-  => Effin.Effect l ()-testEffin = replicateM_ 100 $ do-  r <- Effin.ask-  s <- Effin.get-  Effin.tell (Sum s)-  Effin.put $! s + r--runEffin = Effin.runEffect-  . Effin.runWriter-  . Effin.runState 0-  . Effin.runReader 1--testFreer :: (Freer.Member (Freer.Reader Int) r-  , Freer.Member (Freer.State Int) r-  , Freer.Member (Freer.Writer (Sum Int)) r)-  => Freer.Eff r ()-testFreer = replicateM_ 100 $ do-  r :: Int <- Freer.ask-  s <- Freer.get-  Freer.tell (Sum s)-  Freer.put $! s + r--runFreer :: Freer.Eff '[Freer.Reader Int, Freer.State Int, Freer.Writer (Sum Int)] a-  -> ((a, Int), Sum Int)-runFreer = Freer.run-  . Freer.runWriter-  . flip Freer.runState 0-  . flip Freer.runReader 1--testMTL :: (MonadReader Int m, MonadState Int m, MonadWriter (Sum Int) m)-  => m ()-testMTL = replicateM_ 100 $ do-  r <- ask-  s <- get-  tell (Sum s)-  put $! s + r--runMTL :: ReaderT Int (StateT Int (Writer (Sum Int))) a -> ((a, Int), Sum Int)-runMTL = runWriter-  . flip runStateT 0-  . flip runReaderT 1--runExtensible :: Eff '[ReaderDef Int, StateDef Int, WriterDef (Sum Int)] a-  -> ((a, Int), Sum Int)-runExtensible = leaveEff-  . runWriterDef-  . flip runStateDef 0-  . flip runReaderDef 1--main = defaultMain-  [ bgroup "rws"-    [ bench "extensible" $ nf runExtensible testMTL-    , bench "mtl" $ nf runMTL testMTL-    , bench "mtl-RWS" $ nf (\m -> runRWS m 0 1) testMTL-    , bench "exteff" $ nf runExtEff testExtEff-    , bench "effin" $ nf runEffin testEffin-    , bench "freer-effects" $ nf runFreer testFreer-    ]-  ]

@@ -1,76 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds, FlexibleContexts #-}-import Criterion.Main-import Control.Lens-import Data.Extensible-import Data.Monoid--mkField "foo bar baz qux foobar foobaz fooqux barfoo barbaz barqux"--type Fields = ["foo" >: Sum Int-  , "bar" >: String-  , "baz" >: First Int-  , "qux" >: String-  , "foobar" >: (Sum Int, String)-  , "foobaz" >: (Sum Int, First Int)-  , "fooqux" >: (Sum Int, String)-  , "barfoo" >: (String, Sum Int)-  , "barbaz" >: (String, First Int)-  , "barqux" >: (String, String)]--recA :: Record Fields-recA = foo @= Sum 1 <: bar @= "barA" <: baz @= mempty <: qux @= "qux"-    <: foobar @= (Sum 1, "foobar")-    <: foobaz @= (Sum 5, mempty)-    <: fooqux @= (Sum 6, mempty)-    <: barfoo @= mempty-    <: barbaz @= mempty-    <: barqux @= mempty-    <: nil-{-# NOINLINE recA #-}--recB :: Record Fields-recB = foo @= Sum 2 <: bar @= "barB" <: baz @= pure 42 <: qux @= "qux"-  <: foobar @= (Sum 1, "foobar")-  <: foobaz @= (Sum 5, mempty)-  <: fooqux @= (Sum 7, mempty)-  <: barfoo @= mempty-  <: barbaz @= mempty-  <: barqux @= mempty-  <: nil-{-# NOINLINE recB #-}--data HsRec = HsRec { _hsFoo :: Sum Int, _hsBar :: String, _hsBaz :: First Int-  , _hsQux :: String-  , _hsFooBar :: (Sum Int, String)-  , _hsFooBaz :: (Sum Int, First Int)-  , _hsFooQux :: (Sum Int, String)-  , _hsBarFoo :: (String, Sum Int)-  , _hsBarBaz :: (String, First Int)-  , _hsBarQux :: (String, String)-  }-makeLenses ''HsRec--hsRec = HsRec { _hsFoo = Sum 1, _hsBar = "hsBar"-  , _hsBaz = mempty, _hsQux = "hsQux"-  , _hsFooBar = (Sum 1, "foobar")-  , _hsFooBaz = (Sum 5, mempty)-  , _hsFooQux = (Sum 6, mempty)-  , _hsBarFoo = mempty-  , _hsBarBaz = mempty-  , _hsBarQux = mempty-  }--main = defaultMain-  [ bgroup "basic"-    [ bench "view" $ whnf (view foo) $! recA-    , bench "hsview" $ whnf (view hsFoo) $! hsRec-    , bench "set" $ whnf (set foo 3) $! recB-    , bench "hsset" $ whnf (set hsFoo 3) $! hsRec-    ]-  , bgroup "instances"-    [ bench "mappend" $ whnf (uncurry mappend) (recA, recB)-    , bench "==" $ whnf (uncurry (==)) $! (recA, recB)-    , bench "compare" $ whnf (uncurry compare) (recA, recB)-    , bench "show" $ nf show recA-    ]-  ]

@@ -1,5 +1,5 @@ name:                extensible-version:             0.4.3+version:             0.4.4 synopsis:            Extensible, efficient, optics-friendly data types and effects homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues@@ -12,7 +12,7 @@ category:            Data, Records, Monads build-type:          Simple stability:           experimental-Tested-With:         GHC == 7.10.3, GHC == 8.0.1+Tested-With:         GHC == 7.10.3, GHC == 8.0.2  extra-source-files:   examples/*.hs@@ -85,20 +85,4 @@   main-is: effects.hs   build-depends: base, extensible   hs-source-dirs: tests-  default-language:    Haskell2010--benchmark records-  type:           exitcode-stdio-1.0-  main-is:        records.hs-  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-effects, mtl   default-language:    Haskell2010

@@ -105,24 +105,18 @@  instance Generate '[] where   henumerate _ r = r-  {-# INLINE henumerate #-}    hcount _ = 0-  {-# INLINE hcount #-}    hgenerateList _ = pure HNil-  {-# INLINE hgenerateList #-}  instance Generate xs => Generate (x ': xs) where   henumerate f r = f here $ henumerate (f . navNext) r-  {-# INLINE henumerate #-}    hcount _ = 1 + hcount (Proxy :: Proxy xs)-  {-# INLINE hcount #-}    -- | Enumerate 'Membership's and construct an 'HList'.   hgenerateList f = HCons <$> f here <*> hgenerateList (f . navNext)-  {-# INLINE hgenerateList #-}  -- | Every element in @xs@ satisfies @c@ class (ForallF c xs, Generate xs) => Forall (c :: k -> Constraint) (xs :: [k]) where@@ -134,17 +128,13 @@  instance Forall c '[] where   henumerateFor _ _ _ r = r-  {-# INLINE henumerateFor #-}    hgenerateListFor _ _ = pure HNil-  {-# INLINE hgenerateListFor #-}  instance (c x, Forall c xs) => Forall c (x ': xs) where   henumerateFor p _ f r = f here $ henumerateFor p (Proxy :: Proxy xs) (f . navNext) r-  {-# INLINE henumerateFor #-}    hgenerateListFor p f = HCons <$> f here <*> hgenerateListFor p (f . navNext)-  {-# INLINE hgenerateListFor #-}  type family ForallF (c :: k -> Constraint) (xs :: [k]) :: Constraint where   ForallF c '[] = ()

@@ -60,6 +60,10 @@     (library :: Comp Dict (Instance1 Monoid h) :* xs)   {-# INLINE mappend #-} +instance WrapForall Bounded h xs => Bounded (h :* xs) where+  minBound = hrepeatFor (Proxy :: Proxy (Instance1 Bounded h)) minBound+  maxBound = hrepeatFor (Proxy :: Proxy (Instance1 Bounded h)) maxBound+ instance WrapForall NFData h xs => NFData (h :* xs) where   rnf xs = henumerateFor (Proxy :: Proxy (Instance1 NFData h)) (Proxy :: Proxy xs)     (\i -> deepseq (hlookup i xs)) ()

@@ -18,6 +18,7 @@   , liftEff   , liftsEff   , hoistEff+  , castEff   -- * Step-wise handling   , Interpreter(..)   , handleEff@@ -54,6 +55,7 @@   , stateEff   , runStateEff   , execStateEff+  , evalStateEff   -- ** Writer   , WriterEff   , writerEff@@ -74,14 +76,21 @@   , Identity   , tickEff   , runIterEff+  -- ** Cont+  , ContT+  , contEff+  , runContEff   ) where  import Control.Applicative import Control.Monad.Skeleton import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Cont (ContT(..)) import Data.Extensible.Field+import Data.Extensible.Inclusion import Data.Extensible.Internal import Data.Extensible.Internal.Rig+import Data.Extensible.Product import Data.Extensible.Class import Data.Functor.Identity import Data.Profunctor.Unsafe -- Trustworthy since 7.8@@ -115,6 +124,11 @@   _ -> Instruction i t {-# INLINABLE hoistEff #-} +-- | Upcast an action.+castEff :: IncludeAssoc ys xs => Eff xs a -> Eff ys a+castEff = hoistSkeleton+  $ \(Instruction i t) -> Instruction (hlookup i inclusionAssoc) t+ -- | Build a relay-style handler from a triple of functions. -- -- @@@ -320,11 +334,16 @@ runStateEff = peelEff1 (\a s -> return (a, s)) contState {-# INLINE runStateEff #-} --- | Run the frontal state effect.+-- | Run the frontal state effect and return the final state. execStateEff :: forall k s xs a. Eff (k >: State s ': xs) a -> s -> Eff xs s execStateEff = peelEff1 (const return) contState {-# INLINE execStateEff #-} +-- | Run the frontal state effect and return the final result.+evalStateEff :: forall k s xs a. Eff (k >: State s ': xs) a -> s -> Eff xs a+evalStateEff = peelEff1 (const . return) contState+{-# INLINE evalStateEff #-}+ -- | @(,)@ already is a writer monad. type WriterEff w = (,) w @@ -404,7 +423,7 @@       Right Refl -> handler (getConst t) {-# INLINE catchEff #-} --- | Run the frontal Either effect.+-- | Run an action and abort on 'throwEff'. runEitherEff :: forall k e xs a. Eff (k >: EitherEff e ': xs) a -> Eff xs (Either e a) runEitherEff = peelEff0 (return . Right) $ \(Const e) _ -> return $ Left e {-# INLINE runEitherEff #-}@@ -414,7 +433,7 @@ tickEff k = liftEff k $ Identity () {-# INLINE tickEff #-} --- | Run a computation until 'tickEff'.+-- | Run a computation until the first call of 'tickEff'. runIterEff :: Eff (k >: Identity ': xs) a   -> Eff xs (Either a (Eff (k >: Identity ': xs) a)) runIterEff m = case debone m of@@ -422,3 +441,18 @@   Instruction i t :>>= k -> leadership i     (\Refl -> return $ Right $ k $ runIdentity t)     $ \j -> boned $ Instruction j t :>>= runIterEff . k++-- | Place a continuation-passing action.+contEff :: Associate k (ContT r m) xs => Proxy k+  -> ((a -> m r) -> m r) -> Eff xs a+contEff k = liftEff k . ContT++-- | Unwrap a continuation.+runContEff :: forall k r xs a. Eff (k >: ContT r (Eff xs) ': xs) a+  -> (a -> Eff xs r)+  -> Eff xs r+runContEff m cont = case debone m of+  Return a -> cont a+  Instruction i t :>>= k -> leadership i+    (\Refl -> runContT t (flip runContEff cont . k))+    $ \j -> boned $ Instruction j t :>>= flip runContEff cont . k

@@ -18,8 +18,11 @@   , runReaderDef   , StateDef   , runStateDef+  , evalStateDef+  , execStateDef   , WriterDef   , runWriterDef+  , execWriterDef   , MaybeDef   , runMaybeDef   , EitherDef@@ -68,6 +71,7 @@   throwError = throwEff pEither   catchError = catchEff pEither +-- | A bit dubious instance (Monoid e, Associate "Either" (Const e) xs) => Alternative (Eff xs) where   empty = throwError mempty   p <|> q = catchError p (const q)@@ -76,32 +80,55 @@   mzero = empty   mplus = (<|>) +-- | mtl-compatible reader type ReaderDef r = "Reader" >: ReaderEff r +-- | Specialised version of 'runReaderEff' compatible with the 'MonadReader' instance. runReaderDef :: Eff (ReaderDef r ': xs) a -> r -> Eff xs a runReaderDef = runReaderEff {-# INLINE runReaderDef #-} +-- | mtl-compatible state type StateDef s = "State" >: State s +-- | 'runStateEff' specialised for the 'MonadState' instance. runStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs (a, s) runStateDef = runStateEff {-# INLINE runStateDef #-} +-- | 'evalStateEff' specialised for the 'MonadState' instance.+evalStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs a+evalStateDef = evalStateEff+{-# INLINE evalStateDef #-}++-- | 'execStateEff' specialised for the 'MonadState' instance.+execStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs s+execStateDef = execStateEff+{-# INLINE execStateDef #-}++-- | mtl-compatible writer type WriterDef w = "Writer" >: WriterEff w +-- | 'runWriterDef' specialised for the 'MonadWriter' instance. runWriterDef :: Monoid w => Eff (WriterDef w ': xs) a -> Eff xs (a, w) runWriterDef = runWriterEff {-# INLINE runWriterDef #-} -type MaybeDef = "Maybe" >: EitherEff ()+-- | 'execWriterDef' specialised for the 'MonadWriter' instance.+execWriterDef :: Monoid w => Eff (WriterDef w ': xs) a -> Eff xs w+execWriterDef = execWriterEff+{-# INLINE execWriterDef #-} +type MaybeDef = "Either" >: EitherEff ()++-- | Similar to 'runMaybeT', but on 'Eff' runMaybeDef :: Eff (MaybeDef ': xs) a -> Eff xs (Maybe a) runMaybeDef = runMaybeEff {-# INLINE runMaybeDef #-}  type EitherDef e = "Either" >: EitherEff e +-- | Similar to 'runExceptT', but on 'Eff' runEitherDef :: Eff (EitherDef e ': xs) a -> Eff xs (Either e a) runEitherDef = runEitherEff {-# INLINE runEitherDef #-}

@@ -206,12 +206,26 @@   dimap _ _ _ = error "Impossible"  -- | Annotate a value by the field name.+--+-- @+-- foo :: 'Record' '["num" >: Int, "str" >: String]+-- foo = #num @= 42+--   <: #str @= "foo"+--   <: nil+-- @ (@=) :: Wrapper h => FieldName k -> Repr h v -> Field h (k ':> v) (@=) _ = Field #. review _Wrapper {-# INLINE (@=) #-} infix 1 @=  -- | Lifted ('@=')+-- @+-- foo :: IO ('Record' '["num" >: Int, "str" >: String])+-- foo = hsequence+--   $ #num <@=> readLn+--   <: #str <@=> getLine+--   <: nil+-- @ (<@=>) :: (Functor f, Wrapper h) => FieldName k -> f (Repr h v) -> Comp f (Field h) (k ':> v) (<@=>) k = comp (k @=) {-# INLINE (<@=>) #-}

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

@@ -93,7 +93,7 @@             ]         ]       ]-  info -> fail $ "deriveAsRecord: Unsupported " ++ show info+  info -> fail $ "deriveIsRecord: Unsupported " ++ show info  shape2Pat :: [Pat] -> Pat shape2Pat [] = ConP 'HNil []

@@ -9,6 +9,7 @@ -- ------------------------------------------------------------------------ module Data.Extensible.TH (mkField+  , mkFieldAs   , decEffects   , decEffectSet   , decEffectSuite@@ -39,9 +40,13 @@ -- @ -- mkField :: String -> DecsQ-mkField str = fmap concat $ forM (words str) $ \s@(x:xs) -> do-  let st = litT (strTyLit s)+mkField str = fmap concat $ forM (words str) $ \s@(x:xs) ->   let name = mkName $ if isLower x then x : xs else '_' : x : xs+  in mkFieldAs name s++mkFieldAs :: Name -> String -> DecsQ+mkFieldAs name s = do+  let st = litT (strTyLit s)   let lbl = conE 'Proxy `sigE` (conT ''Proxy `appT` st)   sequence [sigD name $ conT ''FieldOptic `appT` st     , valD (varP name) (normalB $ varE 'itemAssoc `appE` lbl) []

@@ -24,6 +24,7 @@ import Data.Profunctor.Unsafe (Profunctor(..)) import Data.Functor.Identity (Identity(..)) import Data.Extensible.Internal.Rig+import Data.Semigroup import GHC.Generics (Generic)  -- | The extensible data types should take @k -> *@ as a parameter.@@ -59,7 +60,7 @@  -- | Poly-kinded composition newtype Comp (f :: j -> *) (g :: i -> j) (a :: i) = Comp { getComp :: f (g a) }-  deriving (Show, Eq, Ord, Typeable, NFData, Generic)+  deriving (Show, Eq, Ord, Typeable, NFData, Generic, Semigroup, Monoid)  deriving instance (Functor f, Functor g) => Functor (Comp f g) deriving instance (Foldable f, Foldable g) => Foldable (Comp f g)@@ -99,3 +100,10 @@   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)++instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Prod f g a) where+  Prod a b <> Prod c d = Prod (a <> c) (b <> d)++instance (Monoid (f a), Monoid (g a)) => Monoid (Prod f g a) where+  mempty = Prod mempty mempty+  Prod a b `mappend` Prod c d = Prod (mappend a c) (mappend b d)