linear-base 0.1.0 → 0.2.0
raw patch · 128 files changed
+12947/−8857 lines, 128 filesdep +MonadRandomdep +inspection-testingdep +linear-genericsdep ~vectorsetup-changednew-uploader
Dependencies added: MonadRandom, inspection-testing, linear-generics, tasty-inspection-testing
Dependency ranges changed: vector
Files
- CHANGELOG.md +129/−1
- README.md +20/−12
- Setup.hs +2/−5
- bench/Data/Mutable/Array.hs +123/−0
- bench/Data/Mutable/HashMap.hs +184/−124
- bench/Main.hs +4/−4
- docs/DESIGN.md +3/−3
- docs/USER_GUIDE.md +11/−6
- examples/Foreign/Heap.hs +42/−39
- examples/Foreign/List.hs +28/−26
- examples/Generic/Traverse.hs +48/−0
- examples/Main.hs +9/−6
- examples/Simple/FileIO.hs +17/−9
- examples/Simple/Pure.hs +38/−49
- examples/Simple/Quicksort.hs +35/−25
- examples/Simple/TopSort.hs +66/−60
- examples/Test/Foreign.hs +42/−34
- examples/Test/Generic.hs +11/−0
- examples/Test/Quicksort.hs +3/−4
- linear-base.cabal +204/−196
- src/Control/Functor/Linear.hs +56/−32
- src/Control/Functor/Linear/Internal/Class.hs +233/−41
- src/Control/Functor/Linear/Internal/Instances.hs +6/−42
- src/Control/Functor/Linear/Internal/Kan.hs +121/−0
- src/Control/Functor/Linear/Internal/MonadTrans.hs +7/−6
- src/Control/Functor/Linear/Internal/Reader.hs +41/−32
- src/Control/Functor/Linear/Internal/State.hs +50/−44
- src/Control/Monad/IO/Class/Linear.hs +2/−1
- src/Control/Optics/Linear.hs +9/−10
- src/Control/Optics/Linear/Internal.hs +90/−52
- src/Control/Optics/Linear/Iso.hs +15/−10
- src/Control/Optics/Linear/Lens.hs +22/−11
- src/Control/Optics/Linear/Prism.hs +19/−12
- src/Control/Optics/Linear/Traversal.hs +14/−8
- src/Data/Arity/Linear.hs +17/−0
- src/Data/Arity/Linear/Internal.hs +96/−0
- src/Data/Array/Destination.hs +16/−97
- src/Data/Array/Destination/Internal.hs +89/−0
- src/Data/Array/Mutable/Linear.hs +7/−234
- src/Data/Array/Mutable/Linear/Internal.hs +267/−0
- src/Data/Array/Mutable/Unlifted/Linear.hs +85/−90
- src/Data/Array/Polarized.hs +19/−11
- src/Data/Array/Polarized/Pull.hs +27/−24
- src/Data/Array/Polarized/Pull/Internal.hs +40/−35
- src/Data/Array/Polarized/Push.hs +54/−45
- src/Data/Bifunctor/Linear.hs +4/−5
- src/Data/Bifunctor/Linear/Internal/Bifunctor.hs +12/−13
- src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs +20/−15
- src/Data/Bool/Linear.hs +13/−12
- src/Data/Either/Linear.hs +19/−24
- src/Data/Functor/Linear.hs +23/−14
- src/Data/Functor/Linear/Internal/Applicative.hs +182/−21
- src/Data/Functor/Linear/Internal/Functor.hs +136/−34
- src/Data/Functor/Linear/Internal/Traversable.hs +204/−38
- src/Data/HashMap/Mutable/Linear.hs +7/−535
- src/Data/HashMap/Mutable/Linear/Internal.hs +617/−0
- src/Data/List/Linear.hs +211/−176
- src/Data/Maybe/Linear.hs +13/−13
- src/Data/Monoid/Linear.hs +3/−4
- src/Data/Monoid/Linear/Internal/Monoid.hs +106/−18
- src/Data/Monoid/Linear/Internal/Semigroup.hs +170/−50
- src/Data/Num/Linear.hs +102/−49
- src/Data/Ord/Linear.hs +5/−5
- src/Data/Ord/Linear/Internal/Eq.hs +27/−20
- src/Data/Ord/Linear/Internal/Ord.hs +53/−41
- src/Data/Profunctor/Kleisli/Linear.hs +14/−15
- src/Data/Profunctor/Linear.hs +53/−54
- src/Data/Replicator/Linear.hs +44/−0
- src/Data/Replicator/Linear/Internal.hs +185/−0
- src/Data/Replicator/Linear/Internal/Instances.hs +25/−0
- src/Data/Replicator/Linear/Internal/ReplicationStream.hs +98/−0
- src/Data/Set/Mutable/Linear.hs +1/−81
- src/Data/Set/Mutable/Linear/Internal.hs +85/−0
- src/Data/Tuple/Linear.hs +13/−15
- src/Data/Unrestricted/Internal/Consumable.hs +0/−26
- src/Data/Unrestricted/Internal/Dupable.hs +0/−46
- src/Data/Unrestricted/Internal/Instances.hs +0/−241
- src/Data/Unrestricted/Internal/Movable.hs +0/−28
- src/Data/Unrestricted/Internal/Ur.hs +0/−41
- src/Data/Unrestricted/Linear.hs +28/−19
- src/Data/Unrestricted/Linear/Internal/Consumable.hs +279/−0
- src/Data/Unrestricted/Linear/Internal/Dupable.hs +287/−0
- src/Data/Unrestricted/Linear/Internal/Instances.hs +175/−0
- src/Data/Unrestricted/Linear/Internal/Movable.hs +210/−0
- src/Data/Unrestricted/Linear/Internal/Ur.hs +132/−0
- src/Data/Unrestricted/Linear/Internal/UrT.hs +50/−0
- src/Data/V/Linear.hs +27/−16
- src/Data/V/Linear/Internal.hs +248/−0
- src/Data/V/Linear/Internal/Instances.hs +14/−16
- src/Data/V/Linear/Internal/V.hs +0/−167
- src/Data/Vector/Mutable/Linear.hs +6/−316
- src/Data/Vector/Mutable/Linear/Internal.hs +340/−0
- src/Debug/Trace/Linear.hs +29/−26
- src/Foreign/Marshal/Pure.hs +14/−384
- src/Foreign/Marshal/Pure/Internal.hs +397/−0
- src/Prelude/Linear.hs +115/−99
- src/Prelude/Linear/GenericUtil.hs +136/−0
- src/Prelude/Linear/Generically.hs +30/−0
- src/Prelude/Linear/Internal.hs +36/−37
- src/Prelude/Linear/Unsatisfiable.hs +49/−0
- src/Streaming/Internal/Consume.hs +0/−637
- src/Streaming/Internal/Interop.hs +0/−40
- src/Streaming/Internal/Many.hs +0/−371
- src/Streaming/Internal/Process.hs +0/−1474
- src/Streaming/Internal/Produce.hs +0/−486
- src/Streaming/Internal/Type.hs +0/−164
- src/Streaming/Linear.hs +922/−818
- src/Streaming/Linear/Internal/Consume.hs +709/−0
- src/Streaming/Linear/Internal/Interop.hs +45/−0
- src/Streaming/Linear/Internal/Many.hs +397/−0
- src/Streaming/Linear/Internal/Process.hs +1661/−0
- src/Streaming/Linear/Internal/Produce.hs +581/−0
- src/Streaming/Linear/Internal/Type.hs +188/−0
- src/Streaming/Prelude/Linear.hs +62/−64
- src/System/IO/Linear.hs +53/−43
- src/System/IO/Resource.hs +0/−259
- src/System/IO/Resource/Linear.hs +64/−0
- src/System/IO/Resource/Linear/Internal.hs +219/−0
- src/Unsafe/Linear.hs +167/−26
- test/Main.hs +23/−12
- test/Test/Data/Destination.hs +11/−13
- test/Test/Data/Mutable/Array.hs +66/−61
- test/Test/Data/Mutable/HashMap.hs +80/−78
- test/Test/Data/Mutable/Set.hs +36/−35
- test/Test/Data/Mutable/Vector.hs +100/−100
- test/Test/Data/Polarized.hs +22/−22
- test/Test/Data/Replicator.hs +31/−0
- test/Test/Data/V.hs +42/−0
CHANGELOG.md view
@@ -1,5 +1,133 @@ # Change Log -## [0.1.0] - 2021-02-09+## [v0.2.0](https://github.com/tweag/linear-base/tree/v0.2.0) - 2022-03-25++[Full Changelog](https://github.com/tweag/linear-base/compare/v0.1.0...v0.2.0)++### Breaking changes++- Remove `Prelude.Linear.asTypeOf` [\#397](https://github.com/tweag/linear-base/pull/397) ([tbagrel1](https://github.com/tbagrel1))+- Add (and use) linear generics for many classes [\#394](https://github.com/tweag/linear-base/pull/394) ([treeowl](https://github.com/treeowl))+ - `Control.Functor.Linear.Functor`, `Data.Functor.Linear.{Functor,Applicative}` can now be derived through `Generically1`+ - `Data.Functor.Linear.Traversable` cannot be derived directly, but one can get `genericTraverse` for a `Generic1` type and then set `traverse = genericTraverse`+ - `Data.Unrestricted.Linear.{Consumable,Dupable,Movable}` can be derived through `Generically`+- Rework `Data.Monoid.Linear` module (affects linear `Semigroup` and `Monoid`) [\#314](https://github.com/tweag/linear-base/pull/314) ([sjoerdvisscher](https://github.com/sjoerdvisscher)), [\#381](https://github.com/tweag/linear-base/pull/381) ([tbagrel1](https://github.com/tbagrel1))+ - **Remove superclass constraint** on `Prelude.{Semigroup,Monoid}` for `Data.Monoid.Linear.{Semigroup,Monoid}`. `Data.Monoid.Linear.Monoid` instances now have to define `mempty`+ - Add many missing instances of `Data.Monoid.Linear.{Semigroup,Monoid}`+ - Deprecate `Data.Monoid.Linear.{Adding,Multiplying,getAdded,getMultiplied}` in favor of `Data.Semigroup.{Sum,Product}` (reexported under `Data.Monoid.Linear`) which now have linear `Semigroup` and `Monoid` instance. `Sum` and `Product` inner values can be extracted linearly with pattern-matching+ - **`Data.Semigroup` is no longer reexported as a whole under `Data.Monoid.Linear`**. Instead, only newtypes with a linear `Semigroup` instance are reexported+- Add missing fixity declarations for every operator of `linear-base` [\#386](https://github.com/tweag/linear-base/pull/386), ([tbagrel1](https://github.com/tbagrel1))+ - **Unchanged** (already present):<br/>`infixr 0 $`, `infixl 1 &`, `infixr 2 ||`, `infixr 3 &&`,<br/> `infix 4 ==, /=, <=, <, >, >=`, `infixr 5 :>`+ - Add: ```infixr 0 `lseq`, `seq`, $!```+ - Add: `infixl 1 <&>, >>=, >>, &`+ - Add: `infixr 3 ***`+ - Add: ```infix 4 `compare`, `elem` ```+ - Add: `infixl 4 <$>, <$, <*>, <*`+ - Add: `infixr 5 ++`+ - Add: `infixr 6 <>`+ - Add: `infixl 6 +, -`+ - Add: `infixl 7 *`+ - Add: `infixr 9 #., .>, .`+ - **Previously missing fixity declarations defaulted to `infixl 9`, so some code might subtly break when updating to v0.2.0**+- Improve consistency of module naming [\#383](https://github.com/tweag/linear-base/pull/383) ([tbagrel1](https://github.com/tbagrel1))+ - **`System.IO.Resource` -> `System.IO.Resource.Linear`**+- Rework `Data.V.Linear` API [\#360](https://github.com/tweag/linear-base/pull/360) ([tbagrel1](https://github.com/tbagrel1))+ - `Data.Functor.Linear.Applicative` instance+ - `empty :: forall a. V 0 a`+ - `consume :: V 0 a %1 -> ()`+ - `cons :: forall n a. a %1 -> V (n - 1) a %1 -> V n a`+ - `uncons# :: 1 <= n => V n a %1 -> (# a, V (n - 1) a #)`+ - `uncons :: 1 <= n => V n a %1 -> (a, V (n - 1) a)`+ - `elim :: forall (n :: Nat) a b f. IsFunN a b f => f %1 -> V n a %1 -> b`+ - `make :: forall (n :: Nat) a f. IsFunN a (V n a) f => f`+ - `fromReplicator :: forall n a. KnownNat n => Replicator a %1 -> V n a`+ - `theLength :: forall n. KnownNat n => Prelude.Int`+ - **`dupV` is now part of `Data.V.Linear`:**<br/>+ `dupV :: forall n a. (KnownNat n, Dupable a) => a %1 -> V n a`+- Replace `dupV` in the minimal definition of `Data.Unrestricted.Linear.Dupable` with `dupR :: a %1 -> Replicator a` [\#360](https://github.com/tweag/linear-base/pull/360) ([tbagrel1](https://github.com/tbagrel1)) [\#365](https://github.com/tweag/linear-base/pull/365) ([facundominguez](https://github.com/facundominguez))+ - Introduce a new data type `Data.Replicator.Linear.Replicator`, which represents an infinite linear stream producing values of type `a`, with a stream-like API and a `Data.Functor.Linear.Applicative` instance+ - `Data.Unrestricted.Linear.Dupable` no longer depends on `Data.V.Linear`+ - Add `dup3`, `dup4`, `dup5`, `dup6`, `dup7`+- Polymorphise the type of some `Prelude.Linear` functions in levity and multiplicity [\#353](https://github.com/tweag/linear-base/pull/353) ([treeowl](https://github.com/treeowl))+ - `($) :: forall {rep} a (b :: TYPE rep) p q. (a %p-> b) %q-> a %p-> b`+ - `(&) :: forall {rep} a (b :: TYPE rep) p q. a %p-> (a %p-> b) %q-> b`+ - `($!) :: forall {rep} a (b :: TYPE rep) p q. (a %p-> b) %q-> a %p-> b`+ - `(.) :: forall {rep} b (c :: TYPE rep) a q m n. (b %1-> c) %q-> (a %1-> b) %m-> a %n-> c`+ - `forget :: forall {rep} a (b :: TYPE rep). (a %1-> b) %1-> a -> b`+- Multiplicity-polymorphise the type of some `Prelude.Linear` functions [\#319](https://github.com/tweag/linear-base/pull/319) ([aspiwack](https://github.com/aspiwack))+ - `id :: a %q-> a`+ - `const :: a %q-> b -> a`+ - `asTypeOf :: a %q-> a -> a`+ - `seq :: a -> b %q-> b`+ - `curry :: ((a, b) %p-> c) %q-> a %p-> b %p-> c`+ - `uncurry :: (a %p-> b %p-> c) %q-> (a, b) %p-> c`+ - `runIdentity' :: Identity a %p-> a`+- Remove `LinearArrow` usage in `Control.Optics.Linear` and use `FUN 'One` instead [\#308](https://github.com/tweag/linear-base/pull/308) ([sjoerdvisscher](https://github.com/sjoerdvisscher))+ - This change add a `Data.Profunctor.Linear.Profunctor` instance to `FUN 'One`+- Add `.Linear.Internal` modules (and only export parts of them in publicly-exposed `.Linear` modules) [\#306](https://github.com/tweag/linear-base/pull/306) ([ekmett](https://github.com/ekmett))+ - `Data.Array.Destination[.Internal]`+ - `Data.Array.Mutable.Linear[.Internal]`+ - `Data.HashMap.Mutable.Linear[.Internal]`+ - `Data.Set.Mutable.Linear[.Internal]`+ - `Data.Vector.Mutable.Linear[.Internal]`+ - `Foreign.Marshal.Pure[.Internal]`+ - `System.IO.Resource.Linear.[.Internal]`+ - This principle has been applied for newly-created modules in the subsequent PRs++### New additions++- Add `Data.Arity.Linear` module containing type-level helpers to deal with n-ary linear functions and type-level structural integers [\#390](https://github.com/tweag/linear-base/pull/390) ([aspiwack](https://github.com/aspiwack)), [\#391](https://github.com/tweag/linear-base/pull/391) ([tbagrel1](https://github.com/tbagrel1))+- Add `void` function to consume `Control.Functor.Linear.Functor` inner value [\#387](https://github.com/tweag/linear-base/pull/387) ([tbagrel1](https://github.com/tbagrel1))+- Add inspection tests to check inlining of `Data.Replicator.Linear.elim` and `Data.V.Linear.{make,elim}` [\#367](https://github.com/tweag/linear-base/pull/367) ([tbagrel1](https://github.com/tbagrel1))+- Add `genericTraverse` to `Data.Functor.Linear` for `Generics.Linear.Generic1` types [\#366](https://github.com/tweag/linear-base/pull/366) ([tbagrel1](https://github.com/tbagrel1)), [\#384](https://github.com/tweag/linear-base/pull/384) ([aspiwack](https://github.com/aspiwack)), [\#385](https://github.com/tweag/linear-base/pull/385) ([treeowl](https://github.com/treeowl)) +- Add `Unsafe.toLinearN` (and narrow the scope of some coercions in the module internals) [\#346](https://github.com/tweag/linear-base/pull/346) ([treeowl](https://github.com/treeowl))+- Add newtype `Data.Unrestricted.Linear.AsMovable` to derive `Consumable` and `Dupable` from `Movable` [\#357](https://github.com/tweag/linear-base/pull/357) ([tbagrel1](https://github.com/tbagrel1))+- Add `Data.Unrestricted.Linear.{Consumable,Dupable,Moveable}` instances for all Word and Int types [\#352](https://github.com/tweag/linear-base/pull/352) ([googleson78](https://github.com/googleson78))+- Add benchmarks for `Data.HashMap.Linear` [\#338](https://github.com/tweag/linear-base/pull/338) ([utdemir](https://github.com/utdemir))+- Add benchmarks for `Data.Array.Mutable.Linear` [\#331](https://github.com/tweag/linear-base/pull/331) ([utdemir](https://github.com/utdemir))+- Add `Data.Unrestricted.Linear.{Consumable,Dupable}` instances to `Data.V.Linear.V` [\#324](https://github.com/tweag/linear-base/pull/324) ([aspiwack](https://github.com/aspiwack))+- Add `Data.Unrestricted.Linear.UrT`, the unrestricted monad transformer [\#304](https://github.com/tweag/linear-base/pull/304) ([sjoerdvisscher](https://github.com/sjoerdvisscher))++### Code improvements++- Add robustness improvements to `Data.Replicator.Linear.elim` and `Data.V.Linear.{make,elim}` [\#364](https://github.com/tweag/linear-base/pull/364) ([tbagrel1](https://github.com/tbagrel1)), [\#382](https://github.com/tweag/linear-base/pull/382) ([tbagrel1](https://github.com/tbagrel1)), [\#390](https://github.com/tweag/linear-base/pull/390) ([aspiwack](https://github.com/aspiwack)), [\#391](https://github.com/tweag/linear-base/pull/391) ([tbagrel1](https://github.com/tbagrel1))+- Add various optimisations for `Data.HashMap.Linear` [\#337](https://github.com/tweag/linear-base/pull/337) ([utdemir](https://github.com/utdemir))+- Improve `Data.Array.Mutable.Unlifted.Linear.map` performance [\#334](https://github.com/tweag/linear-base/pull/334) ([utdemir](https://github.com/utdemir))+- Remove one `unsafeCoerce` use from `Unsafe.coerce` [\#330](https://github.com/tweag/linear-base/pull/330) ([utdemir](https://github.com/utdemir))+- Improve `Prelude.Linear.seq` performance [\#329](https://github.com/tweag/linear-base/pull/329) ([utdemir](https://github.com/utdemir))+- Use safer `Vector.fromArray` in `Data.Array.Mutable.Linear` internals [\#327](https://github.com/tweag/linear-base/pull/327) ([utdemir](https://github.com/utdemir))+- Remove some incomplete pattern matches in `Data.List.Linear.{scanr,scanr1}` [\#299](https://github.com/tweag/linear-base/pull/299) ([utdemir](https://github.com/utdemir))++### CI/Tooling improvements++- Move CI tests from the `cabal` job to the `stack` job [\#398](https://github.com/tweag/linear-base/pull/398) ([tbagrel1](https://github.com/tbagrel1))+- Set warnings for `ghcide` in the cabal file [\#378](https://github.com/tweag/linear-base/pull/378) ([aspiwack](https://github.com/aspiwack))+- Disable all `hlint` hints except those related to pragmas [\#362](https://github.com/tweag/linear-base/pull/362) ([tbagrel1](https://github.com/tbagrel1))+- Enable doctesting through `cabal-docspec` in the CI [\#361](https://github.com/tweag/linear-base/pull/361) ([andreabedini](https://github.com/andreabedini))+- Format the codebase with [`ormolu`](https://github.com/tweag/ormolu) and add an `ormolu` check to the CI [\#355](https://github.com/tweag/linear-base/pull/355) ([tbagrel1](https://github.com/tbagrel1)), [\#358](https://github.com/tweag/linear-base/pull/358) ([tbagrel1](https://github.com/tbagrel1))+- CI and `shell.nix` overhaul [\#322](https://github.com/tweag/linear-base/pull/322) ([aspiwack](https://github.com/aspiwack)), [\#323](https://github.com/tweag/linear-base/pull/323) ([aspiwack](https://github.com/aspiwack)), [\#325](https://github.com/tweag/linear-base/pull/325) ([utdemir](https://github.com/utdemir)), [\#332](https://github.com/tweag/linear-base/pull/332) ([utdemir](https://github.com/utdemir)), [\#348](https://github.com/tweag/linear-base/pull/348) ([aspiwack](https://github.com/aspiwack)), [\#355](https://github.com/tweag/linear-base/pull/355) ([tbagrel1](https://github.com/tbagrel1)), [\#359](https://github.com/tweag/linear-base/pull/359) ([tbagrel1](https://github.com/tbagrel1))+ - Bump `nixpkgs` and `stackage` pinned versions to recent `unstable`/`nightly` ones+ - Move CI from *Buildkite* to *Github Action*+ - Automatically run the CI on pull requests+ - Add `stack`/Nix integration when `stack` is provided by `nix-shell`/`shell.nix` (the project still builds with a globally installed `stack`)+- Force resolving test dependencies on `cabal` [\#342](https://github.com/tweag/linear-base/pull/342) ([utdemir](https://github.com/utdemir))+- Remove `cabal-docspec` reference from `Setup.hs` [\#335](https://github.com/tweag/linear-base/pull/335) ([facundominguez](https://github.com/facundominguez))+- Start using upstream `nixpkgs` (instead of our own fork) [\#302](https://github.com/tweag/linear-base/pull/302) ([utdemir](https://github.com/utdemir))++### Documentation improvements++- Change relative links for absolute ones in the README [\#401](https://github.com/tweag/linear-base/pull/401) ([tbagrel1](https://github.com/tbagrel1))+- Add comparison table between `Prelude` and `Prelude.Linear` classes [\#368](https://github.com/tweag/linear-base/pull/368) ([tbagrel1](https://github.com/tbagrel1))+- Add Hackage and Stackage badges [\#336](https://github.com/tweag/linear-base/pull/336) ([utdemir](https://github.com/utdemir))+- Hide internal modules from `haddock` documentation [\#326](https://github.com/tweag/linear-base/pull/326) ([utdemir](https://github.com/utdemir)), [\#363](https://github.com/tweag/linear-base/pull/363) ([tbagrel1](https://github.com/tbagrel1))+- Add a note that GHC 9.2 fixes linear `case` in the user guide [\#320](https://github.com/tweag/linear-base/pull/320) ([monoidal](https://github.com/monoidal))+- Replace `#->` with `%1 ->` in the documentation [\#315](https://github.com/tweag/linear-base/pull/315) ([sjoerdvisscher](https://github.com/sjoerdvisscher))+- Fix rendering in `Data.Unrestricted.Linear.Ur` documentation [\#303](https://github.com/tweag/linear-base/pull/303) ([sjoerdvisscher](https://github.com/sjoerdvisscher))+- Fix a typo in `Data.Array.Mutable.Linear.unsafeWrite` documentation [\#301](https://github.com/tweag/linear-base/pull/301) ([daig](https://github.com/daig))+- Add a list of introduction talks about linear types in the README [\#300](https://github.com/tweag/linear-base/pull/300) ([aspiwack](https://github.com/aspiwack))+- Improve developer documentation in `Data.Array.Polarized.Push` [\#294](https://github.com/tweag/linear-base/pull/294) ([Divesh-Otwani](https://github.com/Divesh-Otwani))+++## [v0.1.0](https://github.com/tweag/linear-base/tree/v0.1.0) - 2021-02-09 * Initial release
README.md view
@@ -2,7 +2,8 @@ [](https://github.com/tweag/linear-base/blob/master/LICENSE) [](https://buildkite.com/tweag-1/linear-base)-+[][hackage-pkg]+[][stackage-pkg] Linear base is a standard library for developing applications with linear types. It is named `linear-base` to be an analog to the original [`base`]@@ -29,7 +30,7 @@ ## Getting started `-XLinearTypes` is released with GHC 9, and `linear-base` is released-on [Hackage](https://hackage.haskell.org/package/linear-base).+on [Hackage][hackage-pkg] and [Stackage][stackage-pkg]. All source files with linear types need a language extension pragma at the top:@@ -42,8 +43,11 @@ If you already know what `-XLinearTypes` does and what the linear arrow `a %1-> b` means, then read the [User Guide] and explore the-[`examples/`](./examples) folder to know how to use `linear-base`.+[`examples/`](https://github.com/tweag/linear-base/blob/master/examples) folder to know how to use `linear-base`. +You can also find a table comparing `base` and `linear-base` typeclasses+[here](https://github.com/tweag/linear-base/blob/master/docs/CLASS_TABLE.md).+ ## Learning about `-XLinearTypes` If you're a Haskeller who hasn't written any Linear Haskell code, don't fear!@@ -51,7 +55,7 @@ ### Tutorials and examples - * See the [`examples/`](./examples) folder.+ * See the [`examples/`](https://github.com/tweag/linear-base/blob/master/examples) folder. * [Linear examples on watertight 3D models](https://github.com/gelisam/linear-examples) ### Reading material@@ -65,12 +69,14 @@ * [Here is the paper](https://arxiv.org/pdf/1710.09756.pdf) behind `-XLinearTypes`. ### Talks-- * [Practical Linearity in a higher-order polymorphic language -- POPL 2018](https://www.youtube.com/watch?v=o0z-qlb5xbI)- * [Practical Linearity in a higher-order polymorphic language -- Curry on 2018](https://www.youtube.com/watch?v=t0mhvd3-60Y&t=3s)- * [Practical Linearity in a higher-order polymorphic language -- Haskell Exchange 2018](https://skillsmatter.com/skillscasts/11067-keynote-linear-haskell-practical-linearity-in-a-higher-order-polymorphic-language)+–+ * [Distributed Programming with Linear Types – Haskell Exchange 2017](https://skillsmatter.com/skillscasts/10637-distributed-programming-with-linear-types)+ * [Practical Linearity in a higher-order polymorphic language – POPL 2018](https://www.youtube.com/watch?v=o0z-qlb5xbI)+ * [Practical Linearity in a higher-order polymorphic language – Curry on 2018](https://www.youtube.com/watch?v=t0mhvd3-60Y)+ * [Practical Linearity in a higher-order polymorphic language – Haskell Exchange 2018](https://skillsmatter.com/skillscasts/11067-keynote-linear-haskell-practical-linearity-in-a-higher-order-polymorphic-language) * [Implementing Linear Haskell](https://www.youtube.com/watch?v=uxv62QQajx8)- * [In-place array update with linear types -- ZuriHac 2020](https://www.youtube.com/watch?v=I7-JuVNvz78)+ * [In-place array update with linear types – ZuriHac 2020](https://www.youtube.com/watch?v=I7-JuVNvz78)+ * [Typecheck Your Memory Management with Linear Types – Haskell Exchange 2017](https://skillsmatter.com/skillscasts/14896-typecheck-your-memory-management-with-linear-types) ## Contributing @@ -81,11 +87,13 @@ ## Licence -See the [Licence file](./LICENSE).+See the [Licence file](https://github.com/tweag/linear-base/blob/master/LICENSE). Copyright © Tweag Holding and its affiliates. [Tweag]: https://www.tweag.io/ [`base`]: https://hackage.haskell.org/package/base-[User Guide]: ./docs/USER_GUIDE.md-[Design Document]: ./docs/DESIGN.md+[User Guide]: https://github.com/tweag/linear-base/blob/master/docs/USER_GUIDE.md+[Design Document]: https://github.com/tweag/linear-base/blob/master/docs/DESIGN.md+[hackage-pkg]: https://hackage.haskell.org/package/linear-base+[stackage-pkg]: https://www.stackage.org/nightly/package/linear-base
Setup.hs view
@@ -1,6 +1,3 @@-module Main where--import Distribution.Extra.Doctest (defaultMainWithDoctests)+import Distribution.Simple -main :: IO ()-main = defaultMainWithDoctests "doctests"+main = defaultMain
+ bench/Data/Mutable/Array.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE TypeApplications #-}++module Data.Mutable.Array (benchmarks) where++import Control.DeepSeq (rnf)+import qualified Data.Array.Mutable.Linear as Array.Linear+import Data.Function ((&))+import qualified Data.Unrestricted.Linear as Linear+import qualified Data.Vector+import Gauge+import qualified Prelude.Linear as Linear++dontFuse :: a -> a+dontFuse a = a+{-# NOINLINE dontFuse #-}++arr_size :: Int+arr_size = 10_000_000++benchmarks :: Benchmark+benchmarks =+ bgroup+ "arrays"+ [ runImpls "toList" bToList arr_size,+ runImpls "map" bMap arr_size,+ runImpls "reads" bReads arr_size+ ]++--------------------------------------------------------------------------------++data Impls+ = Impls+ (Array.Linear.Array Int %1 -> ())+ (Data.Vector.Vector Int -> ())++runImpls :: String -> Impls -> Int -> Benchmark+runImpls name impls size =+ let Impls linear dataVector = impls+ in bgroup+ name+ [ bench "Data.Array.Mutable.Linear" $ whnf (runLinear linear) size,+ bench "Data.Vector" $ whnf (runDataVector dataVector) size+ ]+ where+ runLinear :: (Array.Linear.Array Int %1 -> ()) -> Int -> ()+ runLinear cb sz = Linear.unur (Array.Linear.alloc sz 0 (\a -> Linear.move (cb a)))++ runDataVector :: (Data.Vector.Vector Int -> ()) -> Int -> ()+ runDataVector cb sz = cb (Data.Vector.replicate sz 0)++--------------------------------------------------------------------------------++bToList :: Impls+bToList = Impls linear dataVector+ where+ linear :: Array.Linear.Array Int %1 -> ()+ linear hm =+ hm+ Linear.& Array.Linear.toList+ Linear.& Linear.lift rnf+ Linear.& Linear.unur++ dataVector :: Data.Vector.Vector Int -> ()+ dataVector hm =+ hm+ & Data.Vector.toList+ & rnf+{-# NOINLINE bToList #-}++bMap :: Impls+bMap = Impls linear dataVector+ where+ linear :: Array.Linear.Array Int %1 -> ()+ linear hm =+ hm+ Linear.& Array.Linear.map (+ 1)+ Linear.& Array.Linear.unsafeGet 5+ Linear.& (`Linear.lseq` ())++ dataVector :: Data.Vector.Vector Int -> ()+ dataVector hm =+ hm+ & Data.Vector.map (+ 1)+ & dontFuse -- This looks like cheating, I know. But we're trying to measure+ -- the speed of `map`, and without this, `vector` fuses the `map`+ -- with the subsequent `index` to skip writing to the rest of the+ -- vector.+ & (`Data.Vector.unsafeIndex` 5)+ & (`seq` ())+{-# NOINLINE bMap #-}++bReads :: Impls+bReads = Impls linear dataVector+ where+ linear :: Array.Linear.Array Int %1 -> ()+ linear hm =+ hm+ Linear.& Array.Linear.size+ Linear.& \(Linear.Ur sz, arr) ->+ arr+ Linear.& go 0 sz+ where+ go :: Int -> Int -> Array.Linear.Array Int %1 -> ()+ go start end arr+ | start < end =+ Array.Linear.unsafeGet start arr+ Linear.& \(Linear.Ur i, arr') -> i `Linear.seq` go (start + 1) end arr'+ | otherwise = arr `Linear.lseq` ()++ dataVector :: Data.Vector.Vector Int -> ()+ dataVector v =+ let sz = Data.Vector.length v+ in go 0 sz+ where+ go :: Int -> Int -> ()+ go start end+ | start < end =+ (v Data.Vector.! start) `seq` go (start + 1) end+ | otherwise = ()+{-# NOINLINE bReads #-}
bench/Data/Mutable/HashMap.hs view
@@ -2,32 +2,31 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LinearTypes #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-module Data.Mutable.HashMap (hmbench, getHMInput) where+{-# LANGUAGE TupleSections #-} -import Gauge-import qualified System.Random as Random-import qualified System.Random.Shuffle as Random-import Control.DeepSeq (deepseq, force, NFData(..))-import Data.Hashable (Hashable(..), hashWithSalt)-import GHC.Generics (Generic)-import qualified Data.Unrestricted.Linear as Linear-import Data.List (foldl')-import qualified Prelude.Linear as Linear-import Control.Monad.ST (runST, ST)-import Control.Exception (evaluate)+module Data.Mutable.HashMap (hmbench) where +import Control.DeepSeq (NFData (..), deepseq, force)+import qualified Control.Monad.Random as Random+import Control.Monad.ST (ST, runST)+import Data.Coerce (coerce) import qualified Data.HashMap.Mutable.Linear as LMap import qualified Data.HashMap.Strict as Map import qualified Data.HashTable.ST.Basic as BasicST import qualified Data.HashTable.ST.Cuckoo as CuckooST-+import Data.Hashable (Hashable (..), hashWithSalt)+import Data.List (foldl')+import qualified Data.Unrestricted.Linear as Linear+import GHC.Generics (Generic)+import Gauge+import qualified Prelude.Linear as Linear+import qualified System.Random.Shuffle as Random -- # Exported benchmarks -------------------------------------------------------------------------------@@ -35,160 +34,168 @@ newtype Key = Key Int deriving instance Eq Key+ deriving instance Ord Key+ deriving instance Generic Key+ deriving instance NFData Key+ instance Hashable Key where- hash (Key x) =- x `hashWithSalt` (154669 :: Int)- -- Note: salt with a prime+ hash (Key x) =+ x `hashWithSalt` (154669 :: Int) +-- Note: salt with a prime+ data BenchInput where BenchInput ::- { pairs :: ![(Key, Int)] -- Keys paired with values- , shuffle1 :: ![Key]- , shuffle2 :: ![Key]- , shuffle3 :: ![Key]- } -> BenchInput+ { pairs :: ![(Key, Int)], -- Keys paired with values+ shuffle1 :: ![Key],+ shuffle2 :: ![Key],+ shuffle3 :: ![Key]+ } ->+ BenchInput+ deriving (Generic) -hmbench :: BenchInput -> Benchmark-hmbench inp = bgroup "Comparing Linear Hashmaps"- [ bgroup "linear-base:Data.HashMap.Mutable.Linear" $- linear_hashmap inp- , bgroup "unordered-containers:Data.HashMap.Strict" $- vanilla_hashmap_strict inp- , bgroup "hashtables:Data.HashTable.ST.Basic" $- st_basic inp- , bgroup "hashtables:Data.HashTable.ST.Cuckoo" $- st_cuckoo inp- ]+instance NFData BenchInput +hmbench :: Benchmark+hmbench =+ bgroup+ "hashmaps"+ [ bgroup "linear-base:Data.HashMap.Mutable.Linear" $+ linear_hashmap inp,+ bgroup "unordered-containers:Data.HashMap.Strict" $+ vanilla_hashmap_strict inp,+ bgroup "hashtables:Data.HashTable.ST.Basic" $+ st_basic inp,+ bgroup "hashtables:Data.HashTable.ST.Cuckoo" $+ st_cuckoo inp,+ microbenchmarks+ ]+ where+ !inp = force . flip Random.evalRand (Random.mkStdGen 4541645642) $ do+ let keys = map Key $ enumFromTo 1 num_keys+ shuff1 <- Random.shuffleM keys+ shuff2 <- Random.shuffleM shuff1+ shuff3 <- Random.shuffleM shuff2+ vals <- Random.getRandomRs (0, num_keys)+ let kv_pairs = zip keys vals+ return $ BenchInput kv_pairs shuff1 shuff2 shuff3+ descriptions :: [String] descriptions = -- By "shuffle" we mean we vary the order we access keys- [ "Insert x, delete x, repeat for whole range"- , "Insert all, shuffle, modify all"- , "Insert all, shuffle, lookup all"- , "Insert all, shuffle, modify all, shuffle, lookup all"- , "Insert all, shuffle, modify all, shuffle, modify all, shuffle, lookup all"+ [ "Insert x, delete x, repeat for whole range",+ "Insert all, shuffle, modify all",+ "Insert all, shuffle, lookup all",+ "Insert all, shuffle, modify all, shuffle, lookup all",+ "Insert all, shuffle, modify all, shuffle, modify all, shuffle, lookup all" ] - -- # Config ------------------------------------------------------------------------------- num_keys :: Int num_keys = 100_000 -getHMInput :: IO BenchInput-getHMInput = do- let keys = map Key $ enumFromTo 1 num_keys- g0 <- Random.getStdGen- let (gx,gc) = Random.split g0- let (ga,gb) = Random.split gx- shuff1 <- evaluate $ force $ Random.shuffle' keys num_keys ga- shuff2 <- evaluate $ force $ Random.shuffle' shuff1 num_keys gb- shuff3 <- evaluate $ force $ Random.shuffle' shuff2 num_keys gc- g1 <- Random.getStdGen- let (vals :: [Int]) = Random.randomRs (0,num_keys) g1- kv_pairs <- evaluate $ force (zip keys vals)- return $ BenchInput kv_pairs shuff1 shuff2 shuff3- modVal :: Maybe Int -> Maybe Int modVal Nothing = Nothing modVal (Just !k) | even k = Nothing- | otherwise = Just $ floor (sqrt (fromIntegral k) :: Float) + (2*k) + 1-+ | otherwise = Just $ floor (sqrt (fromIntegral k) :: Float) + (2 * k) + 1 -- # Linear Hashmaps ------------------------------------------------------------------------------- linear_hashmap :: BenchInput -> [Benchmark]-linear_hashmap inp@(BenchInput {pairs=kvs}) =+linear_hashmap inp@(BenchInput {pairs = kvs}) = [bench1, bench2, bench3, bench4, bench5] where mkBench :: Int ->- ([(Key,Int)] -> LMap.HashMap Key Int %1-> LMap.HashMap Key Int) ->+ ([(Key, Int)] -> LMap.HashMap Key Int %1 -> LMap.HashMap Key Int) -> Benchmark- mkBench n f = bench (descriptions!!n) $ nf- (\xs -> unur $ LMap.empty num_keys Linear.$ kill Linear.. f xs) kvs+ mkBench n f =+ bench (descriptions !! n) $+ nf+ (\xs -> unur $ LMap.empty num_keys Linear.$ kill Linear.. f xs)+ kvs - kill :: LMap.HashMap k v %1-> Linear.Ur ()+ kill :: LMap.HashMap k v %1 -> Linear.Ur () kill hmap = Linear.lseq hmap (Linear.Ur ()) unur :: Linear.Ur a -> a unur (Linear.Ur a) = a - foldlx :: (b %1-> a -> b) -> [a] -> b %1-> b+ foldlx :: (b %1 -> a -> b) -> [a] -> b %1 -> b foldlx _ [] !b = b- foldlx f (a:as) !b = foldlx f as (f b a)+ foldlx f (a : as) !b = foldlx f as (f b a) - look :: LMap.HashMap Key Int %1-> Key -> LMap.HashMap Key Int- look hmap k = LMap.lookup k hmap Linear.& \case- (Linear.Ur Nothing, hmap0) -> hmap0- (Linear.Ur (Just v), hmap0) -> Linear.seq (force v) hmap0+ look :: LMap.HashMap Key Int %1 -> Key -> LMap.HashMap Key Int+ look hmap k =+ LMap.lookup k hmap Linear.& \case+ (Linear.Ur Nothing, hmap0) -> hmap0+ (Linear.Ur (Just v), hmap0) -> Linear.seq (force v) hmap0 insertDelete ::- LMap.HashMap Key Int %1-> (Key,Int) -> LMap.HashMap Key Int- insertDelete hmap (c,v) = LMap.delete c (LMap.insert c v hmap)+ LMap.HashMap Key Int %1 -> (Key, Int) -> LMap.HashMap Key Int+ insertDelete hmap (c, v) = LMap.delete c (LMap.insert c v hmap) bench1 :: Benchmark bench1 = mkBench 0 bench1_ - bench1_ :: [(Key,Int)] -> LMap.HashMap Key Int %1-> LMap.HashMap Key Int+ bench1_ :: [(Key, Int)] -> LMap.HashMap Key Int %1 -> LMap.HashMap Key Int bench1_ xs = foldlx insertDelete xs bench2 :: Benchmark bench2 = mkBench 1 bench2_ - bench2_ :: [(Key,Int)] -> LMap.HashMap Key Int %1-> LMap.HashMap Key Int+ bench2_ :: [(Key, Int)] -> LMap.HashMap Key Int %1 -> LMap.HashMap Key Int bench2_ xs =- foldlx (Linear.flip (LMap.alter modVal)) (shuffle1 inp) Linear..- LMap.insertAll xs+ foldlx (Linear.flip (LMap.alter modVal)) (shuffle1 inp)+ Linear.. LMap.insertAll xs bench3 :: Benchmark bench3 = mkBench 2 bench3_ - bench3_ :: [(Key,Int)] -> LMap.HashMap Key Int %1-> LMap.HashMap Key Int+ bench3_ :: [(Key, Int)] -> LMap.HashMap Key Int %1 -> LMap.HashMap Key Int bench3_ xs =- foldlx look (shuffle1 inp) Linear..- LMap.insertAll xs+ foldlx look (shuffle1 inp)+ Linear.. LMap.insertAll xs bench4 :: Benchmark bench4 = mkBench 3 bench4_ - bench4_ :: [(Key,Int)] -> LMap.HashMap Key Int %1-> LMap.HashMap Key Int+ bench4_ :: [(Key, Int)] -> LMap.HashMap Key Int %1 -> LMap.HashMap Key Int bench4_ xs =- foldlx look (shuffle2 inp) Linear..- foldlx (Linear.flip (LMap.alter modVal)) (shuffle1 inp) Linear..- LMap.insertAll xs+ foldlx look (shuffle2 inp)+ Linear.. foldlx (Linear.flip (LMap.alter modVal)) (shuffle1 inp)+ Linear.. LMap.insertAll xs bench5 :: Benchmark bench5 = mkBench 4 bench5_ - bench5_ :: [(Key,Int)] -> LMap.HashMap Key Int %1-> LMap.HashMap Key Int+ bench5_ :: [(Key, Int)] -> LMap.HashMap Key Int %1 -> LMap.HashMap Key Int bench5_ xs =- foldlx look (shuffle3 inp) Linear..- foldlx (Linear.flip (LMap.alter modVal)) (shuffle2 inp) Linear..- foldlx (Linear.flip (LMap.alter modVal)) (shuffle1 inp) Linear..- LMap.insertAll xs-+ foldlx look (shuffle3 inp)+ Linear.. foldlx (Linear.flip (LMap.alter modVal)) (shuffle2 inp)+ Linear.. foldlx (Linear.flip (LMap.alter modVal)) (shuffle1 inp)+ Linear.. LMap.insertAll xs -- # Vanilla Hashmaps ------------------------------------------------------------------------------- vanilla_hashmap_strict :: BenchInput -> [Benchmark]-vanilla_hashmap_strict inp@(BenchInput {pairs=kvs}) =+vanilla_hashmap_strict inp@(BenchInput {pairs = kvs}) = [bench1, bench2, bench3, bench4, bench5] where mkBench :: Int ->- ([(Key,Int)] -> Map.HashMap Key Int -> Map.HashMap Key Int) ->+ ([(Key, Int)] -> Map.HashMap Key Int -> Map.HashMap Key Int) -> Benchmark mkBench n f =- bench (descriptions!!n) $ nf (\xs -> f xs Map.empty) kvs+ bench (descriptions !! n) $ nf (\xs -> f xs Map.empty) kvs foldlx :: (b -> a -> b) -> [a] -> b -> b foldlx f xs b = foldl' f b xs@@ -200,49 +207,51 @@ bench1 :: Benchmark bench1 = mkBench 0 $- \xs hm -> foldl' (\m (k,v) -> Map.delete k (Map.insert k v m)) hm xs+ \xs hm -> foldl' (\m (k, v) -> Map.delete k (Map.insert k v m)) hm xs bench2 :: Benchmark bench2 = mkBench 1 $ \xs ->- foldlx (flip $ Map.alter modVal) (shuffle1 inp) .- foldlx (flip $ uncurry Map.insert) xs+ foldlx (flip $ Map.alter modVal) (shuffle1 inp)+ . foldlx (flip $ uncurry Map.insert) xs bench3 :: Benchmark bench3 = mkBench 2 $ \xs ->- foldlx look (shuffle1 inp) .- foldlx (flip $ uncurry Map.insert) xs+ foldlx look (shuffle1 inp)+ . foldlx (flip $ uncurry Map.insert) xs bench4 :: Benchmark bench4 = mkBench 3 $ \xs ->- foldlx look (shuffle2 inp) .- foldlx (flip $ Map.alter modVal) (shuffle1 inp) .- foldlx (flip $ uncurry Map.insert) xs+ foldlx look (shuffle2 inp)+ . foldlx (flip $ Map.alter modVal) (shuffle1 inp)+ . foldlx (flip $ uncurry Map.insert) xs bench5 :: Benchmark bench5 = mkBench 4 $ \xs ->- foldlx look (shuffle3 inp) .- foldlx (flip $ Map.alter modVal) (shuffle2 inp) .- foldlx (flip $ Map.alter modVal) (shuffle1 inp) .- foldlx (flip $ uncurry Map.insert) xs-+ foldlx look (shuffle3 inp)+ . foldlx (flip $ Map.alter modVal) (shuffle2 inp)+ . foldlx (flip $ Map.alter modVal) (shuffle1 inp)+ . foldlx (flip $ uncurry Map.insert) xs -- # ST Basic ------------------------------------------------------------------------------- -st_basic :: BenchInput -> [Benchmark]-st_basic inp@(BenchInput {pairs=kvs}) =+st_basic :: BenchInput -> [Benchmark]+st_basic inp@(BenchInput {pairs = kvs}) = [bench1, bench2, bench3, bench4, bench5] where mkBench :: Int ->- (forall s. [(Key,Int)] -> BasicST.HashTable s Key Int -> ST s ()) ->+ (forall s. [(Key, Int)] -> BasicST.HashTable s Key Int -> ST s ()) -> Benchmark- mkBench n f = bench (descriptions!!n) $ nf- (\xs -> runST (BasicST.newSized num_keys >>= f xs)) kvs+ mkBench n f =+ bench (descriptions !! n) $+ nf+ (\xs -> runST (BasicST.newSized num_keys >>= f xs))+ kvs look :: BasicST.HashTable s Key Int -> Key -> ST s () look m k = do@@ -253,45 +262,47 @@ bench1 :: Benchmark bench1 = mkBench 0 $ \xs hm ->- mapM_ (\(k,v) -> BasicST.insert hm k v >> BasicST.delete hm k) xs+ mapM_ (\(k, v) -> BasicST.insert hm k v >> BasicST.delete hm k) xs bench2 :: Benchmark bench2 = mkBench 1 $ \xs hm -> do- mapM_ (\(k,v) -> BasicST.insert hm k v) xs+ mapM_ (\(k, v) -> BasicST.insert hm k v) xs mapM_ (\k -> BasicST.mutate hm k ((,()) . modVal)) (shuffle1 inp) bench3 :: Benchmark bench3 = mkBench 2 $ \xs hm -> do- mapM_ (\(k,v) -> BasicST.insert hm k v) xs+ mapM_ (\(k, v) -> BasicST.insert hm k v) xs mapM_ (look hm) (shuffle1 inp) bench4 :: Benchmark bench4 = mkBench 3 $ \xs hm -> do- mapM_ (\(k,v) -> BasicST.insert hm k v) xs+ mapM_ (\(k, v) -> BasicST.insert hm k v) xs mapM_ (\k -> BasicST.mutate hm k ((,()) . modVal)) (shuffle1 inp) mapM_ (look hm) (shuffle2 inp) bench5 :: Benchmark bench5 = mkBench 4 $ \xs hm -> do- mapM_ (\(k,v) -> BasicST.insert hm k v) xs+ mapM_ (\(k, v) -> BasicST.insert hm k v) xs mapM_ (\k -> BasicST.mutate hm k ((,()) . modVal)) (shuffle1 inp) mapM_ (\k -> BasicST.mutate hm k ((,()) . modVal)) (shuffle2 inp) mapM_ (look hm) (shuffle3 inp) - -- # ST Cuckoo ------------------------------------------------------------------------------- -st_cuckoo :: BenchInput -> [Benchmark]-st_cuckoo inp@(BenchInput {pairs=kvs}) =+st_cuckoo :: BenchInput -> [Benchmark]+st_cuckoo inp@(BenchInput {pairs = kvs}) = [bench1, bench2, bench3, bench4, bench5] where mkBench :: Int ->- (forall s. [(Key,Int)] -> CuckooST.HashTable s Key Int -> ST s ()) ->+ (forall s. [(Key, Int)] -> CuckooST.HashTable s Key Int -> ST s ()) -> Benchmark- mkBench n f = bench (descriptions!!n) $ nf- (\xs -> runST (CuckooST.newSized num_keys >>= f xs)) kvs+ mkBench n f =+ bench (descriptions !! n) $+ nf+ (\xs -> runST (CuckooST.newSized num_keys >>= f xs))+ kvs look :: CuckooST.HashTable s Key Int -> Key -> ST s () look m k = do@@ -302,28 +313,77 @@ bench1 :: Benchmark bench1 = mkBench 0 $ \xs hm ->- mapM_ (\(k,v) -> CuckooST.insert hm k v >> CuckooST.delete hm k) xs+ mapM_ (\(k, v) -> CuckooST.insert hm k v >> CuckooST.delete hm k) xs bench2 :: Benchmark bench2 = mkBench 1 $ \xs hm -> do- mapM_ (\(k,v) -> CuckooST.insert hm k v) xs+ mapM_ (\(k, v) -> CuckooST.insert hm k v) xs mapM_ (\k -> CuckooST.mutate hm k ((,()) . modVal)) (shuffle1 inp) bench3 :: Benchmark bench3 = mkBench 2 $ \xs hm -> do- mapM_ (\(k,v) -> CuckooST.insert hm k v) xs+ mapM_ (\(k, v) -> CuckooST.insert hm k v) xs mapM_ (look hm) (shuffle1 inp) bench4 :: Benchmark bench4 = mkBench 3 $ \xs hm -> do- mapM_ (\(k,v) -> CuckooST.insert hm k v) xs+ mapM_ (\(k, v) -> CuckooST.insert hm k v) xs mapM_ (\k -> CuckooST.mutate hm k ((,()) . modVal)) (shuffle1 inp) mapM_ (look hm) (shuffle2 inp) bench5 :: Benchmark bench5 = mkBench 4 $ \xs hm -> do- mapM_ (\(k,v) -> CuckooST.insert hm k v) xs+ mapM_ (\(k, v) -> CuckooST.insert hm k v) xs mapM_ (\k -> CuckooST.mutate hm k ((,()) . modVal)) (shuffle1 inp) mapM_ (\k -> CuckooST.mutate hm k ((,()) . modVal)) (shuffle2 inp) mapM_ (look hm) (shuffle3 inp) +-- Microbenchmarks++microbenchmarks :: Benchmark+microbenchmarks =+ bgroup+ "microbenchmarks"+ [ runImpls "insertHeavy" insertHeavy input+ ]+ where+ !input =+ coerce . force . flip Random.evalRand (Random.mkStdGen 4541645642) $+ Random.shuffleM [1 .. num_keys]++data Impls+ = Impls+ ([Key] -> LMap.HashMap Key () %1 -> ())+ ([Key] -> Map.HashMap Key () -> ())++runImpls :: String -> Impls -> [Key] -> Benchmark+runImpls name impls input =+ let Impls linear dataHashMap = impls+ in bgroup+ name+ [ bench "Data.HashMap.Mutable.Linear" $ whnf (runLinear linear) input,+ bench "Data.HashMap.Strict" $ whnf (runDataHashMap dataHashMap) input+ ]+ where+ runLinear :: ([Key] -> LMap.HashMap Key () %1 -> ()) -> [Key] -> ()+ runLinear cb inp = LMap.empty (num_keys * 2) (\hm -> Linear.move (cb inp hm)) Linear.& Linear.unur++ runDataHashMap :: ([Key] -> Map.HashMap Key () -> ()) -> [Key] -> ()+ runDataHashMap cb inp = cb inp Map.empty++insertHeavy :: Impls+insertHeavy = Impls linear dataHashMap+ where+ linear :: [Key] -> LMap.HashMap Key () %1 -> ()+ linear inp hm = go inp hm `Linear.lseq` ()+ where+ go :: [Key] -> LMap.HashMap Key () %1 -> LMap.HashMap Key ()+ go [] h = h+ go (x : xs) h = go xs Linear.$! LMap.insert x () h++ dataHashMap :: [Key] -> Map.HashMap Key () -> ()+ dataHashMap inp hm = go inp hm `seq` ()+ where+ go :: [Key] -> Map.HashMap Key () -> Map.HashMap Key ()+ go [] h = h+ go (x : xs) h = go xs $! Map.insert x () h
bench/Main.hs view
@@ -1,12 +1,12 @@ module Main where +import qualified Data.Mutable.Array as Array+import Data.Mutable.HashMap (hmbench) import Gauge-import Data.Mutable.HashMap (hmbench, getHMInput) main :: IO () main = do- hmInput <- getHMInput defaultMain- [ hmbench hmInput+ [ hmbench,+ Array.benchmarks ]-
docs/DESIGN.md view
@@ -14,7 +14,7 @@ * tools ported from [`base`] and from other critical haskell libraries, like `lens`, * new APIs for using system resources, e.g., file I/O in- [`System.IO.Resource`],+ [`System.IO.Resource.Linear`], * new abstractions made possible by linear types, like monad-free mutable arrays in ([`Data.Array.Mutable.Linear`]). @@ -48,7 +48,7 @@ Example: ```haskell- foldr :: (a #-> b #-> b) -> b #-> [a] #-> b+ foldr :: (a %1-> b %1-> b) -> b %1-> [a] %1-> b foldr f z = \case [] -> z x:xs -> f x (foldr f z xs)@@ -91,5 +91,5 @@ [`Data.Array.Mutable.Linear`]: https://github.com/tweag/linear-base/blob/master/src/Data/Array/Mutable/Linear.hs [blog post]: https://www.tweag.io/posts/2020-01-16-data-vs-control.html [contributor's guide]: ../CONTRIBUTING.md-[`System.IO.Resource`]: https://github.com/tweag/linear-base/blob/master/src/System/IO/Resource.hs+[`System.IO.Resource.Linear`]: https://github.com/tweag/linear-base/blob/master/src/System/IO/Resource/Linear.hs [issue-147]: https://github.com/tweag/linear-base/issues/147
docs/USER_GUIDE.md view
@@ -15,14 +15,16 @@ * The [`Prelude.Linear`] module is a good place to start. It is a prelude for Haskell programs that use `-XLinearTypes` and is meant to replace the original prelude from `base`.- * Mutable data with a pure API.- Consider looking at `Data.{Array, Hashmap, Vector, Set}.Mutable.Linear`.+ * For mutable data with a pure API,+ consider looking at `Data.{Array, Hashmap, Vector, Set}.Mutable.Linear`. * A linear `IO` monad is in `System.IO.Linear`. * A variant of linear `IO` which lets you enforce resource safety- can be found in `System.IO.Resource`.+ can be found in `System.IO.Resource.Linear`. * Streams in the style of the [`streaming` library](https://hackage.haskell.org/package/streaming) is in `Streaming.Linear` and `Streaming.Prelude.Linear`.+ * How `Prelude.Linear` classes relate to their `base` (non-linear) counterpart is+ described in the [class comparison table](https://github.com/tweag/linear-base/blob/master/docs/CLASS_TABLE.md). There are many other modules of course but a lot of the ones not already listed are still experimental, such as system-heap memory management in `Foreign.Marshall.Pure`.@@ -135,6 +137,9 @@ The `(&)` operator is like `($)` with the argument order flipped. +This workaround will no longer be needed in GHC 9.2, where this limitation+has been lifted and `case` can be used in a linear context.+ ### `let` and `where` bindings are not linear The following will **fail** to type check:@@ -164,6 +169,6 @@ fromRead = undefined ``` -[`Data.Unrestricted`]: ../src/Data/Unrestricted/Linear.hs-[`Prelude.Linear`]: ../src/Prelude/Linear.hs-[`README`]: ../README.md+[`Data.Unrestricted`]: https://github.com/tweag/linear-base/blob/master/src/Data/Unrestricted/Linear.hs+[`Prelude.Linear`]: https://github.com/tweag/linear-base/blob/master/src/Prelude/Linear.hs+[`README`]: https://github.com/tweag/linear-base/blob/master/README.md
examples/Foreign/Heap.hs view
@@ -1,31 +1,32 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | Implementation of pairing heaps stored off-heap- module Foreign.Heap where import qualified Data.List as List-import qualified Foreign.List as List import Foreign.List (List)+import qualified Foreign.List as List+import Foreign.Marshal.Pure (Box, Pool) import qualified Foreign.Marshal.Pure as Manual-import Foreign.Marshal.Pure (Pool, Box) import Prelude.Linear hiding (foldl) data Heap k a = Empty | NonEmpty (Box (NEHeap k a))+ data NEHeap k a = Heap k a (Box (List (NEHeap k a))) -instance (Manual.Representable k, Manual.Representable a)- => Manual.MkRepresentable (NEHeap k a) (k, a, Box (List (NEHeap k a))) where-+instance+ (Manual.Representable k, Manual.Representable a) =>+ Manual.MkRepresentable (NEHeap k a) (k, a, Box (List (NEHeap k a)))+ where toRepr (Heap k a l) = (k, a, l) ofRepr (k, a, l) = Heap k a l @@ -34,45 +35,46 @@ -- * Non-empty heap primitives -singletonN :: (Manual.Representable k, Manual.Representable a) => k %1-> a %1-> Pool %1-> NEHeap k a+singletonN :: (Manual.Representable k, Manual.Representable a) => k %1 -> a %1 -> Pool %1 -> NEHeap k a singletonN k a pool = Heap k a (Manual.alloc List.Nil pool) -- XXX: (Movable k, Ord k) is a bit stronger than strictly required. We could -- give a linear version of `Ord` instead.-mergeN :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => NEHeap k a %1-> NEHeap k a %1-> Pool %1-> NEHeap k a+mergeN :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => NEHeap k a %1 -> NEHeap k a %1 -> Pool %1 -> NEHeap k a mergeN (Heap k1 a1 h1) (Heap k2 a2 h2) pool =- testAndRebuild (move k1) a1 h1 (move k2) a2 h2 pool+ testAndRebuild (move k1) a1 h1 (move k2) a2 h2 pool where --- XXX: this is a good example of why we need a working `case` and/or --- `let`.- testAndRebuild :: Ur k %1-> a %1-> Box (List (NEHeap k a)) %1-> Ur k %1-> a %1-> Box (List (NEHeap k a)) %1-> Pool %1-> NEHeap k a+ testAndRebuild :: Ur k %1 -> a %1 -> Box (List (NEHeap k a)) %1 -> Ur k %1 -> a %1 -> Box (List (NEHeap k a)) %1 -> Pool %1 -> NEHeap k a testAndRebuild (Ur k1') a1' h1' (Ur k2') a2' h2' = if k1' <= k2' then helper k1' a1' k2' a2' h1' h2' else helper k2' a2' k1' a1' h2' h1' - helper :: k -> a %1-> k -> a %1-> Box (List (NEHeap k a)) %1-> Box (List (NEHeap k a)) %1-> Pool %1-> NEHeap k a- helper k1'' a1'' k2'' a2'' h1'' h2'' pool'' = Heap k1'' a1'' (Manual.alloc ((List.Cons :: b %1-> Box (List b) %1-> List b) ((Heap :: c %1-> b %1-> Box (List (NEHeap c b)) %1-> NEHeap c b) k2'' a2'' h2'') h1'') pool'')- -- XXX: the type signatures for List.Cons and Heap are necessary for certain- -- older versions of the compiler, and as such are temporary. See PR #38- -- and PR #380 in tweag/ghc/linear-types.+ helper :: k -> a %1 -> k -> a %1 -> Box (List (NEHeap k a)) %1 -> Box (List (NEHeap k a)) %1 -> Pool %1 -> NEHeap k a+ helper k1'' a1'' k2'' a2'' h1'' h2'' pool'' = Heap k1'' a1'' (Manual.alloc ((List.Cons :: b %1 -> Box (List b) %1 -> List b) ((Heap :: c %1 -> b %1 -> Box (List (NEHeap c b)) %1 -> NEHeap c b) k2'' a2'' h2'') h1'') pool'') -mergeN' :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => NEHeap k a %1-> Heap k a %1-> Pool %1-> NEHeap k a+-- XXX: the type signatures for List.Cons and Heap are necessary for certain+-- older versions of the compiler, and as such are temporary. See PR #38+-- and PR #380 in tweag/ghc/linear-types.++mergeN' :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => NEHeap k a %1 -> Heap k a %1 -> Pool %1 -> NEHeap k a mergeN' h Empty pool = pool `lseq` h mergeN' h (NonEmpty h') pool = mergeN h (Manual.deconstruct h') pool -extractMinN :: (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => NEHeap k a %1-> Pool %1-> (k, a, Heap k a)+extractMinN :: (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => NEHeap k a %1 -> Pool %1 -> (k, a, Heap k a) extractMinN (Heap k a h) pool = (k, a, pairUp (Manual.deconstruct h) pool) -pairUp :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => List (NEHeap k a) %1-> Pool %1-> Heap k a+pairUp :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => List (NEHeap k a) %1 -> Pool %1 -> Heap k a pairUp List.Nil pool = pool `lseq` Empty pairUp (List.Cons h r) pool = pairOne h (Manual.deconstruct r) (dup pool) where- pairOne :: NEHeap k a %1-> List (NEHeap k a) %1-> (Pool, Pool) %1-> Heap k a+ pairOne :: NEHeap k a %1 -> List (NEHeap k a) %1 -> (Pool, Pool) %1 -> Heap k a pairOne h' r' (pool1, pool2) = NonEmpty $ Manual.alloc (pairOne' h' r' (dup3 pool1)) pool2 - pairOne' :: NEHeap k a %1-> List (NEHeap k a) %1-> (Pool, Pool, Pool) %1-> NEHeap k a+ pairOne' :: NEHeap k a %1 -> List (NEHeap k a) %1 -> (Pool, Pool, Pool) %1 -> NEHeap k a pairOne' h1 List.Nil pools = pools `lseq` h1 pairOne' h1 (List.Cons h2 r') (pool1, pool2, pool3) =@@ -83,63 +85,64 @@ empty :: Heap k a empty = Empty -singleton :: forall k a. (Manual.Representable k, Manual.Representable a) => k %1-> a %1-> Pool %1-> Heap k a+singleton :: forall k a. (Manual.Representable k, Manual.Representable a) => k %1 -> a %1 -> Pool %1 -> Heap k a singleton k a pool = NonEmpty $ singletonAlloc k a (dup pool) where- singletonAlloc :: k %1-> a %1-> (Pool, Pool) %1-> Box (NEHeap k a)+ singletonAlloc :: k %1 -> a %1 -> (Pool, Pool) %1 -> Box (NEHeap k a) singletonAlloc k' a' (pool1, pool2) = Manual.alloc (singletonN k' a' pool1) pool2 -extractMin :: (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => Heap k a %1-> Pool %1-> Maybe (k, a, Heap k a)+extractMin :: (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => Heap k a %1 -> Pool %1 -> Maybe (k, a, Heap k a) extractMin Empty pool = pool `lseq` Nothing extractMin (NonEmpty h) pool = Just $ extractMinN (Manual.deconstruct h) pool -merge :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => Heap k a %1-> Heap k a %1-> Pool %1-> Heap k a+merge :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => Heap k a %1 -> Heap k a %1 -> Pool %1 -> Heap k a merge Empty h' pool = pool `lseq` h' merge (NonEmpty h) h' pool = NonEmpty $ neMerge (Manual.deconstruct h) h' (dup pool) where- neMerge :: NEHeap k a %1-> Heap k a %1-> (Pool, Pool) %1-> Box (NEHeap k a)+ neMerge :: NEHeap k a %1 -> Heap k a %1 -> (Pool, Pool) %1 -> Box (NEHeap k a) neMerge h1 h2 (pool1, pool2) = Manual.alloc (mergeN' h1 h2 pool1) pool2 -- * Heap sort -- | Guaranteed to yield pairs in ascending key order-foldl :: forall k a b. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => (b %1-> k %1-> a %1-> b) -> b %1-> Heap k a %1-> Pool %1-> b+foldl :: forall k a b. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => (b %1 -> k %1 -> a %1 -> b) -> b %1 -> Heap k a %1 -> Pool %1 -> b foldl f acc h pool = go acc h (dup pool) where- go :: b %1-> Heap k a %1-> (Pool, Pool) %1-> b+ go :: b %1 -> Heap k a %1 -> (Pool, Pool) %1 -> b go acc' h' (pool1, pool2) = dispatch acc' (extractMin h' pool1) pool2 - dispatch :: b %1-> Maybe (k, a, Heap k a) %1-> Pool %1-> b+ dispatch :: b %1 -> Maybe (k, a, Heap k a) %1 -> Pool %1 -> b dispatch acc' Nothing pool' = pool' `lseq` acc'- dispatch acc' (Just(k, a, h')) pool' =+ dispatch acc' (Just (k, a, h')) pool' = foldl f (f acc' k a) h' pool' -- | Strict: stream must terminate.-unfold :: forall k a s. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => (s -> Maybe ((k, a), s)) -> s -> Pool %1-> Heap k a+unfold :: forall k a s. (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => (s -> Maybe ((k, a), s)) -> s -> Pool %1 -> Heap k a unfold step seed pool = dispatch (step seed) pool where- dispatch :: (Maybe ((k, a), s)) -> Pool %1-> Heap k a+ dispatch :: (Maybe ((k, a), s)) -> Pool %1 -> Heap k a dispatch Nothing pool' = pool' `lseq` Empty dispatch (Just ((k, a), next)) pool' = mkStep k a next (dup3 pool') - mkStep :: k -> a -> s -> (Pool, Pool, Pool) %1-> Heap k a+ mkStep :: k -> a -> s -> (Pool, Pool, Pool) %1 -> Heap k a mkStep k a next (pool1, pool2, pool3) = merge (singleton k a pool1) (unfold step next pool2) pool3 -- TODO: linear unfold: could apply to off-heap lists! -ofList :: (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => [(k, a)] -> Pool %1-> Heap k a+ofList :: (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => [(k, a)] -> Pool %1 -> Heap k a ofList l pool = unfold List.uncons l pool -- XXX: sorts in reverse-toList :: (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => Heap k a %1-> Pool %1-> [(k, a)]-toList h pool = foldl (\l k a -> (k,a):l) [] h pool+toList :: (Manual.Representable k, Manual.Representable a, Movable k, Ord k) => Heap k a %1 -> Pool %1 -> [(k, a)]+toList h pool = foldl (\l k a -> (k, a) : l) [] h pool -sort :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k, Movable a) => [(k, a)] -> [(k,a)]+sort :: forall k a. (Manual.Representable k, Manual.Representable a, Movable k, Ord k, Movable a) => [(k, a)] -> [(k, a)] sort l = unur $ Manual.withPool (\pool -> move $ sort' l (dup pool))- -- XXX: can we avoid this call to `move`? where- sort' :: [(k, a)] -> (Pool, Pool) %1-> [(k,a)]+ -- XXX: can we avoid this call to `move`?++ sort' :: [(k, a)] -> (Pool, Pool) %1 -> [(k, a)] sort' l' (pool1, pool2) = toList (ofList l' pool1) pool2
examples/Foreign/List.hs view
@@ -2,17 +2,17 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} module Foreign.List where import qualified Data.List as List-import Foreign.Marshal.Pure (Pool, Box)+import Foreign.Marshal.Pure (Box, Pool) import qualified Foreign.Marshal.Pure as Manual-import Prelude.Linear hiding (map, foldl, foldr)+import Prelude.Linear hiding (foldl, foldr, map) -- XXX: we keep the last Cons in Memory here. A better approach would be to -- always keep a Box instead.@@ -22,14 +22,14 @@ -- TODO: generating appropriate instances using the Generic framework instance- Manual.Representable a- => Manual.MkRepresentable (List a) (Maybe (a, Box (List a))) where-+ Manual.Representable a =>+ Manual.MkRepresentable (List a) (Maybe (a, Box (List a)))+ where toRepr Nil = Nothing toRepr (Cons a l) = Just (a, l) ofRepr Nothing = Nil- ofRepr (Just (a,l)) = Cons a l+ ofRepr (Just (a, l)) = Cons a l instance Manual.Representable a => Manual.Representable (List a) where type AsKnown (List a) = Manual.AsKnown (Maybe (a, Box (List a)))@@ -40,65 +40,67 @@ -- XXX: the mapped function should be of type (a %1-> Pool %1-> b) -- -- Remark: map could be tail-recursive in destination-passing style-map :: forall a b. (Manual.Representable a, Manual.Representable b) => (a %1-> b) -> List a %1-> Pool %1-> List b+map :: forall a b. (Manual.Representable a, Manual.Representable b) => (a %1 -> b) -> List a %1 -> Pool %1 -> List b map _f Nil pool = pool `lseq` Nil map f (Cons a l) pool =- withPools (dup pool) a (Manual.deconstruct l)+ withPools (dup pool) a (Manual.deconstruct l) where- withPools :: (Pool, Pool) %1-> a %1-> List a %1-> List b+ withPools :: (Pool, Pool) %1 -> a %1 -> List a %1 -> List b withPools (pool1, pool2) a' l' = Cons (f a') (Manual.alloc (map f l' pool1) pool2) -foldr :: forall a b. Manual.Representable a => (a %1-> b %1-> b) -> b %1-> List a %1-> b+foldr :: forall a b. Manual.Representable a => (a %1 -> b %1 -> b) -> b %1 -> List a %1 -> b foldr _f seed Nil = seed foldr f seed (Cons a l) = f a (foldr f seed (Manual.deconstruct l)) -foldl :: forall a b. Manual.Representable a => (b %1-> a %1-> b) -> b %1-> List a %1-> b+foldl :: forall a b. Manual.Representable a => (b %1 -> a %1 -> b) -> b %1 -> List a %1 -> b foldl _f seed Nil = seed foldl f seed (Cons a l) = foldl f (f seed a) (Manual.deconstruct l) -- Remark: could be tail-recursive with destination-passing style+ -- | Make a 'List' from a stream. 'List' is a type of strict lists, therefore -- the stream must terminate otherwise 'unfold' will loop. Not tail-recursive.-unfold :: forall a s. Manual.Representable a => (s -> Maybe (a,s)) -> s -> Pool %1-> List a+unfold :: forall a s. Manual.Representable a => (s -> Maybe (a, s)) -> s -> Pool %1 -> List a unfold step state pool = dispatch (step state) (dup pool)- -- XXX: ^ The reason why we need to `dup` the pool before we know whether the- -- next step is a `Nothing` (in which case we don't need the pool at all) or a- -- `Just`, is because of the limitation of `case` to the unrestricted- -- case. Will be fixed. where- dispatch :: Maybe (a, s) -> (Pool, Pool) %1-> List a+ -- XXX: ^ The reason why we need to `dup` the pool before we know whether the+ -- next step is a `Nothing` (in which case we don't need the pool at all) or a+ -- `Just`, is because of the limitation of `case` to the unrestricted+ -- case. Will be fixed.++ dispatch :: Maybe (a, s) -> (Pool, Pool) %1 -> List a dispatch Nothing pools = pools `lseq` Nil dispatch (Just (a, next)) (pool1, pool2) = Cons a (Manual.alloc (unfold step next pool1) pool2) -- | Linear variant of 'unfold'. Note how they are implemented exactly -- identically. They could be merged if multiplicity polymorphism was supported.-unfoldL :: forall a s. Manual.Representable a => (s %1-> Maybe (a,s)) -> s %1-> Pool %1-> List a+unfoldL :: forall a s. Manual.Representable a => (s %1 -> Maybe (a, s)) -> s %1 -> Pool %1 -> List a unfoldL step state pool = dispatch (step state) (dup pool) where- dispatch :: Maybe (a, s) %1-> (Pool, Pool) %1-> List a+ dispatch :: Maybe (a, s) %1 -> (Pool, Pool) %1 -> List a dispatch Nothing pools = pools `lseq` Nil dispatch (Just (a, next)) (pool1, pool2) = Cons a (Manual.alloc (unfoldL step next pool1) pool2) -ofList :: Manual.Representable a => [a] -> Pool %1-> List a+ofList :: Manual.Representable a => [a] -> Pool %1 -> List a ofList l pool = unfold List.uncons l pool -toList :: Manual.Representable a => List a %1-> [a]+toList :: Manual.Representable a => List a %1 -> [a] toList l = foldr (:) [] l -- | Like unfold but builds the list in reverse, and tail recursive-runfold :: forall a s. Manual.Representable a => (s -> Maybe (a,s)) -> s -> Pool %1-> List a+runfold :: forall a s. Manual.Representable a => (s -> Maybe (a, s)) -> s -> Pool %1 -> List a runfold step state pool = loop state Nil pool where- loop :: s -> List a %1-> Pool %1-> List a+ loop :: s -> List a %1 -> Pool %1 -> List a loop state' acc pool' = dispatch (step state') acc (dup pool') - dispatch :: Maybe (a, s) -> List a %1-> (Pool, Pool) %1-> List a+ dispatch :: Maybe (a, s) -> List a %1 -> (Pool, Pool) %1 -> List a dispatch Nothing !acc pools = pools `lseq` acc dispatch (Just (a, next)) !acc (pool1, pool2) = loop next (Cons a (Manual.alloc acc pool1)) pool2 -ofRList :: Manual.Representable a => [a] -> Pool %1-> List a+ofRList :: Manual.Representable a => [a] -> Pool %1 -> List a ofRList l pool = runfold List.uncons l pool
+ examples/Generic/Traverse.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Generic.Traverse (genericTraverseTests) where++import Data.Functor.Linear (genericTraverse)+import qualified Data.Functor.Linear as Data+import Generics.Linear.TH+import Hedgehog+import Prelude.Linear+import Test.Tasty+import Test.Tasty.Hedgehog (testProperty)+import qualified Prelude++data Pair a = MkPair a a+ deriving (Show, Prelude.Eq)++$(deriveGeneric1 ''Pair)++instance Data.Functor Pair where+ fmap f (MkPair x y) = MkPair (f x) (f y)++instance Data.Traversable Pair where+ traverse = genericTraverse++pairTest :: TestTree+pairTest =+ testProperty "traverse via genericTraverse with WithLog and Pair" $+ property $+ ( Data.traverse+ (\x -> (Sum (1 :: Int), 2 * x))+ (MkPair 3 4 :: Pair Int)+ )+ === (Sum 2, (MkPair 6 8))++genericTraverseTests :: TestTree+genericTraverseTests =+ testGroup+ "genericTraverse examples"+ [pairTest]
examples/Main.hs view
@@ -1,15 +1,18 @@ module Main where -import Test.Tasty import Test.Foreign (foreignGCTests)+import Test.Generic (genericTests) import Test.Quicksort (quickSortTests)+import Test.Tasty main :: IO () main = defaultMain allTests allTests :: TestTree-allTests = testGroup "All tests"- [ foreignGCTests- , quickSortTests- ]-+allTests =+ testGroup+ "All tests"+ [ foreignGCTests,+ quickSortTests,+ genericTests+ ]
examples/Simple/FileIO.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -27,16 +27,17 @@ -- runtime. module Simple.FileIO where -import Control.Monad () -- Linear Base Imports import qualified Control.Functor.Linear as Control+import Control.Monad () import Data.Text import Data.Unrestricted.Linear import qualified System.IO as System-import qualified System.IO.Resource as Linear+import qualified System.IO.Resource.Linear as Linear import Prelude -- * Non-linear first line printing+ -------------------------------------------- -- openFile :: FilePath -> IOMode -> IO Handle@@ -71,6 +72,7 @@ System.putStrLn firstLine -- * Linear first line printing+ -------------------------------------------- linearGetFirstLine :: FilePath -> RIO (Ur Text)@@ -102,6 +104,7 @@ -} -- * Linear and non-linear combinators+ ------------------------------------------------- -- Some type synonyms@@ -112,23 +115,28 @@ -- | Linear bind -- Notice the continuation has a linear arrow, -- i.e., (a %1-> RIO b)-(>>#=) :: RIO a %1-> (a %1-> RIO b) %1-> RIO b+(>>#=) :: RIO a %1 -> (a %1 -> RIO b) %1 -> RIO b (>>#=) = (Control.>>=) +infixl 1 >>#= -- same fixity as base.>>=+ -- | Non-linear bind -- Notice the continuation has a non-linear arrow, -- i.e., (() -> RIO b). For simplicity, we don't use -- a more general type, like the following: -- (>>==) :: RIO (Ur a) %1-> (a -> RIO b) %1-> RIO b-(>>==) :: RIO () %1-> (() -> RIO b) %1-> RIO b+(>>==) :: RIO () %1 -> (() -> RIO b) %1 -> RIO b (>>==) ma f = ma Control.>>= (\() -> f ()) +infixl 1 >>== -- same fixity as base.>>=+ -- | Inject -- provided just to make the type explicit-inject :: a %1-> RIO a+inject :: a %1 -> RIO a inject = Control.return -- * The explicit example+ ------------------------------------------------- getFirstLineExplicit :: FilePath -> RIO (Ur Text)@@ -139,10 +147,10 @@ where openFileForReading :: FilePath -> RIO LinHandle openFileForReading fp = Linear.openFile fp System.ReadMode- readOneLine :: LinHandle %1-> RIO (Ur Text, LinHandle)+ readOneLine :: LinHandle %1 -> RIO (Ur Text, LinHandle) readOneLine = Linear.hGetLine closeAndReturnLine ::- (Ur Text, LinHandle) %1-> RIO (Ur Text)+ (Ur Text, LinHandle) %1 -> RIO (Ur Text) closeAndReturnLine (unrText, handle) = Linear.hClose handle >>#= (\() -> inject unrText)
examples/Simple/Pure.hs view
@@ -1,21 +1,18 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE GADTs #-} -{-|-Module : Pure-Description : Pure functions showing the basics of linear haskell.--We have simple linear functions and simple linear data structures that-illustrate the basic concepts of how the type checker of GHC with linear-types behaves. The goal of this is to be a ridiculously simple tutorial-on the basics of linear types.--}--+-- |+-- Module : Pure+-- Description : Pure functions showing the basics of linear haskell.+--+-- We have simple linear functions and simple linear data structures that+-- illustrate the basic concepts of how the type checker of GHC with linear+-- types behaves. The goal of this is to be a ridiculously simple tutorial+-- on the basics of linear types. module Simple.Pure where - -- * Simple linear functions+ ------------------------------------------------------------ {-@@ -29,7 +26,7 @@ times the argument of f is used in the body. -} -linearIdentity :: a %1-> a+linearIdentity :: a %1 -> a linearIdentity x = x {-@@ -42,9 +39,8 @@ consumed exactly once. -} --linearSwap :: (a,a) %1-> (a,a)-linearSwap (x,y) = (y,x)+linearSwap :: (a, a) %1 -> (a, a)+linearSwap (x, y) = (y, x) {- Here, the argument is decomposed by the tuple data constructor into two@@ -73,8 +69,8 @@ Consider the next function as an example. -} -nonLinearSubsume :: (a,a) -> (a,a)-nonLinearSubsume (x,_) = (x,x)+nonLinearSubsume :: (a, a) -> (a, a)+nonLinearSubsume (x, _) = (x, x) {- This function is not linear on its argument and in fact could not have a@@ -91,8 +87,8 @@ zero times. -} -linearPairIdentity :: (a,a) %1-> (a,a)-linearPairIdentity (x,y) = (x,y)+linearPairIdentity :: (a, a) %1 -> (a, a)+linearPairIdentity (x, y) = (x, y) {- Here, notice that `(a,a)` is linear, and since `(,)` is linear@@ -106,8 +102,7 @@ constructor that is linear on the appropreate arguments. -} --linearIdentity2 :: a %1-> a+linearIdentity2 :: a %1 -> a linearIdentity2 x = linearIdentity x {-@@ -127,18 +122,17 @@ use their input exactly twice. -} -nonLinearPair :: a -> (a,a)+nonLinearPair :: a -> (a, a) nonLinearPair x = (linearIdentity x, linearIdentity x) -nonLinearPair2 :: a -> (a,a)+nonLinearPair2 :: a -> (a, a) nonLinearPair2 x = (x, linearIdentity x) - {- The function below uses its input exactly thrice. -} -nonLinearTriple :: a -> (a,(a,a))+nonLinearTriple :: a -> (a, (a, a)) nonLinearTriple x = (linearIdentity x, linearIdentity (nonLinearPair2 x)) {-@@ -183,7 +177,6 @@ -} - regularIdentity :: a -> a regularIdentity x = linearIdentity x @@ -196,11 +189,12 @@ functions are linear functions. -} --(#.) :: (b %1-> c) -> (a %1-> b) -> (a %1-> c)+(#.) :: (b %1 -> c) -> (a %1 -> b) -> (a %1 -> c) g #. f = \a -> g (f a) -linearCompose :: (a,a) %1-> (a,a)+infixr 9 #. -- same fixity as base..++linearCompose :: (a, a) %1 -> (a, a) linearCompose = linearIdentity #. linearSwap {-@@ -212,9 +206,8 @@ (##.) :: (b -> c) -> (a %1-> b) -> (a %1-> c) -} -- -- * Linear functions with user data types+ ------------------------------------------------------------ {-@@ -223,9 +216,9 @@ -} data LinearHolder a where- LinearHolder :: a %1-> LinearHolder a+ LinearHolder :: a %1 -> LinearHolder a -linearHold :: a %1-> LinearHolder a+linearHold :: a %1 -> LinearHolder a linearHold x = LinearHolder x {-@@ -234,11 +227,10 @@ non-linearly. -} --linearHoldExtract :: LinearHolder a %1-> a+linearHoldExtract :: LinearHolder a %1 -> a linearHoldExtract (LinearHolder x) = x -linearIdentity3 :: a %1-> a+linearIdentity3 :: a %1 -> a linearIdentity3 = linearHoldExtract #. linearHold {-@@ -254,26 +246,25 @@ (LinearHolder a %1-> b) ≅ (a %1-> b) -} - data LinearHolder2 where- LinearHolder2 :: a %1-> b -> LinearHolder2+ LinearHolder2 :: a %1 -> b -> LinearHolder2 -linearHold' :: a %1-> LinearHolder2+linearHold' :: a %1 -> LinearHolder2 linearHold' x = LinearHolder2 x "hello"---linearHold' x = LinearHolder2 "hi" x -- fails to type check +-- linearHold' x = LinearHolder2 "hi" x -- fails to type check+ {- We can have constructors with mixed arrows, of course. Here, this means only the first value is bound linearly. This is why the commented out line would fail to type check -} - data ForcedUnlinear a where ForcedUnlinear :: a -> ForcedUnlinear a -forcedLinearPair :: ForcedUnlinear a %1-> (a,a)-forcedLinearPair (ForcedUnlinear x) = (x,x)+forcedLinearPair :: ForcedUnlinear a %1 -> (a, a)+forcedLinearPair (ForcedUnlinear x) = (x, x) {- Above we define a data type ForcedUnlinear which does not use the@@ -285,13 +276,11 @@ linearPair :: a %1-> (a,a) -} --demote :: (ForcedUnlinear a %1-> b) -> (a -> b)+demote :: (ForcedUnlinear a %1 -> b) -> (a -> b) demote f x = f (ForcedUnlinear x) -promote :: (a -> b) -> (ForcedUnlinear a %1-> b)+promote :: (a -> b) -> (ForcedUnlinear a %1 -> b) promote f (ForcedUnlinear x) = f x- {- Another way of saying this is the following equivalence proven by the
examples/Simple/Quicksort.hs view
@@ -4,10 +4,10 @@ -- | This module implements quicksort with mutable arrays from linear-base module Simple.Quicksort (quickSort) where -import GHC.Stack-import qualified Data.Array.Mutable.Linear as Array import Data.Array.Mutable.Linear (Array)+import qualified Data.Array.Mutable.Linear as Array import Data.Unrestricted.Linear+import GHC.Stack import Prelude.Linear hiding (partition) -- # Quicksort@@ -16,38 +16,48 @@ quickSort :: [Int] -> [Int] quickSort xs = unur $ Array.fromList xs $ Array.toList . arrQuicksort -arrQuicksort :: Array Int %1-> Array Int-arrQuicksort arr = Array.size arr &- \(Ur len, arr1) -> go 0 (len-1) arr1+arrQuicksort :: Array Int %1 -> Array Int+arrQuicksort arr =+ Array.size arr+ & \(Ur len, arr1) -> go 0 (len - 1) arr1 -go :: Int -> Int -> Array Int %1-> Array Int+go :: Int -> Int -> Array Int %1 -> Array Int go lo hi arr | lo >= hi = arr- | otherwise = Array.read arr lo &- \(Ur pivot, arr1) -> partition arr1 pivot lo hi &- \(arr2, Ur ix) -> swap arr2 lo ix &- \arr3 -> go lo (ix-1) arr3 &- \arr4 -> go (ix+1) hi arr4+ | otherwise =+ Array.read arr lo+ & \(Ur pivot, arr1) ->+ partition arr1 pivot lo hi+ & \(arr2, Ur ix) ->+ swap arr2 lo ix+ & \arr3 ->+ go lo (ix - 1) arr3+ & \arr4 -> go (ix + 1) hi arr4 -- | @partition arr pivot lo hi = (arr', Ur ix)@ such that -- @arr'[i] <= pivot@ for @lo <= i <= ix@, -- @arr'[j] > pivot@ for @ix < j <= hi@, -- @arr'[k] = arr[k]@ for @k < lo@ and @k > hi@, and -- @arr'@ is a permutation of @arr@.-partition :: Array Int %1-> Int -> Int -> Int -> (Array Int, Ur Int)+partition :: Array Int %1 -> Int -> Int -> Int -> (Array Int, Ur Int) partition arr pivot lx rx- | (rx < lx) = (arr, Ur (lx-1))- | otherwise = Array.read arr lx &- \(Ur lVal, arr1) -> Array.read arr1 rx &- \(Ur rVal, arr2) -> case (lVal <= pivot, pivot < rVal) of- (True, True) -> partition arr2 pivot (lx+1) (rx-1)- (True, False) -> partition arr2 pivot (lx+1) rx- (False, True) -> partition arr2 pivot lx (rx-1)- (False, False) -> swap arr2 lx rx &- \arr3 -> partition arr3 pivot (lx+1) (rx-1)+ | (rx < lx) = (arr, Ur (lx - 1))+ | otherwise =+ Array.read arr lx+ & \(Ur lVal, arr1) ->+ Array.read arr1 rx+ & \(Ur rVal, arr2) -> case (lVal <= pivot, pivot < rVal) of+ (True, True) -> partition arr2 pivot (lx + 1) (rx - 1)+ (True, False) -> partition arr2 pivot (lx + 1) rx+ (False, True) -> partition arr2 pivot lx (rx - 1)+ (False, False) ->+ swap arr2 lx rx+ & \arr3 -> partition arr3 pivot (lx + 1) (rx - 1) -- | @swap a i j@ exchanges the positions of values at @i@ and @j@ of @a@.-swap :: HasCallStack => Array Int %1-> Int -> Int -> Array Int-swap arr i j = Array.read arr i &- \(Ur ival, arr1) -> Array.read arr1 j &- \(Ur jval, arr2) -> (Array.set i jval . Array.set j ival) arr2+swap :: HasCallStack => Array Int %1 -> Int -> Int -> Array Int+swap arr i j =+ Array.read arr i+ & \(Ur ival, arr1) ->+ Array.read arr1 j+ & \(Ur jval, arr2) -> (Array.set i jval . Array.set j ival) arr2
examples/Simple/TopSort.hs view
@@ -1,101 +1,107 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_GHC -Wno-unused-matches #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-} {-# LANGUAGE MagicHash #-}-+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-unused-matches #-} module Simple.TopSort where -import qualified Prelude.Linear as Linear-import Prelude.Linear ((&))-import Data.Unrestricted.Linear-import qualified Data.HashMap.Mutable.Linear as HMap-import Data.HashMap.Mutable.Linear (HashMap) import Data.Bifunctor.Linear (second)-import Data.Maybe.Linear (catMaybes) import qualified Data.Functor.Linear as Data+import Data.HashMap.Mutable.Linear (HashMap)+import qualified Data.HashMap.Mutable.Linear as HMap+import Data.Maybe.Linear (catMaybes)+import Data.Unrestricted.Linear+import Prelude.Linear ((&))+import qualified Prelude.Linear as Linear -- # The topological sort of a DAG ------------------------------------------------------------------------------- type Node = Int+ type InDegGraph = HashMap Node ([Node], Int) topsort :: [(Node, [Node])] -> [Node]-topsort = reverse . postOrder . fmap ( \(n,nbrs) -> (n,(nbrs,0)) )+topsort = reverse . postOrder . fmap (\(n, nbrs) -> (n, (nbrs, 0))) where postOrder :: [(Node, ([Node], Int))] -> [Node] postOrder [] = []- postOrder (xs) = let nodes = map fst xs in- unur Linear.$ HMap.empty (length xs * 2) Linear.$- \hm -> postOrderHM nodes (HMap.insertAll xs hm)+ postOrder (xs) =+ let nodes = map fst xs+ in unur Linear.$+ HMap.empty (length xs * 2) Linear.$+ \hm -> postOrderHM nodes (HMap.insertAll xs hm) +postOrderHM :: [Node] -> InDegGraph %1 -> Ur [Node]+postOrderHM nodes dag =+ findSources nodes (computeInDeg nodes dag) & \case+ (dag, Ur sources) -> pluckSources sources [] dag+ where+ -- O(V + N)+ computeInDeg :: [Node] -> InDegGraph %1 -> InDegGraph+ computeInDeg nodes dag = Linear.foldl incChildren dag (map Ur nodes) -postOrderHM :: [Node] -> InDegGraph %1-> Ur [Node]-postOrderHM nodes dag = findSources nodes (computeInDeg nodes dag) & \case- (dag, Ur sources) -> pluckSources sources [] dag- where- -- O(V + N)- computeInDeg :: [Node] -> InDegGraph %1-> InDegGraph- computeInDeg nodes dag = Linear.foldl incChildren dag (map Ur nodes)+ -- Increment in-degree of all neighbors+ incChildren :: InDegGraph %1 -> Ur Node %1 -> InDegGraph+ incChildren dag (Ur node) =+ HMap.lookup node dag & \case+ (Ur Nothing, dag) -> dag+ (Ur (Just (xs, i)), dag) -> incNodes (move xs) dag+ where+ incNodes :: Ur [Node] %1 -> InDegGraph %1 -> InDegGraph+ incNodes (Ur ns) dag = Linear.foldl incNode dag (map Ur ns) - -- Increment in-degree of all neighbors- incChildren :: InDegGraph %1-> Ur Node %1-> InDegGraph- incChildren dag (Ur node) = HMap.lookup node dag & \case- (Ur Nothing, dag) -> dag- (Ur (Just (xs,i)), dag) -> incNodes (move xs) dag- where- incNodes :: Ur [Node] %1-> InDegGraph %1-> InDegGraph- incNodes (Ur ns) dag = Linear.foldl incNode dag (map Ur ns)+ incNode :: InDegGraph %1 -> Ur Node %1 -> InDegGraph+ incNode dag (Ur node) =+ HMap.lookup node dag & \case+ (Ur Nothing, dag') -> dag'+ (Ur (Just (n, d)), dag') ->+ HMap.insert node (n, d + 1) dag' - incNode :: InDegGraph %1-> Ur Node %1-> InDegGraph- incNode dag (Ur node) = HMap.lookup node dag & \case- (Ur Nothing, dag') -> dag'- (Ur (Just (n,d)), dag') ->- HMap.insert node (n,d+1) dag'- --HMap.alter dag (\(Just (n,d)) -> Just (n,d+1)) node+-- HMap.alter dag (\(Just (n,d)) -> Just (n,d+1)) node -- pluckSources sources postOrdSoFar dag-pluckSources :: [Node] -> [Node] -> InDegGraph %1-> Ur [Node]+pluckSources :: [Node] -> [Node] -> InDegGraph %1 -> Ur [Node] pluckSources [] postOrd dag = lseq dag (move postOrd)-pluckSources (s:ss) postOrd dag = HMap.lookup s dag & \case- (Ur Nothing, dag) -> pluckSources ss (s:postOrd) dag- (Ur (Just (xs,i)), dag) -> walk xs dag & \case- (dag', Ur newSrcs) ->- pluckSources (newSrcs ++ ss) (s:postOrd) dag'+pluckSources (s : ss) postOrd dag =+ HMap.lookup s dag & \case+ (Ur Nothing, dag) -> pluckSources ss (s : postOrd) dag+ (Ur (Just (xs, i)), dag) ->+ walk xs dag & \case+ (dag', Ur newSrcs) ->+ pluckSources (newSrcs ++ ss) (s : postOrd) dag' where -- decrement degree of children, save newly made sources- walk :: [Node] -> InDegGraph %1-> (InDegGraph, Ur [Node])+ walk :: [Node] -> InDegGraph %1 -> (InDegGraph, Ur [Node]) walk children dag = second (Data.fmap catMaybes) (mapAccum decDegree children dag) -- Decrement the degree of a node, save it if it is now a source- decDegree :: Node -> InDegGraph %1-> (InDegGraph, Ur (Maybe Node))- decDegree node dag = HMap.lookup node dag & \case+ decDegree :: Node -> InDegGraph %1 -> (InDegGraph, Ur (Maybe Node))+ decDegree node dag =+ HMap.lookup node dag & \case (Ur Nothing, dag') -> (dag', Ur Nothing)- (Ur (Just (n,d)), dag') ->- checkSource node (HMap.insert node (n,d-1) dag')-+ (Ur (Just (n, d)), dag') ->+ checkSource node (HMap.insert node (n, d - 1) dag') -- Given a list of nodes, determines which are sources-findSources :: [Node] -> InDegGraph %1-> (InDegGraph, Ur [Node])+findSources :: [Node] -> InDegGraph %1 -> (InDegGraph, Ur [Node]) findSources nodes dag = second (Data.fmap catMaybes) (mapAccum checkSource nodes dag) - -- | Check if a node is a source, and if so return it-checkSource :: Node -> InDegGraph %1-> (InDegGraph, Ur (Maybe Node))-checkSource node dag = HMap.lookup node dag & \case- (Ur Nothing, dag) -> (dag, Ur Nothing)- (Ur (Just (xs,0)), dag) -> (dag, Ur (Just node))- (Ur (Just (xs,n)), dag) -> (dag, Ur Nothing)-+checkSource :: Node -> InDegGraph %1 -> (InDegGraph, Ur (Maybe Node))+checkSource node dag =+ HMap.lookup node dag & \case+ (Ur Nothing, dag) -> (dag, Ur Nothing)+ (Ur (Just (xs, 0)), dag) -> (dag, Ur (Just node))+ (Ur (Just (xs, n)), dag) -> (dag, Ur Nothing) mapAccum ::- (a -> b %1-> (b, Ur c)) -> [a] -> b %1-> (b, Ur [c])-mapAccum f [] b = (b, Ur [])-mapAccum f (x:xs) b = mapAccum f xs b & \case- (b, Ur cs) -> second (Data.fmap (:cs)) (f x b)-+ (a -> b %1 -> (b, Ur c)) -> [a] -> b %1 -> (b, Ur [c])+mapAccum f [] b = (b, Ur [])+mapAccum f (x : xs) b =+ mapAccum f xs b & \case+ (b, Ur cs) -> second (Data.fmap (: cs)) (f x b)
examples/Test/Foreign.hs view
@@ -1,47 +1,51 @@ {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-} module Test.Foreign (foreignGCTests) where -import Data.Typeable-import Control.Monad (void) import Control.Exception hiding (assert)+import Control.Monad (void)+import Data.Typeable import qualified Foreign.Heap as Heap import Foreign.List (List) import qualified Foreign.List as List import qualified Foreign.Marshal.Pure as Manual-import qualified Prelude-import Prelude.Linear-import Test.Tasty-import Test.Tasty.Hedgehog (testProperty) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range-+import Prelude.Linear+import Test.Tasty+import Test.Tasty.Hedgehog (testProperty)+import qualified Prelude -- # Organizing tests ------------------------------------------------------------------------------- foreignGCTests :: TestTree-foreignGCTests = testGroup "foreignGCTests"- [ listExampleTests- , heapExampleTests- ]+foreignGCTests =+ testGroup+ "foreignGCTests"+ [ listExampleTests,+ heapExampleTests+ ] listExampleTests :: TestTree-listExampleTests = testGroup "list tests"- [ testProperty "List.toList . List.fromList = id" invertNonGCList- , testProperty "map id = id" mapIdNonGCList- , testProperty "memory freed post-exception" testExecptionOnMem- ]+listExampleTests =+ testGroup+ "list tests"+ [ testProperty "List.toList . List.fromList = id" invertNonGCList,+ testProperty "map id = id" mapIdNonGCList,+ testProperty "memory freed post-exception" testExecptionOnMem+ ] heapExampleTests :: TestTree-heapExampleTests = testGroup "heap tests"- [ testProperty "sort = heapsort" nonGCHeapSort ]-+heapExampleTests =+ testGroup+ "heap tests"+ [testProperty "sort = heapsort" nonGCHeapSort] -- # Internal library -------------------------------------------------------------------------------@@ -49,8 +53,12 @@ list :: Gen [Int] list = Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 100)) -eqList :: forall a. (Manual.Representable a, Movable a, Eq a) =>- List a %1-> List a %1-> Ur Bool+eqList ::+ forall a.+ (Manual.Representable a, Movable a, Eq a) =>+ List a %1 ->+ List a %1 ->+ Ur Bool eqList l1 l2 = move $ (List.toList l1) == (List.toList l2) data InjectedError = InjectedError@@ -58,27 +66,28 @@ instance Exception InjectedError - -- # Properties ------------------------------------------------------------------------------- invertNonGCList :: Property-invertNonGCList = property Prelude.$ do+invertNonGCList = property $ do xs <- forAll list- let xs' = unur $- Manual.withPool (\p -> move $ List.toList $ List.ofList xs p)+ let xs' =+ unur $+ Manual.withPool (\p -> move $ List.toList $ List.ofList xs p) xs === xs' mapIdNonGCList :: Property-mapIdNonGCList = property Prelude.$ do+mapIdNonGCList = property $ do xs <- forAll list- let boolTest = unur $ Manual.withPool $ \p ->- dup3 p & \(p0,p1,p2) ->- eqList (List.ofList xs p0) (List.map id (List.ofList xs p1) p2)+ let boolTest = unur $+ Manual.withPool $ \p ->+ dup3 p & \(p0, p1, p2) ->+ eqList (List.ofList xs p0) (List.map id (List.ofList xs p1) p2) assert boolTest testExecptionOnMem :: Property-testExecptionOnMem = property Prelude.$ do+testExecptionOnMem = property $ do xs <- forAll list let bs = xs ++ (throw InjectedError) let writeBadList = Manual.withPool (move . List.toList . List.ofRList bs)@@ -86,8 +95,7 @@ evalIO (catch @InjectedError (void (evaluate writeBadList)) ignoreCatch) nonGCHeapSort :: Property-nonGCHeapSort = property Prelude.$ do+nonGCHeapSort = property $ do xs <- forAll list- let ys :: [(Int,())] = zip xs $ Prelude.replicate (Prelude.length xs) ()+ let ys :: [(Int, ())] = zip xs $ Prelude.replicate (Prelude.length xs) () (Heap.sort ys) === (reverse $ sort ys)-
+ examples/Test/Generic.hs view
@@ -0,0 +1,11 @@+module Test.Generic (genericTests) where++import Generic.Traverse (genericTraverseTests)+import Test.Tasty++genericTests :: TestTree+genericTests =+ testGroup+ "Generic tests"+ [ genericTraverseTests+ ]
examples/Test/Quicksort.hs view
@@ -1,12 +1,12 @@ module Test.Quicksort (quickSortTests) where import Data.List (sort)-import Simple.Quicksort (quickSort)-import Test.Tasty-import Test.Tasty.Hedgehog (testProperty) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range+import Simple.Quicksort (quickSort)+import Test.Tasty+import Test.Tasty.Hedgehog (testProperty) quickSortTests :: TestTree quickSortTests = testProperty "quicksort sorts" testQuicksort@@ -15,4 +15,3 @@ testQuicksort = property $ do xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int $ Range.linear 0 100) sort xs === quickSort xs-
linear-base.cabal view
@@ -1,206 +1,214 @@-name: linear-base-version: 0.1.0-cabal-version: >=1.10-homepage: https://github.com/tweag/linear-base#README-license: MIT-license-file: LICENSE-author: Tweag-maintainer: arnaud.spiwack@tweag.io-copyright: (c) Tweag Holding and affiliates-category: Prelude-build-type: Simple-synopsis: Standard library for linear types.-description: Please see README.md.-+cabal-version: 3.0+name: linear-base+version: 0.2.0+license: MIT+license-file: LICENSE+copyright: (c) Tweag Holding and affiliates+maintainer: arnaud.spiwack@tweag.io+author: Tweag+homepage: https://github.com/tweag/linear-base#README+synopsis: Standard library for linear types.+description: Please see README.md.+category: Prelude+build-type: Simple extra-source-files:- README.md- CHANGELOG.md- docs/DESIGN.md- docs/USER_GUIDE.md+ README.md+ CHANGELOG.md+ docs/DESIGN.md+ docs/USER_GUIDE.md +source-repository head+ type: git+ location: https://github.com/tweag/linear-base++common warnings+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances+ -- Additional warnings we may consider adding:+ -- * -Wredundant-constraints : would need deactivating in the modules which use Nat+ library- hs-source-dirs: src- exposed-modules:- Control.Monad.IO.Class.Linear- Control.Functor.Linear- Control.Functor.Linear.Internal.Class- Control.Functor.Linear.Internal.Instances- Control.Functor.Linear.Internal.MonadTrans- Control.Functor.Linear.Internal.Reader- Control.Functor.Linear.Internal.State- Control.Optics.Linear- Control.Optics.Linear.Internal- Control.Optics.Linear.Iso- Control.Optics.Linear.Lens- Control.Optics.Linear.Prism- Control.Optics.Linear.Traversal- Data.Array.Destination- Data.Array.Mutable.Linear- Data.Array.Mutable.Unlifted.Linear- Data.Array.Polarized- Data.Array.Polarized.Pull- Data.Array.Polarized.Pull.Internal- Data.Array.Polarized.Push- Data.Bifunctor.Linear- Data.Bifunctor.Linear.Internal.Bifunctor- Data.Bifunctor.Linear.Internal.SymmetricMonoidal- Data.Bool.Linear- Data.Either.Linear- Data.Functor.Linear- Data.Functor.Linear.Internal.Functor- Data.Functor.Linear.Internal.Applicative- Data.Functor.Linear.Internal.Traversable- Data.HashMap.Mutable.Linear- Data.List.Linear- Data.Maybe.Linear- Data.Monoid.Linear- Data.Monoid.Linear.Internal.Monoid- Data.Monoid.Linear.Internal.Semigroup- Data.Num.Linear- Data.Ord.Linear- Data.Ord.Linear.Internal.Ord- Data.Ord.Linear.Internal.Eq- Data.Profunctor.Kleisli.Linear- Data.Profunctor.Linear- Data.Set.Mutable.Linear- Data.Tuple.Linear- Data.Unrestricted.Internal.Consumable- Data.Unrestricted.Internal.Dupable- Data.Unrestricted.Internal.Movable- Data.Unrestricted.Internal.Instances- Data.Unrestricted.Internal.Ur- Data.Unrestricted.Linear- Data.V.Linear- Data.V.Linear.Internal.V- Data.V.Linear.Internal.Instances- Data.Vector.Mutable.Linear- Debug.Trace.Linear- Foreign.Marshal.Pure- Prelude.Linear- Prelude.Linear.Internal- Streaming.Linear- Streaming.Prelude.Linear- Streaming.Internal.Consume- Streaming.Internal.Interop- Streaming.Internal.Many- Streaming.Internal.Process- Streaming.Internal.Produce- Streaming.Internal.Type- System.IO.Linear- System.IO.Resource- Unsafe.Linear- build-depends:- base >= 4.15 && < 5,- containers,- ghc-prim,- hashable,- storable-tuple,- text,- transformers,- vector,- primitive- default-language: Haskell2010+ import: warnings+ exposed-modules:+ Control.Monad.IO.Class.Linear+ Control.Functor.Linear+ Control.Functor.Linear.Internal.Class+ Control.Functor.Linear.Internal.Instances+ Control.Functor.Linear.Internal.Kan+ Control.Functor.Linear.Internal.MonadTrans+ Control.Functor.Linear.Internal.Reader+ Control.Functor.Linear.Internal.State+ Control.Optics.Linear+ Control.Optics.Linear.Internal+ Control.Optics.Linear.Iso+ Control.Optics.Linear.Lens+ Control.Optics.Linear.Prism+ Control.Optics.Linear.Traversal+ Data.Arity.Linear+ Data.Arity.Linear.Internal+ Data.Array.Destination+ Data.Array.Destination.Internal+ Data.Array.Mutable.Linear+ Data.Array.Mutable.Linear.Internal+ Data.Array.Mutable.Unlifted.Linear+ Data.Array.Polarized+ Data.Array.Polarized.Pull+ Data.Array.Polarized.Pull.Internal+ Data.Array.Polarized.Push+ Data.Bifunctor.Linear+ Data.Bifunctor.Linear.Internal.Bifunctor+ Data.Bifunctor.Linear.Internal.SymmetricMonoidal+ Data.Bool.Linear+ Data.Either.Linear+ Data.Functor.Linear+ Data.Functor.Linear.Internal.Functor+ Data.Functor.Linear.Internal.Applicative+ Data.Functor.Linear.Internal.Traversable+ Data.HashMap.Mutable.Linear+ Data.HashMap.Mutable.Linear.Internal+ Data.List.Linear+ Data.Maybe.Linear+ Data.Monoid.Linear+ Data.Monoid.Linear.Internal.Monoid+ Data.Monoid.Linear.Internal.Semigroup+ Data.Num.Linear+ Data.Ord.Linear+ Data.Ord.Linear.Internal.Ord+ Data.Ord.Linear.Internal.Eq+ Data.Profunctor.Kleisli.Linear+ Data.Profunctor.Linear+ Data.Set.Mutable.Linear+ Data.Set.Mutable.Linear.Internal+ Data.Tuple.Linear+ Data.Unrestricted.Linear+ Data.Unrestricted.Linear.Internal.Consumable+ Data.Unrestricted.Linear.Internal.Dupable+ Data.Unrestricted.Linear.Internal.Movable+ Data.Unrestricted.Linear.Internal.Instances+ Data.Unrestricted.Linear.Internal.Ur+ Data.Unrestricted.Linear.Internal.UrT+ Data.Replicator.Linear+ Data.Replicator.Linear.Internal+ Data.Replicator.Linear.Internal.ReplicationStream+ Data.Replicator.Linear.Internal.Instances+ Data.V.Linear+ Data.V.Linear.Internal+ Data.V.Linear.Internal.Instances+ Data.Vector.Mutable.Linear+ Data.Vector.Mutable.Linear.Internal+ Debug.Trace.Linear+ Foreign.Marshal.Pure+ Foreign.Marshal.Pure.Internal+ Prelude.Linear+ Prelude.Linear.Generically+ Prelude.Linear.GenericUtil+ Prelude.Linear.Internal+ Prelude.Linear.Unsatisfiable+ Streaming.Linear+ Streaming.Linear.Internal.Consume+ Streaming.Linear.Internal.Interop+ Streaming.Linear.Internal.Many+ Streaming.Linear.Internal.Process+ Streaming.Linear.Internal.Produce+ Streaming.Linear.Internal.Type+ Streaming.Prelude.Linear+ System.IO.Linear+ System.IO.Resource.Linear+ System.IO.Resource.Linear.Internal+ Unsafe.Linear + hs-source-dirs: src+ default-language: Haskell2010+ build-depends:++ base >=4.15 && <5,+ containers,+ ghc-prim,+ hashable,+ linear-generics >= 0.2,+ storable-tuple,+ text,+ transformers,+ vector >=0.12.2,+ primitive+ test-suite test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs- other-modules:- Test.Data.Destination- Test.Data.Mutable.Array- Test.Data.Mutable.Vector- Test.Data.Mutable.HashMap- Test.Data.Mutable.Set- Test.Data.Polarized- build-depends:- base,- linear-base,- containers,- hedgehog,- tasty,- tasty-hedgehog,- mmorph,- vector- ghc-options: -threaded -rtsopts -with-rtsopts=-N- default-language: Haskell2010+ import: warnings+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ other-modules:+ Test.Data.Destination+ Test.Data.Mutable.Array+ Test.Data.Mutable.Vector+ Test.Data.Mutable.HashMap+ Test.Data.Mutable.Set+ Test.Data.Polarized+ Test.Data.V+ Test.Data.Replicator -test-suite examples- type: exitcode-stdio-1.0- hs-source-dirs: examples- main-is: Main.hs- other-modules:- Test.Foreign- Test.Quicksort- Foreign.List- Foreign.Heap- Simple.FileIO- Simple.Pure- Simple.Quicksort- Simple.TopSort- build-depends:- base,- linear-base,- tasty,- tasty-hedgehog,- hedgehog,- storable-tuple,- vector,- text- ghc-options: -threaded -rtsopts -with-rtsopts=-N- default-language: Haskell2010+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ inspection-testing,+ tasty-inspection-testing,+ base,+ linear-base,+ containers,+ hedgehog,+ tasty,+ tasty-hedgehog,+ mmorph,+ vector -benchmark mutable-data- type: exitcode-stdio-1.0- hs-source-dirs: bench- main-is: Main.hs- other-modules:- Data.Mutable.HashMap- build-depends:- base,- deepseq,- gauge,- hashtables,- hashable,- linear-base,- random,- random-shuffle,- unordered-containers- ghc-options: -rtsopts=ignore- default-language: Haskell2010+test-suite examples+ import: warnings+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: examples+ other-modules:+ Test.Foreign+ Test.Quicksort+ Test.Generic+ Foreign.List+ Foreign.Heap+ Simple.FileIO+ Simple.Pure+ Simple.Quicksort+ Simple.TopSort+ Generic.Traverse --- TODO: Uncomment below block and set 'build-type' to 'Custom' to enable--- doctests once cabal-install 3.4 is released.------ Longer story:------ cabal-install has a piece of code[1] which injects a Cabal upper bound to--- packages with custom Setup.hs's. And this happens after the overrides,--- so the usual mechanisms of overriding upper bounds does not work.------ GHC 9 comes with Cabal 3.4, which is above that bound. So, when using--- GHC 9 with cabal-install 3.2; `build-type: Custom` causes another Cabal--- library to be built, and that causes a strange type error ("expecting IO,--- but got IO"), which I suspect because it conflicts with the existing boot--- packages.------ [1]: https://github.com/haskell/cabal/blob/d28c80acc69b9e7fa992a0b2b7fced937734b238/cabal-install/src/Distribution/Client/ProjectPlanning.hs#L1132-L1149+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base,+ linear-base,+ tasty,+ tasty-hedgehog,+ hedgehog,+ storable-tuple,+ vector,+ text,+ linear-generics --- custom-setup--- setup-depends:--- base >= 4 && <5,--- Cabal,--- cabal-doctest------ test-suite doctests--- type: exitcode-stdio-1.0--- hs-source-dirs: test/--- main-is: Doctest.hs--- build-depends: base--- , doctest--- , linear-base--- ghc-options: -Wall -threaded--- default-language: Haskell2010+benchmark mutable-data+ import: warnings+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench+ other-modules:+ Data.Mutable.HashMap+ Data.Mutable.Array -source-repository head- type: git- location: https://github.com/tweag/linear-base+ default-language: Haskell2010+ build-depends:+ base,+ vector,+ deepseq,+ gauge,+ hashtables,+ hashable,+ linear-base,+ random,+ random-shuffle,+ unordered-containers,+ MonadRandom
src/Control/Functor/Linear.hs view
@@ -8,43 +8,68 @@ -- -- This distinction and the use-cases of each group of functors is explained in -- [this blog post](https://tweag.io/posts/2020-01-16-data-vs-control.html).--- module Control.Functor.Linear ( -- * Control functor hierarchy- Functor(..)- , (<$>)- , (<&>)- , (<$)- , dataFmapDefault- , Applicative(..)- , dataPureDefault- , Monad(..)- , return- , join- , ap- , foldM- , MonadFail(..)- , Data(..)- -- * Monad transformers- -- ** ReaderT monad transformer- -- $readerT- , Reader, reader, runReader, mapReader, withReader- , ReaderT(..), runReaderT, mapReaderT, withReaderT- , ask, local, asks- -- ** StateT monad- -- $stateT- , State, state, runState, execState, mapState, withState- , StateT(..), runStateT, execStateT, mapStateT, withStateT- , get, put, modify, gets- , MonadTrans(..)- , module Control.Functor.Linear.Internal.Instances- ) where+ Functor (..),+ (<$>),+ (<&>),+ (<$),+ void,+ dataFmapDefault,+ Applicative (..),+ dataPureDefault,+ Monad (..),+ return,+ join,+ ap,+ foldM,+ MonadFail (..),+ Data (..), + -- * Monad transformers++ -- ** ReaderT monad transformer+ -- $readerT+ Reader,+ reader,+ runReader,+ mapReader,+ withReader,+ ReaderT (..),+ runReaderT,+ mapReaderT,+ withReaderT,+ ask,+ local,+ asks,++ -- ** StateT monad+ -- $stateT+ State,+ state,+ runState,+ execState,+ mapState,+ withState,+ StateT (..),+ runStateT,+ execStateT,+ mapStateT,+ withStateT,+ get,+ put,+ modify,+ gets,+ MonadTrans (..),+ module Control.Functor.Linear.Internal.Instances,+ )+where+ import Control.Functor.Linear.Internal.Class+import Control.Functor.Linear.Internal.Instances+import Control.Functor.Linear.Internal.MonadTrans import Control.Functor.Linear.Internal.Reader import Control.Functor.Linear.Internal.State-import Control.Functor.Linear.Internal.MonadTrans-import Control.Functor.Linear.Internal.Instances -- $readerT -- See [here](https://mmhaskell.com/monads/reader-writer) to learn about@@ -70,4 +95,3 @@ -- [here](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-State-Lazy.html). -- To learn the basics of the state monad, see -- [here](https://mmhaskell.com/monads/state).-
src/Control/Functor/Linear/Internal/Class.hs view
@@ -1,41 +1,62 @@-{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} -- | This module contains all the classes eventually exported by -- "Control.Functor.Linear". Together with related operations. module Control.Functor.Linear.Internal.Class- (- -- * Functors- Functor(..)- , dataFmapDefault- , (<$>)- , (<&>)- , (<$)- -- * Applicative Functors- , Applicative(..)- , dataPureDefault- -- * Monads- , Monad(..)- , MonadFail(..)- , return- , join- , ap- , foldM- ) where+ ( -- * Functors+ Functor (..),+ dataFmapDefault,+ (<$>),+ (<&>),+ (<$),+ void, -import Prelude (String)-import Prelude.Linear.Internal+ -- * Applicative Functors+ Applicative (..),+ dataPureDefault,++ -- * Monads+ Monad (..),+ MonadFail (..),+ return,+ join,+ ap,+ foldM,+ )+where+ import qualified Control.Monad as NonLinear ()-import qualified Data.Functor.Linear.Internal.Functor as Data+import Data.Functor.Compose+import Data.Functor.Identity import qualified Data.Functor.Linear.Internal.Applicative as Data-import Data.Unrestricted.Internal.Consumable-+import qualified Data.Functor.Linear.Internal.Functor as Data+import Data.Functor.Sum+import Data.Monoid.Linear hiding (Sum)+import Data.Type.Bool+import Data.Unrestricted.Linear.Internal.Consumable+import GHC.TypeLits+import GHC.Types (Type)+import Generics.Linear+import Prelude.Linear.Generically+import Prelude.Linear.Internal+import Prelude.Linear.Unsatisfiable (Unsatisfiable, unsatisfiable)+import Prelude (Bool (..), String) -- # Control Functors -------------------------------------------------------------------------------@@ -59,28 +80,37 @@ class Data.Functor f => Functor f where -- | Map a linear function @g@ over a control functor @f a@. -- Note that @g@ is used linearly over the single @a@ in @f a@.- fmap :: (a %1-> b) %1-> f a %1-> f b+ fmap :: (a %1 -> b) %1 -> f a %1 -> f b -- | Apply the control @fmap@ over a data functor.-dataFmapDefault :: Functor f => (a %1-> b) -> f a %1-> f b+dataFmapDefault :: Functor f => (a %1 -> b) -> f a %1 -> f b dataFmapDefault f = fmap f -(<$>) :: Functor f => (a %1-> b) %1-> f a %1-> f b+(<$>) :: Functor f => (a %1 -> b) %1 -> f a %1 -> f b (<$>) = fmap {-# INLINE (<$>) #-} +infixl 4 <$> -- same fixity as base.<$>+ -- | @ -- ('<&>') = 'flip' 'fmap' -- @-(<&>) :: Functor f => f a %1-> (a %1-> b) %1-> f b+(<&>) :: Functor f => f a %1 -> (a %1 -> b) %1 -> f b (<&>) a f = f <$> a {-# INLINE (<&>) #-} +infixl 1 <&> -- same fixity as base.<&>+ -- | Linearly typed replacement for the standard '(Prelude.<$)' function.-(<$) :: (Functor f, Consumable b) => a %1-> f b %1-> f a+(<$) :: (Functor f, Consumable b) => a %1 -> f b %1 -> f a a <$ fb = fmap (`lseq` a) fb +infixl 4 <$ -- same fixity as base.<$ +-- | Discard a consumable value stored in a control functor.+void :: (Functor f, Consumable a) => f a %1 -> f ()+void = fmap consume+ -- # Control Applicatives ------------------------------------------------------------------------------- @@ -89,25 +119,53 @@ -- '<*>'. class (Data.Applicative f, Functor f) => Applicative f where {-# MINIMAL pure, ((<*>) | liftA2) #-}+ -- | Inject (and consume) a value into an applicative control functor.- pure :: a %1-> f a+ pure :: a %1 -> f a+ -- | Apply the linear function in a control applicative functor to the value -- of type @a@ in another functor. This is essentialy composing two effectful -- computations, one that produces a function @f :: a %1-> b@ and one that -- produces a value of type @a@ into a single effectful computation that -- produces a value of type @b@.- (<*>) :: f (a %1-> b) %1-> f a %1-> f b+ (<*>) :: f (a %1 -> b) %1 -> f a %1 -> f b (<*>) = liftA2 id++ infixl 4 <*> -- same fixity as base.<*>+ -- | @liftA2 g@ consumes @g@ linearly as it lifts it -- over two functors: @liftA2 g :: f a %1-> f b %1-> f c@.- liftA2 :: (a %1-> b %1-> c) %1-> f a %1-> f b %1-> f c+ liftA2 :: (a %1 -> b %1 -> c) %1 -> f a %1 -> f b %1 -> f c liftA2 f x y = f <$> x <*> y -- | Apply the control @pure@ over a data applicative. dataPureDefault :: Applicative f => a -> f a dataPureDefault x = pure x +instance Monoid a => Applicative ((,) a) where+ pure x = (mempty, x)+ (a, f) <*> (b, x) = (a <> b, f x) +instance (Monoid a, Monoid b) => Applicative ((,,) a b) where+ pure x = (mempty, mempty, x)+ (a1, a2, f) <*> (b1, b2, x) = (a1 <> b1, a2 <> b2, f x)++instance (Monoid a, Monoid b, Monoid c) => Applicative ((,,,) a b c) where+ pure x = (mempty, mempty, mempty, x)+ (a1, a2, a3, f) <*> (b1, b2, b3, x) = (a1 <> b1, a2 <> b2, a3 <> b3, f x)++deriving via+ Generically1 Identity+ instance+ Functor Identity++instance Applicative Identity where+ pure = Identity+ Identity f <*> Identity x = Identity (f x)++instance Monad Identity where+ Identity x >>= f = f x+ -- # Control Monads ------------------------------------------------------------------------------- @@ -116,34 +174,168 @@ -- i.e., you sequence functions of the form @a %1-> m b@. class Applicative m => Monad m where {-# MINIMAL (>>=) #-}+ -- | @x >>= g@ applies a /linear/ function @g@ linearly (i.e., using it -- exactly once) on the value of type @a@ inside the value of type @m a@- (>>=) :: m a %1-> (a %1-> m b) %1-> m b- (>>) :: m () %1-> m a %1-> m a+ (>>=) :: m a %1 -> (a %1 -> m b) %1 -> m b++ infixl 1 >>= -- same fixity as base.>>=++ (>>) :: m () %1 -> m a %1 -> m a m >> k = m >>= (\() -> k)+ infixl 1 >> -- same fixity as base.>> -- | This class handles pattern-matching failure in do-notation. -- See "Control.Monad.Fail" for details. class Monad m => MonadFail m where fail :: String -> m a -return :: Monad m => a %1-> m a+return :: Monad m => a %1 -> m a return x = pure x {-# INLINE return #-} -- | Given an effect-producing computation that produces an effect-producing computation -- that produces an @a@, simplify it to an effect-producing -- computation that produces an @a@.-join :: Monad m => m (m a) %1-> m a+join :: Monad m => m (m a) %1 -> m a join action = action >>= id -- | Use this operator to define Applicative instances in terms of Monad instances.-ap :: Monad m => m (a %1-> b) %1-> m a %1-> m b+ap :: Monad m => m (a %1 -> b) %1 -> m a %1 -> m b ap f x = f >>= (\f' -> fmap f' x) -- | Fold from left to right with a linear monad. -- This is a linear version of 'NonLinear.foldM'.-foldM :: forall m a b. Monad m => (b %1-> a %1-> m b) -> b %1-> [a] %1-> m b+foldM :: forall m a b. Monad m => (b %1 -> a %1 -> m b) -> b %1 -> [a] %1 -> m b foldM _ i [] = return i-foldM f i (x:xs) = f i x >>= \i' -> foldM f i' xs+foldM f i (x : xs) = f i x >>= \i' -> foldM f i' xs +---------------+-- Instances --+---------------++deriving via+ Generically1 ((,) a)+ instance+ Functor ((,) a)++deriving via+ Generically1 ((,,) a b)+ instance+ Functor ((,,) a b)++deriving via+ Generically1 ((,,,) a b c)+ instance+ Functor ((,,,) a b c)++deriving via+ Generically1 ((,,,,) a b c d)+ instance+ Functor ((,,,,) a b c d)++instance Monoid a => Monad ((,) a) where+ (a, x) >>= f = go a (f x)+ where+ go :: a %1 -> (a, b) %1 -> (a, b)+ go b1 (b2, y) = (b1 <> b2, y)++deriving via+ Generically1 (Sum f g)+ instance+ (Functor f, Functor g) => Functor (Sum f g)++deriving via+ Generically1 (Compose f g)+ instance+ (Functor f, Functor g) => Functor (Compose f g)++------------------------+-- Generics instances --+------------------------++instance (Generic1 f, Functor (Rep1 f)) => Functor (Generically1 f) where+ fmap f = Generically1 . to1 . fmap f . from1 . unGenerically1++-- True if the generic type does not contain 'Par1', i.e. it does not use its parameter.+type family NoPar1 (f :: Type -> Type) :: Bool where+ NoPar1 U1 = 'True+ NoPar1 (K1 i v) = 'True+ NoPar1 (l :*: r) = NoPar1 l && NoPar1 r+ NoPar1 (l :+: r) = NoPar1 l && NoPar1 r+ NoPar1 (l :.: r) = NoPar1 l || NoPar1 r+ NoPar1 (M1 i c f) = NoPar1 f+ NoPar1 Par1 = 'False++-- If the generic type does not use its parameter, we can linearly coerce the parameter to any other type.+class NoPar1 f ~ 'True => Unused f where+ unused :: f a %1 -> f b++instance Unused U1 where+ unused U1 = U1++instance Unused (K1 i v) where+ unused (K1 c) = K1 c++instance (Unused l, Unused r) => Unused (l :*: r) where+ unused (l :*: r) = unused l :*: unused r++instance (Unused l, Unused r) => Unused (l :+: r) where+ unused (L1 l) = L1 (unused l)+ unused (R1 r) = R1 (unused r)++instance Unused f => Unused (M1 i c f) where+ unused (M1 a) = M1 (unused a)++instance (Unused' (NoPar1 l) l r, (NoPar1 l || NoPar1 r) ~ 'True) => Unused (l :.: r) where+ unused (Comp1 a) = Comp1 (unused' @(NoPar1 l) a)++class Unused' (left_unused :: Bool) l r where+ unused' :: l (r a) %1 -> l (r b)++instance Unused l => Unused' 'True l r where+ unused' = unused++instance (Functor l, Unused r) => Unused' 'False l r where+ unused' = fmap unused++-- A linear map on a pair is only possible if only one side uses its parameter.+-- To get the right type, the other side can then be coerced (instead of mapped) using `unused`.+class (noPar1l ~ NoPar1 l, noPar1r ~ NoPar1 r) => EitherNoPar1 (noPar1l :: Bool) (noPar1r :: Bool) l r where+ eitherNoPar1Map :: (a %1 -> b) %1 -> (l :*: r) a %1 -> (l :*: r) b++instance (Unused l, Functor r, NoPar1 r ~ 'False) => EitherNoPar1 'True 'False l r where+ eitherNoPar1Map f (l :*: r) = unused l :*: fmap f r++instance (Unused r, Functor l, NoPar1 l ~ 'False) => EitherNoPar1 'False 'True l r where+ eitherNoPar1Map f (l :*: r) = fmap f l :*: unused r++type MessageMany =+ 'Text "Can't derive an instance of Functor. One of the constructors"+ ':$$: 'Text "of your datatype uses the type parameter more than once."++instance ('False ~ NoPar1 l, 'False ~ NoPar1 r, Unsatisfiable MessageMany) => EitherNoPar1 'False 'False l r where+ eitherNoPar1Map = unsatisfiable++type MessageZero =+ 'Text "Can't derive an instance of Functor. One of the constructors"+ ':$$: 'Text "of your datatype does not use the type parameter."++instance ('True ~ NoPar1 l, 'True ~ NoPar1 r, Unsatisfiable MessageZero) => EitherNoPar1 'True 'True l r where+ eitherNoPar1Map = unsatisfiable++instance (Functor l, Functor r) => Functor (l :+: r) where+ fmap f (L1 a) = L1 (fmap f a)+ fmap f (R1 a) = R1 (fmap f a)++instance Functor f => Functor (M1 j c f) where+ fmap f (M1 a) = M1 (fmap f a)++instance Functor Par1 where+ fmap f (Par1 a) = Par1 (f a)++instance (Functor f, Functor g) => Functor (f :.: g) where+ fmap f (Comp1 fga) = Comp1 (fmap (fmap f) fga)++instance (Data.Functor l, Data.Functor r, EitherNoPar1 b1 b2 l r) => Functor (l :*: r) where+ fmap = eitherNoPar1Map
src/Control/Functor/Linear/Internal/Instances.hs view
@@ -1,26 +1,21 @@-{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} module Control.Functor.Linear.Internal.Instances- ( Data(..)- ) where+ ( Data (..),+ )+where -import Prelude.Linear.Internal import Control.Functor.Linear.Internal.Class-import qualified Data.Functor.Linear.Internal.Functor as Data import qualified Data.Functor.Linear.Internal.Applicative as Data-import Data.Monoid.Linear hiding (Sum)-import Data.Functor.Sum-import Data.Functor.Compose-import Data.Functor.Identity-+import qualified Data.Functor.Linear.Internal.Functor as Data -- # Deriving Data.XXX in terms of Control.XXX -------------------------------------------------------------------------------@@ -29,7 +24,6 @@ -- Control.XXX classes. newtype Data f a = Data (f a) - -- # Basic instances ------------------------------------------------------------------------------- @@ -39,33 +33,3 @@ instance Applicative f => Data.Applicative (Data f) where pure x = Data (pure x) Data f <*> Data x = Data (f <*> x)--instance Functor ((,) a) where- fmap f (a, x) = (a, f x)--instance Monoid a => Applicative ((,) a) where- pure x = (mempty, x)- (a, f) <*> (b, x) = (a <> b, f x)--instance Monoid a => Monad ((,) a) where- (a, x) >>= f = go a (f x)- where go :: a %1-> (a,b) %1-> (a,b)- go b1 (b2, y) = (b1 <> b2, y)--instance Functor Identity where- fmap f (Identity x) = Identity (f x)--instance Applicative Identity where- pure = Identity- Identity f <*> Identity x = Identity (f x)--instance Monad Identity where- Identity x >>= f = f x--instance (Functor f, Functor g) => Functor (Sum f g) where- fmap f (InL fa) = InL (fmap f fa)- fmap f (InR ga) = InR (fmap f ga)--instance (Functor f, Functor g) => Functor (Compose f g) where- fmap f (Compose fga) = Compose $ fmap (fmap f) fga-
+ src/Control/Functor/Linear/Internal/Kan.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++-- | A few things lifted from kan-extensions and lens for generic deriving of+-- 'Data.Functor.Linear.Traversable' instances (see+-- "Data.Functor.Linear.Internal.Traversable").+module Control.Functor.Linear.Internal.Kan where++import Control.Functor.Linear+import qualified Data.Functor.Linear.Internal.Applicative as Data+import qualified Data.Functor.Linear.Internal.Functor as Data+import Prelude.Linear.Internal++-- | A linear version of @Data.Functor.Day.Curried.Curried@ in the+-- @kan-extensions@ package. We use this for generic traversals. How+-- does it help? Consider a type like+--+-- @data Foo a = Foo a a a a@+--+-- The generic representation may look roughly like+--+-- @D1 _ (C1 _ ((S1 _ Rec1 :*: S1 _ Rec1) :*: (S1 _ Rec1 :*: S1 _ Rec1)))@+--+-- Traversing this naively requires a bunch of @fmap@ applications.+-- Most of them could be removed using 'Yoneda', but one aspect+-- can't be. Let's simplify down to the hard bit:+--+-- @m :*: (n :*: o)@+--+-- Traversing this looks like+--+-- @((:*:) <$> m) <*> ((:*:) <$> n <*> o)@+--+-- We want to reassociate the applications so the whole reconstruction+-- of the generic representation happens in one place, allowing inlining+-- to (hopefully) erase them altogether. It will end up looking roughly like+--+-- @(\x y z -> x :*: (y :*: z)) <$> m <*> n <*> o@+--+-- In our context, we always have the two functor+-- arguments the same, so something like @Curried f f@.+-- @Curried f f a@ is a lot like @f a@, as demonstrated directly by+-- 'lowerCurriedC' and, in @kan-extensions@, @liftCurried@.+-- It's a sort of "continuation passing style" version. If we have+-- something like+--+-- @+-- Con <$> m <*> n <*> o+--+-- -- parenthesized+--+-- ((Con <$> m) <*> n) <*> o+-- @+--+-- we can look at what happens next to each field. So the next thing+-- after performing @m@ is to map @Con@ over it. The next thing after+-- performing @n@ is to apply @Con <$> m@ to it within the functor.+newtype Curried g h a = Curried+ {runCurried :: forall r. g (a %1 -> r) %1 -> h r}++instance Data.Functor g => Data.Functor (Curried g h) where+ fmap f (Curried g) = Curried (g . Data.fmap (. f))+ {-# INLINE fmap #-}++instance Functor g => Functor (Curried g h) where+ fmap f (Curried g) = Curried (\x -> g (fmap (\y -> y . f) x))+ {-# INLINE fmap #-}++instance (Data.Functor g, g ~ h) => Data.Applicative (Curried g h) where+ pure a = Curried (Data.fmap ($ a))+ {-# INLINE pure #-}+ Curried mf <*> Curried ma = Curried (ma . mf . Data.fmap (.))+ {-# INLINE (<*>) #-}++instance (Functor g, g ~ h) => Applicative (Curried g h) where+ pure a = Curried (fmap ($ a))+ {-# INLINE pure #-}+ Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))+ {-# INLINE (<*>) #-}++lowerCurriedC :: Applicative f => Curried f g a %1 -> g a+lowerCurriedC (Curried f) = f (pure id)+{-# INLINE lowerCurriedC #-}++newtype Yoneda f a = Yoneda {runYoneda :: forall b. (a %1 -> b) %1 -> f b}++instance Data.Functor (Yoneda f) where+ fmap f (Yoneda m) = Yoneda (\k -> m (k . f))+ {-# INLINE fmap #-}++instance Functor (Yoneda f) where+ fmap f (Yoneda m) = Yoneda (\k -> m (k . f))+ {-# INLINE fmap #-}++instance Applicative f => Data.Applicative (Yoneda f) where+ pure a = Yoneda (\f -> pure (f a))+ {-# INLINE pure #-}+ Yoneda m <*> Yoneda n = Yoneda (\f -> m (\g -> f . g) <*> n id)+ {-# INLINE (<*>) #-}++instance Applicative f => Applicative (Yoneda f) where+ pure a = Yoneda (\f -> pure (f a))+ {-# INLINE pure #-}+ Yoneda m <*> Yoneda n = Yoneda (\f -> m (\g -> f . g) <*> n id)+ {-# INLINE (<*>) #-}++lowerYoneda :: Yoneda f a %1 -> f a+lowerYoneda (Yoneda m) = m id+{-# INLINE lowerYoneda #-}++-- This bit comes from lens.+liftCurriedYonedaC :: Applicative f => f a %1 -> Curried (Yoneda f) (Yoneda f) a+liftCurriedYonedaC fa = Curried (`yap` fa)+{-# INLINE liftCurriedYonedaC #-}++yap :: Applicative f => Yoneda f (a %1 -> b) %1 -> f a %1 -> Yoneda f b+yap (Yoneda k) fa = Yoneda (\ab_r -> k (\g -> ab_r . g) <*> fa)+{-# INLINE yap #-}
src/Control/Functor/Linear/Internal/MonadTrans.hs view
@@ -1,14 +1,15 @@-{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+ module Control.Functor.Linear.Internal.MonadTrans- ( MonadTrans(..)- ) where+ ( MonadTrans (..),+ )+where import Control.Functor.Linear.Internal.Class class (forall m. Monad m => Monad (t m)) => MonadTrans t where- lift :: Monad m => m a %1-> t m a-+ lift :: Monad m => m a %1 -> t m a
src/Control/Functor/Linear/Internal/Reader.hs view
@@ -1,28 +1,36 @@-{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} module Control.Functor.Linear.Internal.Reader- (- -- ReaderT monad transformer- Reader, reader, runReader, mapReader, withReader- , ReaderT(..), runReaderT, mapReaderT, withReaderT- , ask, local, asks- ) where+ ( -- ReaderT monad transformer+ Reader,+ reader,+ runReader,+ mapReader,+ withReader,+ ReaderT (..),+ runReaderT,+ mapReaderT,+ withReaderT,+ ask,+ local,+ asks,+ )+where -import Prelude.Linear.Internal ((.), ($), runIdentity')-import Data.Unrestricted.Internal.Consumable-import Data.Unrestricted.Internal.Dupable import Control.Functor.Linear.Internal.Class-import Control.Functor.Linear.Internal.MonadTrans import Control.Functor.Linear.Internal.Instances ()-import qualified Data.Functor.Linear.Internal.Functor as Data-import qualified Data.Functor.Linear.Internal.Applicative as Data-import Data.Functor.Identity+import Control.Functor.Linear.Internal.MonadTrans import qualified Control.Monad as NonLinear () import qualified Control.Monad.Trans.Reader as NonLinear-+import Data.Functor.Identity+import qualified Data.Functor.Linear.Internal.Applicative as Data+import qualified Data.Functor.Linear.Internal.Functor as Data+import Data.Unrestricted.Linear.Internal.Consumable+import Data.Unrestricted.Linear.Internal.Dupable+import Prelude.Linear.Internal (runIdentity', ($), (.)) -- # Linear ReaderT -------------------------------------------------------------------------------@@ -34,12 +42,13 @@ -- should use the linear reader monad just like the non-linear monad, except -- that the type system ensures that you explicity use or discard the -- read-only state (with the 'Consumable' instance).-newtype ReaderT r m a = ReaderT (r %1-> m a)+newtype ReaderT r m a = ReaderT (r %1 -> m a) -- XXX: Replace with a newtype deconstructor once it can be inferred as linear.--- | Provide an intial read-only state and run the monadic computation in ++-- | Provide an intial read-only state and run the monadic computation in -- a reader monad transformer-runReaderT :: ReaderT r m a %1-> r %1-> m a+runReaderT :: ReaderT r m a %1 -> r %1 -> m a runReaderT (ReaderT f) = f instance Data.Functor m => Data.Functor (ReaderT r m) where@@ -50,63 +59,63 @@ instance (Data.Applicative m, Dupable r) => Data.Applicative (ReaderT r m) where pure x = ReaderT $ \r -> lseq r (Data.pure x)- ReaderT f <*> ReaderT x = ReaderT ((\(r1,r2) -> f r1 Data.<*> x r2) . dup)+ ReaderT f <*> ReaderT x = ReaderT ((\(r1, r2) -> f r1 Data.<*> x r2) . dup) instance (Applicative m, Dupable r) => Applicative (ReaderT r m) where pure x = ReaderT $ \r -> lseq r (pure x)- ReaderT f <*> ReaderT x = ReaderT ((\(r1,r2) -> f r1 Data.<*> x r2) . dup)+ ReaderT f <*> ReaderT x = ReaderT ((\(r1, r2) -> f r1 Data.<*> x r2) . dup) instance (Monad m, Dupable r) => Monad (ReaderT r m) where- ReaderT x >>= f = ReaderT ((\(r1,r2) -> x r1 >>= (\a -> runReaderT (f a) r2)) . dup)+ ReaderT x >>= f = ReaderT ((\(r1, r2) -> x r1 >>= (\a -> runReaderT (f a) r2)) . dup) type Reader r = ReaderT r Identity ask :: Applicative m => ReaderT r m r ask = ReaderT pure -withReaderT :: (r' %1-> r) %1-> ReaderT r m a %1-> ReaderT r' m a+withReaderT :: (r' %1 -> r) %1 -> ReaderT r m a %1 -> ReaderT r' m a withReaderT f m = ReaderT $ runReaderT m . f -local :: (r %1-> r) %1-> ReaderT r m a %1-> ReaderT r m a+local :: (r %1 -> r) %1 -> ReaderT r m a %1 -> ReaderT r m a local = withReaderT -reader :: Monad m => (r %1-> a) %1-> ReaderT r m a+reader :: Monad m => (r %1 -> a) %1 -> ReaderT r m a reader f = ReaderT (return . f) -runReader :: Reader r a %1-> r %1-> a+runReader :: Reader r a %1 -> r %1 -> a runReader m = runIdentity' . runReaderT m -mapReader :: (a %1-> b) %1-> Reader r a %1-> Reader r b+mapReader :: (a %1 -> b) %1 -> Reader r a %1 -> Reader r b mapReader f = mapReaderT (Identity . f . runIdentity') -mapReaderT :: (m a %1-> n b) %1-> ReaderT r m a %1-> ReaderT r n b+mapReaderT :: (m a %1 -> n b) %1 -> ReaderT r m a %1 -> ReaderT r n b mapReaderT f m = ReaderT (f . runReaderT m) -withReader :: (r' %1-> r) %1-> Reader r a %1-> Reader r' a+withReader :: (r' %1 -> r) %1 -> Reader r a %1 -> Reader r' a withReader = withReaderT -asks :: Monad m => (r %1-> a) %1-> ReaderT r m a+asks :: Monad m => (r %1 -> a) %1 -> ReaderT r m a asks f = ReaderT (return . f) instance Dupable r => MonadTrans (ReaderT r) where lift x = ReaderT (`lseq` x) - -- # Instances for nonlinear ReaderT ------------------------------------------------------------------------------- instance Functor m => Functor (NonLinear.ReaderT r m) where fmap f (NonLinear.ReaderT g) = NonLinear.ReaderT $ \r -> fmap f (g r)+ instance Applicative m => Applicative (NonLinear.ReaderT r m) where pure x = NonLinear.ReaderT $ \_ -> pure x NonLinear.ReaderT f <*> NonLinear.ReaderT x = NonLinear.ReaderT $ \r -> f r <*> x r+ instance Monad m => Monad (NonLinear.ReaderT r m) where NonLinear.ReaderT x >>= f = NonLinear.ReaderT $ \r -> x r >>= (\a -> runReaderT' (f a) r) -- XXX: Temporary, until newtype record projections are linear.-runReaderT' :: NonLinear.ReaderT r m a %1-> r -> m a+runReaderT' :: NonLinear.ReaderT r m a %1 -> r -> m a runReaderT' (NonLinear.ReaderT f) = f instance MonadTrans (NonLinear.ReaderT r) where lift x = NonLinear.ReaderT (\_ -> x)-
src/Control/Functor/Linear/Internal/State.hs view
@@ -1,97 +1,104 @@-{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} module Control.Functor.Linear.Internal.State- ( StateT(..)- , State- , state- , get, put, gets- , modify- , replace- , runStateT, runState- , mapStateT, mapState- , execStateT, execState- , withStateT, withState- ) where+ ( StateT (..),+ State,+ state,+ get,+ put,+ gets,+ modify,+ replace,+ runStateT,+ runState,+ mapStateT,+ mapState,+ execStateT,+ execState,+ withStateT,+ withState,+ )+where -import Prelude.Linear.Internal-import Data.Unrestricted.Internal.Consumable-import Data.Unrestricted.Internal.Dupable-import Control.Functor.Linear.Internal.MonadTrans import Control.Functor.Linear.Internal.Class-import Control.Functor.Linear.Internal.Instances ( Data(..) )-import qualified Data.Functor.Linear.Internal.Functor as Data-import qualified Data.Functor.Linear.Internal.Applicative as Data-import qualified Control.Monad.Trans.State.Strict as NonLinear+import Control.Functor.Linear.Internal.Instances (Data (..))+import Control.Functor.Linear.Internal.MonadTrans import qualified Control.Monad as NonLinear ()+import qualified Control.Monad.Trans.State.Strict as NonLinear import Data.Functor.Identity-+import qualified Data.Functor.Linear.Internal.Applicative as Data+import qualified Data.Functor.Linear.Internal.Functor as Data+import Data.Unrestricted.Linear.Internal.Consumable+import Data.Unrestricted.Linear.Internal.Dupable+import Prelude.Linear.Internal -- # StateT ------------------------------------------------------------------------------- -- | A (strict) linear state monad transformer.-newtype StateT s m a = StateT (s %1-> m (a, s))- deriving Data.Applicative via Data (StateT s m)- -- We derive Data.Applicative and not Data.Functor since Data.Functor can use- -- weaker constraints on m than Control.Functor, while- -- Data.Applicative needs a Monad instance just like Control.Applicative.+newtype StateT s m a = StateT (s %1 -> m (a, s))+ deriving (Data.Applicative) via Data (StateT s m) +-- We derive Data.Applicative and not Data.Functor since Data.Functor can use+-- weaker constraints on m than Control.Functor, while+-- Data.Applicative needs a Monad instance just like Control.Applicative.+ type State s = StateT s Identity get :: (Applicative m, Dupable s) => StateT s m s get = state dup -put :: (Applicative m, Consumable s) => s %1-> StateT s m ()+put :: (Applicative m, Consumable s) => s %1 -> StateT s m () put = Data.void . replace -gets :: (Applicative m, Dupable s) => (s %1-> a) %1-> StateT s m a-gets f = state ((\(s1,s2) -> (f s1, s2)) . dup)+gets :: (Applicative m, Dupable s) => (s %1 -> a) %1 -> StateT s m a+gets f = state ((\(s1, s2) -> (f s1, s2)) . dup) -runStateT :: StateT s m a %1-> s %1-> m (a, s)+runStateT :: StateT s m a %1 -> s %1 -> m (a, s) runStateT (StateT f) = f -state :: Applicative m => (s %1-> (a,s)) %1-> StateT s m a+state :: Applicative m => (s %1 -> (a, s)) %1 -> StateT s m a state f = StateT (pure . f) -runState :: State s a %1-> s %1-> (a, s)+runState :: State s a %1 -> s %1 -> (a, s) runState f = runIdentity' . runStateT f -mapStateT :: (m (a, s) %1-> n (b, s)) %1-> StateT s m a %1-> StateT s n b+mapStateT :: (m (a, s) %1 -> n (b, s)) %1 -> StateT s m a %1 -> StateT s n b mapStateT r (StateT f) = StateT (r . f) -withStateT :: (s %1-> s) %1-> StateT s m a %1-> StateT s m a+withStateT :: (s %1 -> s) %1 -> StateT s m a %1 -> StateT s m a withStateT r (StateT f) = StateT (f . r) -execStateT :: Functor m => StateT s m () %1-> s %1-> m s+execStateT :: Functor m => StateT s m () %1 -> s %1 -> m s execStateT f = fmap (\((), s) -> s) . (runStateT f) -mapState :: ((a,s) %1-> (b,s)) %1-> State s a %1-> State s b+mapState :: ((a, s) %1 -> (b, s)) %1 -> State s a %1 -> State s b mapState f = mapStateT (Identity . f . runIdentity') -withState :: (s %1-> s) %1-> State s a %1-> State s a+withState :: (s %1 -> s) %1 -> State s a %1 -> State s a withState = withStateT -execState :: State s () %1-> s %1-> s+execState :: State s () %1 -> s %1 -> s execState f = runIdentity' . execStateT f -modify :: Applicative m => (s %1-> s) %1-> StateT s m ()+modify :: Applicative m => (s %1 -> s) %1 -> StateT s m () modify f = state $ \s -> ((), f s)+ -- TODO: add strict version of `modify` -- | @replace s@ will replace the current state with the new given state, and -- return the old state.-replace :: Applicative m => s %1-> StateT s m s+replace :: Applicative m => s %1 -> StateT s m s replace s = state $ (\s' -> (s', s)) - -- # Instances of StateT ------------------------------------------------------------------------------- @@ -105,7 +112,7 @@ fmap f (StateT x) = StateT (\s -> fmap (\(a, s') -> (f a, s')) (x s)) instance Monad m => Applicative (StateT s m) where- pure x = StateT (\s -> return (x,s))+ pure x = StateT (\s -> return (x, s)) StateT mf <*> StateT mx = StateT $ \s -> do (f, s') <- mf s (x, s'') <- mx s'@@ -118,4 +125,3 @@ instance MonadTrans (StateT s) where lift x = StateT (\s -> fmap (,s) x)-
src/Control/Monad/IO/Class/Linear.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE LinearTypes #-} {-# LANGUAGE NoImplicitPrelude #-}+ module Control.Monad.IO.Class.Linear where import qualified Control.Functor.Linear as Linear@@ -10,7 +11,7 @@ -- | Like 'NonLinear.MonadIO' but allows to lift both linear -- and non-linear 'IO' actions into a linear monad. class Linear.Monad m => MonadIO m where- liftIO :: Linear.IO a %1-> m a+ liftIO :: Linear.IO a %1 -> m a liftSystemIO :: System.IO a -> m a liftSystemIO io = liftIO (Linear.fromSystemIO io) liftSystemIOU :: System.IO a -> m (Ur a)
src/Control/Optics/Linear.hs view
@@ -88,7 +88,7 @@ -- -- Note that Kleisli arrows basically defined like so: ----- > type Kleisli f a b = a #-> f b+-- > type Kleisli f a b = a %1-> f b -- -- /Note: We abbreviate Control for Control.Functor.Linear./ --@@ -97,7 +97,7 @@ -- +=================+============+===============+====================+===========+ -- | @(->)@ | X | X | X | | -- +-----------------+------------+---------------+--------------------+-----------+--- | @(\#->)@ | X | X | X | |+-- | @(%1->)@ | X | X | X | | -- +-----------------+------------+---------------+--------------------+-----------+ -- | (Prelude) | | | | | -- | @Functor f@ | | | | |@@ -130,18 +130,17 @@ -- includes the standard one -- * The instance marked by (4) implies that the linear iso definition -- includes the standard one--- module Control.Optics.Linear- ( Optic_(..)- , Optic- , module Control.Optics.Linear.Iso- , module Control.Optics.Linear.Lens- , module Control.Optics.Linear.Prism- , module Control.Optics.Linear.Traversal+ ( Optic_ (..),+ Optic,+ module Control.Optics.Linear.Iso,+ module Control.Optics.Linear.Lens,+ module Control.Optics.Linear.Prism,+ module Control.Optics.Linear.Traversal, ) where -import Control.Optics.Linear.Internal (Optic_(..), Optic)+import Control.Optics.Linear.Internal (Optic, Optic_ (..)) import Control.Optics.Linear.Iso import Control.Optics.Linear.Lens import Control.Optics.Linear.Prism
src/Control/Optics/Linear/Internal.hs view
@@ -1,49 +1,74 @@-{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} module Control.Optics.Linear.Internal ( -- * Types- Optic_(..)- , Optic- , Iso, Iso'- , Lens, Lens'- , Prism, Prism'- , Traversal, Traversal'+ Optic_ (..),+ Optic,+ Iso,+ Iso',+ Lens,+ Lens',+ Prism,+ Prism',+ Traversal,+ Traversal',+ -- * Composing optics- , (.>)+ (.>),+ -- * Common optics- , swap, assoc- , _1, _2- , _Left, _Right- , _Just, _Nothing- , traversed+ swap,+ assoc,+ _1,+ _2,+ _Left,+ _Right,+ _Just,+ _Nothing,+ traversed,+ -- * Using optics- , get, set, gets, setSwap- , match, build- , over, overU- , traverseOf, traverseOfU- , toListOf, lengthOf- , reifyLens- , withIso, withLens, withPrism+ get,+ set,+ gets,+ setSwap,+ match,+ build,+ over,+ overU,+ traverseOf,+ traverseOfU,+ toListOf,+ lengthOf,+ reifyLens,+ withIso,+ withLens,+ withPrism,+ -- * Constructing optics- , iso, lens, prism, traversal+ iso,+ lens,+ prism,+ traversal, )- where+where import qualified Control.Arrow as NonLinear import qualified Control.Functor.Linear as Control-import qualified Data.Bifunctor.Linear as Bifunctor import Data.Bifunctor.Linear (SymmetricMonoidal)-import Data.Profunctor.Linear+import qualified Data.Bifunctor.Linear as Bifunctor import Data.Functor.Compose hiding (getCompose) import Data.Functor.Linear import qualified Data.Profunctor.Kleisli.Linear as Linear+import Data.Profunctor.Linear import Data.Void import GHC.Exts (FUN) import GHC.Types@@ -56,12 +81,19 @@ forall arr. c arr => Optic_ arr s t a b type Iso s t a b = Optic Profunctor s t a b+ type Iso' s a = Iso s s a a+ type Lens s t a b = Optic (Strong (,) ()) s t a b+ type Lens' s a = Lens s s a a+ type Prism s t a b = Optic (Strong Either Void) s t a b+ type Prism' s a = Prism s s a a+ type Traversal s t a b = Optic Wandering s t a b+ type Traversal' s a = Traversal s s a a swap :: SymmetricMonoidal m u => Iso (a `m` b) (c `m` d) (b `m` a) (d `m` c)@@ -73,20 +105,21 @@ (.>) :: Optic_ arr s t a b -> Optic_ arr a b x y -> Optic_ arr s t x y Optical f .> Optical g = Optical (f Prelude.. g) +infixr 9 .> -- same fixity as lens..> -lens :: (s %1-> (a, b %1-> t)) -> Lens s t a b-lens k = Optical $ \f -> dimap k (\(x,g) -> g $ x) (first f)+lens :: (s %1 -> (a, b %1 -> t)) -> Lens s t a b+lens k = Optical $ \f -> dimap k (\(x, g) -> g $ x) (first f) -prism :: (b %1-> t) -> (s %1-> Either t a) -> Prism s t a b+prism :: (b %1 -> t) -> (s %1 -> Either t a) -> Prism s t a b prism b s = Optical $ \f -> dimap s (either id id) (second (rmap b f)) -traversal :: (forall f. Control.Applicative f => (a %1-> f b) -> s %1-> f t) -> Traversal s t a b+traversal :: (forall f. Control.Applicative f => (a %1 -> f b) -> s %1 -> f t) -> Traversal s t a b traversal trav = Optical $ wander trav -_1 :: Lens (a,c) (b,c) a b+_1 :: Lens (a, c) (b, c) a b _1 = Optical first -_2 :: Lens (c,a) (c,b) a b+_2 :: Lens (c, a) (c, b) a b _2 = Optical second _Left :: Prism (Either a c) (Either b c) a b@@ -104,10 +137,10 @@ traversed :: Traversable t => Traversal (t a) (t b) a b traversed = Optical $ wander traverse -over :: Optic_ LinearArrow s t a b -> (a %1-> b) -> s %1-> t-over (Optical l) f = getLA (l (LA f))+over :: Optic_ (FUN 'One) s t a b -> (a %1 -> b) -> s %1 -> t+over (Optical l) f = l f -traverseOf :: Optic_ (Linear.Kleisli f) s t a b -> (a %1-> f b) -> s %1-> f t+traverseOf :: Optic_ (Linear.Kleisli f) s t a b -> (a %1 -> f b) -> s %1 -> f t traverseOf (Optical l) f = Linear.runKleisli (l (Linear.Kleisli f)) toListOf :: Optic_ (NonLinear.Kleisli (Const [a])) s t a b -> s -> [a]@@ -122,23 +155,26 @@ set :: Optic_ (->) s t a b -> b -> s -> t set (Optical l) x = l (const x) -setSwap :: Optic_ (Linear.Kleisli (Compose (LinearArrow b) ((,) a))) s t a b -> s %1-> b %1-> (a, t)-setSwap (Optical l) s = getLA (getCompose (Linear.runKleisli (l (Linear.Kleisli (\a -> Compose (LA (\b -> (a,b)))))) s))+setSwap :: Optic_ (Linear.Kleisli (Compose (FUN 'One b) ((,) a))) s t a b -> s %1 -> b %1 -> (a, t)+setSwap (Optical l) s = getCompose (Linear.runKleisli (l (Linear.Kleisli (\a -> Compose (\b -> (a, b))))) s) -match :: Optic_ (Market a b) s t a b -> s %1-> Either t a+match :: Optic_ (Market a b) s t a b -> s %1 -> Either t a match (Optical l) = Prelude.snd (runMarket (l (Market id Right))) -build :: Optic_ (Linear.CoKleisli (Const b)) s t a b -> b %1-> t+build :: Optic_ (Linear.CoKleisli (Const b)) s t a b -> b %1 -> t build (Optical l) x = Linear.runCoKleisli (l (Linear.CoKleisli getConst')) (Const x) -- XXX: move this to Prelude+ -- | Linearly typed patch for the newtype deconstructor. (Temporary until -- inference will get this from the newtype declaration.)-getConst' :: Const a b %1-> a+getConst' :: Const a b %1 -> a getConst' (Const x) = x -lengthOf :: MultIdentity r => Optic_ (NonLinear.Kleisli (Const (Adding r))) s t a b -> s -> r-lengthOf l s = getAdded (gets l (const (Adding one)) s)+lengthOf :: MultIdentity r => Optic_ (NonLinear.Kleisli (Const (Sum r))) s t a b -> s -> r+lengthOf l s =+ (gets l (const (Sum one)) s) & \case+ Sum r -> r -- XXX: the below two functions will be made redundant with multiplicity -- polymorphism on over and traverseOfU@@ -148,27 +184,29 @@ traverseOfU :: Optic_ (NonLinear.Kleisli f) s t a b -> (a -> f b) -> s -> f t traverseOfU (Optical l) f = NonLinear.runKleisli (l (NonLinear.Kleisli f)) -iso :: (s %1-> a) -> (b %1-> t) -> Iso s t a b+iso :: (s %1 -> a) -> (b %1 -> t) -> Iso s t a b iso f g = Optical (dimap f g) -withIso :: Optic_ (Exchange a b) s t a b -> ((s %1-> a) -> (b %1-> t) -> r) -> r+withIso :: Optic_ (Exchange a b) s t a b -> ((s %1 -> a) -> (b %1 -> t) -> r) -> r withIso (Optical l) f = f fro to- where Exchange fro to = l (Exchange id id)+ where+ Exchange fro to = l (Exchange id id) -withPrism :: Optic_ (Market a b) s t a b -> ((b %1-> t) -> (s %1-> Either t a) -> r) -> r+withPrism :: Optic_ (Market a b) s t a b -> ((b %1 -> t) -> (s %1 -> Either t a) -> r) -> r withPrism (Optical l) f = f b m- where Market b m = l (Market id Right)+ where+ Market b m = l (Market id Right) -- XXX: probably a direct implementation would be better-withLens- :: Optic_ (Linear.Kleisli (Compose ((,) a) (FUN 'One b))) s t a b- -> (forall c. (s %1-> (c, a)) -> ((c, b) %1-> t) -> r)- -> r+withLens ::+ Optic_ (Linear.Kleisli (Compose ((,) a) (FUN 'One b))) s t a b ->+ (forall c. (s %1 -> (c, a)) -> ((c, b) %1 -> t) -> r) ->+ r withLens l k = k (Bifunctor.swap . (reifyLens l)) (uncurry ($)) -reifyLens :: Optic_ (Linear.Kleisli (Compose ((,) a) (FUN 'One b))) s t a b -> s %1-> (a, b %1-> t)+reifyLens :: Optic_ (Linear.Kleisli (Compose ((,) a) (FUN 'One b))) s t a b -> s %1 -> (a, b %1 -> t) reifyLens (Optical l) s = getCompose (Linear.runKleisli (l (Linear.Kleisli (\a -> Compose (a, id)))) s) -- linear variant of getCompose-getCompose :: Compose f g a %1-> f (g a)+getCompose :: Compose f g a %1 -> f (g a) getCompose (Compose x) = x
src/Control/Optics/Linear/Iso.hs view
@@ -1,9 +1,9 @@ -- | This module provides linear isomorphisms. ----- An @Iso a b s t@ is equivalent to a @(s \#-> a, b \#-> t)@. In the simple+-- An @Iso a b s t@ is equivalent to a @(s %1-> a, b %1-> t)@. In the simple -- case of an @Iso' a s@, this is equivalent to inverse functions--- @(s \#-> a, a \#-> s)@. In the general case an @Iso a b s t@ means if you--- have the isomorphisms @(a \#-> b, b \#-> a)@ and @(s \#-> t, t \#-> s)@, then+-- @(s %1-> a, a %1-> s)@. In the general case an @Iso a b s t@ means if you+-- have the isomorphisms @(a %1-> b, b %1-> a)@ and @(s %1-> t, t %1-> s)@, then -- you can form isomorphisms between @s@, @t@, @a@ and @b@. -- -- = Example@@ -37,19 +37,24 @@ -- fromClosure (CLeft x f) = Left (f x) -- fromClosure (CRight x f) = Right (f x) -- @--- module Control.Optics.Linear.Iso ( -- * Types- Iso, Iso'+ Iso,+ Iso',+ -- * Composing optics- , (.>)+ (.>),+ -- * Common optics- , swap, assoc+ swap,+ assoc,+ -- * Using optics- , withIso+ withIso,+ -- * Constructing optics- , iso+ iso, )- where+where import Control.Optics.Linear.Internal
src/Control/Optics/Linear/Lens.hs view
@@ -1,12 +1,13 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleContexts #-}+ -- | This module provides linear lenses. ----- A @Lens s t a b@ is equivalent to a @(s \#-> (a,b \#-> t)@. It is a way to+-- A @Lens s t a b@ is equivalent to a @(s %1-> (a,b %1-> t)@. It is a way to -- cut up an instance of a /product type/ @s@ into an @a@ and a way to take a -- @b@ to fill the place of the @a@ in @s@ which yields a @t@. When @a=b@ and--- @s=t@, this type is much more intuitive: @(s \#-> (a,a \#-> s))@. This is a+-- @s=t@, this type is much more intuitive: @(s %1-> (a,a %1-> s))@. This is a -- traversal on exactly one @a@ in a @s@. -- -- = Example@@ -38,20 +39,30 @@ -- locZipL :: Lens' Location Int -- locZipL = lens (\(Location i s) -> (i, \i' -> Location i' s)) -- @--- module Control.Optics.Linear.Lens ( -- * Types- Lens, Lens'+ Lens,+ Lens',+ -- * Composing lens- , (.>)+ (.>),+ -- * Common optics- , _1, _2+ _1,+ _2,+ -- * Using optics- , get, set, gets, setSwap- , over, overU- , reifyLens, withLens+ get,+ set,+ gets,+ setSwap,+ over,+ overU,+ reifyLens,+ withLens,+ -- * Constructing optics- , lens+ lens, ) where
src/Control/Optics/Linear/Prism.hs view
@@ -1,8 +1,8 @@ -- | This module provides linear prisms. ----- A @Prism s t a b@ is equivalent to @(s \#-> Either a t, b \#-> t)@ for some--- /sum type/ @s@. In the non-polymorphic version, this is a @(s \#-> Either a--- s, a \#-> s)@ which represents taking one case of a sum type and a way to+-- A @Prism s t a b@ is equivalent to @(s %1-> Either a t, b %1-> t)@ for some+-- /sum type/ @s@. In the non-polymorphic version, this is a @(s %1-> Either a+-- s, a %1-> s)@ which represents taking one case of a sum type and a way to -- build the sum-type given that one case. A prism is a traversal focusing on -- one branch or case that a sum type could be. --@@ -45,21 +45,28 @@ -- decompose (IdLicence l) = Right l -- decompose x = Left x -- @--- module Control.Optics.Linear.Prism ( -- * Types- Prism, Prism'+ Prism,+ Prism',+ -- * Composing optics- , (.>)+ (.>),+ -- * Common optics- , _Left, _Right- , _Just, _Nothing+ _Left,+ _Right,+ _Just,+ _Nothing,+ -- * Using optics- , match, build- , withPrism+ match,+ build,+ withPrism,+ -- * Constructing optics- , prism+ prism, )- where+where import Control.Optics.Linear.Internal
src/Control/Optics/Linear/Traversal.hs view
@@ -50,20 +50,26 @@ -- traverse' (\(Student s i) -> Student <$> onName s <*> pure i) students <*> -- pure texts -- @--- module Control.Optics.Linear.Traversal ( -- * Types- Traversal, Traversal'+ Traversal,+ Traversal',+ -- * Composing optics- , (.>)+ (.>),+ -- * Common optics- , traversed+ traversed,+ -- * Using optics- , over, overU- , traverseOf, traverseOfU+ over,+ overU,+ traverseOf,+ traverseOfU,+ -- * Constructing optics- , traversal+ traversal, )- where+where import Control.Optics.Linear.Internal
+ src/Data/Arity/Linear.hs view
@@ -0,0 +1,17 @@+-- |+-- This module provides type-level helpers and classes to deal with n-ary+-- functions.+--+-- See 'Data.V.Linear.make', 'Data.V.Linear.elim' and+-- 'Data.Replicator.Linear.elim' for use-cases.+module Data.Arity.Linear+ ( Peano (..),+ NatToPeano,+ PeanoToNat,+ FunN,+ Arity,+ IsFunN,+ )+where++import Data.Arity.Linear.Internal
+ src/Data/Arity/Linear/Internal.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Arity.Linear.Internal where++import Data.Kind+import GHC.TypeLits+import GHC.Types++data Peano = Z | S Peano++-- | Converts a GHC type-level 'Nat' to a structural type-level natural ('Peano').+type NatToPeano :: Nat -> Peano+type family NatToPeano n where+ NatToPeano 0 = 'Z+ NatToPeano n = 'S (NatToPeano (n - 1))++-- | Converts a structural type-level natural ('Peano') to a GHC type-level 'Nat'.+type PeanoToNat :: Peano -> Nat+type family PeanoToNat n where+ PeanoToNat 'Z = 0+ PeanoToNat ('S n) = 1 + PeanoToNat n++-- | @'FunN' n a b@ represents a function taking @n@ linear arguments of+-- type @a@ and returning a result of type @b@.+type FunN :: Peano -> Type -> Type -> Type+type family FunN n a b where+ FunN 'Z _ b = b+ FunN ('S n) a b = a %1 -> FunN n a b++-- | The 'Arity' type family exists to help the type checker fill in+-- blanks. Chances are that you can safely ignore 'Arity' completely if it's in+-- the type of a function you care. But read on if you are curious.+--+-- The idea is that in a function like 'Data.Replicator.Linear.elim' some of the+-- type arguments are redundant. The function has an ambiguous type, so you will+-- always have to help the compiler either with a type annotation or a type+-- application. But there are several complete ways to do so. In+-- 'Data.Replicator.Linear.elim', if you give the values of `n`, `a`, and `b`,+-- then you can deduce the value of `f` (indeed, it's @'FunN' n a b@). With+-- 'Arity' we can go in the other direction: if `b` and `f` are both known, then+-- we know that `n` is @'Arity' b f@+--+-- 'Arity' returns a 'Nat' rather than a 'Peano' because the result is never+-- consumed. It exists to infer arguments to functions such as+-- 'Data.Replicator.Linear.elim' from the other arguments if they are known.+--+-- 'Arity' could /theorically/ be an associated type family to the 'IsFunN' type+-- class. But it's better to make it a closed type family (which can't be+-- associated to a type class) because it lets us give a well-defined error+-- case. In addition, GHC cannot see that @0 /= 1 + (? :: Nat)@ and as a result we get+-- some overlap which is only allowed in (ordered) closed type families.+type Arity :: Type -> Type -> Nat+type family Arity b f where+ Arity b b = 0+ Arity b (a %1 -> f) = Arity b f + 1+ Arity b f =+ TypeError+ ( 'Text "Arity: "+ ':<>: 'ShowType f+ ':<>: 'Text " isn't a linear function with head "+ ':<>: 'ShowType b+ ':<>: 'Text "."+ )++-- | The 'IsFun' type class is meant to help the type checker fill in+-- blanks. Chances are that you can safely ignore 'IsFun' completely if it's in+-- the type of a function you care. But read on if you are curious.+--+-- The type class 'IsFun' is a kind of inverse to 'FunN', it is meant to be+-- read as @'IsFunN' a b f@ if and only if there exists @n@ such that @f =+-- 'FunN' n a b@ (`n` can be retrieved as @'Arity' b f@ or+-- @'Data.V.Linear.ArityV' f@).+--+-- The reason why 'Arity' (read its documentation first) is not sufficient for+-- our purpose, is that it can find @n@ /if/ @f@ is a linear function of the+-- appropriate shape. But what if @f@ is partially undetermined? Then it is+-- likely that 'Arity' will be stuck. But we know, for instance, that if @f = a1+-- %1 -> a2 %1 -> c@ then we must have @a1 ~ a2@. The trick is that instance+-- resolution of 'IsFun' will add unification constraints that the type checker+-- has to solve. Look in particular at the instance @'IsFunN' a b (a\' %p ->+-- f))@: it matches liberally, so triggers on quite underdetermined @f@, but has+-- equality constraints in its context which will help the type checker.+class IsFunN a b f++instance IsFunN a b b++instance (IsFunN a b f, a' ~ a, p ~ 'One) => IsFunN a b (a' %p -> f)
src/Data/Array/Destination.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-} -- | This module provides destination arrays --@@ -44,7 +41,7 @@ -- -- @ -- jacobi1d :: Int -> Vector Double -> Vector Double--- jacobi1d n oldA = case stepArr n oldA of +-- jacobi1d n oldA = case stepArr n oldA of -- newB -> stepArr n newB -- -- -- @jacobi1d N A[N] B[N] = (new_A[N], new_B[N])@.@@ -110,100 +107,22 @@ -- -- and the only way to really consume a @DArray@ is via our API -- which requires you to completely fill the array.--- module Data.Array.Destination- (- -- * The Data Type- DArray- -- * Create and use a @DArray@- , alloc- , size- -- * Ways to write to a @DArray@- , replicate- , split- , mirror- , fromFunction- , fill- , dropEmpty- )- where--import Data.Vector (Vector, (!))-import qualified Data.Vector as Vector-import Data.Vector.Mutable (MVector)-import qualified Data.Vector.Mutable as MVector-import GHC.Exts (RealWorld)-import qualified Prelude as Prelude-import System.IO.Unsafe (unsafeDupablePerformIO)-import GHC.Stack-import Data.Unrestricted.Linear-import Prelude.Linear hiding (replicate)-import qualified Unsafe.Linear as Unsafe---- | A destination array, or @DArray@, is a write-only array that is filled--- by some computation which ultimately returns an array.-data DArray a where- DArray :: MVector RealWorld a -> DArray a---- XXX: use of Vector in types is temporary. I will probably move away from--- vectors and implement most stuff in terms of Array# and MutableArray#--- eventually, anyway. This would allow to move the MutableArray logic to--- linear IO, possibly, and segregate the unsafe casts to the Linear IO--- module. @`alloc` n k@ must be called with a non-negative value of @n@.-alloc :: Int -> (DArray a %1-> ()) %1-> Vector a-alloc n writer = (\(Ur dest, vec) -> writer (DArray dest) `lseq` vec) $- unsafeDupablePerformIO Prelude.$ do- destArray <- MVector.unsafeNew n- vec <- Vector.unsafeFreeze destArray- Prelude.return (Ur destArray, vec)---- | Get the size of a destination array.-size :: DArray a %1-> (Ur Int, DArray a)-size (DArray mvec) = (Ur (MVector.length mvec), DArray mvec)---- | Fill a destination array with a constant-replicate :: a -> DArray a %1-> ()-replicate a = fromFunction (const a)---- | @fill a dest@ fills a singleton destination array.--- Caution, @'fill' a dest@ will fail is @dest@ isn't of length exactly one.-fill :: HasCallStack => a %1-> DArray a %1-> ()-fill a (DArray mvec) =- if MVector.length mvec /= 1- then error "Destination.fill: requires a destination of size 1" $ a- else a &- Unsafe.toLinear (\x -> unsafeDupablePerformIO (MVector.write mvec 0 x))---- | @dropEmpty dest@ consumes and empty array and fails otherwise.-dropEmpty :: HasCallStack => DArray a %1-> ()-dropEmpty (DArray mvec)- | MVector.length mvec > 0 = error "Destination.dropEmpty on non-empty array."- | otherwise = mvec `seq` ()---- | @'split' n dest = (destl, destr)@ such as @destl@ has length @n@.------ 'split' is total: if @n@ is larger than the length of @dest@, then--- @destr@ is empty.-split :: Int -> DArray a %1-> (DArray a, DArray a)-split n (DArray mvec) | (ml, mr) <- MVector.splitAt n mvec =- (DArray ml, DArray mr)+ ( -- * The Data Type+ DArray, --- | Fills the destination array with the contents of given vector.------ Errors if the given vector is smaller than the destination array.-mirror :: HasCallStack => Vector a -> (a %1-> b) -> DArray b %1-> ()-mirror v f arr =- size arr & \(Ur sz, arr') ->- if Vector.length v < sz- then error "Destination.mirror: argument smaller than DArray" $ arr'- else fromFunction (\t -> f (v ! t)) arr'+ -- * Create and use a @DArray@+ alloc,+ size, --- | Fill a destination array using the given index-to-value function.-fromFunction :: (Int -> b) -> DArray b %1-> ()-fromFunction f (DArray mvec) = unsafeDupablePerformIO Prelude.$ do- let n = MVector.length mvec- Prelude.sequence_ [MVector.unsafeWrite mvec m (f m) | m <- [0..n-1]]--- The use of the mutable array is linear, since getting the length does not--- touch any elements, and each write fills in exactly one slot, so--- each slot of the destination array is filled.+ -- * Ways to write to a @DArray@+ replicate,+ split,+ mirror,+ fromFunction,+ fill,+ dropEmpty,+ )+where +import Data.Array.Destination.Internal
+ src/Data/Array/Destination/Internal.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Array.Destination.Internal where++import Data.Unrestricted.Linear+import Data.Vector (Vector, (!))+import qualified Data.Vector as Vector+import Data.Vector.Mutable (MVector)+import qualified Data.Vector.Mutable as MVector+import GHC.Exts (RealWorld)+import GHC.Stack+import Prelude.Linear hiding (replicate)+import System.IO.Unsafe (unsafeDupablePerformIO)+import qualified Unsafe.Linear as Unsafe+import qualified Prelude as Prelude++-- | A destination array, or @DArray@, is a write-only array that is filled+-- by some computation which ultimately returns an array.+data DArray a where+ DArray :: MVector RealWorld a -> DArray a++-- XXX: use of Vector in types is temporary. I will probably move away from+-- vectors and implement most stuff in terms of Array# and MutableArray#+-- eventually, anyway. This would allow to move the MutableArray logic to+-- linear IO, possibly, and segregate the unsafe casts to the Linear IO+-- module. @`alloc` n k@ must be called with a non-negative value of @n@.+alloc :: Int -> (DArray a %1 -> ()) %1 -> Vector a+alloc n writer = (\(Ur dest, vec) -> writer (DArray dest) `lseq` vec) $+ unsafeDupablePerformIO $ do+ destArray <- MVector.unsafeNew n+ vec <- Vector.unsafeFreeze destArray+ Prelude.return (Ur destArray, vec)++-- | Get the size of a destination array.+size :: DArray a %1 -> (Ur Int, DArray a)+size (DArray mvec) = (Ur (MVector.length mvec), DArray mvec)++-- | Fill a destination array with a constant+replicate :: a -> DArray a %1 -> ()+replicate a = fromFunction (const a)++-- | @fill a dest@ fills a singleton destination array.+-- Caution, @'fill' a dest@ will fail is @dest@ isn't of length exactly one.+fill :: HasCallStack => a %1 -> DArray a %1 -> ()+fill a (DArray mvec) =+ if MVector.length mvec /= 1+ then error "Destination.fill: requires a destination of size 1" $ a+ else+ a+ & Unsafe.toLinear (\x -> unsafeDupablePerformIO (MVector.write mvec 0 x))++-- | @dropEmpty dest@ consumes and empty array and fails otherwise.+dropEmpty :: HasCallStack => DArray a %1 -> ()+dropEmpty (DArray mvec)+ | MVector.length mvec > 0 = error "Destination.dropEmpty on non-empty array."+ | otherwise = mvec `seq` ()++-- | @'split' n dest = (destl, destr)@ such as @destl@ has length @n@.+--+-- 'split' is total: if @n@ is larger than the length of @dest@, then+-- @destr@ is empty.+split :: Int -> DArray a %1 -> (DArray a, DArray a)+split n (DArray mvec)+ | (ml, mr) <- MVector.splitAt n mvec =+ (DArray ml, DArray mr)++-- | Fills the destination array with the contents of given vector.+--+-- Errors if the given vector is smaller than the destination array.+mirror :: HasCallStack => Vector a -> (a %1 -> b) -> DArray b %1 -> ()+mirror v f arr =+ size arr & \(Ur sz, arr') ->+ if Vector.length v < sz+ then error "Destination.mirror: argument smaller than DArray" $ arr'+ else fromFunction (\t -> f (v ! t)) arr'++-- | Fill a destination array using the given index-to-value function.+fromFunction :: (Int -> b) -> DArray b %1 -> ()+fromFunction f (DArray mvec) = unsafeDupablePerformIO $ do+ let n = MVector.length mvec+ Prelude.sequence_ [MVector.unsafeWrite mvec m (f m) | m <- [0 .. n - 1]]++-- The use of the mutable array is linear, since getting the length does not+-- touch any elements, and each write fills in exactly one slot, so+-- each slot of the destination array is filled.
src/Data/Array/Mutable/Linear.hs view
@@ -1,13 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE UnboxedTuples #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-} -- | -- This module provides a pure linear interface for arrays with in-place@@ -36,15 +27,18 @@ module Data.Array.Mutable.Linear ( -- * Mutable Linear Arrays Array,+ -- * Performing Computations with Arrays alloc, allocBeside, fromList,+ -- * Modifications set, unsafeSet, resize, map,+ -- * Accessors get, unsafeGet,@@ -52,235 +46,14 @@ slice, toList, freeze,+ -- * Mutable-style interface read, unsafeRead, write,- unsafeWrite+ unsafeWrite, ) where -import Data.Unrestricted.Linear-import GHC.Stack-import Data.Array.Mutable.Unlifted.Linear (Array#)-import qualified Data.Array.Mutable.Unlifted.Linear as Unlifted-import qualified Data.Functor.Linear as Data-import qualified Data.Vector as Vector-import qualified Data.Vector.Mutable as MVector-import Prelude.Linear ((&), forget)-import qualified Data.Primitive.Array as Prim-import System.IO.Unsafe (unsafeDupablePerformIO)-import Prelude hiding (read, map)---- # Data types----------------------------------------------------------------------------------data Array a = Array (Array# a)---- # Creation------------------------------------------------------------------------------------ | Allocate a constant array given a size and an initial value--- The size must be non-negative, otherwise this errors.-alloc :: HasCallStack =>- Int -> a -> (Array a %1-> Ur b) %1-> Ur b-alloc s x f- | s < 0 =- (error ("Array.alloc: negative size: " ++ show s) :: x %1-> x)- (f undefined)- | otherwise = Unlifted.alloc s x (\arr -> f (Array arr))---- | Allocate a constant array given a size and an initial value,--- using another array as a uniqueness proof.-allocBeside :: Int -> a -> Array b %1-> (Array a, Array b)-allocBeside s x (Array orig)- | s < 0 =- Unlifted.lseq- orig- (error ("Array.allocBeside: negative size: " ++ show s))- | otherwise =- wrap (Unlifted.allocBeside s x orig)- where- wrap :: (# Array# a, Array# b #) %1-> (Array a, Array b)- wrap (# orig, new #) = (Array orig, Array new)---- | Allocate an array from a list-fromList :: HasCallStack =>- [a] -> (Array a %1-> Ur b) %1-> Ur b-fromList list (f :: Array a %1-> Ur b) =- alloc- (Prelude.length list)- (error "invariant violation: unintialized array position")- (\arr -> f (insert arr))- where- insert :: Array a %1-> Array a- insert = doWrites (zip list [0..])-- doWrites :: [(a,Int)] -> Array a %1-> Array a- doWrites [] arr = arr- doWrites ((a,ix):xs) arr = doWrites xs (unsafeSet ix a arr)---- # Mutations and Reads----------------------------------------------------------------------------------size :: Array a %1-> (Ur Int, Array a)-size (Array arr) = f (Unlifted.size arr)- where- f :: (# Ur Int, Array# a #) %1-> (Ur Int, Array a)- f (# s, arr #) = (s, Array arr)---- | Sets the value of an index. The index should be less than the arrays--- size, otherwise this errors.-set :: HasCallStack => Int -> a -> Array a %1-> Array a-set i x arr = unsafeSet i x (assertIndexInRange i arr)---- | Same as 'set, but does not do bounds-checking. The behaviour is undefined--- if an out-of-bounds index is provided.-unsafeSet :: Int -> a -> Array a %1-> Array a-unsafeSet ix val (Array arr) =- Array (Unlifted.set ix val arr)---- | Get the value of an index. The index should be less than the arrays 'size',--- otherwise this errors.-get :: HasCallStack => Int -> Array a %1-> (Ur a, Array a)-get i arr = unsafeGet i (assertIndexInRange i arr)---- | Same as 'get', but does not do bounds-checking. The behaviour is undefined--- if an out-of-bounds index is provided.-unsafeGet :: Int -> Array a %1-> (Ur a, Array a)-unsafeGet ix (Array arr) = wrap (Unlifted.get ix arr)- where- wrap :: (# Ur a, Array# a #) %1-> (Ur a, Array a)- wrap (# ret, arr #) = (ret, Array arr)---- | Resize an array. That is, given an array, a target size, and a seed--- value; resize the array to the given size using the seed value to fill--- in the new cells when necessary and copying over all the unchanged cells.------ Target size should be non-negative.------ @--- let b = resize n x a,--- then size b = n,--- and b[i] = a[i] for i < size a,--- and b[i] = x for size a <= i < n.--- @-resize :: HasCallStack => Int -> a -> Array a %1-> Array a-resize newSize seed (Array arr :: Array a)- | newSize < 0 =- Unlifted.lseq- arr- (error "Trying to resize to a negative size.")- | otherwise =- doCopy (Unlifted.allocBeside newSize seed arr)- where- doCopy :: (# Array# a, Array# a #) %1-> Array a- doCopy (# new, old #) = wrap (Unlifted.copyInto 0 old new)-- wrap :: (# Array# a, Array# a #) %1-> Array a- wrap (# src, dst #) = src `Unlifted.lseq` Array dst----- | Return the array elements as a lazy list.-toList :: Array a %1-> Ur [a]-toList (Array arr) = Unlifted.toList arr---- | Copy a slice of the array, starting from given offset and copying given--- number of elements. Returns the pair (oldArray, slice).------ Start offset + target size should be within the input array, and both should--- be non-negative.------ @--- let b = slice i n a,--- then size b = n,--- and b[j] = a[i+j] for 0 <= j < n--- @-slice- :: HasCallStack- => Int -- ^ Start offset- -> Int -- ^ Target size- -> Array a %1-> (Array a, Array a)-slice from targetSize arr =- size arr & \case- (Ur s, Array old)- | s < from + targetSize ->- Unlifted.lseq- old- (error "Slice index out of bounds.")- | otherwise ->- doCopy- (Unlifted.allocBeside- targetSize- (error "invariant violation: uninitialized array index")- old)- where- doCopy :: (# Array# a, Array# a #) %1-> (Array a, Array a)- doCopy (# new, old #) = wrap (Unlifted.copyInto from old new)-- wrap :: (# Array# a, Array# a #) %1-> (Array a, Array a)- wrap (# old, new #) = (Array old, Array new)---- | /O(1)/ Convert an 'Array' to an immutable 'Vector.Vector' (from--- 'vector' package).-freeze :: Array a %1-> Ur (Vector.Vector a)-freeze (Array arr) =- Unlifted.freeze go arr- where- go arr = unsafeDupablePerformIO $ do- mut <- Prim.unsafeThawArray (Prim.Array arr)- let mv = MVector.MVector 0 (Prim.sizeofMutableArray mut) mut- Vector.unsafeFreeze mv- -- We only need to do above because 'Vector' constructor is hidden.- -- Once it is exposed, we should be able to replace it with something- -- safer like: `go arr = Vector 0 (sizeof arr) arr`--map :: (a -> b) -> Array a %1-> Array b-map f (Array arr) = Array (Unlifted.map f arr)---- # Mutation-style API------------------------------------------------------------------------------------ | Same as 'set', but takes the 'Array' as the first parameter.-write :: HasCallStack => Array a %1-> Int -> a -> Array a-write arr i a = set i a arr---- | Same as 'unsafeSafe', but takes the 'Array' as the first parameter.-unsafeWrite :: Array a %1-> Int -> a -> Array a-unsafeWrite arr i a = unsafeSet i a arr---- | Same as 'get', but takes the 'Array' as the first parameter.-read :: HasCallStack => Array a %1-> Int -> (Ur a, Array a)-read arr i = get i arr---- | Same as 'unsafeGet', but takes the 'Array' as the first parameter.-unsafeRead :: Array a %1-> Int -> (Ur a, Array a)-unsafeRead arr i = unsafeGet i arr---- # Instances----------------------------------------------------------------------------------instance Consumable (Array a) where- consume :: Array a %1-> ()- consume (Array arr) = arr `Unlifted.lseq` ()--instance Dupable (Array a) where- dup2 :: Array a %1-> (Array a, Array a)- dup2 (Array arr) = wrap (Unlifted.dup2 arr)- where- wrap :: (# Array# a, Array# a #) %1-> (Array a, Array a)- wrap (# a1, a2 #) = (Array a1, Array a2)--instance Data.Functor Array where- fmap f arr = map (forget f) arr---- # Internal library------------------------------------------------------------------------------------ | Check if given index is within the Array, otherwise panic.-assertIndexInRange :: HasCallStack => Int -> Array a %1-> Array a-assertIndexInRange i arr =- size arr & \(Ur s, arr') ->- if 0 <= i && i < s- then arr'- else arr' `lseq` error "Array: index out of bounds"+import Data.Array.Mutable.Linear.Internal+import Prelude hiding (map, read)
+ src/Data/Array/Mutable/Linear/Internal.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Array.Mutable.Linear.Internal+ ( -- * Mutable Linear Arrays+ Array (..),++ -- * Performing Computations with Arrays+ alloc,+ allocBeside,+ fromList,++ -- * Modifications+ set,+ unsafeSet,+ resize,+ map,++ -- * Accessors+ get,+ unsafeGet,+ size,+ slice,+ toList,+ freeze,++ -- * Mutable-style interface+ read,+ unsafeRead,+ write,+ unsafeWrite,+ )+where++import Data.Array.Mutable.Unlifted.Linear (Array#)+import qualified Data.Array.Mutable.Unlifted.Linear as Unlifted+import qualified Data.Functor.Linear as Data+import qualified Data.Primitive.Array as Prim+import Data.Unrestricted.Linear+import qualified Data.Vector as Vector+import GHC.Stack+import Prelude.Linear (forget, (&))+import Prelude hiding (map, read)++-- # Data types+-------------------------------------------------------------------------------++data Array a = Array (Array# a)++-- # Creation+-------------------------------------------------------------------------------++-- | Allocate a constant array given a size and an initial value+-- The size must be non-negative, otherwise this errors.+alloc ::+ HasCallStack =>+ Int ->+ a ->+ (Array a %1 -> Ur b) %1 ->+ Ur b+alloc s x f+ | s < 0 =+ (error ("Array.alloc: negative size: " ++ show s) :: x %1 -> x)+ (f undefined)+ | otherwise = Unlifted.alloc s x (\arr -> f (Array arr))++-- | Allocate a constant array given a size and an initial value,+-- using another array as a uniqueness proof.+allocBeside :: Int -> a -> Array b %1 -> (Array a, Array b)+allocBeside s x (Array orig)+ | s < 0 =+ Unlifted.lseq+ orig+ (error ("Array.allocBeside: negative size: " ++ show s))+ | otherwise =+ wrap (Unlifted.allocBeside s x orig)+ where+ wrap :: (# Array# a, Array# b #) %1 -> (Array a, Array b)+ wrap (# orig, new #) = (Array orig, Array new)++-- | Allocate an array from a list+fromList ::+ HasCallStack =>+ [a] ->+ (Array a %1 -> Ur b) %1 ->+ Ur b+fromList list (f :: Array a %1 -> Ur b) =+ alloc+ (Prelude.length list)+ (error "invariant violation: unintialized array position")+ (\arr -> f (insert arr))+ where+ insert :: Array a %1 -> Array a+ insert = doWrites (zip list [0 ..])++ doWrites :: [(a, Int)] -> Array a %1 -> Array a+ doWrites [] arr = arr+ doWrites ((a, ix) : xs) arr = doWrites xs (unsafeSet ix a arr)++-- # Mutations and Reads+-------------------------------------------------------------------------------++size :: Array a %1 -> (Ur Int, Array a)+size (Array arr) = f (Unlifted.size arr)+ where+ f :: (# Ur Int, Array# a #) %1 -> (Ur Int, Array a)+ f (# s, arr #) = (s, Array arr)++-- | Sets the value of an index. The index should be less than the arrays+-- size, otherwise this errors.+set :: HasCallStack => Int -> a -> Array a %1 -> Array a+set i x arr = unsafeSet i x (assertIndexInRange i arr)++-- | Same as 'set, but does not do bounds-checking. The behaviour is undefined+-- if an out-of-bounds index is provided.+unsafeSet :: Int -> a -> Array a %1 -> Array a+unsafeSet ix val (Array arr) =+ Array (Unlifted.set ix val arr)++-- | Get the value of an index. The index should be less than the arrays 'size',+-- otherwise this errors.+get :: HasCallStack => Int -> Array a %1 -> (Ur a, Array a)+get i arr = unsafeGet i (assertIndexInRange i arr)++-- | Same as 'get', but does not do bounds-checking. The behaviour is undefined+-- if an out-of-bounds index is provided.+unsafeGet :: Int -> Array a %1 -> (Ur a, Array a)+unsafeGet ix (Array arr) = wrap (Unlifted.get ix arr)+ where+ wrap :: (# Ur a, Array# a #) %1 -> (Ur a, Array a)+ wrap (# ret, arr #) = (ret, Array arr)++-- | Resize an array. That is, given an array, a target size, and a seed+-- value; resize the array to the given size using the seed value to fill+-- in the new cells when necessary and copying over all the unchanged cells.+--+-- Target size should be non-negative.+--+-- @+-- let b = resize n x a,+-- then size b = n,+-- and b[i] = a[i] for i < size a,+-- and b[i] = x for size a <= i < n.+-- @+resize :: HasCallStack => Int -> a -> Array a %1 -> Array a+resize newSize seed (Array arr :: Array a)+ | newSize < 0 =+ Unlifted.lseq+ arr+ (error "Trying to resize to a negative size.")+ | otherwise =+ doCopy (Unlifted.allocBeside newSize seed arr)+ where+ doCopy :: (# Array# a, Array# a #) %1 -> Array a+ doCopy (# new, old #) = wrap (Unlifted.copyInto 0 old new)++ wrap :: (# Array# a, Array# a #) %1 -> Array a+ wrap (# src, dst #) = src `Unlifted.lseq` Array dst++-- | Return the array elements as a lazy list.+toList :: Array a %1 -> Ur [a]+toList (Array arr) = Unlifted.toList arr++-- | Copy a slice of the array, starting from given offset and copying given+-- number of elements. Returns the pair (oldArray, slice).+--+-- Start offset + target size should be within the input array, and both should+-- be non-negative.+--+-- @+-- let b = slice i n a,+-- then size b = n,+-- and b[j] = a[i+j] for 0 <= j < n+-- @+slice ::+ HasCallStack =>+ -- | Start offset+ Int ->+ -- | Target size+ Int ->+ Array a %1 ->+ (Array a, Array a)+slice from targetSize arr =+ size arr & \case+ (Ur s, Array old)+ | s < from + targetSize ->+ Unlifted.lseq+ old+ (error "Slice index out of bounds.")+ | otherwise ->+ doCopy+ ( Unlifted.allocBeside+ targetSize+ (error "invariant violation: uninitialized array index")+ old+ )+ where+ doCopy :: (# Array# a, Array# a #) %1 -> (Array a, Array a)+ doCopy (# new, old #) = wrap (Unlifted.copyInto from old new)++ wrap :: (# Array# a, Array# a #) %1 -> (Array a, Array a)+ wrap (# old, new #) = (Array old, Array new)++-- | /O(1)/ Convert an 'Array' to an immutable 'Vector.Vector' (from+-- 'vector' package).+freeze :: Array a %1 -> Ur (Vector.Vector a)+freeze (Array arr) =+ Unlifted.freeze (\a -> Vector.fromArray (Prim.Array a)) arr++map :: (a -> b) -> Array a %1 -> Array b+map f (Array arr) = Array (Unlifted.map f arr)++-- # Mutation-style API+-------------------------------------------------------------------------------++-- | Same as 'set', but takes the 'Array' as the first parameter.+write :: HasCallStack => Array a %1 -> Int -> a -> Array a+write arr i a = set i a arr++-- | Same as 'unsafeSet', but takes the 'Array' as the first parameter.+unsafeWrite :: Array a %1 -> Int -> a -> Array a+unsafeWrite arr i a = unsafeSet i a arr++-- | Same as 'get', but takes the 'Array' as the first parameter.+read :: HasCallStack => Array a %1 -> Int -> (Ur a, Array a)+read arr i = get i arr++-- | Same as 'unsafeGet', but takes the 'Array' as the first parameter.+unsafeRead :: Array a %1 -> Int -> (Ur a, Array a)+unsafeRead arr i = unsafeGet i arr++-- # Instances+-------------------------------------------------------------------------------++instance Consumable (Array a) where+ consume :: Array a %1 -> ()+ consume (Array arr) = arr `Unlifted.lseq` ()++instance Dupable (Array a) where+ dup2 :: Array a %1 -> (Array a, Array a)+ dup2 (Array arr) = wrap (Unlifted.dup2 arr)+ where+ wrap :: (# Array# a, Array# a #) %1 -> (Array a, Array a)+ wrap (# a1, a2 #) = (Array a1, Array a2)++instance Data.Functor Array where+ fmap f arr = map (forget f) arr++-- # Internal library+-------------------------------------------------------------------------------++-- | Check if given index is within the Array, otherwise panic.+assertIndexInRange :: HasCallStack => Int -> Array a %1 -> Array a+assertIndexInRange i arr =+ size arr & \(Ur s, arr') ->+ if 0 <= i && i < s+ then arr'+ else arr' `lseq` error "Array: index out of bounds"
src/Data/Array/Mutable/Unlifted/Linear.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LinearTypes #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedNewtypes #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | -- This module provides an unlifted mutable array with a pure@@ -18,52 +18,55 @@ -- -- This module is meant to be imported qualified. module Data.Array.Mutable.Unlifted.Linear- ( Array#- , unArray#- , alloc- , allocBeside- , lseq- , size- , get- , set- , copyInto- , map- , toList- , freeze- , dup2- ) where+ ( Array#,+ unArray#,+ alloc,+ allocBeside,+ lseq,+ size,+ get,+ set,+ copyInto,+ map,+ toList,+ freeze,+ dup2,+ )+where -import Data.Unrestricted.Linear hiding (lseq, dup2)+import Data.Unrestricted.Linear hiding (dup2, lseq)+import qualified GHC.Exts as GHC+import qualified Unsafe.Linear as Unsafe import Prelude (Int) import qualified Prelude as Prelude-import qualified Unsafe.Linear as Unsafe-import qualified GHC.Exts as GHC -- | A mutable array holding @a@s newtype Array# a = Array# (GHC.MutableArray# GHC.RealWorld a) -- | Extract the underlying 'GHC.MutableArray#', consuming the 'Array#' -- in process.-unArray# :: (GHC.MutableArray# GHC.RealWorld a -> b) -> Array# a %1-> Ur b+unArray# :: (GHC.MutableArray# GHC.RealWorld a -> b) -> Array# a %1 -> Ur b unArray# f = Unsafe.toLinear (\(Array# a) -> Ur (f a)) -- | Consume an 'Array#'. -- -- Note that we can not implement a 'Consumable' instance because 'Array#' -- is unlifted.-lseq :: Array# a %1-> b %1-> b+lseq :: Array# a %1 -> b %1 -> b lseq = Unsafe.toLinear2 (\_ b -> b) +infixr 0 `lseq` -- same fixity as base.seq+ -- | Allocate a mutable array of given size using a default value. -- -- The size should be non-negative.-alloc :: Int -> a -> (Array# a %1-> Ur b) %1-> Ur b+alloc :: Int -> a -> (Array# a %1 -> Ur b) %1 -> Ur b alloc (GHC.I# s) a f = let new = GHC.runRW# Prelude.$ \st -> case GHC.newArray# s a st of (# _, arr #) -> Array# arr in f new-{-# NOINLINE alloc #-} -- prevents runRW# from floating outwards+{-# NOINLINE alloc #-} -- prevents runRW# from floating outwards -- For the reasoning behind these NOINLINE pragmas, see the discussion at: -- https://github.com/tweag/linear-base/pull/187#pullrequestreview-489183531@@ -72,39 +75,39 @@ -- using another 'Array#' as a uniqueness proof. -- -- The size should be non-negative.-allocBeside :: Int -> a -> Array# b %1-> (# Array# a, Array# b #)+allocBeside :: Int -> a -> Array# b %1 -> (# Array# a, Array# b #) allocBeside (GHC.I# s) a orig = let new = GHC.runRW# Prelude.$ \st -> case GHC.newArray# s a st of (# _, arr #) -> Array# arr in (# new, orig #)-{-# NOINLINE allocBeside #-} -- prevents runRW# from floating outwards+{-# NOINLINE allocBeside #-} -- prevents runRW# from floating outwards -size :: Array# a %1-> (# Ur Int, Array# a #)+size :: Array# a %1 -> (# Ur Int, Array# a #) size = Unsafe.toLinear go where go :: Array# a -> (# Ur Int, Array# a #) go (Array# arr) = let !s = GHC.sizeofMutableArray# arr- in (# Ur (GHC.I# s), Array# arr #)+ in (# Ur (GHC.I# s), Array# arr #) -get :: Int -> Array# a %1-> (# Ur a, Array# a #)+get :: Int -> Array# a %1 -> (# Ur a, Array# a #) get (GHC.I# i) = Unsafe.toLinear go where go :: Array# a -> (# Ur a, Array# a #) go (Array# arr) = case GHC.runRW# (GHC.readArray# arr i) of (# _, ret #) -> (# Ur ret, Array# arr #)-{-# NOINLINE get #-} -- prevents the runRW# effect from being reordered+{-# NOINLINE get #-} -- prevents the runRW# effect from being reordered -set :: Int -> a -> Array# a %1-> Array# a+set :: Int -> a -> Array# a %1 -> Array# a set (GHC.I# i) (a :: a) = Unsafe.toLinear go where go :: Array# a -> Array# a go (Array# arr) = case GHC.runRW# (GHC.writeArray# arr i a) of _ -> Array# arr-{-# NOINLINE set #-} -- prevents the runRW# effect from being reordered+{-# NOINLINE set #-} -- prevents the runRW# effect from being reordered -- | Copy the first mutable array into the second mutable array, starting -- from the given index of the source array.@@ -116,82 +119,74 @@ -- copyInto n src dest: -- dest[i] = src[n+i] for i < size dest, i < size src + n -- @-copyInto :: Int -> Array# a %1-> Array# a %1-> (# Array# a, Array# a #)+copyInto :: Int -> Array# a %1 -> Array# a %1 -> (# Array# a, Array# a #) copyInto start@(GHC.I# start#) = Unsafe.toLinear2 go where go :: Array# a -> Array# a -> (# Array# a, Array# a #) go (Array# src) (Array# dst) =- let !(GHC.I# len#) = Prelude.min- (GHC.I# (GHC.sizeofMutableArray# src) Prelude.- start)- (GHC.I# (GHC.sizeofMutableArray# dst))- in case GHC.runRW# (GHC.copyMutableArray# src start# dst 0# len#) of+ let !(GHC.I# len#) =+ Prelude.min+ (GHC.I# (GHC.sizeofMutableArray# src) Prelude.- start)+ (GHC.I# (GHC.sizeofMutableArray# dst))+ in case GHC.runRW# (GHC.copyMutableArray# src start# dst 0# len#) of _ -> (# Array# src, Array# dst #)-{-# NOINLINE copyInto #-} -- prevents the runRW# effect from being reordered+{-# NOINLINE copyInto #-} -- prevents the runRW# effect from being reordered -map :: (a -> b) -> Array# a %1-> Array# b-map (f :: a -> b) arr =- size arr- `chain2` \(# Ur s, arr' #) -> go 0 s arr'- where- -- When we're mapping an array, we first insert `b`'s- -- inside an `Array# a` by unsafeCoerce'ing, and then we- -- unsafeCoerce the result to an `Array# b`.- go :: Int -> Int -> Array# a %1-> Array# b- go i s arr'- | i Prelude.== s =- Unsafe.toLinear GHC.unsafeCoerce# arr'- | Prelude.otherwise =- get i arr'- `chain2` \(# Ur a, arr'' #) -> set i (Unsafe.coerce (f a)) arr''- `chain` \arr''' -> go (i Prelude.+ 1) s arr'''+map :: (a -> b) -> Array# a %1 -> Array# b+map (f :: a -> b) =+ Unsafe.toLinear+ ( \(Array# as) ->+ let -- We alias the input array to write the resulting -- 'b's to,+ -- just to make the typechecker happy. Care must be taken to+ -- only read indices from 'as' that is not yet written to 'bs'.+ bs :: GHC.MutableArray# GHC.RealWorld b+ bs = GHC.unsafeCoerce# as+ len :: GHC.Int#+ len = GHC.sizeofMutableArray# as++ -- For each index ([0..len]), we read the element on 'as', pass+ -- it through 'f' and write to the same location on 'bs'.+ go :: GHC.Int# -> GHC.State# GHC.RealWorld -> ()+ go i st+ | GHC.I# i Prelude.== GHC.I# len = ()+ | Prelude.otherwise =+ case GHC.readArray# as i st of+ (# st', a #) ->+ case GHC.writeArray# bs i (f a) st' of+ !st'' -> go (i GHC.+# 1#) st''+ in GHC.runRW# (go 0#) `GHC.seq` Array# bs+ ) {-# NOINLINE map #-} -- | Return the array elements as a lazy list.-toList :: Array# a %1-> Ur [a]+toList :: Array# a %1 -> Ur [a] toList = unArray# Prelude.$ \arr -> go 0 (GHC.I# (GHC.sizeofMutableArray# arr)) arr- where- go i len arr- | i Prelude.== len = []- | GHC.I# i# <- i =- case GHC.runRW# (GHC.readArray# arr i#) of- (# _, ret #) -> ret : go (i Prelude.+ 1) len arr+ where+ go i len arr+ | i Prelude.== len = []+ | GHC.I# i# <- i =+ case GHC.runRW# (GHC.readArray# arr i#) of+ (# _, ret #) -> ret : go (i Prelude.+ 1) len arr -- | /O(1)/ Convert an 'Array#' to an immutable 'GHC.Array#'.-freeze :: (GHC.Array# a -> b) -> Array# a %1-> Ur b+freeze :: (GHC.Array# a -> b) -> Array# a %1 -> Ur b freeze f = unArray# go- where- go mut =- case GHC.runRW# (GHC.unsafeFreezeArray# mut) of- (# _, ret #) -> f ret+ where+ go mut =+ case GHC.runRW# (GHC.unsafeFreezeArray# mut) of+ (# _, ret #) -> f ret -- | Clone an array.-dup2 :: Array# a %1-> (# Array# a, Array# a #)+dup2 :: Array# a %1 -> (# Array# a, Array# a #) dup2 = Unsafe.toLinear go- where- go :: Array# a -> (# Array# a, Array# a #)- go (Array# arr) =- case GHC.runRW#- (GHC.cloneMutableArray# arr 0# (GHC.sizeofMutableArray# arr)) of- (# _, new #) -> (# Array# arr, Array# new #)+ where+ go :: Array# a -> (# Array# a, Array# a #)+ go (Array# arr) =+ case GHC.runRW#+ (GHC.cloneMutableArray# arr 0# (GHC.sizeofMutableArray# arr)) of+ (# _, new #) -> (# Array# arr, Array# new #) {-# NOINLINE dup2 #-}---- * Internal library---- Below two are variants of (&) specialized for taking commonly used--- unlifted values and returning a levity-polymorphic result.------ They are not polymorphic on their first parameter since levity-polymorphism--- disallows binding to levity-polymorphic values.--chain :: forall (r :: GHC.RuntimeRep) a (b :: GHC.TYPE r).- Array# a %1-> (Array# a %1-> b) %1-> b-chain a f = f a--chain2 :: forall (r :: GHC.RuntimeRep) a b (c :: GHC.TYPE r).- (# b, Array# a #) %1-> ((# b, Array# a #) %1-> c) %1-> c-chain2 a f = f a-infixl 1 `chain`, `chain2`
src/Data/Array/Polarized.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | This module documents polarized arrays and top-level conversions --@@ -81,7 +81,7 @@ -- since the @b@ is completely abstract due to the rank2 type -- (read about -XRankNTypes for more) this computation must fill the array -- by wrapping writes of values of type @a@ with the given linear conversion--- function of type @a %1-> b@. This prevents the computation from being +-- function of type @a %1-> b@. This prevents the computation from being -- evaluated until we are sure we want to allocate. -- -- == Background for the interested@@ -92,19 +92,18 @@ -- * http://www.cse.chalmers.se/~josefs/talks/LinArrays.pdf -- * http://jyp.github.io/posts/controlled-fusion.html -- * https://www.sciencedirect.com/science/article/pii/030439759090147A--- module Data.Array.Polarized- ( transfer- , walk+ ( transfer,+ walk, )- where+where -import qualified Data.Array.Polarized.Pull.Internal as Pull import qualified Data.Array.Polarized.Pull as Pull+import qualified Data.Array.Polarized.Pull.Internal as Pull import qualified Data.Array.Polarized.Push as Push import qualified Data.Foldable as NonLinear-import Prelude.Linear import Data.Vector (Vector)+import Prelude.Linear -- DEVELOPER NOTE: --@@ -128,11 +127,20 @@ -- | Convert a pull array into a push array. -- NOTE: this does NOT require allocation and can be in-lined.-transfer :: Pull.Array a %1-> Push.Array a+transfer :: Pull.Array a %1 -> Push.Array a transfer (Pull.Array f n) =- Push.Array (\k -> NonLinear.foldMap' (\x -> k (f x)) [0..(n-1)])+ -- 'transfer' was+ -- > transfer (Pull.Array f n) =+ -- > Push.Array (\k -> NonLinear.foldMap' (\x -> k (f x)) [0 .. (n - 1)])+ -- but 'Linear.Monoid' no longer implies 'NonLinear.Monoid'. So we can have+ -- @mempty :: a@ and @(<>) :: a -> a -> a@ (by degrading 'Linear.<>'), but we+ -- no longer have the 'NonLinear.Monoid' instance required to use+ -- 'NonLinear.foldMap\''. As a result, we just expand 'foldMap\'' to its+ -- definition in terms of 'foldl\'', which doesn't require 'NonLinear.Monoid':+ -- > foldMap' f' = foldl' (\acc a -> acc <> f' a) mempty+ Push.Array (\k -> NonLinear.foldl' (\acc a -> acc <> k (f a)) mempty [0 .. (n - 1)]) -- | This is a shortcut convenience function -- for @transfer . Pull.fromVector@.-walk :: Vector a %1-> Push.Array a+walk :: Vector a %1 -> Push.Array a walk = transfer . Pull.fromVector
src/Data/Array/Polarized/Pull.hs view
@@ -5,29 +5,31 @@ -- -- These are part of a larger framework for controlling when memory is -- allocated for an array. See @Data.Array.Polarized@.--- module Data.Array.Polarized.Pull- ( Array+ ( Array,+ -- * Construction- , fromFunction- , fromVector- , make- , singleton+ fromFunction,+ fromVector,+ make,+ singleton,+ -- * Consumption- , toVector- , asList+ toVector,+ asList,+ -- * Operations- , zip- , zipWith- , append- , foldr- , foldMap- , findLength- , split- , reverse- , index+ zip,+ zipWith,+ append,+ foldr,+ foldMap,+ findLength,+ split,+ reverse,+ index, )- where+where import Data.Array.Polarized.Pull.Internal -- XXX: the data constructor Pull.Array could be used unsafely, so we don't@@ -41,26 +43,27 @@ -- In particular, PullArrays are incredibly unfriendly in returned-value -- position at the moment, moreso than they should be import qualified Data.Functor.Linear as Data-import Prelude.Linear hiding (zip, zipWith, foldr, foldMap, reverse) import Data.Vector (Vector) import qualified Data.Vector as Vector+import Prelude.Linear hiding (foldMap, foldr, reverse, zip, zipWith) import qualified Unsafe.Linear as Unsafe -- | Convert a pull array into a list.-asList :: Array a %1-> [a]-asList = foldr (\x xs -> x:xs) []+asList :: Array a %1 -> [a]+asList = foldr (\x xs -> x : xs) [] -- | @zipWith f [x1,x2,...,xn] [y1,y2,...,yn] = [f x1 y1, ..., f xn yn]@ -- __Partial:__ `zipWith f [x1,x2,...,xn] [y1,y2,...,yp]` is an error -- if @n ≠ p@.-zipWith :: (a %1-> b %1-> c) -> Array a %1-> Array b %1-> Array c+zipWith :: (a %1 -> b %1 -> c) -> Array a %1 -> Array b %1 -> Array c zipWith f x y = Data.fmap (uncurry f) (zip x y) -- | Fold a pull array using a monoid.-foldMap :: Monoid m => (a %1-> m) -> Array a %1-> m+foldMap :: Monoid m => (a %1 -> m) -> Array a %1 -> m foldMap f = foldr ((<>) . f) mempty -- I'm fairly sure this can be used safely+ -- | Convert a Vector to a pull array.-fromVector :: Vector a %1-> Array a+fromVector :: Vector a %1 -> Array a fromVector = Unsafe.toLinear $ \v -> fromFunction (v Vector.!) (Vector.length v)
src/Data/Array/Polarized/Pull/Internal.hs view
@@ -1,20 +1,19 @@-{-# OPTIONS_HADDOCK hide #-}-{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}+{-# OPTIONS_HADDOCK hide #-} module Data.Array.Polarized.Pull.Internal where import qualified Data.Functor.Linear as Data-import Prelude.Linear-import qualified Prelude import Data.Vector (Vector) import qualified Data.Vector as Vector-+import Prelude.Linear import qualified Unsafe.Linear as Unsafe+import qualified Prelude -- | A pull array is an array from which it is easy to extract elements, and -- this can be done in any order. The linear consumption of a pull array means@@ -22,12 +21,13 @@ -- freely. data Array a where Array :: (Int -> a) -> Int -> Array a- deriving Prelude.Semigroup via NonLinear (Array a)- -- In the linear consumption of a pull array f n, (f i) should be consumed- -- linearly for every 0 <= i < n. The exported functions (from non-internal- -- modules) should enforce this invariant, but the current type of PullArray- -- does not.+ deriving (Prelude.Semigroup) via NonLinear (Array a) +-- In the linear consumption of a pull array f n, (f i) should be consumed+-- linearly for every 0 <= i < n. The exported functions (from non-internal+-- modules) should enforce this invariant, but the current type of PullArray+-- does not.+ instance Data.Functor Array where fmap f (Array g n) = fromFunction (\x -> f (g x)) n @@ -37,24 +37,25 @@ -- is interesting in and of itself: I think this is like an n-ary With), and -- changing the other arrows makes no difference) - -- | Produce a pull array of lenght 1 consisting of solely the given element.-singleton :: a %1-> Array a+singleton :: a %1 -> Array a singleton = Unsafe.toLinear (\x -> fromFunction (\_ -> x) 1) -- | @zip [x1, ..., xn] [y1, ..., yn] = [(x1,y1), ..., (xn,yn)]@ -- __Partial:__ `zip [x1,x2,...,xn] [y1,y2,...,yp]` is an error if @n ≠ p@.-zip :: Array a %1-> Array b %1-> Array (a,b)+zip :: Array a %1 -> Array b %1 -> Array (a, b) zip (Array g n) (Array h m)- | n /= m = error "Polarized.zip: size mismatch"+ | n /= m = error "Polarized.zip: size mismatch" | otherwise = fromFunction (\k -> (g k, h k)) n -- | Concatenate two pull arrays.-append :: Array a %1-> Array a %1-> Array a+append :: Array a %1 -> Array a %1 -> Array a append (Array f m) (Array g n) = Array h (m + n)- where h k = if k < m- then f k- else g (k-m)+ where+ h k =+ if k < m+ then f k+ else g (k - m) -- | Creates a pull array of given size, filled with the given element. make :: a -> Int -> Array a@@ -64,15 +65,17 @@ (<>) = append -- | A right-fold of a pull array.-foldr :: (a %1-> b %1-> b) -> b %1-> Array a %1-> b+foldr :: (a %1 -> b %1 -> b) -> b %1 -> Array a %1 -> b foldr f z (Array g n) = go f z g n- where go :: (_ %1-> _ %1-> _) -> _ %1-> _ -> _ -> _- go _ z' _ 0 = z'- go f' z' g' k = go f' (f' (g' (k-1)) z') g' (k-1)- -- go is strict in its last argument+ where+ go :: (_ %1 -> _ %1 -> _) -> _ %1 -> _ -> _ -> _+ go _ z' _ 0 = z'+ go f' z' g' k = go f' (f' (g' (k - 1)) z') g' (k - 1) +-- go is strict in its last argument+ -- | Extract the length of an array, and give back the original array.-findLength :: Array a %1-> (Int, Array a)+findLength :: Array a %1 -> (Int, Array a) findLength (Array f n) = (n, Array f n) -- | @'fromFunction' arrIndexer len@ constructs a pull array given a function@@ -80,31 +83,33 @@ -- length @len@. fromFunction :: (Int -> a) -> Int -> Array a fromFunction f n = Array f' n- where f' k- | k < 0 = error "Pull.Array: negative index"- | k >= n = error "Pull.Array: index too large"- | otherwise = f k+ where+ f' k+ | k < 0 = error "Pull.Array: negative index"+ | k >= n = error "Pull.Array: index too large"+ | otherwise = f k -- XXX: this is used internally to ensure out of bounds errors occur, but -- is unnecessary if the input function can be assumed to already have bounded -- domain, for instance in `append`. -- | This is a convenience function for @alloc . transfer@-toVector :: Array a %1-> Vector a+toVector :: Array a %1 -> Vector a toVector (Array f n) = Vector.generate n f+ -- TODO: A test to make sure alloc . transfer == toVector -- | @'split' n v = (vl, vr)@ such that @vl@ has length @n@. -- -- 'split' is total: if @n@ is larger than the length of @v@, -- then @vr@ is empty.-split :: Int -> Array a %1-> (Array a, Array a)-split k (Array f n) = (fromFunction f (min k n), fromFunction (\x -> f (x+k)) (max (n-k) 0))+split :: Int -> Array a %1 -> (Array a, Array a)+split k (Array f n) = (fromFunction f (min k n), fromFunction (\x -> f (x + k)) (max (n - k) 0)) -- | Reverse a pull array.-reverse :: Array a %1-> Array a-reverse (Array f n) = Array (\x -> f (n+1-x)) n+reverse :: Array a %1 -> Array a+reverse (Array f n) = Array (\x -> f (n + 1 - x)) n -- | Index a pull array (without checking bounds)-index :: Array a %1-> Int -> (a, Array a)+index :: Array a %1 -> Int -> (a, Array a) index (Array f n) ix = (f ix, Array f n)
src/Data/Array/Polarized/Push.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | This module provides push arrays. --@@ -11,28 +11,27 @@ -- -- This module is designed to be imported qualified as @Push@. module Data.Array.Polarized.Push- (- -- * Construction- Array(..)- , make- , singleton- , cons- , snoc- -- * Operations- , alloc- , foldMap- , unzip+ ( -- * Construction+ Array (..),+ make,+ singleton,+ cons,+ snoc,++ -- * Operations+ alloc,+ foldMap,+ unzip, ) where -import qualified Data.Functor.Linear as Data-import qualified Data.Array.Destination as DArray import Data.Array.Destination (DArray)+import qualified Data.Array.Destination as DArray+import qualified Data.Functor.Linear as Data import Data.Vector (Vector)-import qualified Prelude-import Prelude.Linear hiding (unzip, foldMap) import GHC.Stack-+import Prelude.Linear hiding (foldMap, unzip)+import qualified Prelude -- The Types -------------------------------------------------------------------------------@@ -40,32 +39,42 @@ -- | Push arrays are un-allocated finished arrays. These are finished -- computations passed along or enlarged until we are ready to allocate. data Array a where- Array :: (forall m. Monoid m => (a -> m) -> m) %1-> Array a- -- Developer notes:- --- -- Think of @(a -> m)@ as something that writes an @a@ and think of- -- @((a -> m) -> m)@ as something that takes a way to write a single element- -- and writes and concatenates all elements.- --- -- Also, note that in this formulation we don't know the length beforehand.+ Array :: (forall m. Monoid m => (a -> m) -> m) %1 -> Array a +-- Developer notes:+--+-- Think of @(a -> m)@ as something that writes an @a@ and think of+-- @((a -> m) -> m)@ as something that takes a way to write a single element+-- and writes and concatenates all elements. The @m@ is something that+-- represents a writing of some elements to an array, a delayed write.+--+-- Also, note that in this formulation we don't know the length beforehand.+ data ArrayWriter a where- ArrayWriter :: (DArray a %1-> ()) %1-> !Int -> ArrayWriter a- -- The second parameter is the length of the @DArray@+ ArrayWriter :: (DArray a %1 -> ()) %1 -> !Int -> ArrayWriter a +-- The second parameter is the length of the @DArray@+--+-- Developer notes:+--+-- This is the linear monoid @m@ that we instantiate the above array with+-- in order to allocate. An @ArrayWriter a@ is something that holds the+-- ingredients to write some number of elements to an array, without+-- holding the space to do so. -- API ------------------------------------------------------------------------------- -- | Convert a push array into a vector by allocating. This would be a common -- end to a computation using push and pull arrays.-alloc :: Array a %1-> Vector a-alloc (Array k) = allocArrayWriter $ k singletonWriter where- singletonWriter :: a -> ArrayWriter a- singletonWriter a = ArrayWriter (DArray.fill a) 1+alloc :: Array a %1 -> Vector a+alloc (Array k) = allocArrayWriter $ k singletonWriter+ where+ singletonWriter :: a -> ArrayWriter a+ singletonWriter a = ArrayWriter (DArray.fill a) 1 - allocArrayWriter :: ArrayWriter a %1-> Vector a- allocArrayWriter (ArrayWriter writer len) = DArray.alloc len writer+ allocArrayWriter :: ArrayWriter a %1 -> Vector a+ allocArrayWriter (ArrayWriter writer len) = DArray.alloc len writer -- | @`make` x n@ creates a constant push array of length @n@ in which every -- element is @x@.@@ -77,18 +86,17 @@ singleton :: a -> Array a singleton x = Array (\writeA -> writeA x) -snoc :: a -> Array a %1-> Array a+snoc :: a -> Array a %1 -> Array a snoc x (Array k) = Array (\writeA -> (k writeA) <> (writeA x)) -cons :: a -> Array a %1-> Array a+cons :: a -> Array a %1 -> Array a cons x (Array k) = Array (\writeA -> (writeA x) <> (k writeA)) -foldMap :: Monoid b => (a -> b) -> Array a %1-> b+foldMap :: Monoid b => (a -> b) -> Array a %1 -> b foldMap f (Array k) = k f -unzip :: Array (a,b) %1-> (Array a, Array b)-unzip (Array k) = k (\(a,b) -> (singleton a, singleton b))-+unzip :: Array (a, b) %1 -> (Array a, Array b)+unzip (Array k) = k (\(a, b) -> (singleton a, singleton b)) -- # Instances -------------------------------------------------------------------------------@@ -111,7 +119,7 @@ empty :: Array a empty = Array (\_ -> mempty) -append :: Array a %1-> Array a %1-> Array a+append :: Array a %1 -> Array a %1 -> Array a append (Array k1) (Array k2) = Array (\writeA -> k1 writeA <> k2 writeA) instance Prelude.Semigroup (ArrayWriter a) where@@ -126,14 +134,15 @@ instance Monoid (ArrayWriter a) where mempty = emptyWriter -addWriters :: ArrayWriter a %1-> ArrayWriter a %1-> ArrayWriter a+addWriters :: ArrayWriter a %1 -> ArrayWriter a %1 -> ArrayWriter a addWriters (ArrayWriter k1 l1) (ArrayWriter k2 l2) = ArrayWriter- (\darr ->- (DArray.split l1 darr) & \(darr1,darr2) -> consume (k1 darr1, k2 darr2))- (l1+l2)+ ( \darr ->+ (DArray.split l1 darr) & \(darr1, darr2) -> consume (k1 darr1, k2 darr2)+ )+ (l1 + l2) emptyWriter :: ArrayWriter a emptyWriter = ArrayWriter DArray.dropEmpty 0--- Remark. @emptyWriter@ assumes we can split a destination array at 0. +-- Remark. @emptyWriter@ assumes we can split a destination array at 0.
src/Data/Bifunctor/Linear.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | This module provides Bifunctor and related classes. --@@ -21,11 +21,10 @@ -- > negateRight :: (Int, Bool) %1-> (Int, Bool) -- > negateRight x = second not x module Data.Bifunctor.Linear- ( Bifunctor(..),- SymmetricMonoidal(..),+ ( Bifunctor (..),+ SymmetricMonoidal (..), )- where+where import Data.Bifunctor.Linear.Internal.Bifunctor import Data.Bifunctor.Linear.Internal.SymmetricMonoidal-
src/Data/Bifunctor/Linear/Internal/Bifunctor.hs view
@@ -1,14 +1,15 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} module Data.Bifunctor.Linear.Internal.Bifunctor- ( Bifunctor(..)- ) where+ ( Bifunctor (..),+ )+where import Prelude.Linear - -- | The Bifunctor class -- -- == Laws@@ -25,28 +26,26 @@ -- * If all are supplied, then -- @'bimap' f g = 'first' f '.' 'second' g class Bifunctor p where- {-# MINIMAL bimap | (first , second) #-}- bimap :: (a %1-> b) -> (c %1-> d) -> a `p` c %1-> b `p` d+ {-# MINIMAL bimap | (first, second) #-}+ bimap :: (a %1 -> b) -> (c %1 -> d) -> a `p` c %1 -> b `p` d bimap f g x = first f (second g x) {-# INLINE bimap #-} - first :: (a %1-> b) -> a `p` c %1-> b `p` c+ first :: (a %1 -> b) -> a `p` c %1 -> b `p` c first f = bimap f id {-# INLINE first #-} - second :: (b %1-> c) -> a `p` b %1-> a `p` c+ second :: (b %1 -> c) -> a `p` b %1 -> a `p` c second = bimap id {-# INLINE second #-} - -- # Instances ------------------------------------------------------------------------------- instance Bifunctor (,) where- bimap f g (x,y) = (f x, g y)- first f (x,y) = (f x, y)- second g (x,y) = (x, g y)+ bimap f g (x, y) = (f x, g y)+ first f (x, y) = (f x, y)+ second g (x, y) = (x, g y) instance Bifunctor Either where bimap f g = either (Left . f) (Right . g)-
src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs view
@@ -1,18 +1,19 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} module Data.Bifunctor.Linear.Internal.SymmetricMonoidal- ( SymmetricMonoidal(..)- ) where+ ( SymmetricMonoidal (..),+ )+where import Data.Bifunctor.Linear.Internal.Bifunctor-import Prelude.Linear import Data.Kind (Type) import Data.Void-+import Prelude.Linear -- | A SymmetricMonoidal class --@@ -29,30 +30,34 @@ -- * @rassoc . lassoc = id@ -- * @lassoc . rassoc = id@ -- * @second swap . rassoc . first swap = rassoc . swap . rassoc@-class Bifunctor m => SymmetricMonoidal (m :: Type -> Type -> Type) (u :: Type)- | m -> u, u -> m where+class+ Bifunctor m =>+ SymmetricMonoidal (m :: Type -> Type -> Type) (u :: Type)+ | m -> u,+ u -> m+ where {-# MINIMAL swap, (rassoc | lassoc) #-}- rassoc :: (a `m` b) `m` c %1-> a `m` (b `m` c)+ rassoc :: (a `m` b) `m` c %1 -> a `m` (b `m` c) rassoc = swap . lassoc . swap . lassoc . swap- lassoc :: a `m` (b `m` c) %1-> (a `m` b) `m` c+ lassoc :: a `m` (b `m` c) %1 -> (a `m` b) `m` c lassoc = swap . rassoc . swap . rassoc . swap- swap :: a `m` b %1-> b `m` a+ swap :: a `m` b %1 -> b `m` a+ -- XXX: should unitors be added? -- XXX: Laws don't seem minimial - -- # Instances ------------------------------------------------------------------------------- instance SymmetricMonoidal (,) () where swap (x, y) = (y, x)- rassoc ((x,y),z) = (x,(y,z))+ rassoc ((x, y), z) = (x, (y, z)) instance SymmetricMonoidal Either Void where swap = either Right Left rassoc (Left (Left x)) = Left x- rassoc (Left (Right x)) = (Right :: a %1-> Either b a) (Left x)- rassoc (Right x) = (Right :: a %1-> Either b a) (Right x)+ rassoc (Left (Right x)) = (Right :: a %1 -> Either b a) (Left x)+ rassoc (Right x) = (Right :: a %1 -> Either b a) (Right x)+ -- XXX: the above type signatures are necessary for certain older versions of -- the compiler, and as such are temporary-
src/Data/Bool/Linear.hs view
@@ -4,37 +4,38 @@ -- | This module provides linear functions on the standard 'Bool' type. module Data.Bool.Linear ( -- * The Boolean type- Bool(..)+ Bool (..),+ -- * Operators- , (&&)- , (||)- , not- , otherwise+ (&&),+ (||),+ not,+ otherwise, )- where+where -import Prelude (Bool(..), otherwise)+import Prelude (Bool (..), otherwise) -- | @True@ iff both are @True@. -- __NOTE:__ this is strict and not lazy!-(&&) :: Bool %1-> Bool %1-> Bool+(&&) :: Bool %1 -> Bool %1 -> Bool False && False = False False && True = False True && x = x -infixr 3 &&+infixr 3 && -- same as base.&& -- | @True@ iff either is @True@ -- __NOTE:__ this is strict and not lazy!-(||) :: Bool %1-> Bool %1-> Bool+(||) :: Bool %1 -> Bool %1 -> Bool True || False = True True || True = True False || x = x -infixr 2 ||+infixr 2 || -- same as base.|| -- | @not b@ is @True@ iff b is @False@ -- __NOTE:__ this is strict and not lazy!-not :: Bool %1-> Bool+not :: Bool %1 -> Bool not False = True not True = False
src/Data/Either/Linear.hs view
@@ -4,64 +4,59 @@ -- | This module contains useful functions for working with 'Either's. module Data.Either.Linear- ( Either (..)- , either- , lefts- , rights- , fromLeft- , fromRight- , partitionEithers+ ( Either (..),+ either,+ lefts,+ rights,+ fromLeft,+ fromRight,+ partitionEithers, )- where+where import Data.Unrestricted.Linear-import Prelude (Either(..))-+import Prelude (Either (..)) -- XXX Design Notes -- Functions like isLeft do not make sense in a linear program. -------------------------------------------------------------------------------- - -- | Linearly consume an @Either@ by applying the first linear function on a -- value constructed with @Left@ and the second linear function on a value -- constructed with @Right@.-either :: (a %1-> c) -> (b %1-> c) -> Either a b %1-> c+either :: (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c either f _ (Left x) = f x either _ g (Right y) = g y - -- | Get all the left elements in order, and consume the right ones.-lefts :: Consumable b => [Either a b] %1-> [a]+lefts :: Consumable b => [Either a b] %1 -> [a] lefts [] = [] lefts (Left a : xs) = a : lefts xs lefts (Right b : xs) = lseq b (lefts xs) - -- | Get all the right elements in order, and consume the left ones.-rights :: Consumable a => [Either a b] %1-> [b]+rights :: Consumable a => [Either a b] %1 -> [b] rights [] = [] rights (Left a : xs) = lseq a (rights xs) rights (Right b : xs) = b : rights xs - -- | Get the left element of a consumable @Either@ with a default-fromLeft :: (Consumable a, Consumable b) => a %1-> Either a b %1-> a+fromLeft :: (Consumable a, Consumable b) => a %1 -> Either a b %1 -> a fromLeft x (Left a) = lseq x a fromLeft x (Right b) = lseq b x -- | Get the right element of a consumable @Either@ with a default-fromRight :: (Consumable a, Consumable b) => b %1-> Either a b %1-> b+fromRight :: (Consumable a, Consumable b) => b %1 -> Either a b %1 -> b fromRight x (Left a) = lseq a x fromRight x (Right b) = lseq x b -- | Partition and consume a list of @Either@s into two lists with all the -- lefts in one and the rights in the second, in the order they appeared in the -- initial list.-partitionEithers :: [Either a b] %1-> ([a], [b])+partitionEithers :: [Either a b] %1 -> ([a], [b]) partitionEithers [] = ([], [])-partitionEithers (x:xs) = fromRecur x (partitionEithers xs)+partitionEithers (x : xs) = fromRecur x (partitionEithers xs) where- fromRecur :: Either a b %1-> ([a], [b]) %1-> ([a], [b])- fromRecur (Left a) (as, bs) = (a:as, bs)- fromRecur (Right b) (as, bs) = (as, b:bs)+ fromRecur :: Either a b %1 -> ([a], [b]) %1 -> ([a], [b])+ fromRecur (Left a) (as, bs) = (a : as, bs)+ fromRecur (Right b) (as, bs) = (as, b : bs)
src/Data/Functor/Linear.hs view
@@ -13,25 +13,34 @@ -- * Linear data functors should be thought of as containers of data. -- * Linear data applicative functors should be thought of as containers -- that can be zipped.--- * Linear data traversible functors should be thought of as+-- * Linear data traversable functors should be thought of as -- containers which store a finite number of values. --+-- This module also defines 'genericTraverse' for types implementing+-- 'Generics.Linear.Generic1'. module Data.Functor.Linear ( -- * Data Functor Hierarchy- Functor(..)- , (<$>)- , (<$)- , void- , Applicative(..)- , Const(..)- -- * Linear traversable hierarchy- , Traversable(..)- , mapM, sequenceA, for, forM- , mapAccumL, mapAccumR+ Functor (..),+ (<$>),+ (<$),+ void,+ Applicative (..),+ Const (..),++ -- * Linear traversable hierarchy+ Traversable (..),+ genericTraverse,+ GTraversable,+ mapM,+ sequenceA,+ for,+ forM,+ mapAccumL,+ mapAccumR, )- where+where -import Data.Functor.Linear.Internal.Functor+import Data.Functor.Const import Data.Functor.Linear.Internal.Applicative+import Data.Functor.Linear.Internal.Functor import Data.Functor.Linear.Internal.Traversable-import Data.Functor.Const
src/Data/Functor/Linear/Internal/Applicative.hs view
@@ -1,19 +1,42 @@-{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_HADDOCK hide #-} module Data.Functor.Linear.Internal.Applicative- (- Applicative(..)- ) where+ ( Applicative (..),+ genericPure,+ genericLiftA2,+ )+where -import Data.Functor.Linear.Internal.Functor-import Prelude.Linear.Internal import qualified Control.Monad.Trans.Reader as NonLinear-import Data.Monoid.Linear hiding (Sum) import Data.Functor.Compose import Data.Functor.Const import Data.Functor.Identity+import Data.Functor.Linear.Internal.Functor+import Data.Functor.Product+import Data.Monoid (Ap (..))+import Data.Monoid.Linear hiding (Product)+import Data.Unrestricted.Linear.Internal.Ur (Ur (..))+import GHC.TypeLits+import Generics.Linear+import Prelude.Linear.Generically+import Prelude.Linear.Internal+import Prelude.Linear.Unsatisfiable+import qualified Prelude -- # Applicative definition -------------------------------------------------------------------------------@@ -48,32 +71,170 @@ class Functor f => Applicative f where {-# MINIMAL pure, (liftA2 | (<*>)) #-} pure :: a -> f a- (<*>) :: f (a %1-> b) %1-> f a %1-> f b+ (<*>) :: f (a %1 -> b) %1 -> f a %1 -> f b+ infixl 4 <*> -- same fixity as base.<*> f <*> x = liftA2 ($) f x- liftA2 :: (a %1-> b %1-> c) -> f a %1-> f b %1-> f c+ liftA2 :: (a %1 -> b %1 -> c) -> f a %1 -> f b %1 -> f c liftA2 f x y = f <$> x <*> y -- # Instances ------------------------------------------------------------------------------- -instance Monoid x => Applicative (Const x) where- pure _ = Const mempty- Const x <*> Const y = Const (x <> y)+deriving via+ Generically1 (Const x)+ instance+ Monoid x => Applicative (Const x) -instance Monoid a => Applicative ((,) a) where- pure x = (mempty, x)- (u,f) <*> (v,x) = (u <> v, f x)+deriving via+ Generically1 Ur+ instance+ Applicative Ur -instance Applicative Identity where- pure = Identity- Identity f <*> Identity x = Identity (f x)+deriving via+ Generically1 ((,) a)+ instance+ Monoid a => Applicative ((,) a) +deriving via+ Generically1 (Product f g)+ instance+ (Applicative f, Applicative g) => Applicative (Product f g)++deriving via+ Generically1 (f :*: g)+ instance+ (Applicative f, Applicative g) => Applicative (f :*: g)++deriving via+ Generically1 ((,,) a b)+ instance+ (Monoid a, Monoid b) => Applicative ((,,) a b)++deriving via+ Generically1 ((,,,) a b c)+ instance+ (Monoid a, Monoid b, Monoid c) => Applicative ((,,,) a b c)++deriving via+ Generically1 Identity+ instance+ Applicative Identity+ instance (Applicative f, Applicative g) => Applicative (Compose f g) where- pure x = Compose (pure (pure x))- (Compose f) <*> (Compose x) = Compose (liftA2 (<*>) f x)- liftA2 f (Compose x) (Compose y) = Compose (liftA2 (liftA2 f) x y)+ pure x = Compose (pure (pure x))+ (Compose f) <*> (Compose x) = Compose (liftA2 (<*>) f x)+ liftA2 f (Compose x) (Compose y) = Compose (liftA2 (liftA2 f) x y) instance Applicative m => Applicative (NonLinear.ReaderT r m) where pure x = NonLinear.ReaderT (\_ -> pure x) NonLinear.ReaderT f <*> NonLinear.ReaderT x = NonLinear.ReaderT (\r -> f r <*> x r) +instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where+ (Ap x) <> (Ap y) = Ap $ liftA2 (<>) x y++instance (Applicative f, Monoid a) => Monoid (Ap f a) where+ mempty = Ap $ pure mempty++-- ----------------+-- Generic deriving+-- ----------------++instance+ (Generic1 f, Functor (Rep1 f), GApplicative ('ShowType f) (Rep1 f)) =>+ Applicative (Generically1 f)+ where+ pure = Generically1 Prelude.. genericPure+ liftA2 f (Generically1 x) (Generically1 y) = Generically1 (genericLiftA2 f x y)++genericPure ::+ forall f a.+ (Generic1 f, GApplicative ('ShowType f) (Rep1 f)) =>+ a ->+ f a+genericPure = to1 Prelude.. gpure @('ShowType f)++genericLiftA2 ::+ forall f a b c.+ (Generic1 f, GApplicative ('ShowType f) (Rep1 f)) =>+ (a %1 -> b %1 -> c) ->+ f a %1 ->+ f b %1 ->+ f c+genericLiftA2 f x y = to1 (gliftA2 @('ShowType f) f (from1 x) (from1 y))++class GApplicative (s :: ErrorMessage) f where+ gpure :: a -> f a+ gliftA2 :: (a %1 -> b %1 -> c) -> f a %1 -> f b %1 -> f c++instance+ Unsatisfiable+ ( 'Text "Cannot derive a data Applicative instance for" ':$$: s+ ':$$: 'Text "because empty types cannot implement pure."+ ) =>+ GApplicative s V1+ where+ gpure = unsatisfiable+ gliftA2 = unsatisfiable++instance GApplicative s U1 where+ gpure _ = U1+ gliftA2 _ U1 U1 = U1+ {-# INLINE gpure #-}+ {-# INLINE gliftA2 #-}++instance GApplicative s f => GApplicative s (M1 i c f) where+ gpure = M1 Prelude.. gpure @s+ gliftA2 f (M1 x) (M1 y) = M1 (gliftA2 @s f x y)+ {-# INLINE gpure #-}+ {-# INLINE gliftA2 #-}++instance GApplicative s Par1 where+ gpure = Par1+ gliftA2 f (Par1 x) (Par1 y) = Par1 (f x y)+ {-# INLINE gpure #-}+ {-# INLINE gliftA2 #-}++instance (GApplicative s f, Applicative g) => GApplicative s (f :.: g) where+ gpure = Comp1 Prelude.. gpure @s Prelude.. pure+ gliftA2 f (Comp1 x) (Comp1 y) = Comp1 (gliftA2 @s (liftA2 f) x y)+ {-# INLINE gpure #-}+ {-# INLINE gliftA2 #-}++instance (GApplicative s f, GApplicative s g) => GApplicative s (f :*: g) where+ gpure a = gpure @s a :*: gpure @s a+ gliftA2 f (a1 :*: a2) (b1 :*: b2) = gliftA2 @s f a1 b1 :*: gliftA2 @s f a2 b2+ {-# INLINE gpure #-}+ {-# INLINE gliftA2 #-}++instance+ Unsatisfiable+ ( 'Text "Cannot derive a data Applicative instance for" ':$$: s+ ':$$: 'Text "because sum types do not admit a uniform Applicative definition."+ ) =>+ GApplicative s (x :+: y)+ where+ gpure = unsatisfiable+ gliftA2 = unsatisfiable++instance GApplicative s f => GApplicative s (MP1 m f) where+ gpure a = MP1 (gpure @s a)+ gliftA2 f (MP1 a) (MP1 b) = MP1 (gliftA2 @s f a b)+ {-# INLINE gpure #-}+ {-# INLINE gliftA2 #-}++instance Monoid c => GApplicative s (K1 i c) where+ gpure _ = K1 mempty+ gliftA2 _ (K1 x) (K1 y) = K1 (x <> y)+ {-# INLINE gpure #-}+ {-# INLINE gliftA2 #-}++instance+ Unsatisfiable+ ( 'Text "Cannot derive a data Applicative instance for" ':$$: s+ ':$$: 'Text "because it contains one or more primitive unboxed fields."+ ':$$: 'Text "Such unboxed types lack canonical monoid operations."+ ) =>+ GApplicative s (URec a)+ where+ gpure = unsatisfiable+ gliftA2 = unsatisfiable
src/Data/Functor/Linear/Internal/Functor.hs view
@@ -1,26 +1,41 @@-{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LinearTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+ module Data.Functor.Linear.Internal.Functor- (- Functor(..)- , (<$>)- , (<$)- , void- ) where+ ( Functor (..),+ (<$>),+ (<$),+ void,+ )+where -import Prelude.Linear.Internal-import Prelude (Maybe(..), Either(..))-import Data.Functor.Const-import Data.Functor.Sum-import Data.Functor.Compose-import Data.Functor.Identity-import qualified Control.Monad.Trans.Reader as NonLinear import qualified Control.Monad.Trans.Cont as NonLinear-import qualified Control.Monad.Trans.Maybe as NonLinear import qualified Control.Monad.Trans.Except as NonLinear+import qualified Control.Monad.Trans.Maybe as NonLinear+import qualified Control.Monad.Trans.Reader as NonLinear import qualified Control.Monad.Trans.State.Strict as Strict-import Data.Unrestricted.Internal.Consumable+import Data.Functor.Compose+import Data.Functor.Const+import Data.Functor.Identity+import Data.Functor.Product+import Data.Functor.Sum+import Data.Unrestricted.Linear.Internal.Consumable+import Data.Unrestricted.Linear.Internal.Ur+import Generics.Linear+import Prelude.Linear.Generically+import Prelude.Linear.Internal+import Prelude (Either (..), Maybe (..)) -- # Functor definition -------------------------------------------------------------------------------@@ -30,51 +45,87 @@ -- b@ __on each__ value of type @a@ in the functor and consume a given functor -- of type @f a@. class Functor f where- fmap :: (a %1-> b) -> f a %1-> f b+ fmap :: (a %1 -> b) -> f a %1 -> f b -(<$>) :: Functor f => (a %1-> b) -> f a %1-> f b+(<$>) :: Functor f => (a %1 -> b) -> f a %1 -> f b (<$>) = fmap +infixl 4 <$> -- same fixity as base.<$>+ -- | Replace all occurances of @b@ with the given @a@ -- and consume the functor @f b@.-(<$) :: (Functor f, Consumable b) => a -> f b %1-> f a+(<$) :: (Functor f, Consumable b) => a -> f b %1 -> f a a <$ fb = fmap (`lseq` a) fb +infixl 4 <$ -- same fixity as base.<$+ -- | Discard a consumable value stored in a data functor.-void :: (Functor f, Consumable a) => f a %1-> f ()+void :: (Functor f, Consumable a) => f a %1 -> f () void = fmap consume -- # Instances ------------------------------------------------------------------------------- instance Functor [] where- fmap _f [] = []- fmap f (a:as) = f a : fmap f as+ fmap (f :: a %1 -> b) = go+ where+ go :: [a] %1 -> [b]+ go [] = []+ go (a : as) = f a : go as -instance Functor (Const x) where- fmap _ (Const x) = Const x+deriving via+ Generically1 (Const x)+ instance+ Functor (Const x) -instance Functor Maybe where- fmap _ Nothing = Nothing- fmap f (Just x) = Just (f x)+deriving via+ Generically1 Maybe+ instance+ Functor Maybe -instance Functor (Either e) where- fmap _ (Left x) = Left x- fmap f (Right x) = Right (f x)+deriving via+ Generically1 (Either e)+ instance+ Functor (Either e) -instance Functor ((,) a) where- fmap f (x,y) = (x, f y)+deriving via+ Generically1 ((,) a)+ instance+ Functor ((,) a) -instance Functor Identity where- fmap f (Identity x) = Identity (f x)+deriving via+ Generically1 ((,,) a b)+ instance+ Functor ((,,) a b) +deriving via+ Generically1 ((,,,) a b c)+ instance+ Functor ((,,,) a b c)++deriving via+ Generically1 ((,,,,) a b c d)+ instance+ Functor ((,,,,) a b c d)++deriving via+ Generically1 Identity+ instance+ Functor Identity+ instance (Functor f, Functor g) => Functor (Sum f g) where fmap f (InL fa) = InL (fmap f fa) fmap f (InR ga) = InR (fmap f ga) +instance (Functor f, Functor g) => Functor (Product f g) where+ fmap f (Pair fa ga) = Pair (fmap f fa) (fmap f ga)+ instance (Functor f, Functor g) => Functor (Compose f g) where fmap f (Compose x) = Compose (fmap (fmap f) x) +instance Functor Ur where+ fmap f (Ur a) = Ur (f a)+ --------------------------------- -- Monad transformer instances -- ---------------------------------@@ -103,3 +154,54 @@ instance Functor m => Functor (Strict.StateT s m) where fmap f (Strict.StateT x) = Strict.StateT (\s -> fmap (\(a, s') -> (f a, s')) (x s)) +------------------------+-- Generics instances --+------------------------+instance (Generic1 f, Functor (Rep1 f)) => Functor (Generically1 f) where+ fmap f = Generically1 . to1 . fmap f . from1 . unGenerically1++instance Functor U1 where+ fmap _ U1 = U1++instance Functor V1 where+ fmap _ = \case {}++instance (Functor f, Functor g) => Functor (f :*: g) where+ fmap f (l :*: r) = fmap f l :*: fmap f r++instance (Functor f, Functor g) => Functor (f :+: g) where+ fmap f (L1 a) = L1 (fmap f a)+ fmap f (R1 a) = R1 (fmap f a)++instance Functor (K1 i v) where+ fmap _ (K1 c) = K1 c++instance Functor f => Functor (M1 i c f) where+ fmap f (M1 a) = M1 (fmap f a)++instance Functor Par1 where+ fmap f (Par1 a) = Par1 (f a)++instance (Functor f, Functor g) => Functor (f :.: g) where+ fmap f (Comp1 a) = Comp1 (fmap (fmap f) a)++instance Functor f => Functor (MP1 m f) where+ fmap f (MP1 x) = MP1 (fmap f x)++instance Functor UAddr where+ fmap _ (UAddr c) = UAddr c++instance Functor UChar where+ fmap _ (UChar c) = UChar c++instance Functor UDouble where+ fmap _ (UDouble c) = UDouble c++instance Functor UFloat where+ fmap _ (UFloat c) = UFloat c++instance Functor UInt where+ fmap _ (UInt c) = UInt c++instance Functor UWord where+ fmap _ (UWord c) = UWord c
src/Data/Functor/Linear/Internal/Traversable.hs view
@@ -1,32 +1,45 @@-{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} module Data.Functor.Linear.Internal.Traversable ( -- * Linear traversable hierarchy- -- $ traversable- Traversable(..)- , mapM, sequenceA, for, forM- , mapAccumL, mapAccumR- ) where+ -- $+ Traversable (..),+ genericTraverse,+ GTraversable,+ mapM,+ sequenceA,+ for,+ forM,+ mapAccumL,+ mapAccumR,+ )+where import qualified Control.Functor.Linear.Internal.Class as Control-import qualified Control.Functor.Linear.Internal.State as Control import qualified Control.Functor.Linear.Internal.Instances as Control-import qualified Data.Functor.Linear.Internal.Functor as Data-import qualified Data.Functor.Linear.Internal.Applicative as Data+import Control.Functor.Linear.Internal.Kan+import qualified Control.Functor.Linear.Internal.State as Control import Data.Functor.Const+import qualified Data.Functor.Linear.Internal.Applicative as Data+import qualified Data.Functor.Linear.Internal.Functor as Data+import GHC.Types (Multiplicity (..))+import Generics.Linear import Prelude.Linear.Internal-import Prelude (Maybe(..), Either(..))+import Prelude (Either (..), Maybe (..)) --- $traversable+-- traversable -- TODO: write the laws -- TODO: maybe add a Foldable class between Functor and Traversable as well@@ -52,77 +65,230 @@ -- by Mauro Jaskelioff and Ondrej Rypacek, -- in /Mathematically-Structured Functional Programming/, 2012, online at -- <http://arxiv.org/pdf/1202.2919>.--- class Data.Functor t => Traversable t where {-# MINIMAL traverse | sequence #-} - traverse :: Control.Applicative f => (a %1-> f b) -> t a %1-> f (t b)+ traverse :: Control.Applicative f => (a %1 -> f b) -> t a %1 -> f (t b) {-# INLINE traverse #-} traverse f x = sequence (Data.fmap f x) - sequence :: Control.Applicative f => t (f a) %1-> f (t a)+ sequence :: Control.Applicative f => t (f a) %1 -> f (t a) {-# INLINE sequence #-} sequence = traverse id -mapM :: (Traversable t, Control.Monad m) => (a %1-> m b) -> t a %1-> m (t b)+mapM :: (Traversable t, Control.Monad m) => (a %1 -> m b) -> t a %1 -> m (t b) mapM = traverse {-# INLINE mapM #-} -sequenceA :: (Traversable t, Control.Applicative f) => t (f a) %1-> f (t a)+sequenceA :: (Traversable t, Control.Applicative f) => t (f a) %1 -> f (t a) sequenceA = sequence {-# INLINE sequenceA #-} -for :: (Traversable t, Control.Applicative f) => t a %1-> (a %1-> f b) -> f (t b)+for :: (Traversable t, Control.Applicative f) => t a %1 -> (a %1 -> f b) -> f (t b) for t f = traverse f t {-# INLINE for #-} -forM :: (Traversable t, Control.Monad m) => t a %1-> (a %1-> m b) -> m (t b)+forM :: (Traversable t, Control.Monad m) => t a %1 -> (a %1 -> m b) -> m (t b) forM = for {-# INLINE forM #-} -mapAccumL :: Traversable t => (a %1-> b %1-> (a,c)) -> a %1-> t b %1-> (a, t c)+mapAccumL :: Traversable t => (a %1 -> b %1 -> (a, c)) -> a %1 -> t b %1 -> (a, t c) mapAccumL f s t = swap $ Control.runState (traverse (\b -> Control.state $ \i -> swap $ f i b) t) s -mapAccumR :: Traversable t => (a %1-> b %1-> (a,c)) -> a %1-> t b %1-> (a, t c)+mapAccumR :: Traversable t => (a %1 -> b %1 -> (a, c)) -> a %1 -> t b %1 -> (a, t c) mapAccumR f s t = swap $ runStateR (traverse (\b -> StateR $ \i -> swap $ f i b) t) s -swap :: (a,b) %1-> (b,a)-swap (x,y) = (y,x)+swap :: (a, b) %1 -> (b, a)+swap (x, y) = (y, x) -- | A right-to-left state transformer-newtype StateR s a = StateR (s %1-> (a, s))+newtype StateR s a = StateR (s %1 -> (a, s)) deriving (Data.Functor, Data.Applicative) via Control.Data (StateR s) -runStateR :: StateR s a %1-> s %1-> (a, s)+runStateR :: StateR s a %1 -> s %1 -> (a, s) runStateR (StateR f) = f instance Control.Functor (StateR s) where fmap f (StateR x) = StateR $ (\(a, s') -> (f a, s')) . x instance Control.Applicative (StateR s) where- pure x = StateR $ \s -> (x,s)+ pure x = StateR $ \s -> (x, s) StateR f <*> StateR x = StateR (go . Control.fmap f . x)- where go :: (a, (a %1-> b, s)) %1-> (b, s)- go (a, (h, s'')) = (h a, s'')+ where+ go :: (a, (a %1 -> b, s)) %1 -> (b, s)+ go (a, (h, s'')) = (h a, s'') --------------------------- Standard instances --+-- Generic derived instances -- ------------------------ instance Traversable [] where- traverse _f [] = Control.pure []- traverse f (a : as) = (:) Control.<$> f a Control.<*> traverse f as+ -- We define traverse explicitly both to allow specialization+ -- to the appropriate Applicative and to allow specialization to+ -- the passed function. The generic definition allows neither, sadly.+ traverse f = go+ where+ go [] = Control.pure []+ go (x : xs) = Control.liftA2 (:) (f x) (go xs) instance Traversable ((,) a) where- sequence (a, fb) = (a,) Control.<$> fb+ traverse = genericTraverse +instance Traversable ((,,) a b) where+ traverse = genericTraverse++instance Traversable ((,,,) a b c) where+ traverse = genericTraverse++instance Traversable ((,,,,) a b c d) where+ traverse = genericTraverse+ instance Traversable Maybe where- sequence Nothing = Control.pure Nothing- sequence (Just x) = Control.fmap Just x+ traverse = genericTraverse instance Traversable (Const a) where- sequence (Const x) = Control.pure (Const x)+ traverse = genericTraverse instance Traversable (Either a) where- sequence (Left x) = Control.pure (Left x)- sequence (Right x) = Right Control.<$> x+ traverse = genericTraverse++instance Traversable U1 where+ traverse = genericTraverse++instance Traversable V1 where+ traverse = genericTraverse++instance (Traversable f, Traversable g) => Traversable (f :*: g) where+ traverse = genericTraverse++instance (Traversable f, Traversable g) => Traversable (f :+: g) where+ traverse = genericTraverse++instance Traversable f => Traversable (M1 i c f) where+ traverse = genericTraverse++instance Traversable Par1 where+ traverse = genericTraverse++instance (Traversable f, Traversable g) => Traversable (f :.: g) where+ traverse = genericTraverse++instance Traversable (K1 i v) where+ traverse = genericTraverse++instance Traversable UAddr where+ traverse = genericTraverse++instance Traversable UChar where+ traverse = genericTraverse++instance Traversable UDouble where+ traverse = genericTraverse++instance Traversable UFloat where+ traverse = genericTraverse++instance Traversable UInt where+ traverse = genericTraverse++instance Traversable UWord where+ traverse = genericTraverse++-- | This type class derives the definition of 'genericTraverse' by induction on+-- the generic representation of a type.+class GTraversable t where+ -- gtraverse :: Applicative f => (a %1 -> f b) -> t a %1 -> forall r. (forall k. ((a %1 -> r) %1 -> k) %1 -> f k) %1 -> forall k. (t b %1 -> k) %1 -> f k+ --+ -- TODO: developer documentation on why we use this type rather than the more+ -- straightforward type of `traverse`. Used, for instance, in the+ -- generic-deriving package.+ gtraverse :: Control.Applicative f => (a %1 -> f b) -> t a %1 -> Curried (Yoneda f) (Yoneda f) (t b)++instance GTraversable t => GTraversable (M1 i c t) where+ gtraverse f (M1 x) = lcoerce (gtraverse f x)+ {-# INLINE gtraverse #-}++-- Can m be polymorphic? I'm not optimistic.+instance (m ~ 'One, GTraversable t) => GTraversable (MP1 m t) where+ gtraverse f (MP1 x) = Control.fmap MP1 (gtraverse f x)+ {-# INLINE gtraverse #-}++instance GTraversable Par1 where+ gtraverse f (Par1 x) = lcoerce (liftCurriedYonedaC (f x))+ {-# INLINE gtraverse #-}++instance (GTraversable f, Traversable g) => GTraversable (f :.: g) where+ gtraverse f (Comp1 x) = lcoerce (gtraverse (traverse f) x)+ {-# INLINE gtraverse #-}++instance (GTraversable f, GTraversable g) => GTraversable (f :+: g) where+ gtraverse f (L1 x) = L1 Control.<$> gtraverse f x+ gtraverse f (R1 x) = R1 Control.<$> gtraverse f x+ {-# INLINE gtraverse #-}++instance (GTraversable f, GTraversable g) => GTraversable (f :*: g) where+ gtraverse f (x :*: y) = Control.liftA2 (:*:) (gtraverse f x) (gtraverse f y)+ {-# INLINE gtraverse #-}++instance GTraversable (K1 i c) where+ gtraverse _ (K1 c) = Control.pure (K1 c)+ {-# INLINE gtraverse #-}++instance GTraversable U1 where+ gtraverse _ U1 = Control.pure U1+ {-# INLINE gtraverse #-}++instance GTraversable V1 where+ gtraverse _ v = Control.pure ((\case {}) v)++instance GTraversable UAddr where+ gtraverse _ (UAddr x) = Control.pure (UAddr x)+ {-# INLINE gtraverse #-}++instance GTraversable UChar where+ gtraverse _ (UChar x) = Control.pure (UChar x)+ {-# INLINE gtraverse #-}++instance GTraversable UDouble where+ gtraverse _ (UDouble x) = Control.pure (UDouble x)+ {-# INLINE gtraverse #-}++instance GTraversable UFloat where+ gtraverse _ (UFloat x) = Control.pure (UFloat x)+ {-# INLINE gtraverse #-}++instance GTraversable UInt where+ gtraverse _ (UInt x) = Control.pure (UInt x)+ {-# INLINE gtraverse #-}++instance GTraversable UWord where+ gtraverse _ (UWord x) = Control.pure (UWord x)+ {-# INLINE gtraverse #-}++-- | Implementation of 'Data.Functor.Linear.traverse' for types which derive+-- (linear) 'Generics.Linear.Generic1'.+--+-- ### Performance note+--+-- At present, this function does not perform well for recursive types like lists;+-- it will not specialize to either+--+-- ### Example+--+-- > data T+-- > $(deriveGeneric1 ''T)+-- >+-- > instance Traversable T where+-- > traverse = genericTraverse+--+-- Note that, contrary to many other classes in linear-base, we can't define+-- `Traversable T` using deriving via, because the+-- [role](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html)+-- of `t`, in the type of 'Data.Functor.Linear.traverse', is nominal.+genericTraverse ::+ (Generic1 t, GTraversable (Rep1 t), Control.Applicative f) =>+ (a %1 -> f b) ->+ t a %1 ->+ f (t b)+genericTraverse f = lowerYoneda . lowerCurriedC . Control.fmap to1 . gtraverse f . from1+{-# INLINE genericTraverse #-}
src/Data/HashMap/Mutable/Linear.hs view
@@ -1,17 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UnliftedNewtypes #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | -- This module provides mutable hashmaps with a linear interface.@@ -22,9 +9,11 @@ ( -- * A mutable hashmap HashMap, Keyed,+ -- * Constructors empty, fromList,+ -- * Modifiers insert, insertAll,@@ -36,536 +25,19 @@ shrinkToFit, alter, alterF,+ -- * Accessors size, capacity, lookup, member, toList,+ -- * Combining maps union, unionWith,- intersectionWith+ intersectionWith, ) where -import qualified Control.Functor.Linear as Control-import Data.Array.Mutable.Linear (Array)-import Data.Functor.Identity hiding (runIdentity)-import qualified Data.Functor.Linear as Data-import qualified Data.Array.Mutable.Linear as Array-import Data.Hashable-import Data.Unrestricted.Linear-import Prelude.Linear hiding ((+), lookup, read, filter, mapMaybe, insert)-import Prelude ((+))-import qualified Data.Maybe as NonLinear-import qualified Data.Function as NonLinear-import qualified Prelude-import Unsafe.Coerce (unsafeCoerce)-import qualified Unsafe.Linear as Unsafe---- # Implementation Notes--- This is a simple implementatation of robin hood hashing.------ See these links:------ * https://programming.guide/robin-hood-hashing.html--- * https://andre.arko.net/2017/08/24/robin-hood-hashing/--- * https://cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf------- # Constants------------------------------------------------------- | When to trigger a resize.------ A high load factor usually is not desirable because it makes operations--- do more probes. A very low one is also not desirable since there're some--- operations which take time relative to the 'capacity'.------ This should be between (0, 1)------ The value 0.75 is what Java uses:--- https://docs.oracle.com/javase/10/docs/api/java/util/HashMap.html-constMaxLoadFactor :: Float-constMaxLoadFactor = 0.75---- | When resizing, the capacity will be multiplied by this amount.------ This should be greater than one.-constGrowthFactor :: Int-constGrowthFactor = 2---- # Core Data Types------------------------------------------------------- | A mutable hashmap with a linear interface.-data HashMap k v where- -- |- -- @loadFactor m = size m / cap m@- --- -- Invariants:- -- - array is non-empty- -- - (count / capacity) <= constMaxLoadFactor.- HashMap- :: Int -- ^ The number of stored (key, value) pairs.- -> RobinArr k v -- ^ Underlying array.- %1-> HashMap k v---- | An array of Robin values------ Each cell is Nothing if empty and is a RobinVal with the correct--- PSL otherwise.-type RobinArr k v = Array (Maybe (RobinVal k v))---- | Robin values are triples of the key, value and PSL--- (the probe sequence length).-data RobinVal k v = RobinVal {-# UNPACK #-} !PSL k v- deriving (Show)--incRobinValPSL :: RobinVal k v -> RobinVal k v-incRobinValPSL (RobinVal (PSL p) k v) = RobinVal (PSL (p+1)) k v--decRobinValPSL :: RobinVal k v -> RobinVal k v-decRobinValPSL (RobinVal (PSL p) k v) = RobinVal (PSL (p-1)) k v---- | A probe sequence length-newtype PSL = PSL Int- deriving (Prelude.Eq, Prelude.Ord, Prelude.Num, Prelude.Show)---- | At minimum, we need to store hashable--- and identifiable keys-type Keyed k = (Prelude.Eq k, Hashable k)---- | The results of searching for where to insert a key.------ PSL's on the constructors are the probes spent from the query, this--- might be different than PSL's of the cell at the returned index--- (in case of `IndexToSwap` constructor).-data ProbeResult k v where- -- | An empty cell at index to insert a new element with PSL.- IndexToInsert :: !PSL -> !Int -> ProbeResult k v- -- | A matching cell at index with a PSL and a value to update.- IndexToUpdate :: v -> !PSL -> !Int -> ProbeResult k v- -- | An occupied, richer, cell which should be evicted when inserting- -- the new element. The swapped-out cell will then need to be inserted- -- with a higher PSL.- IndexToSwap :: RobinVal k v -> !PSL -> !Int -> ProbeResult k v---- # Construction and Modification------------------------------------------------------- | Run a computation with an empty 'HashMap' with given capacity.-empty :: forall k v b.- Keyed k => Int -> (HashMap k v %1-> Ur b) %1-> Ur b-empty size scope =- Array.alloc- (max 1 size)- Nothing- (\arr -> scope (HashMap 0 arr))---- | Create an empty HashMap, using another as a uniqueness proof.-allocBeside :: Keyed k => Int -> HashMap k' v' %1-> (HashMap k v, HashMap k' v')-allocBeside size (HashMap s' arr) =- Array.allocBeside (max 1 size) Nothing arr & \(arr', arr'') ->- (HashMap size arr', HashMap s' arr'')---- | Run a computation with an 'HashMap' containing given key-value pairs.-fromList :: forall k v b.- Keyed k => [(k, v)] -> (HashMap k v %1-> Ur b) %1-> Ur b-fromList xs scope =- Array.alloc- (max- 1- (ceiling @Float @Int (fromIntegral (Prelude.length xs) / constMaxLoadFactor)))- Nothing- (\arr -> scope (insertAll xs (HashMap 0 arr)))---- | The most general modification function; which can insert, update or delete--- a value of the key, while collecting an effect in the form of an arbitrary--- 'Control.Functor'.-alterF :: (Keyed k, Control.Functor f) => (Maybe v -> f (Ur (Maybe v))) -> k -> HashMap k v %1-> f (HashMap k v)-alterF f key hm =- idealIndexForKey key hm & \(Ur idx, hm') ->- probeFrom (key, 0) idx hm' & \case- -- The key does not exist, and there is an empty cell to insert.- (HashMap count arr, IndexToInsert psl ix) ->- f Nothing Control.<&> \case- -- We don't need to insert anything.- Ur Nothing -> HashMap count arr- -- We need to insert a new key.- Ur (Just v)->- HashMap- (count+1)- (Array.write arr ix (Just (RobinVal psl key v)))- & growMapIfNecessary- -- The key exists.- (hm'', IndexToUpdate v psl ix) ->- capacity hm'' & \(Ur cap, HashMap count arr) ->- f (Just v) Control.<&> \case- -- We need to delete it.- Ur Nothing ->- Array.write arr ix Nothing & \arr' ->- shiftSegmentBackward 1 cap arr' ((ix + 1) `mod` cap) & \arr'' ->- HashMap- (count - 1)- arr''- -- We need to update it.- Ur (Just new)->- HashMap- count- (Array.write arr ix (Just (RobinVal psl key new)))- -- The key does not exist, but there is a key to evict.- (hm, IndexToSwap evicted psl ix) ->- f Nothing Control.<&> \case- -- We don't need to insert anything.- Ur Nothing -> hm- -- We need to insert a new key.- Ur (Just v)->- capacity hm & \(Ur cap, HashMap count arr) ->- tryInsertAtIndex- (HashMap- count- (Array.write arr ix (Just (RobinVal psl key v))))- ((ix + 1) `mod` cap)- (incRobinValPSL evicted)- & growMapIfNecessary---- aspiwack: I'm implementing `alter` in terms of `alterF`, because, at this--- point, we may have some bug fixes and so on and so forth. And maintaining two--- functions this size is quite a bit unpleasant. Nevertheless, the extra boxing--- required by the intermediate `Ur` call, there, makes it so that the--- specialisation of `alterF` to `Identity` doesn't quite yield the code that we--- would like, it's a bit costlier than it should. So in an ideal word, we would--- implement both manually. In the future probably.--- | A general modification function; which can insert, update or delete--- a value of the key. See 'alterF', for an even more general function.-alter :: Keyed k => (Maybe v -> Maybe v) -> k -> HashMap k v %1-> HashMap k v-alter f key hm = runIdentity $ alterF (\v -> Identity (Ur (f v))) key hm- where- runIdentity :: Identity a %1-> a- runIdentity (Identity x) = x---- | Insert a key value pair to a 'HashMap'. It overwrites the previous--- value if it exists.-insert :: Keyed k => k -> v -> HashMap k v %1-> HashMap k v-insert k v = alter (\_ -> Just v) k---- | Delete a key from a 'HashMap'. Does nothing if the key does not--- exist.-delete :: Keyed k => k -> HashMap k v %1-> HashMap k v-delete = alter (\_ -> Nothing)---- | 'insert' (in the provided order) the given key-value pairs to--- the hashmap.-insertAll :: Keyed k => [(k, v)] -> HashMap k v %1-> HashMap k v-insertAll [] hmap = hmap-insertAll ((k, v) : xs) hmap = insertAll xs (insert k v hmap)--- TODO: Do a resize first on the length of the input.---- | A version of 'fmap' which can throw out the elements.------ Complexity: O(capacity hm)-mapMaybe :: Keyed k => (v -> Maybe v') -> HashMap k v %1-> HashMap k v'-mapMaybe f = mapMaybeWithKey (\_k v -> f v)---- | Same as 'mapMaybe', but also has access to the keys.-mapMaybeWithKey :: forall k v v' .- Keyed k => (k -> v -> Maybe v') -> HashMap k v %1-> HashMap k v'-mapMaybeWithKey _ (HashMap 0 arr) = HashMap 0 (Unsafe.coerce arr)-mapMaybeWithKey f (HashMap _ arr) = Array.size arr & \(Ur size, arr1) ->- mapAndPushBack 0 (size-1) (False,0) 0 arr1 & \(Ur c, arr2) ->- HashMap c (Unsafe.coerce arr2) where-- f' :: k -> v -> Maybe v- f' k v = unsafeCoerce (f k v)-- -- Going from arr[0] to arr[size-1] map each element while- -- simultaneously pushing elements back if some earlier element(s)- -- were deleted in a contiguous segment and if the current- -- element has PSL > 0. Maintain a counter of how- -- far to push elements back. At arr[size-1] if needed, call- -- shiftSegmentBackward with the counter at arr[0].- mapAndPushBack ::- Int -> -- ^ Current index- Int -> -- ^ Last index of array which is (size-1)- (Bool, Int) -> -- ^ (b,n) s.t. b iff open space n cells before current cell- Int -> -- ^ Count of present key-value pairs- RobinArr k v %1->- (Ur Int, RobinArr k v) -- ^ The new count and fully mapped array- mapAndPushBack ix end (shift,dec) count arr- | (ix > end) =- if shift- then (Ur count, shiftSegmentBackward dec (end+1) arr 0)- else (Ur count, arr)- | otherwise = Array.read arr ix & \case- (Ur Nothing, arr1) ->- mapAndPushBack (ix+1) end (False,0) count arr1- (Ur (Just (RobinVal (PSL p) k v)), arr1) -> case f' k v of- Nothing -> Array.write arr1 ix Nothing &- \arr2 -> mapAndPushBack (ix+1) end (True,dec+1) count arr2- Just v' -> case shift of- False -> Array.write arr1 ix (Just (RobinVal (PSL p) k v')) &- \arr2 -> mapAndPushBack (ix+1) end (False,0) (count+1) arr2- True -> case dec <= p of- False -> Array.write arr1 (ix-p) (Just (RobinVal 0 k v')) &- \arr2 -> case p == 0 of- False -> Array.write arr2 ix Nothing &- \arr3 -> mapAndPushBack (ix+1) end (True,p) (count+1) arr3- True -> mapAndPushBack (ix+1) end (False,0) (count+1) arr2- True -> Array.write arr1 (ix-dec) (Just (RobinVal (PSL (p-dec)) k v')) &- \arr2 -> Array.write arr2 ix Nothing &- \arr3 -> mapAndPushBack (ix+1) end (True,dec) (count+1) arr3---- | Complexity: O(capacity hm)-filterWithKey :: Keyed k => (k -> v -> Bool) -> HashMap k v %1-> HashMap k v-filterWithKey f =- mapMaybeWithKey- (\k v -> if f k v then Just v else Nothing)---- | Complexity: O(capacity hm)-filter :: Keyed k => (v -> Bool) -> HashMap k v %1-> HashMap k v-filter f = filterWithKey (\_k v -> f v)---- | Union of two maps using the provided function on conflicts.------ Complexity: O(min(capacity hm1, capacity hm2)-unionWith- :: Keyed k => (v -> v -> v)- -> HashMap k v %1-> HashMap k v %1-> HashMap k v-unionWith onConflict (hm1 :: HashMap k v) hm2 =- -- To insert the elements in smaller map to the larger map, we- -- compare their capacities, and flip the arguments if necessary.- capacity hm1 & \(Ur cap1, hm1') ->- capacity hm2 & \(Ur cap2, hm2') ->- if cap1 > cap2- then go onConflict hm1' (toList hm2')- else go (\v2 v1 -> onConflict v1 v2) hm2' (toList hm1')- where- go :: (v -> v -> v)- -> HashMap k v -- ^ larger map- %1-> Ur [(k, v)] -- ^ contents of the smaller map- %1-> HashMap k v- go _ hm (Ur []) = hm- go f hm (Ur ((k, vr):xs)) =- alter (\case- Nothing -> Just vr- Just vl -> Just (f vl vr))- k- hm- & \hm -> go f hm (Ur xs)---- | A right-biased union.------ Complexity: O(min(capacity hm1, capacity hm2)-union :: Keyed k => HashMap k v %1-> HashMap k v %1-> HashMap k v-union hm1 hm2 = unionWith (\_v1 v2 -> v2) hm1 hm2---- | Intersection of two maps with the provided combine function.------ Complexity: O(min(capacity hm1, capacity hm2)-intersectionWith- :: Keyed k- => (a -> b -> c)- -> HashMap k a %1-> HashMap k b %1-> HashMap k c-intersectionWith combine (hm1 :: HashMap k a') hm2 =- allocBeside 0 hm1 & \(hmNew, hm1') ->- capacity hm1' & \(Ur cap1, hm1'') ->- capacity hm2 & \(Ur cap2, hm2') ->- if cap1 > cap2- then go combine hm1'' (toList hm2') hmNew- else go (\v2 v1 -> combine v1 v2) hm2' (toList hm1'') hmNew- where- -- Iterate over the smaller map, while checking for the matches- -- on the bigger map; and accumulate results on a third map.- go :: (a -> b -> c)- -> HashMap k a %1-> Ur [(k, b)]- %1-> HashMap k c %1-> HashMap k c- go _ hm (Ur []) acc = hm `lseq` acc- go f hm (Ur ((k, b):xs)) acc =- lookup k hm & \case- (Ur Nothing, hm') -> go f hm' (Ur xs) acc- (Ur (Just a), hm') -> go f hm' (Ur xs) (insert k (f a b) acc)---- |--- Reduce the 'HashMap' 'capacity' to decrease wasted memory. Returns--- a semantically identical 'HashMap'.------ This is only useful after a lot of deletes.------ Complexity: O(capacity hm)-shrinkToFit :: Keyed k => HashMap k a %1-> HashMap k a-shrinkToFit hm =- size hm & \(Ur size, hm') ->- let targetSize = ceiling- (Prelude.max 1 (fromIntegral size Prelude./ constMaxLoadFactor))- in resize targetSize hm'---- # Querying------------------------------------------------------- | Number of key-value pairs inside the 'HashMap'-size :: HashMap k v %1-> (Ur Int, HashMap k v)-size (HashMap ct arr) = (Ur ct, HashMap ct arr)---- | Maximum number of elements the HashMap can store without--- resizing. However, for performance reasons, the 'HashMap' might be--- before full.------ Use 'shrinkToFit' to reduce the wasted space.-capacity :: HashMap k v %1-> (Ur Int, HashMap k v)-capacity (HashMap ct arr) =- Array.size arr & \(len, arr') ->- (len, HashMap ct arr')---- | Look up a value from a 'HashMap'.-lookup :: Keyed k => k -> HashMap k v %1-> (Ur (Maybe v), HashMap k v)-lookup k hm =- idealIndexForKey k hm & \(Ur idx, hm') ->- probeFrom (k,0) idx hm' & \case- (h, IndexToUpdate v _ _) ->- (Ur (Just v), h)- (h, IndexToInsert _ _) ->- (Ur Nothing, h)- (h, IndexToSwap _ _ _) ->- (Ur Nothing, h)---- | Check if the given key exists.-member :: Keyed k => k -> HashMap k v %1-> (Ur Bool, HashMap k v)-member k hm =- lookup k hm & \case- (Ur Nothing, hm') -> (Ur False, hm')- (Ur (Just _), hm') -> (Ur True, hm')---- | Converts a HashMap to a lazy list.-toList :: HashMap k v %1-> Ur [(k, v)]-toList (HashMap _ arr) =- Array.toList arr & \(Ur elems) ->- elems- NonLinear.& NonLinear.catMaybes- NonLinear.& Prelude.map (\(RobinVal _ k v) -> (k, v))- NonLinear.& Ur---- # Instances-----------------------------------------------------instance Consumable (HashMap k v) where- consume :: HashMap k v %1-> ()- consume (HashMap _ arr) = consume arr--instance Dupable (HashMap k v) where- dup2 (HashMap i arr) = dup2 arr & \(a1, a2) ->- (HashMap i a1, HashMap i a2)--instance Data.Functor (HashMap k) where- fmap f (HashMap c arr) =- HashMap c $- Data.fmap- (\case- Nothing -> Nothing- Just (RobinVal p k v) -> Just (RobinVal p k (f v))- )- arr--instance Prelude.Semigroup (HashMap k v) where- (<>) = error "Prelude.<>: invariant violation, unrestricted HashMap"--instance Keyed k => Semigroup (HashMap k v) where- (<>) = union---- # Internal library-----------------------------------------------------_debugShow :: (Show k, Show v) => HashMap k v %1-> String-_debugShow (HashMap _ robinArr) =- Array.toList robinArr & \(Ur xs) -> show xs--idealIndexForKey- :: Keyed k- => k -> HashMap k v %1-> (Ur Int, HashMap k v)-idealIndexForKey k hm =- capacity hm & \(Ur cap, hm') ->- (Ur (mod (hash k) cap), hm')---- | Given a key, psl of the probe so far, current unread index, and--- a full hashmap, return a probe result: the place the key already--- exists, a place to swap from, or an unfilled cell to write over.-probeFrom :: Keyed k =>- (k, PSL) -> Int -> HashMap k v %1-> (HashMap k v, ProbeResult k v)-probeFrom (k, p) ix (HashMap ct arr) = Array.read arr ix & \case- (Ur Nothing, arr') ->- (HashMap ct arr', IndexToInsert p ix)- (Ur (Just robinVal'@(RobinVal psl k' v')), arr') ->- case k Prelude.== k' of- -- Note: in the True case, we must have p == psl- True -> (HashMap ct arr', IndexToUpdate v' psl ix)- False -> case psl Prelude.< p of- True -> (HashMap ct arr', IndexToSwap robinVal' p ix)- False ->- capacity (HashMap ct arr') & \(Ur cap, HashMap ct' arr'') ->- probeFrom (k, p+1) ((ix+1)`mod` cap) (HashMap ct' arr'')---- | Try to insert at a given index with a given PSL. So the--- probing starts from the given index (with the given PSL).-tryInsertAtIndex :: Keyed k =>- HashMap k v %1-> Int -> RobinVal k v -> HashMap k v-tryInsertAtIndex hmap ix (RobinVal psl key val) =- probeFrom (key, psl) ix hmap & \case- (HashMap ct arr, IndexToUpdate _ psl' ix') ->- HashMap ct (Array.write arr ix' (Just $ RobinVal psl' key val))- (HashMap c arr, IndexToInsert psl' ix') ->- HashMap (c + 1) (Array.write arr ix' (Just $ RobinVal psl' key val))- (hm, IndexToSwap oldVal psl' ix') ->- capacity hm & \(Ur cap, HashMap ct arr) ->- tryInsertAtIndex- (HashMap ct (Array.write arr ix' (Just $ RobinVal psl' key val)))- ((ix' + 1) `mod` cap)- (incRobinValPSL oldVal)---- | Shift all cells with PSLs > 0 in a continuous segment--- following the deleted cell, backwards by one and decrement--- their PSLs.-shiftSegmentBackward :: Keyed k =>- Int -> Int -> RobinArr k v %1-> Int -> RobinArr k v-shiftSegmentBackward dec s arr ix = Array.read arr ix & \case- (Ur Nothing, arr') -> arr'- (Ur (Just (RobinVal 0 _ _)), arr') -> arr'- (Ur (Just val), arr') ->- Array.write arr' ix Nothing & \arr'' ->- shiftSegmentBackward- dec- s- (Array.write arr'' ((ix-dec+s) `mod` s) (Just $ decRobinValPSL val))- ((ix+1) `mod` s)--- TODO: This does twice as much writes than necessary, it first empties--- the cell, just to update it again at the next call. We can save some--- writes by only emptying the last cell.---- | Makes sure that the map is not exceeding its utilization threshold--- (constMaxUtilization), resizes (constGrowthFactor) if necessary.-growMapIfNecessary :: Keyed k => HashMap k v %1-> HashMap k v-growMapIfNecessary hm =- capacity hm & \(Ur cap, hm') ->- size hm' & \(Ur sz, hm'') ->- let load = fromIntegral sz / fromIntegral cap- in if load Prelude.< constMaxLoadFactor- then hm''- else- let newCap = max 1 (cap * constGrowthFactor)- in resize newCap hm''---- | Resizes the HashMap to given capacity.------ Invariant: Given capacity should be greater than the size, this is not--- checked.-resize :: Keyed k => Int -> HashMap k v %1-> HashMap k v-resize targetSize (HashMap _ arr) =- Array.allocBeside targetSize Nothing arr & \(newArr, oldArr) ->- Array.toList oldArr & \(Ur elems) ->- let xs =- elems- NonLinear.& NonLinear.catMaybes- NonLinear.& Prelude.map (\(RobinVal _ k v) -> (k, v))- in insertAll xs (HashMap 0 newArr)--- TODO: 'insertAll' keeps checking capacity on each insert. We should--- replace it with a faster unsafe variant.+import Data.HashMap.Mutable.Linear.Internal
+ src/Data/HashMap/Mutable/Linear/Internal.hs view
@@ -0,0 +1,617 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedNewtypes #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.HashMap.Mutable.Linear.Internal where++import qualified Control.Functor.Linear as Control+import Data.Array.Mutable.Linear (Array)+import qualified Data.Array.Mutable.Linear as Array+import qualified Data.Function as NonLinear+import Data.Functor.Identity hiding (runIdentity)+import qualified Data.Functor.Linear as Data+import Data.Hashable+import qualified Data.Maybe as NonLinear+import Data.Unrestricted.Linear+import Prelude.Linear hiding (filter, insert, lookup, mapMaybe, read, (+))+import Unsafe.Coerce (unsafeCoerce)+import qualified Unsafe.Linear as Unsafe+import Prelude ((+))+import qualified Prelude++-- # Implementation Notes+-- This is a simple implementatation of robin hood hashing.+--+-- See these links:+--++-- * https://programming.guide/robin-hood-hashing.html++-- * https://andre.arko.net/2017/08/24/robin-hood-hashing/++-- * https://cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf++--++-- # Constants+--------------------------------------------------++-- | When to trigger a resize.+--+-- A high load factor usually is not desirable because it makes operations+-- do more probes. A very low one is also not desirable since there're some+-- operations which take time relative to the 'capacity'.+--+-- This should be between (0, 1)+--+-- The value 0.75 is what Java uses:+-- https://docs.oracle.com/javase/10/docs/api/java/util/HashMap.html+constMaxLoadFactor :: Float+constMaxLoadFactor = 0.75++-- | When resizing, the capacity will be multiplied by this amount.+--+-- This should be greater than one.+constGrowthFactor :: Int+constGrowthFactor = 2++-- # Core Data Types+--------------------------------------------------++-- | A mutable hashmap with a linear interface.+data HashMap k v where+ -- |+ -- @loadFactor m = size m / cap m@+ --+ -- Invariants:+ -- - array is non-empty+ -- - (count / capacity) <= constMaxLoadFactor.+ HashMap ::+ -- | The number of stored (key, value) pairs.+ !Int ->+ -- | Capacity of the underlying array (cached here)+ !Int ->+ -- | Underlying array.+ !(RobinArr k v) %1 ->+ HashMap k v++-- | An array of Robin values+--+-- Each cell is Nothing if empty and is a RobinVal with the correct+-- PSL otherwise.+type RobinArr k v = Array (Maybe (RobinVal k v))++-- | Robin values are triples of the key, value and PSL+-- (the probe sequence length).+data RobinVal k v = RobinVal !PSL !k v+ deriving (Show)++incRobinValPSL :: RobinVal k v -> RobinVal k v+incRobinValPSL (RobinVal (PSL p) k v) = RobinVal (PSL (p + 1)) k v++decRobinValPSL :: RobinVal k v -> RobinVal k v+decRobinValPSL (RobinVal (PSL p) k v) = RobinVal (PSL (p - 1)) k v++-- | A probe sequence length+newtype PSL = PSL Int+ deriving (Prelude.Eq, Prelude.Ord, Prelude.Num, Prelude.Show)++-- | At minimum, we need to store hashable+-- and identifiable keys+type Keyed k = (Prelude.Eq k, Hashable k)++-- | The results of searching for where to insert a key.+--+-- PSL's on the constructors are the probes spent from the query, this+-- might be different than PSL's of the cell at the returned index+-- (in case of `IndexToSwap` constructor).+data ProbeResult k v where+ -- | An empty cell at index to insert a new element with PSL.+ IndexToInsert :: !PSL -> !Int -> ProbeResult k v+ -- | A matching cell at index with a PSL and a value to update.+ IndexToUpdate :: v -> !PSL -> !Int -> ProbeResult k v+ -- | An occupied, richer, cell which should be evicted when inserting+ -- the new element. The swapped-out cell will then need to be inserted+ -- with a higher PSL.+ IndexToSwap :: RobinVal k v -> !PSL -> !Int -> ProbeResult k v++-- # Construction and Modification+--------------------------------------------------++-- | Run a computation with an empty 'HashMap' with given capacity.+empty ::+ forall k v b.+ Keyed k =>+ Int ->+ (HashMap k v %1 -> Ur b) %1 ->+ Ur b+empty size scope =+ let cap = max 1 size+ in Array.alloc cap Nothing (\arr -> scope (HashMap 0 cap arr))++-- | Create an empty HashMap, using another as a uniqueness proof.+allocBeside :: Keyed k => Int -> HashMap k' v' %1 -> (HashMap k v, HashMap k' v')+allocBeside size (HashMap s' c' arr) =+ let cap = max 1 size+ in Array.allocBeside cap Nothing arr & \(arr', arr'') ->+ (HashMap size cap arr', HashMap s' c' arr'')++-- | Run a computation with an 'HashMap' containing given key-value pairs.+fromList ::+ forall k v b.+ Keyed k =>+ [(k, v)] ->+ (HashMap k v %1 -> Ur b) %1 ->+ Ur b+fromList xs scope =+ let cap =+ max+ 1+ (ceiling @Float @Int (fromIntegral (Prelude.length xs) / constMaxLoadFactor))+ in Array.alloc+ cap+ Nothing+ (\arr -> scope (insertAll xs (HashMap 0 cap arr)))++-- | The most general modification function; which can insert, update or delete+-- a value of the key, while collecting an effect in the form of an arbitrary+-- 'Control.Functor'.+alterF :: (Keyed k, Control.Functor f) => (Maybe v -> f (Ur (Maybe v))) -> k -> HashMap k v %1 -> f (HashMap k v)+alterF f key hm =+ idealIndexForKey key hm & \(Ur idx, hm') ->+ probeFrom key 0 idx hm' `chainU` \case+ -- The key does not exist, and there is an empty cell to insert.+ (# HashMap count cap arr, IndexToInsert psl ix #) ->+ f Nothing Control.<&> \case+ -- We don't need to insert anything.+ Ur Nothing -> HashMap count cap arr+ -- We need to insert a new key.+ Ur (Just v) ->+ HashMap+ (count + 1)+ cap+ (Array.unsafeWrite arr ix (Just (RobinVal psl key v)))+ & growMapIfNecessary+ -- The key exists.+ (# HashMap count cap arr, IndexToUpdate v psl ix #) ->+ f (Just v) Control.<&> \case+ -- We need to delete it.+ Ur Nothing ->+ Array.unsafeWrite arr ix Nothing & \arr' ->+ shiftSegmentBackward 1 cap arr' ((ix + 1) `mod` cap) & \arr'' ->+ HashMap+ (count - 1)+ cap+ arr''+ -- We need to update it.+ Ur (Just new) ->+ HashMap+ count+ cap+ (Array.unsafeWrite arr ix (Just (RobinVal psl key new)))+ -- The key does not exist, but there is a key to evict.+ (# HashMap count cap arr, IndexToSwap evicted psl ix #) ->+ f Nothing Control.<&> \case+ -- We don't need to insert anything.+ Ur Nothing -> HashMap count cap arr+ -- We need to insert a new key.+ Ur (Just v) ->+ tryInsertAtIndex+ ( HashMap+ count+ cap+ (Array.unsafeWrite arr ix (Just (RobinVal psl key v)))+ )+ ((ix + 1) `mod` cap)+ (incRobinValPSL evicted)+ & growMapIfNecessary+{-# INLINE alterF #-}++-- aspiwack: I'm implementing `alter` in terms of `alterF`, because, at this+-- point, we may have some bug fixes and so on and so forth. And maintaining two+-- functions this size is quite a bit unpleasant. Nevertheless, the extra boxing+-- required by the intermediate `Ur` call, there, makes it so that the+-- specialisation of `alterF` to `Identity` doesn't quite yield the code that we+-- would like, it's a bit costlier than it should. So in an ideal word, we would+-- implement both manually. In the future probably.++-- | A general modification function; which can insert, update or delete+-- a value of the key. See 'alterF', for an even more general function.+alter :: Keyed k => (Maybe v -> Maybe v) -> k -> HashMap k v %1 -> HashMap k v+alter f key hm = runIdentity $ alterF (\v -> Identity (Ur (f v))) key hm+ where+ runIdentity :: Identity a %1 -> a+ runIdentity (Identity x) = x+{-# INLINE alter #-}++-- | Insert a key value pair to a 'HashMap'. It overwrites the previous+-- value if it exists.+insert :: Keyed k => k -> v -> HashMap k v %1 -> HashMap k v+insert k v = alter (\_ -> Just v) k++-- | Delete a key from a 'HashMap'. Does nothing if the key does not+-- exist.+delete :: Keyed k => k -> HashMap k v %1 -> HashMap k v+delete = alter (\_ -> Nothing)++-- | 'insert' (in the provided order) the given key-value pairs to+-- the hashmap.+insertAll :: Keyed k => [(k, v)] -> HashMap k v %1 -> HashMap k v+insertAll [] hmap = hmap+insertAll ((k, v) : xs) hmap = insertAll xs (insert k v hmap)++-- TODO: Do a resize first on the length of the input.++-- | A version of 'fmap' which can throw out the elements.+--+-- Complexity: O(capacity hm)+mapMaybe :: Keyed k => (v -> Maybe v') -> HashMap k v %1 -> HashMap k v'+mapMaybe f = mapMaybeWithKey (\_k v -> f v)++-- | Same as 'mapMaybe', but also has access to the keys.+mapMaybeWithKey ::+ forall k v v'.+ Keyed k =>+ (k -> v -> Maybe v') ->+ HashMap k v %1 ->+ HashMap k v'+mapMaybeWithKey _ (HashMap 0 cap arr) = HashMap 0 cap (Unsafe.coerce arr)+mapMaybeWithKey f (HashMap _ cap arr) =+ Array.size arr & \(Ur size, arr1) ->+ mapAndPushBack 0 (size - 1) (False, 0) 0 arr1 & \(Ur c, arr2) ->+ HashMap c cap (Unsafe.coerce arr2)+ where+ f' :: k -> v -> Maybe v+ f' k v = unsafeCoerce (f k v)++ -- Going from arr[0] to arr[size-1] map each element while+ -- simultaneously pushing elements back if some earlier element(s)+ -- were deleted in a contiguous segment and if the current+ -- element has PSL > 0. Maintain a counter of how+ -- far to push elements back. At arr[size-1] if needed, call+ -- shiftSegmentBackward with the counter at arr[0].+ mapAndPushBack ::+ Int -> -- Current index+ Int -> -- Last index of array which is (size-1)+ (Bool, Int) -> -- (b,n) s.t. b iff open space n cells before current cell+ Int -> -- Count of present key-value pairs+ RobinArr k v %1 ->+ (Ur Int, RobinArr k v) -- The new count and fully mapped array+ mapAndPushBack ix end (shift, dec) count arr+ | (ix > end) =+ if shift+ then (Ur count, shiftSegmentBackward dec (end + 1) arr 0)+ else (Ur count, arr)+ | otherwise =+ Array.unsafeRead arr ix & \case+ (Ur Nothing, arr1) ->+ mapAndPushBack (ix + 1) end (False, 0) count arr1+ (Ur (Just (RobinVal (PSL p) k v)), arr1) -> case f' k v of+ Nothing ->+ Array.unsafeWrite arr1 ix Nothing+ & \arr2 -> mapAndPushBack (ix + 1) end (True, dec + 1) count arr2+ Just v' -> case shift of+ False ->+ Array.unsafeWrite arr1 ix (Just (RobinVal (PSL p) k v'))+ & \arr2 -> mapAndPushBack (ix + 1) end (False, 0) (count + 1) arr2+ True -> case dec <= p of+ False ->+ Array.unsafeWrite arr1 (ix - p) (Just (RobinVal 0 k v'))+ & \arr2 -> case p == 0 of+ False ->+ Array.unsafeWrite arr2 ix Nothing+ & \arr3 -> mapAndPushBack (ix + 1) end (True, p) (count + 1) arr3+ True -> mapAndPushBack (ix + 1) end (False, 0) (count + 1) arr2+ True ->+ Array.unsafeWrite arr1 (ix - dec) (Just (RobinVal (PSL (p - dec)) k v'))+ & \arr2 ->+ Array.unsafeWrite arr2 ix Nothing+ & \arr3 -> mapAndPushBack (ix + 1) end (True, dec) (count + 1) arr3++-- | Complexity: O(capacity hm)+filterWithKey :: Keyed k => (k -> v -> Bool) -> HashMap k v %1 -> HashMap k v+filterWithKey f =+ mapMaybeWithKey+ (\k v -> if f k v then Just v else Nothing)++-- | Complexity: O(capacity hm)+filter :: Keyed k => (v -> Bool) -> HashMap k v %1 -> HashMap k v+filter f = filterWithKey (\_k v -> f v)++-- | Union of two maps using the provided function on conflicts.+--+-- Complexity: O(min(capacity hm1, capacity hm2)+unionWith ::+ Keyed k =>+ (v -> v -> v) ->+ HashMap k v %1 ->+ HashMap k v %1 ->+ HashMap k v+unionWith onConflict (hm1 :: HashMap k v) hm2 =+ -- To insert the elements in smaller map to the larger map, we+ -- compare their capacities, and flip the arguments if necessary.+ capacity hm1 & \(Ur cap1, hm1') ->+ capacity hm2 & \(Ur cap2, hm2') ->+ if cap1 > cap2+ then go onConflict hm1' (toList hm2')+ else go (\v2 v1 -> onConflict v1 v2) hm2' (toList hm1')+ where+ go ::+ (v -> v -> v) ->+ HashMap k v %1 -> -- larger map+ Ur [(k, v)] %1 -> -- contents of the smaller map+ HashMap k v+ go _ hm (Ur []) = hm+ go f hm (Ur ((k, vr) : xs)) =+ alter+ ( \case+ Nothing -> Just vr+ Just vl -> Just (f vl vr)+ )+ k+ hm+ & \hm -> go f hm (Ur xs)++-- | A right-biased union.+--+-- Complexity: O(min(capacity hm1, capacity hm2)+union :: Keyed k => HashMap k v %1 -> HashMap k v %1 -> HashMap k v+union hm1 hm2 = unionWith (\_v1 v2 -> v2) hm1 hm2++-- | Intersection of two maps with the provided combine function.+--+-- Complexity: O(min(capacity hm1, capacity hm2)+intersectionWith ::+ Keyed k =>+ (a -> b -> c) ->+ HashMap k a %1 ->+ HashMap k b %1 ->+ HashMap k c+intersectionWith combine (hm1 :: HashMap k a') hm2 =+ allocBeside 0 hm1 & \(hmNew, hm1') ->+ capacity hm1' & \(Ur cap1, hm1'') ->+ capacity hm2 & \(Ur cap2, hm2') ->+ if cap1 > cap2+ then go combine hm1'' (toList hm2') hmNew+ else go (\v2 v1 -> combine v1 v2) hm2' (toList hm1'') hmNew+ where+ -- Iterate over the smaller map, while checking for the matches+ -- on the bigger map; and accumulate results on a third map.+ go ::+ (a -> b -> c) ->+ HashMap k a %1 ->+ Ur [(k, b)] %1 ->+ HashMap k c %1 ->+ HashMap k c+ go _ hm (Ur []) acc = hm `lseq` acc+ go f hm (Ur ((k, b) : xs)) acc =+ lookup k hm & \case+ (Ur Nothing, hm') -> go f hm' (Ur xs) acc+ (Ur (Just a), hm') -> go f hm' (Ur xs) (insert k (f a b) acc)++-- |+-- Reduce the 'HashMap' 'capacity' to decrease wasted memory. Returns+-- a semantically identical 'HashMap'.+--+-- This is only useful after a lot of deletes.+--+-- Complexity: O(capacity hm)+shrinkToFit :: Keyed k => HashMap k a %1 -> HashMap k a+shrinkToFit hm =+ size hm & \(Ur size, hm') ->+ let targetSize =+ ceiling+ (Prelude.max 1 (fromIntegral size Prelude./ constMaxLoadFactor))+ in resize targetSize hm'++-- # Querying+--------------------------------------------------++-- | Number of key-value pairs inside the 'HashMap'+size :: HashMap k v %1 -> (Ur Int, HashMap k v)+size (HashMap ct cap arr) = (Ur ct, HashMap ct cap arr)++-- | Maximum number of elements the HashMap can store without+-- resizing. However, for performance reasons, the 'HashMap' might be+-- before full.+--+-- Use 'shrinkToFit' to reduce the wasted space.+capacity :: HashMap k v %1 -> (Ur Int, HashMap k v)+capacity (HashMap ct cap arr) = (Ur cap, HashMap ct cap arr)++-- | Look up a value from a 'HashMap'.+lookup :: Keyed k => k -> HashMap k v %1 -> (Ur (Maybe v), HashMap k v)+lookup k hm =+ idealIndexForKey k hm & \(Ur idx, hm') ->+ probeFrom k 0 idx hm' `chainU` \case+ (# h, IndexToUpdate v _ _ #) ->+ (Ur (Just v), h)+ (# h, IndexToInsert _ _ #) ->+ (Ur Nothing, h)+ (# h, IndexToSwap _ _ _ #) ->+ (Ur Nothing, h)++-- | Check if the given key exists.+member :: Keyed k => k -> HashMap k v %1 -> (Ur Bool, HashMap k v)+member k hm =+ lookup k hm & \case+ (Ur Nothing, hm') -> (Ur False, hm')+ (Ur (Just _), hm') -> (Ur True, hm')++-- | Converts a HashMap to a lazy list.+toList :: HashMap k v %1 -> Ur [(k, v)]+toList (HashMap _ _ arr) =+ Array.toList arr & \(Ur elems) ->+ elems+ NonLinear.& NonLinear.catMaybes+ NonLinear.& Prelude.map (\(RobinVal _ k v) -> (k, v))+ NonLinear.& Ur++-- # Instances+--------------------------------------------------++instance Consumable (HashMap k v) where+ consume :: HashMap k v %1 -> ()+ consume (HashMap _ _ arr) = consume arr++instance Dupable (HashMap k v) where+ dup2 (HashMap i c arr) =+ dup2 arr & \(a1, a2) ->+ (HashMap i c a1, HashMap i c a2)++instance Data.Functor (HashMap k) where+ fmap f (HashMap s c arr) =+ HashMap s c $+ Data.fmap+ ( \case+ Nothing -> Nothing+ Just (RobinVal p k v) -> Just (RobinVal p k (f v))+ )+ arr++instance Prelude.Semigroup (HashMap k v) where+ (<>) = error "Prelude.<>: invariant violation, unrestricted HashMap"++instance Keyed k => Semigroup (HashMap k v) where+ (<>) = union++-- # Internal library+--------------------------------------------------++_debugShow :: (Show k, Show v) => HashMap k v %1 -> String+_debugShow (HashMap _ _ robinArr) =+ Array.toList robinArr & \(Ur xs) -> show xs++idealIndexForKey ::+ Keyed k =>+ k ->+ HashMap k v %1 ->+ (Ur Int, HashMap k v)+idealIndexForKey k (HashMap sz cap arr) =+ (Ur (mod (hash k) cap), HashMap sz cap arr)++-- | Given a key, psl of the probe so far, current unread index, and+-- a full hashmap, return a probe result: the place the key already+-- exists, a place to swap from, or an unfilled cell to write over.+probeFrom ::+ Keyed k =>+ k ->+ PSL ->+ Int ->+ HashMap k v %1 ->+ (# HashMap k v, ProbeResult k v #)+probeFrom k p ix (HashMap ct cap arr) =+ Array.unsafeRead arr ix `chainU'` \case+ (Ur Nothing, arr') ->+ (# HashMap ct cap arr', IndexToInsert p ix #)+ (Ur (Just robinVal'@(RobinVal psl k' v')), arr') ->+ case k Prelude.== k' of+ -- Note: in the True case, we must have p == psl+ True -> (# HashMap ct cap arr', IndexToUpdate v' psl ix #)+ False -> case psl Prelude.< p of+ True -> (# HashMap ct cap arr', IndexToSwap robinVal' p ix #)+ False ->+ probeFrom k (p + 1) ((ix + 1) `mod` cap) (HashMap ct cap arr')++-- | Try to insert at a given index with a given PSL. So the+-- probing starts from the given index (with the given PSL).+tryInsertAtIndex ::+ Keyed k =>+ HashMap k v %1 ->+ Int ->+ RobinVal k v ->+ HashMap k v+tryInsertAtIndex hmap ix (RobinVal psl key val) =+ probeFrom key psl ix hmap `chainU` \case+ (# HashMap ct cap arr, IndexToUpdate _ psl' ix' #) ->+ Array.unsafeWrite arr ix' (Just $ RobinVal psl' key val)+ & HashMap ct cap+ (# HashMap ct cap arr, IndexToInsert psl' ix' #) ->+ Array.unsafeWrite arr ix' (Just $ RobinVal psl' key val)+ & HashMap (ct + 1) cap+ (# HashMap ct cap arr, IndexToSwap oldVal psl' ix' #) ->+ Array.unsafeWrite arr ix' (Just $ RobinVal psl' key val)+ & HashMap ct cap+ & \hm -> tryInsertAtIndex hm ((ix' + 1) `mod` cap) (incRobinValPSL oldVal)++-- | Shift all cells with PSLs > 0 in a continuous segment+-- following the deleted cell, backwards by one and decrement+-- their PSLs.+shiftSegmentBackward ::+ Keyed k =>+ Int ->+ Int ->+ RobinArr k v %1 ->+ Int ->+ RobinArr k v+shiftSegmentBackward dec s arr ix =+ Array.unsafeRead arr ix & \case+ (Ur Nothing, arr') -> arr'+ (Ur (Just (RobinVal 0 _ _)), arr') -> arr'+ (Ur (Just val), arr') ->+ Array.unsafeWrite arr' ix Nothing & \arr'' ->+ shiftSegmentBackward+ dec+ s+ (Array.unsafeWrite arr'' ((ix - dec + s) `mod` s) (Just $ decRobinValPSL val))+ ((ix + 1) `mod` s)++-- TODO: This does twice as much writes than necessary, it first empties+-- the cell, just to update it again at the next call. We can save some+-- writes by only emptying the last cell.++-- | Makes sure that the map is not exceeding its utilization threshold+-- (constMaxUtilization), resizes (constGrowthFactor) if necessary.+growMapIfNecessary :: Keyed k => HashMap k v %1 -> HashMap k v+growMapIfNecessary (HashMap sz cap arr) =+ let load = fromIntegral sz / fromIntegral cap+ in if load Prelude.< constMaxLoadFactor+ then HashMap sz cap arr+ else+ let newCap = max 1 (cap * constGrowthFactor)+ in resize newCap (HashMap sz cap arr)++-- | Resizes the HashMap to given capacity.+--+-- Invariant: Given capacity should be greater than the size, this is not+-- checked.+resize :: Keyed k => Int -> HashMap k v %1 -> HashMap k v+resize targetSize (HashMap _ _ arr) =+ Array.allocBeside targetSize Nothing arr & \(newArr, oldArr) ->+ Array.toList oldArr & \(Ur elems) ->+ let xs =+ elems+ NonLinear.& NonLinear.catMaybes+ NonLinear.& Prelude.map (\(RobinVal _ k v) -> (k, v))+ in insertAll xs (HashMap 0 targetSize newArr)++-- TODO: 'insertAll' keeps checking capacity on each insert. We should+-- replace it with a faster unsafe variant.++-- TODO: Remove the below workarounds once we are on GHC 9.2.+--+-- We have to use these functions below because:+--++-- * GHC <9.2 does not allow linear `case` statements.++-- * LambdaCase workaround does not work, because (&) does not work with++-- unlifted types.+chainU :: (# a, b #) %1 -> ((# a, b #) %1 -> c) %1 -> c+chainU x f = f x++chainU' :: a %1 -> (a %1 -> (# b, c #)) %1 -> (# b, c #)+chainU' x f = f x
src/Data/List/Linear.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE LinearTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | -- Linear versions of 'Data.List' functions.@@ -10,346 +11,380 @@ -- original "Data.List" module for more detailed information. module Data.List.Linear ( -- * Basic functions- (++)- , map- , filter- , NonLinear.head- , uncons- , NonLinear.tail- , NonLinear.last- , NonLinear.init- , reverse- , NonLinear.lookup- , length- , NonLinear.null- , traverse'+ (++),+ map,+ filter,+ NonLinear.head,+ uncons,+ NonLinear.tail,+ NonLinear.last,+ NonLinear.init,+ reverse,+ NonLinear.lookup,+ length,+ NonLinear.null,+ traverse',+ -- * Extracting sublists- , take- , drop- , splitAt- , span- , partition- , takeWhile- , dropWhile- , NonLinear.find- , intersperse- , intercalate- , transpose- -- * Folds- , foldl- , foldl'- , foldl1- , foldl1'- , foldr- , foldr1- , foldMap- , foldMap'- -- * Special folds- , concat- , concatMap- , and- , or- , any- , all- , sum- , product- -- * Building lists- , scanl- , scanl1- , scanr- , scanr1- , repeat- , replicate- , cycle- , iterate- , unfoldr- -- * Ordered lists- , NonLinear.sort- , NonLinear.sortOn- , NonLinear.insert- -- * Zipping lists- , zip- , zip'- , zip3- , zipWith- , zipWith'- , zipWith3- , unzip- , unzip3- ) where+ take,+ drop,+ splitAt,+ span,+ partition,+ takeWhile,+ dropWhile,+ NonLinear.find,+ intersperse,+ intercalate,+ transpose, -import qualified Unsafe.Linear as Unsafe-import qualified Prelude as Prelude-import Prelude (Maybe(..), Either(..), Int)-import Prelude.Linear.Internal+ -- * Folds+ foldl,+ foldl',+ foldl1,+ foldl1',+ foldr,+ foldr1,+ foldMap,+ foldMap',++ -- * Special folds+ concat,+ concatMap,+ and,+ or,+ any,+ all,+ sum,+ product,++ -- * Building lists+ scanl,+ scanl1,+ scanr,+ scanr1,+ repeat,+ replicate,+ cycle,+ iterate,+ unfoldr,++ -- * Ordered lists+ NonLinear.sort,+ NonLinear.sortOn,+ NonLinear.insert,++ -- * Zipping lists+ zip,+ zip',+ zip3,+ zipWith,+ zipWith',+ zipWith3,+ unzip,+ unzip3,+ )+where+ import Data.Bool.Linear-import Data.Unrestricted.Linear import Data.Functor.Linear+import qualified Data.Functor.Linear as Data+import qualified Data.List as NonLinear+import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Monoid.Linear import Data.Num.Linear-import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Unrestricted.Linear import GHC.Stack-import qualified Data.List as NonLinear-import qualified Data.Functor.Linear as Data+import Prelude.Linear.Internal+import qualified Unsafe.Linear as Unsafe+import Prelude (Either (..), Int, Maybe (..))+import qualified Prelude as Prelude -- # Basic functions -------------------------------------------------- -(++) :: [a] %1-> [a] %1-> [a]+(++) :: [a] %1 -> [a] %1 -> [a] (++) = Unsafe.toLinear2 (NonLinear.++) -map :: (a %1-> b) -> [a] %1-> [b]+infixr 5 ++ -- same fixity as base.++++map :: (a %1 -> b) -> [a] %1 -> [b] map = fmap -- | @filter p xs@ returns a list with elements satisfying the predicate. -- -- See 'Data.Maybe.Linear.mapMaybe' if you do not want the 'Dupable' constraint.-filter :: Dupable a => (a %1-> Bool) -> [a] %1-> [a]+filter :: Dupable a => (a %1 -> Bool) -> [a] %1 -> [a] filter _ [] = []-filter p (x:xs) =+filter p (x : xs) = dup x & \case (x', x'') -> if p x'- then x'' : filter p xs- else x'' `lseq` filter p xs+ then x'' : filter p xs+ else x'' `lseq` filter p xs -uncons :: [a] %1-> Maybe (a, [a])+uncons :: [a] %1 -> Maybe (a, [a]) uncons [] = Nothing-uncons (x:xs) = Just (x, xs)+uncons (x : xs) = Just (x, xs) -reverse :: [a] %1-> [a]+reverse :: [a] %1 -> [a] reverse = Unsafe.toLinear NonLinear.reverse -- | Return the length of the given list alongside with the list itself.-length :: [a] %1-> (Ur Int, [a])+length :: [a] %1 -> (Ur Int, [a]) length = Unsafe.toLinear $ \xs -> (Ur (NonLinear.length xs), xs)+ -- We can only do this because of the fact that 'NonLinear.length' -- does not inspect the elements. -- 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of -- length @n@ and second element is the remainder of the list.-splitAt :: Int -> [a] %1-> ([a], [a])+splitAt :: Int -> [a] %1 -> ([a], [a]) splitAt i = Unsafe.toLinear (Prelude.splitAt i) -- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where -- first element is longest prefix (possibly empty) of @xs@ of elements that -- satisfy @p@ and second element is the remainder of the list.-span :: Dupable a => (a %1-> Bool) -> [a] %1-> ([a], [a])+span :: Dupable a => (a %1 -> Bool) -> [a] %1 -> ([a], [a]) span _ [] = ([], [])-span f (x:xs) = dup x & \case- (x', x'') ->- if f x'- then span f xs & \case (ts, fs) -> (x'':ts, fs)- else ([x''], xs)+span f (x : xs) =+ dup x & \case+ (x', x'') ->+ if f x'+ then span f xs & \case (ts, fs) -> (x'' : ts, fs)+ else ([x''], xs) -- The partition function takes a predicate a list and returns the -- pair of lists of elements which do and do not satisfy the predicate, -- respectively.-partition :: Dupable a => (a %1-> Bool) -> [a] %1-> ([a], [a])+partition :: Dupable a => (a %1 -> Bool) -> [a] %1 -> ([a], [a]) partition p (xs :: [a]) = foldr select ([], []) xs- where- select :: a %1-> ([a], [a]) %1-> ([a], [a])- select x (ts, fs) =- dup2 x & \(x', x'') ->- if p x'- then (x'':ts, fs)- else (ts, x'':fs)+ where+ select :: a %1 -> ([a], [a]) %1 -> ([a], [a])+ select x (ts, fs) =+ dup2 x & \(x', x'') ->+ if p x'+ then (x'' : ts, fs)+ else (ts, x'' : fs) -- | __NOTE__: This does not short-circuit and always traverses the -- entire list to consume the rest of the elements.-takeWhile :: Dupable a => (a %1-> Bool) -> [a] %1-> [a]+takeWhile :: Dupable a => (a %1 -> Bool) -> [a] %1 -> [a] takeWhile _ [] = []-takeWhile p (x:xs) =+takeWhile p (x : xs) = dup2 x & \(x', x'') -> if p x'- then x'' : takeWhile p xs- else (x'', xs) `lseq` []+ then x'' : takeWhile p xs+ else (x'', xs) `lseq` [] -dropWhile :: Dupable a => (a %1-> Bool) -> [a] %1-> [a]+dropWhile :: Dupable a => (a %1 -> Bool) -> [a] %1 -> [a] dropWhile _ [] = []-dropWhile p (x:xs) =+dropWhile p (x : xs) = dup2 x & \(x', x'') -> if p x'- then x'' `lseq` dropWhile p xs- else x'' : xs+ then x'' `lseq` dropWhile p xs+ else x'' : xs -- | __NOTE__: This does not short-circuit and always traverses the -- entire list to consume the rest of the elements.-take :: Consumable a => Int -> [a] %1-> [a]+take :: Consumable a => Int -> [a] %1 -> [a] take _ [] = []-take i (x:xs)+take i (x : xs) | i Prelude.< 0 = (x, xs) `lseq` []- | otherwise = x : take (i-1) xs+ | otherwise = x : take (i - 1) xs -drop :: Consumable a => Int -> [a] %1-> [a]+drop :: Consumable a => Int -> [a] %1 -> [a] drop _ [] = []-drop i (x:xs)- | i Prelude.< 0 = x:xs- | otherwise = x `lseq` drop (i-1) xs-+drop i (x : xs)+ | i Prelude.< 0 = x : xs+ | otherwise = x `lseq` drop (i - 1) xs -- | The intersperse function takes an element and a list and -- `intersperses' that element between the elements of the list.-intersperse :: a -> [a] %1-> [a]+intersperse :: a -> [a] %1 -> [a] intersperse sep = Unsafe.toLinear (NonLinear.intersperse sep) -- | @intercalate xs xss@ is equivalent to @(concat (intersperse xs -- xss))@. It inserts the list xs in between the lists in xss and -- concatenates the result.-intercalate :: [a] -> [[a]] %1-> [a]+intercalate :: [a] -> [[a]] %1 -> [a] intercalate sep = Unsafe.toLinear (NonLinear.intercalate sep) -- | The transpose function transposes the rows and columns of its argument.-transpose :: [[a]] %1-> [[a]]+transpose :: [[a]] %1 -> [[a]] transpose = Unsafe.toLinear NonLinear.transpose -traverse' :: Data.Applicative f => (a %1-> f b) -> [a] %1-> f [b]+traverse' :: Data.Applicative f => (a %1 -> f b) -> [a] %1 -> f [b] traverse' _ [] = Data.pure []-traverse' f (a:as) = (:) <$> f a <*> traverse' f as+traverse' f (a : as) = (:) <$> f a <*> traverse' f as -- # Folds -------------------------------------------------- -foldr :: (a %1-> b %1-> b) -> b %1-> [a] %1-> b+foldr :: (a %1 -> b %1 -> b) -> b %1 -> [a] %1 -> b foldr f = Unsafe.toLinear2 (NonLinear.foldr (\a b -> f a b)) -foldr1 :: HasCallStack => (a %1-> a %1-> a) -> [a] %1-> a+foldr1 :: HasCallStack => (a %1 -> a %1 -> a) -> [a] %1 -> a foldr1 f = Unsafe.toLinear (NonLinear.foldr1 (\a b -> f a b)) -foldl :: (b %1-> a %1-> b) -> b %1-> [a] %1-> b+foldl :: (b %1 -> a %1 -> b) -> b %1 -> [a] %1 -> b foldl f = Unsafe.toLinear2 (NonLinear.foldl (\b a -> f b a)) -foldl' :: (b %1-> a %1-> b) -> b %1-> [a] %1-> b+foldl' :: (b %1 -> a %1 -> b) -> b %1 -> [a] %1 -> b foldl' f = Unsafe.toLinear2 (NonLinear.foldl' (\b a -> f b a)) -foldl1 :: HasCallStack => (a %1-> a %1-> a) -> [a] %1-> a+foldl1 :: HasCallStack => (a %1 -> a %1 -> a) -> [a] %1 -> a foldl1 f = Unsafe.toLinear (NonLinear.foldl1 (\a b -> f a b)) -foldl1' :: HasCallStack => (a %1-> a %1-> a) -> [a] %1-> a+foldl1' :: HasCallStack => (a %1 -> a %1 -> a) -> [a] %1 -> a foldl1' f = Unsafe.toLinear (NonLinear.foldl1' (\a b -> f a b)) -- | Map each element of the structure to a monoid, -- and combine the results.-foldMap :: Monoid m => (a %1-> m) -> [a] %1-> m+foldMap :: Monoid m => (a %1 -> m) -> [a] %1 -> m foldMap f = foldr ((<>) . f) mempty -- | A variant of 'foldMap' that is strict in the accumulator.-foldMap' :: Monoid m => (a %1-> m) -> [a] %1-> m+foldMap' :: Monoid m => (a %1 -> m) -> [a] %1 -> m foldMap' f = foldl' (\acc a -> acc <> f a) mempty -concat :: [[a]] %1-> [a]+concat :: [[a]] %1 -> [a] concat = Unsafe.toLinear NonLinear.concat -concatMap :: (a %1-> [b]) -> [a] %1-> [b]+concatMap :: (a %1 -> [b]) -> [a] %1 -> [b] concatMap f = Unsafe.toLinear (NonLinear.concatMap (forget f)) -sum :: AddIdentity a => [a] %1-> a+sum :: AddIdentity a => [a] %1 -> a sum = foldl' (+) zero -product :: MultIdentity a => [a] %1-> a+product :: MultIdentity a => [a] %1 -> a product = foldl' (*) one -- | __NOTE:__ This does not short-circuit, and always consumes the -- entire container.-any :: (a %1-> Bool) -> [a] %1-> Bool+any :: (a %1 -> Bool) -> [a] %1 -> Bool any p = foldl' (\b a -> b || p a) False -- | __NOTE:__ This does not short-circuit, and always consumes the -- entire container.-all :: (a %1-> Bool) -> [a] %1-> Bool+all :: (a %1 -> Bool) -> [a] %1 -> Bool all p = foldl' (\b a -> b && p a) True -- | __NOTE:__ This does not short-circuit, and always consumes the -- entire container.-and :: [Bool] %1-> Bool+and :: [Bool] %1 -> Bool and = foldl' (&&) True -- | __NOTE:__ This does not short-circuit, and always consumes the -- entire container.-or :: [Bool] %1-> Bool+or :: [Bool] %1 -> Bool or = foldl' (||) False -- # Building Lists -------------------------------------------------- -iterate :: Dupable a => (a %1-> a) -> a %1-> [a]-iterate f a = dup2 a & \(a', a'') ->- a' : iterate f (f a'')+iterate :: Dupable a => (a %1 -> a) -> a %1 -> [a]+iterate f a =+ dup2 a & \(a', a'') ->+ a' : iterate f (f a'') -repeat :: Dupable a => a %1-> [a]+repeat :: Dupable a => a %1 -> [a] repeat = iterate id -cycle :: (HasCallStack, Dupable a) => [a] %1-> [a]+cycle :: (HasCallStack, Dupable a) => [a] %1 -> [a] cycle [] = Prelude.error "cycle: empty list" cycle xs = dup2 xs & \(xs', xs'') -> xs' ++ cycle xs'' -scanl :: Dupable b => (b %1-> a %1-> b) -> b %1-> [a] %1-> [b]+scanl :: Dupable b => (b %1 -> a %1 -> b) -> b %1 -> [a] %1 -> [b] scanl _ b [] = [b]-scanl f b (x:xs) = dup2 b & \(b', b'') -> b' : scanl f (f b'' x) xs+scanl f b (x : xs) = dup2 b & \(b', b'') -> b' : scanl f (f b'' x) xs -scanl1 :: Dupable a => (a %1-> a %1-> a) -> [a] %1-> [a]+scanl1 :: Dupable a => (a %1 -> a %1 -> a) -> [a] %1 -> [a] scanl1 _ [] = []-scanl1 f (x:xs) = scanl f x xs+scanl1 f (x : xs) = scanl f x xs -scanr :: Dupable b => (a %1-> b %1-> b) -> b %1-> [a] %1-> [b]-scanr _ b [] = [b]-scanr f b (a:as) =- scanr f b as & \(b':bs') ->- dup2 b' & \(b'', b''') ->- f a b'' : b''' : bs'+scanr :: Dupable b => (a %1 -> b %1 -> b) -> b %1 -> [a] %1 -> [b]+scanr _ b [] = [b]+scanr f b (a : as) =+ scanr f b as & \case+ (b' : bs') ->+ dup2 b' & \(b'', b''') ->+ f a b'' : b''' : bs'+ [] ->+ -- this branch is impossible since scanr never returns an empty list.+ Prelude.error "impossible" a -scanr1 :: Dupable a => (a %1-> a %1-> a) -> [a] %1-> [a]-scanr1 _ [] = []-scanr1 _ [a] = [a]-scanr1 f (a:as) =- scanr1 f as & \(a':as') ->- dup2 a' & \(a'', a''') ->- f a a'' : a''' : as'+scanr1 :: Dupable a => (a %1 -> a %1 -> a) -> [a] %1 -> [a]+scanr1 _ [] = []+scanr1 _ [a] = [a]+scanr1 f (a : as) =+ scanr1 f as & \case+ (a' : as') ->+ dup2 a' & \(a'', a''') ->+ f a a'' : a''' : as'+ [] ->+ -- this branch is impossible since we know that the 'scanr1' result will+ -- be non-empty since 'as' is also non-empty.+ Prelude.error "impossible" a -replicate :: Dupable a => Int -> a %1-> [a]+replicate :: Dupable a => Int -> a %1 -> [a] replicate i a | i Prelude.< 1 = a `lseq` [] | i Prelude.== 1 = [a]- | otherwise = dup2 a & \(a', a'') -> a' : replicate (i-1) a''+ | otherwise = dup2 a & \(a', a'') -> a' : replicate (i - 1) a'' -unfoldr :: (b %1-> Maybe (a, b)) -> b %1-> [a]+unfoldr :: (b %1 -> Maybe (a, b)) -> b %1 -> [a] unfoldr f = Unsafe.toLinear (NonLinear.unfoldr (forget f)) -- # Zipping and unzipping lists -------------------------------------------------- -zip :: (Consumable a, Consumable b) => [a] %1-> [b] %1-> [(a, b)]+zip :: (Consumable a, Consumable b) => [a] %1 -> [b] %1 -> [(a, b)] zip = zipWith (,) -- | Same as 'zip', but returns the leftovers instead of consuming them.-zip' :: [a] %1-> [b] %1-> ([(a, b)], Maybe (Either (NonEmpty a) (NonEmpty b)))+zip' :: [a] %1 -> [b] %1 -> ([(a, b)], Maybe (Either (NonEmpty a) (NonEmpty b))) zip' = zipWith' (,) -zip3 :: (Consumable a, Consumable b, Consumable c) => [a] %1-> [b] %1-> [c] %1-> [(a, b, c)]+zip3 :: (Consumable a, Consumable b, Consumable c) => [a] %1 -> [b] %1 -> [c] %1 -> [(a, b, c)] zip3 = zipWith3 (,,) -zipWith :: (Consumable a, Consumable b) => (a %1 -> b %1->c) -> [a] %1-> [b] %1-> [c]+zipWith :: (Consumable a, Consumable b) => (a %1 -> b %1 -> c) -> [a] %1 -> [b] %1 -> [c] zipWith f xs ys = zipWith' f xs ys & \(ret, leftovers) -> leftovers `lseq` ret -- | Same as 'zipWith', but returns the leftovers instead of consuming them.-zipWith' :: (a %1-> b %1-> c) -> [a] %1-> [b] %1-> ([c], Maybe (Either (NonEmpty a) (NonEmpty b)))+zipWith' :: (a %1 -> b %1 -> c) -> [a] %1 -> [b] %1 -> ([c], Maybe (Either (NonEmpty a) (NonEmpty b))) zipWith' _ [] [] = ([], Nothing)-zipWith' _ (a:as) [] = ([], Just (Left (a :| as)))-zipWith' _ [] (b:bs) = ([], Just (Right (b :| bs)))-zipWith' f (a:as) (b:bs) = zipWith' f as bs & \case- (cs, rest) -> (f a b : cs, rest)+zipWith' _ (a : as) [] = ([], Just (Left (a :| as)))+zipWith' _ [] (b : bs) = ([], Just (Right (b :| bs)))+zipWith' f (a : as) (b : bs) =+ zipWith' f as bs & \case+ (cs, rest) -> (f a b : cs, rest) -zipWith3 :: forall a b c d. (Consumable a, Consumable b, Consumable c) => (a %1-> b %1-> c %1-> d) -> [a] %1-> [b] %1-> [c] %1-> [d]+zipWith3 :: forall a b c d. (Consumable a, Consumable b, Consumable c) => (a %1 -> b %1 -> c %1 -> d) -> [a] %1 -> [b] %1 -> [c] %1 -> [d] zipWith3 _ [] ys zs = (ys, zs) `lseq` [] zipWith3 _ xs [] zs = (xs, zs) `lseq` [] zipWith3 _ xs ys [] = (xs, ys) `lseq` []-zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs+zipWith3 f (x : xs) (y : ys) (z : zs) = f x y z : zipWith3 f xs ys zs -unzip :: [(a, b)] %1-> ([a], [b])+unzip :: [(a, b)] %1 -> ([a], [b]) unzip = Unsafe.toLinear NonLinear.unzip -unzip3 :: [(a, b, c)] %1-> ([a], [b], [c])+unzip3 :: [(a, b, c)] %1 -> ([a], [b], [c]) unzip3 = Unsafe.toLinear NonLinear.unzip3++-- # Instances+--------------------------------------------------++instance Semigroup (NonEmpty a) where+ (x :| xs) <> (y :| ys) = x :| (xs ++ (y : ys))++instance Semigroup [a] where+ (<>) = (++)+ {-# INLINE (<>) #-}++instance Monoid [a] where+ mempty = []
src/Data/Maybe/Linear.hs view
@@ -3,43 +3,43 @@ -- | This module provides linear functions on the standard 'Maybe' type. module Data.Maybe.Linear- ( Maybe (..)- , maybe- , fromMaybe- , maybeToList- , catMaybes- , mapMaybe+ ( Maybe (..),+ maybe,+ fromMaybe,+ maybeToList,+ catMaybes,+ mapMaybe, )- where+where import qualified Data.Functor.Linear as Linear-import Prelude (Maybe(..))+import Prelude (Maybe (..)) -- | @maybe b f m@ returns @(f a)@ where @a@ is in -- @m@ if it exists and @b@ otherwise-maybe :: b -> (a %1-> b) -> Maybe a %1-> b+maybe :: b -> (a %1 -> b) -> Maybe a %1 -> b maybe x _ Nothing = x maybe _ f (Just y) = f y -- | @fromMaybe default m@ is the @a@ in -- @m@ if it exists and the @default@ otherwise-fromMaybe :: a -> Maybe a %1-> a+fromMaybe :: a -> Maybe a %1 -> a fromMaybe a Nothing = a fromMaybe _ (Just a') = a' -- | @maybeToList m@ creates a singleton or an empty list -- based on the @Maybe a@.-maybeToList :: Maybe a %1-> [a]+maybeToList :: Maybe a %1 -> [a] maybeToList Nothing = [] maybeToList (Just a) = [a] -- | @catMaybes xs@ discards the @Nothing@s in @xs@ -- and extracts the @a@s-catMaybes :: [Maybe a] %1-> [a]+catMaybes :: [Maybe a] %1 -> [a] catMaybes [] = [] catMaybes (Nothing : xs) = catMaybes xs catMaybes (Just a : xs) = a : catMaybes xs -- | @mapMaybe f xs = catMaybes (map f xs)@-mapMaybe :: (a %1-> Maybe b) -> [a] %1-> [b]+mapMaybe :: (a %1 -> Maybe b) -> [a] %1 -> [b] mapMaybe f xs = catMaybes (Linear.fmap f xs)
src/Data/Monoid/Linear.hs view
@@ -2,11 +2,10 @@ -- | This module provides linear versions of 'Monoid' and related classes. module Data.Monoid.Linear- ( module Data.Monoid.Linear.Internal.Monoid- , module Data.Monoid.Linear.Internal.Semigroup+ ( module Data.Monoid.Linear.Internal.Monoid,+ module Data.Monoid.Linear.Internal.Semigroup, )- where+where import Data.Monoid.Linear.Internal.Monoid import Data.Monoid.Linear.Internal.Semigroup-
src/Data/Monoid/Linear/Internal/Monoid.hs view
@@ -1,11 +1,10 @@-{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_HADDOCK hide #-} -- | This module provides linear versions of 'Monoid'. --@@ -13,43 +12,132 @@ -- [post](https://www.schoolofhaskell.com/user/mgsloan/monoids-tour). module Data.Monoid.Linear.Internal.Monoid ( -- * Monoid operations- Monoid(..)- , mconcat+ Monoid (..),+ mconcat,+ mappend,+ -- Cannot export Data.Monoid.{First,Last} because of the name clash with Data.Semigroup.{First,Last} )- where+where -import Prelude.Linear.Internal+import Data.Functor.Compose (Compose (Compose))+import qualified Data.Functor.Compose as Functor+import Data.Functor.Const (Const)+import Data.Functor.Identity (Identity (Identity))+import Data.Functor.Product (Product (Pair))+import qualified Data.Functor.Product as Functor+import qualified Data.Monoid as Monoid import Data.Monoid.Linear.Internal.Semigroup+import Data.Ord (Down (Down))+import Data.Proxy (Proxy (Proxy))+import Data.Unrestricted.Linear.Internal.Consumable (Consumable) import GHC.Types hiding (Any)+import Prelude.Linear.Internal+import Prelude (Maybe (Nothing)) import qualified Prelude -- | A linear monoid is a linear semigroup with an identity on the binary -- operation.-class (Semigroup a, Prelude.Monoid a) => Monoid a where- {-# MINIMAL #-}+--+-- Laws (same as 'Data.Monoid.Monoid'):+-- * ∀ x ∈ G, x <> mempty = mempty <> x = x+class Semigroup a => Monoid a where+ {-# MINIMAL mempty #-} mempty :: a- mempty = Prelude.mempty- -- convenience redefine -mconcat :: Monoid a => [a] %1-> a+instance (Prelude.Semigroup a, Monoid a) => Prelude.Monoid (NonLinear a) where+ mempty = NonLinear mempty++-- convenience redefine++mconcat :: Monoid a => [a] %1 -> a mconcat (xs' :: [a]) = go mempty xs' where- go :: a %1-> [a] %1-> a+ go :: a %1 -> [a] %1 -> a go acc [] = acc- go acc (x:xs) = go (acc <> x) xs+ go acc (x : xs) = go (acc <> x) xs +mappend :: Monoid a => a %1 -> a %1 -> a+mappend = (<>)+ --------------- -- Instances -- --------------- instance Prelude.Monoid (Endo a) where mempty = Endo id-instance Monoid (Endo a) -instance (Monoid a, Monoid b) => Monoid (a,b)+-- Instances below are listed in the same order as in https://hackage.haskell.org/package/base-4.16.0.0/docs/Data-Monoid.html -instance Monoid a => Monoid (Dual a)+instance Monoid All where+ mempty = All True +instance Monoid Any where+ mempty = Any False+ instance Monoid Ordering where- mempty = EQ+ mempty = EQ +instance Monoid () where+ mempty = ()++instance Monoid a => Monoid (Identity a) where+ mempty = Identity mempty++instance Consumable a => Monoid (Monoid.First a) where+ mempty = Monoid.First Nothing++instance Consumable a => Monoid (Monoid.Last a) where+ mempty = Monoid.Last Nothing++instance Monoid a => Monoid (Down a) where+ mempty = Down mempty++-- Cannot add instance (Ord a, Bounded a) => Monoid (Max a); would require (NonLinear.Ord a, Consumable a)+-- Cannot add instance (Ord a, Bounded a) => Monoid (Min a); would require (NonLinear.Ord a, Consumable a)++instance Monoid a => Monoid (Dual a) where+ mempty = Dual mempty++instance Monoid (Endo a) where+ mempty = Endo id++-- See Data.Num.Linear for instance ... => Monoid (Product a)+-- See Data.Num.Linear for instance ... => Monoid (Sum a)+-- See System.IO.Linear for instance ... => Monoid (IO a)+-- See System.IO.Resource.Internal for instance ... => Monoid (RIO a)++instance Monoid a => Monoid (Maybe a) where+ mempty = Nothing++-- See Data.List.Linear for instance ... => Monoid [a]+-- Cannot add instance Monoid a => Monoid (Op a b); would require Dupable b++instance Monoid (Proxy a) where+ mempty = Proxy++-- Cannot add instance Monoid a => Monoid (ST s a); I think that it would require a linear ST monad+-- Cannot add instance Monoid b => Monoid (a -> b); would require Dupable a++instance (Monoid a, Monoid b) => Monoid (a, b) where+ mempty = (mempty, mempty)++instance Monoid a => Monoid (Const a b) where+ mempty = mempty++-- See Data.Functor.Linear.Applicative for instance ... => Monoid (Ap f a)+-- Cannot add instance Alternative f => Monoid (Alt f a); we don't have a linear Alternative++instance (Monoid a, Monoid b, Monoid c) => Monoid (a, b, c) where+ mempty = (mempty, mempty, mempty)++instance (Monoid (f a), Monoid (g a)) => Monoid (Functor.Product f g a) where+ mempty = Pair mempty mempty++instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a, b, c, d) where+ mempty = (mempty, mempty, mempty, mempty)++instance Monoid (f (g a)) => Monoid (Functor.Compose f g a) where+ mempty = Compose mempty++instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => Monoid (a, b, c, d, e) where+ mempty = (mempty, mempty, mempty, mempty, mempty)
src/Data/Monoid/Linear/Internal/Semigroup.hs view
@@ -1,89 +1,209 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_HADDOCK hide #-} -- | This module provides a linear version of 'Semigroup'. module Data.Monoid.Linear.Internal.Semigroup ( -- * Semigroup- Semigroup(..)+ Semigroup (..),+ -- * Endo- , Endo(..), appEndo- , NonLinear(..)- , module Data.Semigroup+ Endo (..),+ appEndo,++ -- * NonLinear newtype+ NonLinear (..),++ -- * Data.Semigroup reexports+ All (..),+ Any (..),+ First (..),+ Last (..),+ Dual (..),+ Sum (..),+ Product (..), )- where+where -import Prelude.Linear.Internal-import Data.Semigroup hiding (Semigroup(..), Endo(..))+import qualified Data.Functor.Compose as Functor+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))+import qualified Data.Functor.Product as Functor+import qualified Data.Monoid as Monoid+import Data.Ord (Down (..))+import Data.Proxy (Proxy (..))+import Data.Semigroup+ ( All (..),+ Any (..),+ Dual (..),+ First (..),+ Last (..),+ Product (..),+ Sum (..),+ ) import qualified Data.Semigroup as Prelude+import Data.Unrestricted.Linear.Internal.Consumable (Consumable, lseq)+import Data.Void (Void)+import GHC.Tuple import GHC.Types hiding (Any)+import Prelude.Linear.Internal+import Prelude (Either (..), Maybe (..)) -- | A linear semigroup @a@ is a type with an associative binary operation @<>@ -- that linearly consumes two @a@s.-class Prelude.Semigroup a => Semigroup a where- (<>) :: a %1-> a %1-> a-------------------- Instances --------------------instance Semigroup () where- () <> () = ()+--+-- Laws (same as 'Data.Semigroup.Semigroup'):+-- * ∀ x ∈ G, y ∈ G, z ∈ G, x <> (y <> z) = (x <> y) <> z+class Semigroup a where+ (<>) :: a %1 -> a %1 -> a+ infixr 6 <> -- same fixity as base.<> --- | An @Endo a@ is just a linear function of type @a %1-> a@.+-- | An @'Endo' a@ is just a linear function of type @a %1-> a@. -- This has a classic monoid definition with 'id' and '(.)'.-newtype Endo a = Endo (a %1-> a)+newtype Endo a = Endo (a %1 -> a) deriving (Prelude.Semigroup) via NonLinear (Endo a) -- TODO: have this as a newtype deconstructor once the right type can be -- correctly inferred+ -- | A linear application of an 'Endo'.-appEndo :: Endo a %1-> a %1-> a+appEndo :: Endo a %1 -> a %1 -> a appEndo (Endo f) = f -instance Semigroup (Endo a) where- Endo f <> Endo g = Endo (f . g)+-- | @DerivingVia@ combinator for 'Prelude.Semigroup' (resp. 'Prelude.Monoid')+-- given linear 'Semigroup' (resp. 'Monoid').+--+-- > newtype Endo a = Endo (a %1-> a)+-- > deriving (Prelude.Semigroup) via NonLinear (Endo a)+newtype NonLinear a = NonLinear a -instance (Semigroup a, Semigroup b) => Semigroup (a,b) where- (a,x) <> (b,y) = (a <> b, x <> y)+---------------+-- Instances --+--------------- -instance Semigroup a => Semigroup (Dual a) where- Dual x <> Dual y = Dual (y <> x)+instance Semigroup a => Prelude.Semigroup (NonLinear a) where+ NonLinear a <> NonLinear b = NonLinear (a <> b) +-- Instances below are listed in the same order as in https://hackage.haskell.org/package/base-4.16.0.0/docs/Data-Semigroup.html+ instance Semigroup All where All False <> All False = All False All False <> All True = All False- All True <> All False = All False- All True <> All True = All True+ All True <> All False = All False+ All True <> All True = All True+ instance Semigroup Any where Any False <> Any False = Any False Any False <> Any True = Any True- Any True <> Any False = Any True- Any True <> Any True = Any True---- | DerivingVia combinator for Prelude.Semigroup given (linear) Semigroup.--- For linear monoids, you should supply a Prelude.Monoid instance and either--- declare an empty Monoid instance, or use DeriveAnyClass. For example:------ > newtype Endo a = Endo (a %1-> a)--- > deriving (Prelude.Semigroup) via NonLinear (Endo a)-newtype NonLinear a = NonLinear a+ Any True <> Any False = Any True+ Any True <> Any True = Any True -instance Semigroup a => Prelude.Semigroup (NonLinear a) where- NonLinear a <> NonLinear b = NonLinear (a <> b)+instance Semigroup Void where+ (<>) = \case {} instance Semigroup Ordering where- LT <> LT = LT- LT <> GT = LT- LT <> EQ = LT- EQ <> y = y- GT <> LT = GT- GT <> GT = GT- GT <> EQ = GT- -- We can not use `lseq` above because of an import loop.- -- So it's easier to just expand the cases here.+ LT <> LT = LT+ LT <> GT = LT+ LT <> EQ = LT+ EQ <> y = y+ GT <> LT = GT+ GT <> GT = GT+ GT <> EQ = GT +instance Semigroup () where+ () <> () = ()++instance Semigroup a => Semigroup (Identity a) where+ Identity x <> Identity y = Identity (x <> y)++instance Consumable a => Semigroup (Monoid.First a) where+ (Monoid.First Nothing) <> y = y+ x <> (Monoid.First y) =+ y & \case+ Nothing -> x+ Just y' -> y' `lseq` x++instance Consumable a => Semigroup (Monoid.Last a) where+ x <> (Monoid.Last Nothing) = x+ (Monoid.Last x) <> y =+ x & \case+ Nothing -> y+ Just x' -> x' `lseq` y++instance Semigroup a => Semigroup (Down a) where+ (Down x) <> (Down y) = Down (x <> y)++instance Consumable a => Semigroup (First a) where+ x <> (First y) = y `lseq` x++instance Consumable a => Semigroup (Last a) where+ (Last x) <> y = x `lseq` y++-- Cannot add instance Ord a => Semigroup (Max a); would require (NonLinear.Ord a, Consumable a)+-- Cannot add instance Ord a => Semigroup (Min a); would require (NonLinear.Ord a, Consumable a)++instance Semigroup a => Semigroup (Dual a) where+ Dual x <> Dual y = Dual (y <> x)++instance Semigroup (Endo a) where+ Endo f <> Endo g = Endo (f . g)++-- See Data.Num.Linear for instance ... => Semigroup (Product a)+-- See Data.Num.Linear for instance ... => Semigroup (Sum a)+-- See System.IO.Linear for instance ... => Semigroup (IO a)+-- See System.IO.Resource.Internal for instance ... => Semigroup (RIO a)+-- See Data.List.Linear for instance ... => Semigroup (NonEmpty a)++instance Semigroup a => Semigroup (Maybe a) where+ x <> Nothing = x+ Nothing <> y = y+ Just x <> Just y = Just (x <> y)++instance Semigroup a => Semigroup (Solo a) where+ Solo x <> Solo y = Solo (x <> y)++-- See Data.List.Linear for instance ... => Semigroup [a]++instance (Consumable a, Consumable b) => Semigroup (Either a b) where+ Left x <> y = x `lseq` y+ x <> y =+ y & \case+ Left y' -> y' `lseq` x+ Right y' -> y' `lseq` x++-- Cannot add instance Semigroup a => Semigroup (Op a b); would require Dupable b++instance Semigroup (Proxy a) where+ Proxy <> Proxy = Proxy++-- Cannot add instance Semigroup a => Semigroup (ST s a); I think that it would require a linear ST monad+-- Cannot add instance Semigroup b => Semigroup (a -> b); would require Dupable a++instance (Semigroup a, Semigroup b) => Semigroup (a, b) where+ (x1, x2) <> (y1, y2) = (x1 <> y1, x2 <> y2)++instance Semigroup a => Semigroup (Const a b) where+ Const x <> Const y = Const (x <> y)++-- See Data.Functor.Linear.Applicative for instance ... => Semigroup (Ap f a)+-- Cannot add instance Alternative f => Semigroup (Alt f a); we don't have a linear Alternative++instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where+ (x1, x2, x3) <> (y1, y2, y3) = (x1 <> y1, x2 <> y2, x3 <> y3)++instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Functor.Product f g a) where+ Functor.Pair x1 x2 <> Functor.Pair y1 y2 = Functor.Pair (x1 <> y1) (x2 <> y2)++instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) => Semigroup (a, b, c, d) where+ (x1, x2, x3, x4) <> (y1, y2, y3, y4) = (x1 <> y1, x2 <> y2, x3 <> y3, x4 <> y4)++instance (Semigroup (f (g a))) => Semigroup (Functor.Compose f g a) where+ Functor.Compose x <> Functor.Compose y = Functor.Compose (x <> y)++instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) => Semigroup (a, b, c, d, e) where+ (x1, x2, x3, x4, x5) <> (y1, y2, y3, y4, y5) = (x1 <> y1, x2 <> y2, x3 <> y3, x4 <> y4, x5 <> y5)
src/Data/Num/Linear.hs view
@@ -2,9 +2,9 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE StandaloneDeriving #-}-+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | This module provides a linear 'Num' class with instances. -- Import this module to use linear versions of @(+)@, @(-)@, etc, on numeric@@ -20,30 +20,32 @@ -- * (AddIdentity ∩ MultIdentity) ⊆ Semiring -- * (AdditiveGroup ∩ Semiring) ⊆ Ring -- * (FromInteger ∩ Ring) ⊆ Num--- module Data.Num.Linear- (- -- * Num and sub-classes- Num(..)- , Additive(..)- , AddIdentity(..)- , AdditiveGroup(..)- , Multiplicative(..)- , MultIdentity(..)- , Semiring- , Ring- , FromInteger(..)- -- * Mechanisms for deriving instances- , Adding(..), getAdded- , Multiplying(..), getMultiplied+ ( -- * Num and sub-classes+ Num (..),+ Additive (..),+ AddIdentity (..),+ AdditiveGroup (..),+ Multiplicative (..),+ MultIdentity (..),+ Semiring,+ Ring,+ FromInteger (..),++ -- * Mechanisms for deriving instances+ Adding (..),+ getAdded,+ Multiplying (..),+ getMultiplied, )- where+where -- TODO: flesh out laws-import qualified Prelude++import Data.Monoid.Linear import Data.Unrestricted.Linear import qualified Unsafe.Linear as Unsafe-import Data.Monoid.Linear+import qualified Prelude -- | A type that can be added linearly. The operation @(+)@ is associative and -- commutative, i.e., for all @a@, @b@, @c@@@ -51,7 +53,8 @@ -- > (a + b) + c = a + (b + c) -- > a + b = b + c class Additive a where- (+) :: a %1-> a %1-> a+ (+) :: a %1 -> a %1 -> a+ infixl 6 + -- same fixity as base.+ -- | An 'Additive' type with an identity on @(+)@. class Additive a => AddIdentity a where@@ -61,16 +64,18 @@ -- the laws of an [abelian group](https://en.wikipedia.org/wiki/Abelian_group) class AddIdentity a => AdditiveGroup a where {-# MINIMAL negate | (-) #-}- negate :: a %1-> a+ negate :: a %1 -> a negate x = zero - x- (-) :: a %1-> a %1-> a+ (-) :: a %1 -> a %1 -> a+ infixl 6 - -- same fixity as base.- x - y = x + negate y -- | A numeric type with an associative @(*)@ operation class Multiplicative a where- (*) :: a %1-> a %1-> a+ (*) :: a %1 -> a %1 -> a+ infixl 7 * -- same fixity as base.* --- | A 'Multipcative' type with an identity for @(*)@+-- | A 'Multiplicative' type with an identity for @(*)@ class Multiplicative a => MultIdentity a where one :: a @@ -80,7 +85,7 @@ -- -- > zero * x = zero -- > a * (b + c) = (a * b) + (a * c)-class (AddIdentity a, MultIdentity a) => Semiring a where+class (AddIdentity a, MultIdentity a) => Semiring a -- Note: -- Having a linear (*) means we can't short-circuit multiplication by zero@@ -88,8 +93,7 @@ -- | A 'Ring' instance is a numeric type with @(+)@, @(-)@, @(*)@ and all -- the following properties: a group with @(+)@ and a 'MultIdentity' with @(*)@ -- along with distributive laws.-class (AdditiveGroup a, Semiring a) => Ring a where-+class (AdditiveGroup a, Semiring a) => Ring a -- | A numeric type that 'Integer's can be embedded into while satisfying -- all the typeclass laws @Integer@s obey. That is, if there's some property@@ -99,14 +103,15 @@ -- -- For mathy folk: @fromInteger@ should be a homomorphism over @(+)@ and @(*)@. class FromInteger a where- fromInteger :: Prelude.Integer %1-> a+ fromInteger :: Prelude.Integer %1 -> a -- XXX: subclass of Prelude.Num? subclass of Eq? class (Ring a, FromInteger a) => Num a where {-# MINIMAL abs, signum #-}+ -- XXX: is it fine to insist abs,signum are linear? I think it is- abs :: a %1-> a- signum :: a %1-> a+ abs :: a %1 -> a+ signum :: a %1 -> a newtype MovableNum a = MovableNum a deriving (Consumable, Dupable, Movable, Prelude.Num)@@ -126,9 +131,10 @@ instance (Movable a, Prelude.Num a) => MultIdentity (MovableNum a) where one = MovableNum 1 -instance (Movable a, Prelude.Num a) => Semiring (MovableNum a) where-instance (Movable a, Prelude.Num a) => Ring (MovableNum a) where+instance (Movable a, Prelude.Num a) => Semiring (MovableNum a) +instance (Movable a, Prelude.Num a) => Ring (MovableNum a)+ instance (Movable a, Prelude.Num a) => FromInteger (MovableNum a) where fromInteger = Unsafe.toLinear Prelude.fromInteger @@ -136,57 +142,104 @@ abs = liftU Prelude.abs signum = liftU Prelude.signum -liftU :: (Movable a) => (a -> b) %1-> (a %1-> b)+liftU :: (Movable a) => (a -> b) %1 -> (a %1 -> b) liftU f x = lifted f (move x)- where lifted :: (a -> b) %1-> (Ur a %1-> b)- lifted g (Ur a) = g a+ where+ lifted :: (a -> b) %1 -> (Ur a %1 -> b)+ lifted g (Ur a) = g a -liftU2 :: (Movable a, Movable b) => (a -> b -> c) %1-> (a %1-> b %1-> c)+liftU2 :: (Movable a, Movable b) => (a -> b -> c) %1 -> (a %1 -> b %1 -> c) liftU2 f x y = lifted f (move x) (move y)- where lifted :: (a -> b -> c) %1-> (Ur a %1-> Ur b %1-> c)- lifted g (Ur a) (Ur b) = g a b+ where+ lifted :: (a -> b -> c) %1 -> (Ur a %1 -> Ur b %1 -> c)+ lifted g (Ur a) (Ur b) = g a b --- A newtype wrapper to give the underlying monoid for an additive structure.+-- | A newtype wrapper to give the underlying monoid for an additive structure.+--+-- Deprecated because 'Data.Semigroup.Sum' (reexported as+-- 'Data.Monoid.Linear.Sum') now has a linear 'Semigroup' and+-- 'Data.Monoid.Linear.Monoid' instance. newtype Adding a = Adding a- deriving Prelude.Semigroup via NonLinear (Adding a)+ deriving (Prelude.Eq, Prelude.Ord, Prelude.Show)+ deriving (Prelude.Semigroup) via NonLinear (Adding a)+ deriving (Prelude.Monoid) via NonLinear (Adding a)+{-# DEPRECATED Adding "Use 'Data.Semigroup.Sum' (reexported as 'Data.Monoid.Linear.Sum') instead" #-} -getAdded :: Adding a %1-> a+getAdded :: Adding a %1 -> a getAdded (Adding x) = x+{-# DEPRECATED getAdded "Use 'Data.Semigroup.Sum' (reexported as 'Data.Monoid.Linear.Sum') and pattern-match to extract the inner value linearly" #-} instance Additive a => Semigroup (Adding a) where Adding a <> Adding b = Adding (a + b)-instance AddIdentity a => Prelude.Monoid (Adding a) where++instance AddIdentity a => Monoid (Adding a) where mempty = Adding zero-instance AddIdentity a => Monoid (Adding a) --- A newtype wrapper to give the underlying monoid for a multiplicative structure.+-- | A newtype wrapper to give the underlying monoid for a multiplicative structure.+--+-- Deprecated because 'Data.Semigroup.Product' (reexported as+-- 'Data.Monoid.Linear.Product') now has a linear 'Semigroup' and+-- 'Data.Monoid.Linear.Monoid' instance. newtype Multiplying a = Multiplying a- deriving Prelude.Semigroup via NonLinear (Multiplying a)+ deriving (Prelude.Eq, Prelude.Ord, Prelude.Show)+ deriving (Prelude.Semigroup) via NonLinear (Multiplying a)+ deriving (Prelude.Monoid) via NonLinear (Multiplying a)+{-# DEPRECATED Multiplying "Use 'Data.Semigroup.Product' (reexported as 'Data.Monoid.Linear.Product') instead" #-} -getMultiplied :: Multiplying a %1-> a+getMultiplied :: Multiplying a %1 -> a getMultiplied (Multiplying x) = x+{-# DEPRECATED getMultiplied "Use 'Data.Semigroup.Product' (reexported as 'Data.Monoid.Linear.Product') and pattern-match to extract the inner value linearly" #-} instance Multiplicative a => Semigroup (Multiplying a) where Multiplying a <> Multiplying b = Multiplying (a * b)-instance MultIdentity a => Prelude.Monoid (Multiplying a) where++instance MultIdentity a => Monoid (Multiplying a) where mempty = Multiplying one-instance MultIdentity a => Monoid (Multiplying a) +instance Multiplicative a => Semigroup (Product a) where+ (Product x) <> (Product y) = Product (x * y)++instance Additive a => Semigroup (Sum a) where+ (Sum x) <> (Sum y) = Sum (x + y)++instance MultIdentity a => Monoid (Product a) where+ mempty = Product one++instance AddIdentity a => Monoid (Sum a) where+ mempty = Sum zero+ deriving via MovableNum Prelude.Int instance Additive Prelude.Int+ deriving via MovableNum Prelude.Double instance Additive Prelude.Double+ deriving via MovableNum Prelude.Int instance AddIdentity Prelude.Int+ deriving via MovableNum Prelude.Double instance AddIdentity Prelude.Double+ deriving via MovableNum Prelude.Int instance AdditiveGroup Prelude.Int+ deriving via MovableNum Prelude.Double instance AdditiveGroup Prelude.Double+ deriving via MovableNum Prelude.Int instance Multiplicative Prelude.Int+ deriving via MovableNum Prelude.Double instance Multiplicative Prelude.Double+ deriving via MovableNum Prelude.Int instance MultIdentity Prelude.Int+ deriving via MovableNum Prelude.Double instance MultIdentity Prelude.Double+ deriving via MovableNum Prelude.Int instance Semiring Prelude.Int+ deriving via MovableNum Prelude.Double instance Semiring Prelude.Double+ deriving via MovableNum Prelude.Int instance Ring Prelude.Int+ deriving via MovableNum Prelude.Double instance Ring Prelude.Double+ deriving via MovableNum Prelude.Int instance FromInteger Prelude.Int+ deriving via MovableNum Prelude.Double instance FromInteger Prelude.Double+ deriving via MovableNum Prelude.Int instance Num Prelude.Int+ deriving via MovableNum Prelude.Double instance Num Prelude.Double
src/Data/Ord/Linear.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} module Data.Ord.Linear- ( module Data.Ord.Linear.Internal.Ord- , module Data.Ord.Linear.Internal.Eq- ) where+ ( module Data.Ord.Linear.Internal.Ord,+ module Data.Ord.Linear.Internal.Eq,+ )+where -import Data.Ord.Linear.Internal.Ord import Data.Ord.Linear.Internal.Eq-+import Data.Ord.Linear.Internal.Ord
src/Data/Ord/Linear/Internal/Eq.hs view
@@ -1,19 +1,20 @@-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LinearTypes #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} -- | This module provides a linear 'Eq' class for testing equality between -- values, along with standard instances. module Data.Ord.Linear.Internal.Eq- ( Eq(..)+ ( Eq (..), )- where+where import Data.Bool.Linear-import qualified Prelude-import Prelude.Linear.Internal import Data.Unrestricted.Linear+import Prelude.Linear.Internal+import qualified Prelude -- | Testing equality on values. --@@ -24,14 +25,14 @@ -- * @x == y@ implies @y == x@ -- * @x == y@ and @y == z@ implies @x == z@ -- * @(x == y)@ ≌ @not (x /= y)@--- class Eq a where {-# MINIMAL (==) | (/=) #-}- (==) :: a %1-> a %1-> Bool+ (==) :: a %1 -> a %1 -> Bool x == y = not (x /= y)- (/=) :: a %1-> a %1-> Bool+ infix 4 == -- same fixity as base.==+ (/=) :: a %1 -> a %1 -> Bool x /= y = not (x == y)- infix 4 ==, /=+ infix 4 /= -- same fixity as base./= -- * Instances @@ -41,7 +42,7 @@ instance (Consumable a, Eq a) => Eq [a] where [] == [] = True- (x:xs) == (y:ys) = x == y && xs == ys+ (x : xs) == (y : ys) = x == y && xs == ys xs == ys = (xs, ys) `lseq` False instance (Consumable a, Eq a) => Eq (Prelude.Maybe a) where@@ -49,8 +50,10 @@ Prelude.Just x == Prelude.Just y = x == y x == y = (x, y) `lseq` False -instance (Consumable a, Consumable b, Eq a, Eq b)- => Eq (Prelude.Either a b) where+instance+ (Consumable a, Consumable b, Eq a, Eq b) =>+ Eq (Prelude.Either a b)+ where Prelude.Left x == Prelude.Left y = x == y Prelude.Right x == Prelude.Right y = x == y x == y = (x, y) `lseq` False@@ -68,20 +71,24 @@ a == a' && b == b' && c == c' && d == d' deriving via MovableEq () instance Eq ()+ deriving via MovableEq Prelude.Int instance Eq Prelude.Int+ deriving via MovableEq Prelude.Double instance Eq Prelude.Double+ deriving via MovableEq Prelude.Bool instance Eq Prelude.Bool+ deriving via MovableEq Prelude.Char instance Eq Prelude.Char+ deriving via MovableEq Prelude.Ordering instance Eq Prelude.Ordering newtype MovableEq a = MovableEq a instance (Prelude.Eq a, Movable a) => Eq (MovableEq a) where- MovableEq ar == MovableEq br- = move (ar, br) & \(Ur (a, b)) ->- a Prelude.== b-- MovableEq ar /= MovableEq br- = move (ar, br) & \(Ur (a, b)) ->- a Prelude./= b+ MovableEq ar == MovableEq br =+ move (ar, br) & \(Ur (a, b)) ->+ a Prelude.== b + MovableEq ar /= MovableEq br =+ move (ar, br) & \(Ur (a, b)) ->+ a Prelude./= b
src/Data/Ord/Linear/Internal/Ord.hs view
@@ -1,24 +1,25 @@-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} module Data.Ord.Linear.Internal.Ord- ( Ord(..)- , Ordering(..)- , min- , max+ ( Ord (..),+ Ordering (..),+ min,+ max, )- where+where +import Data.Bool.Linear (Bool (..), not)+import Data.Monoid.Linear+import Data.Ord (Ordering (..)) import Data.Ord.Linear.Internal.Eq-import qualified Prelude-import Prelude.Linear.Internal-import Data.Ord (Ordering(..))-import Data.Bool.Linear ( Bool (..), not ) import Data.Unrestricted.Linear-import Data.Monoid.Linear+import Prelude.Linear.Internal+import qualified Prelude -- | Linear Orderings --@@ -44,42 +45,47 @@ -- | @compare x y@ returns an @Ordering@ which is -- one of @GT@ (greater than), @EQ@ (equal), or @LT@ (less than) -- which should be understood as \"x is @(compare x y)@ y\".- compare :: a %1-> a %1-> Ordering+ compare :: a %1 -> a %1 -> Ordering - (<=) :: a %1-> a %1-> Bool+ -- /!\ `compare` doesn't have a specified fixity in base+ -- but we chose infix 4 for consistency with `elem`, <, <=, ==, /= ...+ infix 4 `compare`++ (<=) :: a %1 -> a %1 -> Bool x <= y = not (x > y)+ infix 4 <= -- same fixity as base.<= - (<) :: a %1-> a %1-> Bool+ (<) :: a %1 -> a %1 -> Bool x < y = compare x y == LT+ infix 4 < -- same fixity as base.< - (>) :: a %1-> a %1-> Bool+ (>) :: a %1 -> a %1 -> Bool x > y = compare x y == GT+ infix 4 > -- same fixity as base.> - (>=) :: a %1-> a %1-> Bool+ (>=) :: a %1 -> a %1 -> Bool x >= y = not (x < y)-- infix 4 <=, <, >, >=-+ infix 4 >= -- same fixity as base.>= -- | @max x y@ returns the larger input, or 'y' -- in case of a tie.-max :: (Dupable a, Ord a) => a %1-> a %1-> a+max :: (Dupable a, Ord a) => a %1 -> a %1 -> a max x y = dup2 x & \(x', x'') -> dup2 y & \(y', y'') -> if x' <= y'- then x'' `lseq` y''- else y'' `lseq` x''+ then x'' `lseq` y''+ else y'' `lseq` x'' -- | @min x y@ returns the smaller input, or 'y' -- in case of a tie.-min :: (Dupable a, Ord a) => a %1-> a %1-> a+min :: (Dupable a, Ord a) => a %1 -> a %1 -> a min x y = dup2 x & \(x', x'') -> dup2 y & \(y', y'') -> if x' <= y'- then y'' `lseq` x''- else x'' `lseq` y''+ then y'' `lseq` x''+ else x'' `lseq` y'' -- * Instances @@ -92,19 +98,21 @@ Prelude.Just x `compare` Prelude.Nothing = x `lseq` GT Prelude.Just x `compare` Prelude.Just y = x `compare` y -instance (Consumable a, Consumable b, Ord a, Ord b)- => Ord (Prelude.Either a b) where+instance+ (Consumable a, Consumable b, Ord a, Ord b) =>+ Ord (Prelude.Either a b)+ where Prelude.Left x `compare` Prelude.Right y = (x, y) `lseq` LT Prelude.Right x `compare` Prelude.Left y = (x, y) `lseq` GT Prelude.Left x `compare` Prelude.Left y = x `compare` y Prelude.Right x `compare` Prelude.Right y = x `compare` y instance (Consumable a, Ord a) => Ord [a] where- {-# SPECIALISE instance Ord [Prelude.Char] #-}+ {-# SPECIALIZE instance Ord [Prelude.Char] #-} compare [] [] = EQ compare xs [] = xs `lseq` GT compare [] ys = ys `lseq` LT- compare (x:xs) (y:ys) =+ compare (x : xs) (y : ys) = compare x y & \case EQ -> compare xs ys res -> (xs, ys) `lseq` res@@ -122,25 +130,29 @@ compare a a' <> compare b b' <> compare c c' <> compare d d' deriving via MovableOrd () instance Ord ()+ deriving via MovableOrd Prelude.Int instance Ord Prelude.Int+ deriving via MovableOrd Prelude.Double instance Ord Prelude.Double+ deriving via MovableOrd Prelude.Bool instance Ord Prelude.Bool+ deriving via MovableOrd Prelude.Char instance Ord Prelude.Char+ deriving via MovableOrd Prelude.Ordering instance Ord Prelude.Ordering newtype MovableOrd a = MovableOrd a instance (Prelude.Eq a, Movable a) => Eq (MovableOrd a) where- MovableOrd ar == MovableOrd br- = move (ar, br) & \(Ur (a, b)) ->- a Prelude.== b+ MovableOrd ar == MovableOrd br =+ move (ar, br) & \(Ur (a, b)) ->+ a Prelude.== b - MovableOrd ar /= MovableOrd br- = move (ar, br) & \(Ur (a, b)) ->- a Prelude./= b+ MovableOrd ar /= MovableOrd br =+ move (ar, br) & \(Ur (a, b)) ->+ a Prelude./= b instance (Prelude.Ord a, Movable a) => Ord (MovableOrd a) where- MovableOrd ar `compare` MovableOrd br- = move (ar, br) & \(Ur (a, b)) ->- a `Prelude.compare` b-+ MovableOrd ar `compare` MovableOrd br =+ move (ar, br) & \(Ur (a, b)) ->+ a `Prelude.compare` b
src/Data/Profunctor/Kleisli/Linear.hs view
@@ -3,8 +3,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | This module provides (linear) Kleisli and CoKleisli arrows --@@ -17,7 +17,7 @@ -- The basic idea is that a Kleisli arrow is like a function arrow -- and @Kleisli m a b@ is similar to a function from @a@ to @b@. Basically: ----- > type Kleisli m a b = a #-> m b+-- > type Kleisli m a b = a %1-> m b -- -- == Why make this definition? --@@ -31,19 +31,18 @@ -- A CoKleisli arrow is just one that represents a computation from -- a @m a@ to an @a@ via a linear arrow. (It's a Co-something because it -- reverses the order of the function arrows in the something.)--- module Data.Profunctor.Kleisli.Linear- ( Kleisli(..)- , CoKleisli(..)+ ( Kleisli (..),+ CoKleisli (..), )- where+where +import qualified Control.Functor.Linear as Control+import qualified Data.Functor.Linear as Data import Data.Profunctor.Linear import Data.Void-import Prelude.Linear (Either(..), either)+import Prelude.Linear (Either (..), either) import Prelude.Linear.Internal-import qualified Control.Functor.Linear as Control-import qualified Data.Functor.Linear as Data -- Ideally, there would only be one Kleisli arrow, parametrised by -- a multiplicity parameter:@@ -55,21 +54,21 @@ -- | Linear Kleisli arrows for the monad `m`. These arrows are still useful -- in the case where `m` is not a monad however, and some profunctorial -- properties still hold in this weaker setting.-newtype Kleisli m a b = Kleisli { runKleisli :: a %1-> m b }+newtype Kleisli m a b = Kleisli {runKleisli :: a %1 -> m b} instance Data.Functor f => Profunctor (Kleisli f) where dimap f g (Kleisli h) = Kleisli (Data.fmap g . h . f) instance Control.Functor f => Strong (,) () (Kleisli f) where- first (Kleisli f) = Kleisli (\(a,b) -> (,b) Control.<$> f a)- second (Kleisli g) = Kleisli (\(a,b) -> (a,) Control.<$> g b)+ first (Kleisli f) = Kleisli (\(a, b) -> (,b) Control.<$> f a)+ second (Kleisli g) = Kleisli (\(a, b) -> (a,) Control.<$> g b) instance Control.Applicative f => Strong Either Void (Kleisli f) where- first (Kleisli f) = Kleisli (either (Data.fmap Left . f) (Control.pure . Right))+ first (Kleisli f) = Kleisli (either (Data.fmap Left . f) (Control.pure . Right)) second (Kleisli g) = Kleisli (either (Control.pure . Left) (Data.fmap Right . g)) instance Data.Applicative f => Monoidal (,) () (Kleisli f) where- Kleisli f *** Kleisli g = Kleisli $ \(x,y) -> (,) Data.<$> f x Data.<*> g y+ Kleisli f *** Kleisli g = Kleisli $ \(x, y) -> (,) Data.<$> f x Data.<*> g y unit = Kleisli $ \() -> Data.pure () instance Data.Functor f => Monoidal Either Void (Kleisli f) where@@ -86,7 +85,7 @@ -- profunctorial properties still hold in this weaker setting. -- However stronger requirements on `f` are needed for profunctorial -- strength, so we have fewer instances.-newtype CoKleisli w a b = CoKleisli { runCoKleisli :: w a %1-> b }+newtype CoKleisli w a b = CoKleisli {runCoKleisli :: w a %1 -> b} instance Data.Functor f => Profunctor (CoKleisli f) where dimap f g (CoKleisli h) = CoKleisli (g . h . Data.fmap f)
src/Data/Profunctor/Linear.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | This module provides profunctor classes and instances. --@@ -22,29 +23,29 @@ -- * @Strong@ and @Wandering@ are classes drawn from -- [this paper](https://www.cs.ox.ac.uk/jeremy.gibbons/publications/proyo.pdf) -- * 'Exchange' and 'Market' are ways of encoding isomorphisms and prisms--- module Data.Profunctor.Linear- ( Profunctor(..)- , Monoidal(..)- , Strong(..)- , Wandering(..)- , LinearArrow(..), getLA- , Exchange(..)- , Market(..), runMarket- ) where+ ( Profunctor (..),+ Monoidal (..),+ Strong (..),+ Wandering (..),+ Exchange (..),+ Market (..),+ runMarket,+ )+where +import Control.Arrow (Kleisli (..)) import qualified Control.Functor.Linear as Control-import Data.Bifunctor.Linear hiding (first, second) import qualified Data.Bifunctor as Prelude+import Data.Bifunctor.Linear hiding (first, second) import Data.Functor.Identity+import Data.Kind (FUN, Type)+import Data.Void+import GHC.Types (Multiplicity (One)) import Prelude.Linear import Prelude.Linear.Internal (runIdentity')-import Data.Kind (Type)-import Data.Void import qualified Prelude-import Control.Arrow (Kleisli(..)) - -- | A Profunctor can be thought of as a computation that involves taking -- @a@(s) as input and returning @b@(s). These computations compose with -- (linear) functions. Profunctors generalize the function arrow @->@.@@ -58,19 +59,18 @@ -- > lmap (f . g) = lmap f . lmap g -- > rmap id = id -- > rmap (f . g) = rmap f . rmap g--- class Profunctor (arr :: Type -> Type -> Type) where {-# MINIMAL dimap | lmap, rmap #-} - dimap :: (s %1-> a) -> (b %1-> t) -> a `arr` b -> s `arr` t+ dimap :: (s %1 -> a) -> (b %1 -> t) -> a `arr` b -> s `arr` t dimap f g x = lmap f (rmap g x) {-# INLINE dimap #-} - lmap :: (s %1-> a) -> a `arr` t -> s `arr` t+ lmap :: (s %1 -> a) -> a `arr` t -> s `arr` t lmap f = dimap f id {-# INLINE lmap #-} - rmap :: (b %1-> t) -> s `arr` b -> s `arr` t+ rmap :: (b %1 -> t) -> s `arr` b -> s `arr` t rmap = dimap id {-# INLINE rmap #-} @@ -80,6 +80,7 @@ -- with the bifunctor @m@. class (SymmetricMonoidal m u, Profunctor arr) => Monoidal m u arr where (***) :: a `arr` b -> x `arr` y -> (a `m` x) `arr` (b `m` y)+ infixr 3 *** -- same fixity as base.*** unit :: u `arr` u -- | A @(Strong m u arr)@ instance means that the function-like thing@@ -126,63 +127,60 @@ -- where @HasKleisliFunctor@ or @HasKleisliApplicative@ are some constraints -- which allow for the @arr@ to be @Kleisli f@ for control functors -- or applicatives @f@.--- class (Strong (,) () arr, Strong Either Void arr) => Wandering arr where -- | Equivalently but less efficient in general: -- -- > wander :: Data.Traversable f => a `arr` b -> f a `arr` f b- wander :: forall s t a b. (forall f. Control.Applicative f => (a %1-> f b) -> s %1-> f t) -> a `arr` b -> s `arr` t+ wander :: forall s t a b. (forall f. Control.Applicative f => (a %1 -> f b) -> s %1 -> f t) -> a `arr` b -> s `arr` t --------------- -- Instances -- --------------- --- | This newtype is needed to implement 'Profunctor' instances of @#->@.-newtype LinearArrow a b = LA (a %1-> b)---- | Temporary deconstructor since inference doesn't get it right-getLA :: LinearArrow a b %1-> a %1-> b-getLA (LA f) = f--instance Profunctor LinearArrow where- dimap f g (LA h) = LA $ g . h . f+instance Profunctor (FUN 'One) where+ dimap f g h = g . h . f -instance Strong (,) () LinearArrow where- first (LA f) = LA $ \(a,b) -> (f a, b)- second (LA g) = LA $ \(a,b) -> (a, g b)+instance Strong (,) () (FUN 'One) where+ first f (a, b) = (f a, b)+ second g (a, b) = (a, g b) -instance Strong Either Void LinearArrow where- first (LA f) = LA $ either (Left . f) Right- second (LA g) = LA $ either Left (Right . g)+instance Strong Either Void (FUN 'One) where+ first f = either (Left . f) Right+ second g = either Left (Right . g) -instance Wandering LinearArrow where- wander f (LA a_to_b) = LA $ \s -> runIdentity' $ f (Identity . a_to_b) s+instance Wandering (FUN 'One) where+ wander f a_to_b s = runIdentity' $ f (Identity . a_to_b) s -instance Monoidal (,) () LinearArrow where- LA f *** LA g = LA $ \(a,x) -> (f a, g x)- unit = LA id+instance Monoidal (,) () (FUN 'One) where+ (f *** g) (a, x) = (f a, g x)+ unit = id -instance Monoidal Either Void LinearArrow where- LA f *** LA g = LA $ bimap f g- unit = LA $ \case {}+instance Monoidal Either Void (FUN 'One) where+ f *** g = bimap f g+ unit = \case {} instance Profunctor (->) where dimap f g h x = g (h (f x))+ instance Strong (,) () (->) where first f (x, y) = (f x, y)+ instance Strong Either Void (->) where first f (Left x) = Left (f x) first _ (Right y) = Right y+ instance Monoidal (,) () (->) where- (f *** g) (a,x) = (f a, g x)+ (f *** g) (a, x) = (f a, g x) unit () = ()+ instance Monoidal Either Void (->) where f *** g = Prelude.bimap f g unit = \case {} -- | An exchange is a pair of translation functions that encode an -- isomorphism; an @Exchange a b s t@ is equivalent to a @Iso a b s t@.-data Exchange a b s t = Exchange (s %1-> a) (b %1-> t)+data Exchange a b s t = Exchange (s %1 -> a) (b %1 -> t)+ instance Profunctor (Exchange a b) where dimap f g (Exchange p q) = Exchange (p . f) (g . q) @@ -190,16 +188,16 @@ dimap f g (Kleisli h) = Kleisli (\x -> forget g Prelude.<$> h (f x)) instance Prelude.Functor f => Strong (,) () (Kleisli f) where- first (Kleisli f) = Kleisli (\(a,b) -> (,b) Prelude.<$> f a)- second (Kleisli g) = Kleisli (\(a,b) -> (a,) Prelude.<$> g b)+ first (Kleisli f) = Kleisli (\(a, b) -> (,b) Prelude.<$> f a)+ second (Kleisli g) = Kleisli (\(a, b) -> (a,) Prelude.<$> g b) instance Prelude.Applicative f => Strong Either Void (Kleisli f) where- first (Kleisli f) = Kleisli $ \case- Left x -> Prelude.fmap Left (f x)- Right y -> Prelude.pure (Right y)+ first (Kleisli f) = Kleisli $ \case+ Left x -> Prelude.fmap Left (f x)+ Right y -> Prelude.pure (Right y) instance Prelude.Applicative f => Monoidal (,) () (Kleisli f) where- Kleisli f *** Kleisli g = Kleisli (\(x,y) -> (,) Prelude.<$> f x Prelude.<*> g y)+ Kleisli f *** Kleisli g = Kleisli (\(x, y) -> (,) Prelude.<$> f x Prelude.<*> g y) unit = Kleisli Prelude.pure instance Prelude.Functor f => Monoidal Either Void (Kleisli f) where@@ -210,8 +208,9 @@ -- | A market is a pair of constructor and deconstructor functions that encode -- a prism; a @Market a b s t@ is equivalent to a @Prism a b s t@.-data Market a b s t = Market (b %1-> t) (s %1-> Either t a)-runMarket :: Market a b s t %1-> (b %1-> t, s %1-> Either t a)+data Market a b s t = Market (b %1 -> t) (s %1 -> Either t a)++runMarket :: Market a b s t %1 -> (b %1 -> t, s %1 -> Either t a) runMarket (Market f g) = (f, g) instance Profunctor (Market a b) where
+ src/Data/Replicator/Linear.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | This module defines a stream-like type named 'Replicator', which is+-- mainly used in the definition of the 'Data.Unrestricted.Dupable' class+-- to provide efficient linear duplication.+-- The API of 'Replicator' is close to the one of an infinite stream: it+-- can either produce a new value linearly (with 'next' or 'next#'), or be+-- linearly discarded (with 'consume' or 'extract').+--+-- A crucial aspect, from a performance standpoint, is that the 'pure' function+-- (which takes an unrestricted argument) is implemented efficiently: the+-- 'Replicator' returns /the same/ value on each call to 'next'. That is, the+-- pointer is always shared. This will allow 'Data.Unrestricted.Movable' types+-- to be given an efficient instance of 'Data.Unrestricted.Dupable'. Instances+-- of both 'Data.Unrestricted.Movable' and 'Data.Unrestricted.Dupable' typically+-- involve deep copies. The implementation of 'pure' lets us make sure that, for+-- @Movable@ types, only one deep copy is performed, rather than one per+-- additional replica.+--+-- Strictly speaking, the implementation of '(<*>)' plays a role in all this as+-- well:+-- For two 'pure' 'Replicators' @fs@ and @as@, @fs \<*\> as@ is a pure+-- 'Replicator'. Together, 'pure' and '(<*>)' form the+-- 'Data.Functor.Linear.Applicative' instance of 'Replicator'.+module Data.Replicator.Linear+ ( Replicator,+ consume,+ duplicate,+ map,+ pure,+ (<*>),+ next,+ next#,+ take,+ extract,+ extend,+ Elim,+ elim,+ )+where++import Data.Replicator.Linear.Internal+import Data.Replicator.Linear.Internal.Instances ()
+ src/Data/Replicator/Linear/Internal.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Replicator.Linear.Internal+ ( Replicator (..),+ consume,+ duplicate,+ map,+ pure,+ (<*>),+ liftA2,+ next,+ next#,+ take,+ extract,+ extend,+ Elim,+ elim,+ )+where++import Data.Arity.Linear.Internal+import Data.Kind (Constraint, Type)+import Data.Replicator.Linear.Internal.ReplicationStream (ReplicationStream (..))+import qualified Data.Replicator.Linear.Internal.ReplicationStream as ReplicationStream+import GHC.TypeLits+import Prelude.Linear.Internal+import Prelude ((-))+import qualified Prelude++-- | 'Replicator' is a stream-like data structure used to linearly duplicate+-- values.+data Replicator a where+ Moved :: a -> Replicator a+ Streamed :: ReplicationStream a %1 -> Replicator a++consume :: Replicator a %1 -> ()+consume (Moved _) = ()+consume (Streamed stream) = ReplicationStream.consume stream+{-# INLINEABLE consume #-}++duplicate :: Replicator a %1 -> Replicator (Replicator a)+duplicate = \case+ Moved x -> Moved (Moved x)+ Streamed stream -> Streamed $ ReplicationStream.map Streamed (ReplicationStream.duplicate stream)++map :: (a %1 -> b) -> Replicator a %1 -> Replicator b+map f = \case+ Moved x -> Moved (f x)+ Streamed stream -> Streamed $ ReplicationStream.map f stream++pure :: a -> Replicator a+pure = Moved++(<*>) :: Replicator (a %1 -> b) %1 -> Replicator a %1 -> Replicator b+Moved f <*> Moved x = Moved (f x)+Moved f <*> Streamed s = Streamed (ReplicationStream.map f s)+Streamed fs <*> Moved x = Streamed (ReplicationStream.map (\f -> f x) fs)+Streamed sf <*> Streamed sx = Streamed (sf ReplicationStream.<*> sx)++infixl 4 <*> -- same fixity as base.<*>++liftA2 :: (a %1 -> b %1 -> c) -> Replicator a %1 -> Replicator b %1 -> Replicator c+liftA2 f (Moved a) (Moved b) = Moved (f a b)+liftA2 f (Moved a) (Streamed s) = Streamed (ReplicationStream.map (f a) s)+liftA2 f (Streamed s) (Moved b) = Streamed (ReplicationStream.map (\a -> f a b) s)+liftA2 f (Streamed sa) (Streamed sb) = Streamed (ReplicationStream.liftA2 f sa sb)+-- We need to inline this to get good results with generic deriving of+-- Dupable.+{-# INLINE liftA2 #-}++-- | Extracts the next item from the \"infinite stream\" @'Replicator' a@.+next :: Replicator a %1 -> (a, Replicator a)+next (Moved x) = (x, Moved x)+next (Streamed (ReplicationStream s give dups consumes)) =+ dups s & \case+ (s1, s2) -> (give s1, Streamed (ReplicationStream s2 give dups consumes))+{-# INLINEABLE next #-}++-- | Extracts the next item from the \"infinite stream\" @'Replicator' a@.+-- Same function as 'next', but returning an unboxed tuple.+next# :: Replicator a %1 -> (# a, Replicator a #)+next# (Moved x) = (# x, Moved x #)+next# (Streamed (ReplicationStream s give dups consumes)) =+ dups s & \case+ (s1, s2) -> (# give s1, Streamed (ReplicationStream s2 give dups consumes) #)+{-# INLINEABLE next# #-}++-- | @'take' n as@ is a list of size @n@, containing @n@ replicas from @as@.+take :: Prelude.Int -> Replicator a %1 -> [a]+take 0 r =+ consume r & \case+ () -> []+take 1 r = [extract r]+take n r =+ next r & \case+ (a, r') -> a : take (n - 1) r'++-- | Returns the next item from @'Replicator' a@ and efficiently consumes+-- the replicator at the same time.+extract :: Replicator a %1 -> a+extract (Moved x) = x+extract (Streamed (ReplicationStream s give _ _)) = give s+{-# INLINEABLE extract #-}++-- | Comonadic 'extend' function.+--+-- > extend f = map f . duplicate+extend :: (Replicator a %1 -> b) -> Replicator a %1 -> Replicator b+extend f = map f . duplicate++-- | Takes a function of type @a %1 -> a %1 -> ... %1 -> a %1 -> b@, and+-- returns a @b@ . The replicator is used to supply all the items of type @a@+-- required by the function.+--+-- For instance:+--+-- > elim @1 :: (a %1 -> b) %1 -> Replicator a %1 -> b+-- > elim @2 :: (a %1 -> a %1 -> b) %1 -> Replicator a %1 -> b+-- > elim @3 :: (a %1 -> a %1 -> a %1 -> b) %1 -> Replicator a %1 -> b+--+-- It is not always necessary to give the arity argument. It can be+-- inferred from the function argument.+--+-- > elim (,) :: Replicator a %1 -> (a, a)+-- > elim (,,) :: Replicator a %1 -> (a, a, a)+--+-- About the constraints of this function (they won't get in your way):+--+-- * @'Elim' ('NatToPeano' n) a b@ provides the actual implementation of 'elim'; there is an instance of this class for any @(n, a, b)@+-- * @'IsFunN' a b f, f ~ 'FunN' ('NatToPeano' n) a b, n ~ 'Arity' b f@ indicate the shape of @f@ to the typechecker (see documentation of 'IsFunN').+elim ::+ forall (n :: Nat) a b f.+ ( Elim (NatToPeano n) a b,+ IsFunN a b f,+ f ~ FunN (NatToPeano n) a b,+ n ~ Arity b f+ ) =>+ f %1 ->+ Replicator a %1 ->+ b+elim f r = elim' @(NatToPeano n) f r++-- | @'Elim' n a b@ is used to implement 'elim' without recursion+-- so that we can guarantee that 'elim' will be inlined and unrolled.+--+-- 'Elim' is solely used in the signature of 'elim'.+type Elim :: Peano -> Type -> Type -> Constraint+class Elim n a b where+ -- Note that 'elim' is, in particular, used to force eta-expansion of+ -- 'elim\''. Otherwise, 'elim\'' might not get inlined (see+ -- https://github.com/tweag/linear-base/issues/369).+ elim' :: FunN n a b %1 -> Replicator a %1 -> b++instance Elim 'Z a b where+ elim' b r =+ consume r & \case+ () -> b+ {-# INLINE elim' #-}++instance Elim ('S 'Z) a b where+ elim' f r = f (extract r)+ {-# INLINE elim' #-}++instance (Elim ('S n) a b) => Elim ('S ('S n)) a b where+ elim' g r =+ next r & \case+ (a, r') -> elim' @('S n) (g a) r'+ {-# INLINE elim' #-}
+ src/Data/Replicator/Linear/Internal/Instances.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS -Wno-orphans #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Replicator.Linear.Internal.Instances where++import qualified Data.Functor.Linear as Data+import Data.Replicator.Linear.Internal+import qualified Data.Replicator.Linear.Internal as Replicator+import Data.Replicator.Linear.Internal.ReplicationStream+import qualified Data.Replicator.Linear.Internal.ReplicationStream as ReplicationStream++instance Data.Functor ReplicationStream where+ fmap = ReplicationStream.map++instance Data.Applicative ReplicationStream where+ pure = ReplicationStream.pure+ f <*> x = f ReplicationStream.<*> x++instance Data.Functor Replicator where+ fmap = Replicator.map++instance Data.Applicative Replicator where+ pure = Replicator.pure+ f <*> x = f Replicator.<*> x+ liftA2 = Replicator.liftA2
+ src/Data/Replicator/Linear/Internal/ReplicationStream.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Replicator.Linear.Internal.ReplicationStream+ ( ReplicationStream (..),+ consume,+ duplicate,+ map,+ pure,+ (<*>),+ liftA2,+ )+where++import Data.Unrestricted.Linear.Internal.Ur+import Prelude.Linear.Internal++-- | @ReplicationStream s g dup2 c@ is the infinite linear stream+-- @repeat (g s)@ where @dup2@ is used to make as many copies of @s@ as+-- necessary, and @c@ is used to consume @s@ when consuming the stream.+--+-- Although it isn't enforced at type level, @dup2@ should abide by the same+-- laws as 'Data.Unrestricted.Linear.dup2':+-- * @first c (dup2 a) ≃ a ≃ second c (dup2 a)@ (neutrality)+-- * @first dup2 (dup2 a) ≃ (second dup2 (dup2 a))@ (associativity)+--+-- This type is solely used to implement 'Data.Replicator.Linear'+data ReplicationStream a where+ ReplicationStream ::+ s %1 ->+ (s %1 -> a) ->+ (s %1 -> (s, s)) ->+ (s %1 -> ()) ->+ ReplicationStream a++consume :: ReplicationStream a %1 -> ()+consume (ReplicationStream s _ _ consumes) = consumes s+{-# INLINEABLE consume #-}++duplicate :: ReplicationStream a %1 -> ReplicationStream (ReplicationStream a)+duplicate (ReplicationStream s give dups consumes) =+ ReplicationStream+ s+ (\s' -> ReplicationStream s' give dups consumes)+ dups+ consumes++map :: (a %1 -> b) -> ReplicationStream a %1 -> ReplicationStream b+map f (ReplicationStream s give dups consumes) =+ ReplicationStream s (f . give) dups consumes++pure :: a -> ReplicationStream a+pure x =+ ReplicationStream+ (Ur x)+ unur+ ( \case+ Ur x' -> (Ur x', Ur x')+ )+ ( \case+ Ur _ -> ()+ )++(<*>) :: ReplicationStream (a %1 -> b) %1 -> ReplicationStream a %1 -> ReplicationStream b+(ReplicationStream sf givef dupsf consumesf) <*> (ReplicationStream sx givex dupsx consumesx) =+ ReplicationStream+ (sf, sx)+ (\(sf', sx') -> givef sf' (givex sx'))+ ( \(sf', sx') ->+ (dupsf sf', dupsx sx') & \case+ ((sf1, sf2), (sx1, sx2)) -> ((sf1, sx1), (sf2, sx2))+ )+ ( \(sf', sx') ->+ consumesf sf' & \case+ () -> consumesx sx'+ )++liftA2 :: (a %1 -> b %1 -> c) -> ReplicationStream a %1 -> ReplicationStream b %1 -> ReplicationStream c+liftA2 f (ReplicationStream sa givea dupsa consumesa) (ReplicationStream sb giveb dupsb consumesb) =+ ReplicationStream+ (sa, sb)+ (\(sa', sb') -> f (givea sa') (giveb sb'))+ ( \(sa', sb') ->+ (dupsa sa', dupsb sb') & \case+ ((sa1, sa2), (sb1, sb2)) -> ((sa1, sb1), (sa2, sb2))+ )+ ( \(sa', sb') ->+ consumesa sa' & \case+ () -> consumesb sb'+ )+-- We need to inline this to get good results with generic deriving+-- of Dupable.+{-# INLINE liftA2 #-}++infixl 4 <*> -- same fixity as base.<*>
src/Data/Set/Mutable/Linear.hs view
@@ -1,12 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-} -- | -- This module defines linear mutable sets.@@ -31,76 +23,4 @@ ) where -import qualified Data.HashMap.Mutable.Linear as Linear-import qualified Prelude.Linear as Linear hiding (insert)-import Prelude (Int, Bool)-import qualified Prelude-import Data.Monoid.Linear-import Data.Unrestricted.Linear----- # Data Definitions------------------------------------------------------------------------------------ XXX This representation could be improved on with AVL trees, for example-newtype Set a = Set (Linear.HashMap a ())--type Keyed a = Linear.Keyed a----- # Constructors and Mutators----------------------------------------------------------------------------------empty :: Keyed a => Int -> (Set a %1-> Ur b) %1-> Ur b-empty s (f :: Set a %1-> Ur b) =- Linear.empty s (\hm -> f (Set hm))--toList :: Keyed a => Set a %1-> Ur [a]-toList (Set hm) =- Linear.toList hm- Linear.& \(Ur xs) -> Ur (Prelude.map Prelude.fst xs)--insert :: Keyed a => a -> Set a %1-> Set a-insert a (Set hmap) = Set (Linear.insert a () hmap)--delete :: Keyed a => a -> Set a %1-> Set a-delete a (Set hmap) = Set (Linear.delete a hmap)--union :: Keyed a => Set a %1-> Set a %1-> Set a-union (Set hm1) (Set hm2) =- Set (Linear.unionWith (\_ _ -> ()) hm1 hm2)--intersection :: Keyed a => Set a %1-> Set a %1-> Set a-intersection (Set hm1) (Set hm2) =- Set (Linear.intersectionWith (\_ _ -> ()) hm1 hm2)---- # Accessors----------------------------------------------------------------------------------size :: Keyed a => Set a %1-> (Ur Int, Set a)-size (Set hm) =- Linear.size hm Linear.& \(s, hm') -> (s, Set hm')--member :: Keyed a => a -> Set a %1-> (Ur Bool, Set a)-member a (Set hm) =- Linear.member a hm Linear.& \(b, hm') -> (b, Set hm')--fromList :: Keyed a => [a] -> (Set a %1-> Ur b) %1-> Ur b-fromList xs f =- Linear.fromList (Prelude.map (,()) xs) (\hm -> f (Set hm))---- # Typeclass Instances----------------------------------------------------------------------------------instance Prelude.Semigroup (Set a) where- (<>) = Prelude.error "Prelude.(<>): invariant violation, unrestricted Set"--instance Keyed a => Semigroup (Set a) where- (<>) = union--instance Consumable (Set a) where- consume (Set hmap) = consume hmap--instance Dupable (Set a) where- dup2 (Set hm) = dup2 hm Linear.& \(hm1, hm2) ->- (Set hm1, Set hm2)+import Data.Set.Mutable.Linear.Internal
+ src/Data/Set/Mutable/Linear/Internal.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Set.Mutable.Linear.Internal where++import qualified Data.HashMap.Mutable.Linear as Linear+import Data.Monoid.Linear+import Data.Unrestricted.Linear+import qualified Prelude.Linear as Linear hiding (insert)+import Prelude (Bool, Int)+import qualified Prelude++-- # Data Definitions+-------------------------------------------------------------------------------++-- XXX This representation could be improved on with AVL trees, for example+newtype Set a = Set (Linear.HashMap a ())++type Keyed a = Linear.Keyed a++-- # Constructors and Mutators+-------------------------------------------------------------------------------++empty :: Keyed a => Int -> (Set a %1 -> Ur b) %1 -> Ur b+empty s (f :: Set a %1 -> Ur b) =+ Linear.empty s (\hm -> f (Set hm))++toList :: Keyed a => Set a %1 -> Ur [a]+toList (Set hm) =+ Linear.toList hm+ Linear.& \(Ur xs) -> Ur (Prelude.map Prelude.fst xs)++insert :: Keyed a => a -> Set a %1 -> Set a+insert a (Set hmap) = Set (Linear.insert a () hmap)++delete :: Keyed a => a -> Set a %1 -> Set a+delete a (Set hmap) = Set (Linear.delete a hmap)++union :: Keyed a => Set a %1 -> Set a %1 -> Set a+union (Set hm1) (Set hm2) =+ Set (Linear.unionWith (\_ _ -> ()) hm1 hm2)++intersection :: Keyed a => Set a %1 -> Set a %1 -> Set a+intersection (Set hm1) (Set hm2) =+ Set (Linear.intersectionWith (\_ _ -> ()) hm1 hm2)++-- # Accessors+-------------------------------------------------------------------------------++size :: Keyed a => Set a %1 -> (Ur Int, Set a)+size (Set hm) =+ Linear.size hm Linear.& \(s, hm') -> (s, Set hm')++member :: Keyed a => a -> Set a %1 -> (Ur Bool, Set a)+member a (Set hm) =+ Linear.member a hm Linear.& \(b, hm') -> (b, Set hm')++fromList :: Keyed a => [a] -> (Set a %1 -> Ur b) %1 -> Ur b+fromList xs f =+ Linear.fromList (Prelude.map (,()) xs) (\hm -> f (Set hm))++-- # Typeclass Instances+-------------------------------------------------------------------------------++instance Prelude.Semigroup (Set a) where+ (<>) = Prelude.error "Prelude.(<>): invariant violation, unrestricted Set"++instance Keyed a => Semigroup (Set a) where+ (<>) = union++instance Consumable (Set a) where+ consume (Set hmap) = consume hmap++instance Dupable (Set a) where+ dup2 (Set hm) =+ dup2 hm Linear.& \(hm1, hm2) ->+ (Set hm1, Set hm2)
src/Data/Tuple/Linear.hs view
@@ -2,25 +2,23 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | This module provides linear functions commonly used on tuples- module Data.Tuple.Linear- (- fst- , snd- , swap- , curry- , uncurry+ ( fst,+ snd,+ swap,+ curry,+ uncurry, )- where+where -import Prelude.Linear.Internal import Data.Unrestricted.Linear+import Prelude.Linear.Internal -fst :: Consumable b => (a,b) %1-> a-fst (a,b) = lseq b a+fst :: Consumable b => (a, b) %1 -> a+fst (a, b) = lseq b a -snd :: Consumable a => (a,b) %1-> b-snd (a,b) = lseq a b+snd :: Consumable a => (a, b) %1 -> b+snd (a, b) = lseq a b -swap :: (a,b) %1-> (b,a)-swap (a,b) = (b,a)+swap :: (a, b) %1 -> (b, a)+swap (a, b) = (b, a)
− src/Data/Unrestricted/Internal/Consumable.hs
@@ -1,26 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE LinearTypes #-}--module Data.Unrestricted.Internal.Consumable- (- -- * Consumable- Consumable(..)- , lseq- , seqUnit- )- where--class Consumable a where- consume :: a %1-> ()---- | Consume the unit and return the second argument.--- This is like 'seq' but since the first argument is restricted to be of type--- @()@ it is consumed, hence @seqUnit@ is linear in its first argument.-seqUnit :: () %1-> b %1-> b-seqUnit () b = b---- | Consume the first argument and return the second argument.--- This is like 'seq' but the first argument is restricted to be 'Consumable'.-lseq :: Consumable a => a %1-> b %1-> b-lseq a b = seqUnit (consume a) b-
− src/Data/Unrestricted/Internal/Dupable.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE GADTs #-}-module Data.Unrestricted.Internal.Dupable- (- -- * Dupable- Dupable(..)- , dup- , dup3- ) where--import Data.Unrestricted.Internal.Consumable-import GHC.TypeLits-import Data.Type.Equality-import Data.V.Linear.Internal.V (V)-import qualified Data.V.Linear.Internal.V as V---- | The laws of @Dupable@ are dual to those of 'Monoid':------ * @first consume (dup2 a) ≃ a ≃ second consume (dup2 a)@ (neutrality)--- * @first dup2 (dup2 a) ≃ (second dup2 (dup2 a))@ (associativity)------ Where the @(≃)@ sign represents equality up to type isomorphism.------ When implementing 'Dupable' instances for composite types, using 'dupV'--- should be more convenient since 'V' has a zipping 'Applicative' instance.-class Consumable a => Dupable a where- {-# MINIMAL dupV | dup2 #-}-- dupV :: forall n. KnownNat n => a %1-> V n a- dupV a =- case V.caseNat @n of- Prelude.Left Refl -> a `lseq` V.make @0 @a- Prelude.Right Refl -> V.iterate dup2 a-- dup2 :: a %1-> (a, a)- dup2 a = V.elim (dupV @a @2 a) (,)--dup3 :: Dupable a => a %1-> (a, a, a)-dup3 x = V.elim (dupV @_ @3 x) (,,)--dup :: Dupable a => a %1-> (a, a)-dup = dup2-
− src/Data/Unrestricted/Internal/Instances.hs
@@ -1,241 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}---- | This module exports instances of Consumable, Dupable and Movable------ We export instances in this module to avoid a circular dependence--- and keep things clean. Movable depends on the defintion of Ur yet--- many instances of Movable which we might have put in the module with--- Movable depend on Ur. So, we just put the instances of Movable and the--- other classes (for cleanness) in this module to avoid this dependence.-module Data.Unrestricted.Internal.Instances where--import Data.Unrestricted.Internal.Consumable-import Data.Unrestricted.Internal.Dupable-import Data.Unrestricted.Internal.Movable-import Data.Unrestricted.Internal.Ur-import qualified Data.Functor.Linear.Internal.Functor as Data-import qualified Data.Functor.Linear.Internal.Applicative as Data-import GHC.Types hiding (Any)-import Data.Monoid.Linear-import Data.List.NonEmpty-import qualified Prelude-import qualified Unsafe.Linear as Unsafe-import Data.V.Linear ()--instance Consumable () where- consume () = ()--instance Dupable () where- dupV () = Data.pure ()--instance Movable () where- move () = Ur ()--instance Consumable Bool where- consume True = ()- consume False = ()--instance Dupable Bool where- dupV True = Data.pure True- dupV False = Data.pure False--instance Movable Bool where- move True = Ur True- move False = Ur False--instance Consumable Int where- -- /!\ 'Int#' is an unboxed unlifted data-types, therefore it cannot have any- -- linear values hidden in a closure anywhere. Therefore it is safe to call- -- non-linear functions linearly on this type: there is no difference between- -- copying an 'Int#' and using it several times. /!\- consume (I# i) = Unsafe.toLinear (\_ -> ()) i--instance Dupable Int where- -- /!\ 'Int#' is an unboxed unlifted data-types, therefore it cannot have any- -- linear values hidden in a closure anywhere. Therefore it is safe to call- -- non-linear functions linearly on this type: there is no difference between- -- copying an 'Int#' and using it several times. /!\- dupV (I# i) = Unsafe.toLinear (\j -> Data.pure (I# j)) i--instance Movable Int where- -- /!\ 'Int#' is an unboxed unlifted data-types, therefore it cannot have any- -- linear values hidden in a closure anywhere. Therefore it is safe to call- -- non-linear functions linearly on this type: there is no difference between- -- copying an 'Int#' and using it several times. /!\- move (I# i) = Unsafe.toLinear (\j -> Ur (I# j)) i--instance Consumable Double where- -- /!\ 'Double#' is an unboxed unlifted data-types, therefore it cannot have any- -- linear values hidden in a closure anywhere. Therefore it is safe to call- -- non-linear functions linearly on this type: there is no difference between- -- copying an 'Double#' and using it several times. /!\- consume (D# i) = Unsafe.toLinear (\_ -> ()) i--instance Dupable Double where- -- /!\ 'Double#' is an unboxed unlifted data-types, therefore it cannot have any- -- linear values hidden in a closure anywhere. Therefore it is safe to call- -- non-linear functions linearly on this type: there is no difference between- -- copying an 'Double#' and using it several times. /!\- dupV (D# i) = Unsafe.toLinear (\j -> Data.pure (D# j)) i--instance Movable Double where- -- /!\ 'Double#' is an unboxed unlifted data-types, therefore it cannot have any- -- linear values hidden in a closure anywhere. Therefore it is safe to call- -- non-linear functions linearly on this type: there is no difference between- -- copying an 'Double#' and using it several times. /!\- move (D# i) = Unsafe.toLinear (\j -> Ur (D# j)) i--instance Consumable Char where- consume (C# c) = Unsafe.toLinear (\_ -> ()) c--instance Dupable Char where- dupV (C# c) = Unsafe.toLinear (\x -> Data.pure (C# x)) c--instance Movable Char where- move (C# c) = Unsafe.toLinear (\x -> Ur (C# x)) c--instance Consumable Ordering where- consume LT = ()- consume GT = ()- consume EQ = ()--instance Dupable Ordering where- dup2 LT = (LT, LT)- dup2 GT = (GT, GT)- dup2 EQ = (EQ, EQ)--instance Movable Ordering where- move LT = Ur LT- move GT = Ur GT- move EQ = Ur EQ---- TODO: instances for longer primitive tuples--- TODO: default instances based on the Generic framework--instance (Consumable a, Consumable b) => Consumable (a, b) where- consume (a, b) = consume a `lseq` consume b--instance (Dupable a, Dupable b) => Dupable (a, b) where- dupV (a, b) = (,) Data.<$> dupV a Data.<*> dupV b--instance (Movable a, Movable b) => Movable (a, b) where- move (a, b) = (,) Data.<$> move a Data.<*> move b--instance (Consumable a, Consumable b, Consumable c) => Consumable (a, b, c) where- consume (a, b, c) = consume a `lseq` consume b `lseq` consume c--instance (Dupable a, Dupable b, Dupable c) => Dupable (a, b, c) where- dupV (a, b, c) = (,,) Data.<$> dupV a Data.<*> dupV b Data.<*> dupV c--instance (Movable a, Movable b, Movable c) => Movable (a, b, c) where- move (a, b, c) = (,,) Data.<$> move a Data.<*> move b Data.<*> move c--instance Consumable a => Consumable (Prelude.Maybe a) where- consume Prelude.Nothing = ()- consume (Prelude.Just x) = consume x--instance Dupable a => Dupable (Prelude.Maybe a) where- dupV Prelude.Nothing = Data.pure Prelude.Nothing- dupV (Prelude.Just x) = Data.fmap Prelude.Just (dupV x)--instance Movable a => Movable (Prelude.Maybe a) where- move (Prelude.Nothing) = Ur Prelude.Nothing- move (Prelude.Just x) = Data.fmap Prelude.Just (move x)--instance (Consumable a, Consumable b) => Consumable (Prelude.Either a b) where- consume (Prelude.Left a) = consume a- consume (Prelude.Right b) = consume b--instance (Dupable a, Dupable b) => Dupable (Prelude.Either a b) where- dupV (Prelude.Left a) = Data.fmap Prelude.Left (dupV a)- dupV (Prelude.Right b) = Data.fmap Prelude.Right (dupV b)--instance (Movable a, Movable b) => Movable (Prelude.Either a b) where- move (Prelude.Left a) = Data.fmap Prelude.Left (move a)- move (Prelude.Right b) = Data.fmap Prelude.Right (move b)--instance Consumable a => Consumable [a] where- consume [] = ()- consume (a:l) = consume a `lseq` consume l--instance Dupable a => Dupable [a] where- dupV [] = Data.pure []- dupV (a:l) = (:) Data.<$> dupV a Data.<*> dupV l--instance Movable a => Movable [a] where- move [] = Ur []- move (a:l) = (:) Data.<$> move a Data.<*> move l--instance Consumable a => Consumable (NonEmpty a) where- consume (x :| xs) = consume x `lseq` consume xs--instance Dupable a => Dupable (NonEmpty a) where- dupV (x :| xs) = (:|) Data.<$> dupV x Data.<*> dupV xs--instance Movable a => Movable (NonEmpty a) where- move (x :| xs) = (:|) Data.<$> move x Data.<*> move xs--instance Consumable (Ur a) where- consume (Ur _) = ()--instance Dupable (Ur a) where- dupV (Ur a) = Data.pure (Ur a)--instance Movable (Ur a) where- move (Ur a) = Ur (Ur a)--instance Prelude.Functor Ur where- fmap f (Ur a) = Ur (f a)--instance Prelude.Applicative Ur where- pure = Ur- Ur f <*> Ur x = Ur (f x)--instance Data.Functor Ur where- fmap f (Ur a) = Ur (f a)--instance Data.Applicative Ur where- pure = Ur- Ur f <*> Ur x = Ur (f x)--instance Prelude.Foldable Ur where- foldMap f (Ur x) = f x--instance Prelude.Traversable Ur where- sequenceA (Ur x) = Prelude.fmap Ur x---- Some stock instances-deriving instance Consumable a => Consumable (Sum a)-deriving instance Dupable a => Dupable (Sum a)-deriving instance Movable a => Movable (Sum a)-deriving instance Consumable a => Consumable (Product a)-deriving instance Dupable a => Dupable (Product a)-deriving instance Movable a => Movable (Product a)-deriving instance Consumable All-deriving instance Dupable All-deriving instance Movable All-deriving instance Consumable Any-deriving instance Dupable Any-deriving instance Movable Any--newtype MovableMonoid a = MovableMonoid a- deriving (Prelude.Semigroup, Prelude.Monoid)--instance (Movable a, Prelude.Semigroup a) => Semigroup (MovableMonoid a) where- MovableMonoid a <> MovableMonoid b = MovableMonoid (combine (move a) (move b))- where combine :: Prelude.Semigroup a => Ur a %1-> Ur a %1-> a- combine (Ur x) (Ur y) = x Prelude.<> y-instance (Movable a, Prelude.Monoid a) => Monoid (MovableMonoid a)-
− src/Data/Unrestricted/Internal/Movable.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE LinearTypes #-}-module Data.Unrestricted.Internal.Movable- (- -- * Movable- Movable(..)- ) where--import Data.Unrestricted.Internal.Ur-import Data.Unrestricted.Internal.Dupable---- | Use @'Movable' a@ to represent a type which can be used many times even--- when given linearly. Simple data types such as 'Bool' or @[]@ are 'Movable'.--- Though, bear in mind that this typically induces a deep copy of the value.------ Formally, @'Movable' a@ is the class of--- [coalgebras](https://ncatlab.org/nlab/show/coalgebra+over+a+comonad) of the--- 'Ur' comonad. That is------ * @unur (move x) = x@--- * @move \@(Ur a) (move \@a x) = fmap (move \@a) $ move \@a x ------ Additionally, a 'Movable' instance must be compatible with its 'Dupable' parent instance. That is:------ * @case move x of {Ur _ -> ()} = consume x@--- * @case move x of {Ur x -> (x, x)} = dup2 x@-class Dupable a => Movable a where- move :: a %1-> Ur a-
− src/Data/Unrestricted/Internal/Ur.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE GADTs #-}--module Data.Unrestricted.Internal.Ur- (- Ur(..)- , unur- , lift- , lift2- ) where---- | @Ur a@ represents unrestricted values of type @a@ in a linear--- context. The key idea is that because the contructor holds @a@ with a--- regular arrow, a function that uses @Ur a@ linearly can use @a@--- however it likes.--- > someLinear :: Ur a %1-> (a,a)--- > someLinear (Ur a) = (a,a)-data Ur a where- Ur :: a -> Ur a---- | Get an @a@ out of an @Ur a@. If you call this function on a--- linearly bound @Ur a@, then the @a@ you get out has to be used--- linearly, for example:------ > restricted :: Ur a %1-> b--- > restricted x = f (unur x)--- > where--- > -- f __must__ be linear--- > f :: a %1-> b--- > f x = ...-unur :: Ur a %1-> a-unur (Ur a) = a---- | Lifts a function on a linear @Ur a@.-lift :: (a -> b) -> Ur a %1-> Ur b-lift f (Ur a) = Ur (f a)---- | Lifts a function to work on two linear @Ur a@.-lift2 :: (a -> b -> c) -> Ur a %1-> Ur b %1-> Ur c-lift2 f (Ur a) (Ur b) = Ur (f a b)-
src/Data/Unrestricted/Linear.hs view
@@ -55,26 +55,35 @@ -- > fromMove (Ur 0) = True -- > fromMove (Ur 1) = True -- > fromMove (Ur x) = False--- module Data.Unrestricted.Linear ( -- * Unrestricted- Ur(..)- , unur- , lift- , lift2- -- * Performing non-linear actions on linearly bound values- , Consumable(..)- , Dupable(..)- , Movable(..)- , lseq- , dup- , dup3- , module Data.Unrestricted.Internal.Instances- ) where+ Ur (..),+ unur,+ lift,+ lift2,+ UrT (..),+ runUrT,+ liftUrT,+ evalUrT, -import Data.Unrestricted.Internal.Consumable-import Data.Unrestricted.Internal.Dupable-import Data.Unrestricted.Internal.Movable-import Data.Unrestricted.Internal.Ur-import Data.Unrestricted.Internal.Instances+ -- * Performing non-linear actions on linearly bound values+ Consumable (..),+ Dupable (..),+ Movable (..),+ lseq,+ dup,+ dup3,+ dup4,+ dup5,+ dup6,+ dup7,+ module Data.Unrestricted.Linear.Internal.Instances,+ )+where +import Data.Unrestricted.Linear.Internal.Consumable+import Data.Unrestricted.Linear.Internal.Dupable+import Data.Unrestricted.Linear.Internal.Instances+import Data.Unrestricted.Linear.Internal.Movable+import Data.Unrestricted.Linear.Internal.Ur+import Data.Unrestricted.Linear.Internal.UrT
+ src/Data/Unrestricted/Linear/Internal/Consumable.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Unrestricted.Linear.Internal.Consumable+ ( -- * Consumable+ Consumable (..),+ lseq,+ seqUnit,++ -- * Generic deriving+ GConsumable,+ genericConsume,+ )+where++import Data.List.NonEmpty (NonEmpty)+import qualified Data.Monoid as Monoid+import qualified Data.Replicator.Linear.Internal as Replicator+import qualified Data.Replicator.Linear.Internal.ReplicationStream as ReplicationStream+import qualified Data.Semigroup as Semigroup+import Data.Unrestricted.Linear.Internal.Ur+import qualified Data.Vector as Vector+import Data.Void (Void)+import GHC.Tuple (Solo)+import GHC.Types (Multiplicity (..))+import Generics.Linear+import Prelude.Linear.Generically+import Prelude.Linear.Internal+import qualified Unsafe.Linear as Unsafe+import qualified Prelude as Prelude++class Consumable a where+ consume :: a %1 -> ()++-- | Consume the unit and return the second argument.+-- This is like 'seq' but since the first argument is restricted to be of type+-- @()@ it is consumed, hence @seqUnit@ is linear in its first argument.+seqUnit :: () %1 -> b %1 -> b+seqUnit () b = b++-- | Consume the first argument and return the second argument.+-- This is like 'seq' but the first argument is restricted to be 'Consumable'.+lseq :: Consumable a => a %1 -> b %1 -> b+lseq a b = seqUnit (consume a) b++infixr 0 `lseq` -- same fixity as base.seq++-- ----------------+-- Instances++instance Consumable (ReplicationStream.ReplicationStream a) where+ consume = ReplicationStream.consume++instance Consumable (Replicator.Replicator a) where+ consume = Replicator.consume++instance Consumable a => Consumable (Vector.Vector a) where+ consume xs = consume (Unsafe.toLinear Vector.toList xs)++-- Prelude and primitive instances++deriving via+ Generically Prelude.Char+ instance+ Consumable Prelude.Char++deriving via+ Generically Prelude.Double+ instance+ Consumable Prelude.Double++deriving via+ Generically Prelude.Float+ instance+ Consumable Prelude.Float++deriving via+ Generically Prelude.Int+ instance+ Consumable Prelude.Int++deriving via+ Generically Prelude.Word+ instance+ Consumable Prelude.Word++deriving via+ Generically Prelude.Ordering+ instance+ Consumable Prelude.Ordering++deriving via+ Generically Prelude.Bool+ instance+ Consumable Prelude.Bool++deriving via+ Generically ()+ instance+ Consumable ()++instance Consumable Void where+ consume = \case {}++deriving via+ Generically (Solo a)+ instance+ _ => Consumable (Solo a)++deriving via+ Generically (a, b)+ instance+ _ => Consumable (a, b)++deriving via+ Generically (a, b, c)+ instance+ _ => Consumable (a, b, c)++deriving via+ Generically (a, b, c, d)+ instance+ _ => Consumable (a, b, c, d)++deriving via+ Generically (a, b, c, d, e)+ instance+ _ => Consumable (a, b, c, d, e)++deriving via+ Generically (Prelude.Maybe a)+ instance+ _ => Consumable (Prelude.Maybe a)++deriving via+ Generically (Prelude.Either e a)+ instance+ _ => Consumable (Prelude.Either e a)++deriving via+ Generically [a]+ instance+ _ => Consumable [a]++deriving via+ Generically (NonEmpty a)+ instance+ _ => Consumable (NonEmpty a)++deriving via+ Generically (Ur a)+ instance+ Consumable (Ur a)++-- Data.Semigroup instances++deriving via+ Generically (Semigroup.Arg a b)+ instance+ _ => Consumable (Semigroup.Arg a b)++deriving newtype instance _ => Consumable (Semigroup.Min a)++deriving newtype instance _ => Consumable (Semigroup.Max a)++deriving newtype instance _ => Consumable (Semigroup.First a)++deriving newtype instance _ => Consumable (Semigroup.Last a)++deriving newtype instance _ => Consumable (Semigroup.WrappedMonoid a)++deriving newtype instance _ => Consumable (Semigroup.Dual a)++deriving newtype instance Consumable Semigroup.All++deriving newtype instance Consumable Semigroup.Any++deriving newtype instance _ => Consumable (Semigroup.Sum a)++deriving newtype instance _ => Consumable (Semigroup.Product a)++-- Data.Monoid instances++deriving newtype instance _ => Consumable (Monoid.First a)++deriving newtype instance _ => Consumable (Monoid.Last a)++deriving newtype instance _ => Consumable (Monoid.Alt f a)++deriving newtype instance _ => Consumable (Monoid.Ap f a)++-- ----------------+-- Generic deriving++instance (Generic a, GConsumable (Rep a)) => Consumable (Generically a) where+ consume (Generically x) = genericConsume x++genericConsume :: (Generic a, GConsumable (Rep a)) => a %1 -> ()+genericConsume = gconsume . from+{-# INLINEABLE genericConsume #-}++-- | A class for generic representations that can be consumed.+class GConsumable f where+ gconsume :: f p %1 -> ()++instance GConsumable V1 where+ gconsume = \case {}+ {-# INLINE gconsume #-}++instance GConsumable U1 where+ gconsume U1 = ()+ {-# INLINE gconsume #-}++instance (GConsumable f, GConsumable g) => GConsumable (f :+: g) where+ gconsume (L1 a) = gconsume a+ gconsume (R1 a) = gconsume a+ {-# INLINE gconsume #-}++instance (GConsumable f, GConsumable g) => GConsumable (f :*: g) where+ gconsume (a :*: b) = gconsume a `seqUnit` gconsume b+ {-# INLINE gconsume #-}++instance Consumable c => GConsumable (K1 i c) where+ gconsume (K1 c) = consume c+ {-# INLINE gconsume #-}++instance GConsumable f => GConsumable (M1 i t f) where+ gconsume (M1 a) = gconsume a+ {-# INLINE gconsume #-}++-- This split is a bit awkward. We'd like to be able to *default*+-- the multiplicity to `Many` when it's polymorphic. We'll be able+-- to do that once the Exportable Named Defaults Proposal+-- (https://github.com/ghc-proposals/ghc-proposals/pull/409#issuecomment-931839874)+-- has been implemented. The same goes for Dupable and Movable.+instance GConsumable (MP1 'Many f) where+ gconsume (MP1 _) = ()+ {-# INLINE gconsume #-}++instance GConsumable f => GConsumable (MP1 'One f) where+ gconsume (MP1 x) = gconsume x+ {-# INLINE gconsume #-}++-- Instances for unlifted generic representations+--+-- /!\ 'Char#', 'Double#', 'Float#', 'Int#', 'Word#' are unboxed data-types,+-- and therefore they cannot have any linear values hidden in a closure+-- anywhere. Therefore it is safe to call non-linear functions linearly on+-- these types. We refrain from including a 'GConsumable' instance for 'UAddr'+-- for the moment, as that seems potentially confusing—pointers usually+-- must be created, duplicated, and destroyed rather carefully. /!\++instance GConsumable UChar where+ gconsume (UChar x) = Unsafe.toLinear (\_ -> ()) x++instance GConsumable UDouble where+ gconsume (UDouble x) = Unsafe.toLinear (\_ -> ()) x++instance GConsumable UFloat where+ gconsume (UFloat x) = Unsafe.toLinear (\_ -> ()) x++instance GConsumable UInt where+ gconsume (UInt x) = Unsafe.toLinear (\_ -> ()) x++instance GConsumable UWord where+ gconsume (UWord x) = Unsafe.toLinear (\_ -> ()) x
+ src/Data/Unrestricted/Linear/Internal/Dupable.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Unrestricted.Linear.Internal.Dupable+ ( Dupable (..),+ genericDupR,+ dup,+ dup3,+ dup4,+ dup5,+ dup6,+ dup7,+ GDupable,+ )+where++import Data.List.NonEmpty (NonEmpty)+import Data.Replicator.Linear.Internal (Replicator (..))+import qualified Data.Replicator.Linear.Internal as Replicator+import Data.Replicator.Linear.Internal.ReplicationStream (ReplicationStream (..))+import qualified Data.Replicator.Linear.Internal.ReplicationStream as ReplicationStream+import qualified Data.Semigroup as Semigroup+import Data.Unrestricted.Linear.Internal.Consumable+import Data.Unrestricted.Linear.Internal.Ur (Ur)+import GHC.Tuple (Solo (..))+import GHC.Types (Multiplicity (..))+import Generics.Linear+import Prelude.Linear.Generically+import Prelude.Linear.Internal+import qualified Unsafe.Linear as Unsafe+import qualified Prelude++-- | The laws of 'Dupable' are dual to those of 'Monoid':+--+-- * 1. @first consume (dup2 a) ≃ a ≃ second consume (dup2 a)@ ('dup2' neutrality)+-- * 2. @first dup2 (dup2 a) ≃ (second dup2 (dup2 a))@ ('dup2' associativity)+--+-- where the @(≃)@ sign represents equality up to type isomorphism.+--+-- * 3. @dup2 = Replicator.elim (,) . dupR@ (coherence between 'dup2' and 'dupR')+-- * 4. @consume = Replicator.elim () . dupR@ (coherence between 'consume' and 'dupR')+--+-- * 5. @Replicator.extract . dupR = id@ ('dupR' identity)+-- * 6. @dupR . dupR = (Replicator.map dupR) . dupR@ ('dupR' interchange)+--+-- (Laws 1-2 and 5-6 are equivalent)+--+-- Implementation of 'Dupable' for 'Data.Unrestricted.Movable' types should+-- be done with @deriving via 'Data.Unrestricted.AsMovable'@.+--+-- Implementation of 'Dupable' for other types can be done with+-- @deriving via 'Generically'@. Note that at present this mechanism+-- can have performance problems for recursive parameterized types.+-- Specifically, the methods will not specialize to underlying 'Dupable'+-- instances. See [this GHC issue](https://gitlab.haskell.org/ghc/ghc/-/issues/21131).+class Consumable a => Dupable a where+ {-# MINIMAL dupR | dup2 #-}++ -- | Creates a 'Replicator' for the given @a@.+ --+ -- You usually want to define this method using 'Replicator'\'s+ -- 'Data.Functor.Linear.Applicative' instance. For instance, here is an+ -- implementation of @'Dupable' [a]@:+ --+ -- > instance Dupable a => Dupable [a] where+ -- > dupR [] = pure []+ -- > dupR (a : as) = (:) <$> dupR a <*> dupR as+ dupR :: a %1 -> Replicator a+ dupR x = Streamed $ ReplicationStream x id dup2 consume++ -- | Creates two @a@s from a @'Dupable' a@, in a linear fashion.+ dup2 :: a %1 -> (a, a)+ dup2 x = Replicator.elim (,) (dupR x)++-- | Creates 3 @a@s from a @'Dupable' a@, in a linear fashion.+dup3 :: Dupable a => a %1 -> (a, a, a)+dup3 x = Replicator.elim (,,) (dupR x)++-- | Creates 4 @a@s from a @'Dupable' a@, in a linear fashion.+dup4 :: Dupable a => a %1 -> (a, a, a, a)+dup4 x = Replicator.elim (,,,) (dupR x)++-- | Creates 5 @a@s from a @'Dupable' a@, in a linear fashion.+dup5 :: Dupable a => a %1 -> (a, a, a, a, a)+dup5 x = Replicator.elim (,,,,) (dupR x)++-- | Creates 6 @a@s from a @'Dupable' a@, in a linear fashion.+dup6 :: Dupable a => a %1 -> (a, a, a, a, a, a)+dup6 x = Replicator.elim (,,,,,) (dupR x)++-- | Creates 7 @a@s from a @'Dupable' a@, in a linear fashion.+dup7 :: Dupable a => a %1 -> (a, a, a, a, a, a, a)+dup7 x = Replicator.elim (,,,,,,) (dupR x)++-- | Creates two @a@s from a @'Dupable' a@. Same function as 'dup2'.+dup :: Dupable a => a %1 -> (a, a)+dup = dup2++------------+-- Instances+------------++instance Dupable (ReplicationStream a) where+ dupR = Streamed . ReplicationStream.duplicate++instance Dupable (Replicator a) where+ dupR = Replicator.duplicate++deriving via+ Generically Prelude.Bool+ instance+ Dupable Prelude.Bool++deriving via+ Generically Prelude.Int+ instance+ Dupable Prelude.Int++deriving via+ Generically Prelude.Word+ instance+ Dupable Prelude.Word++deriving via+ Generically Prelude.Ordering+ instance+ Dupable Prelude.Ordering++deriving via+ Generically Prelude.Char+ instance+ Dupable Prelude.Char++deriving via+ Generically Prelude.Double+ instance+ Dupable Prelude.Double++deriving via+ Generically Prelude.Float+ instance+ Dupable Prelude.Float++deriving via+ Generically (Prelude.Maybe a)+ instance+ Dupable a => Dupable (Prelude.Maybe a)++deriving via+ Generically (Prelude.Either a b)+ instance+ (Dupable a, Dupable b) => Dupable (Prelude.Either a b)++-- This instance is written manually because I (David Feuer) haven't+-- been able to find a way to get the generic version to specialize+-- to a particular underlying Dupable. The recursion leads to the+-- whole thing being a loop breaker and I don't know how to fix that.+instance Dupable a => Dupable [a] where+ dupR = go+ where+ go :: [a] %1 -> Replicator [a]+ go [] = Replicator.pure []+ go (x : xs) = Replicator.liftA2 (:) (dupR x) (go xs)++deriving via+ Generically (NonEmpty a)+ instance+ Dupable a => Dupable (NonEmpty a)++deriving via+ Generically (Ur a)+ instance+ Dupable (Ur a)++deriving via+ Generically ()+ instance+ Dupable ()++deriving via+ Generically (Solo a)+ instance+ Dupable a => Dupable (Solo a)++deriving via+ Generically (a, b)+ instance+ (Dupable a, Dupable b) => Dupable (a, b)++deriving via+ Generically (a, b, c)+ instance+ (Dupable a, Dupable b, Dupable c) => Dupable (a, b, c)++deriving via+ Generically (a, b, c, d)+ instance+ (Dupable a, Dupable b, Dupable c, Dupable d) => Dupable (a, b, c, d)++deriving via+ Generically (a, b, c, d, e)+ instance+ (Dupable a, Dupable b, Dupable c, Dupable d, Dupable e) => Dupable (a, b, c, d, e)++deriving newtype instance Dupable a => Dupable (Semigroup.Sum a)++deriving newtype instance Dupable a => Dupable (Semigroup.Product a)++deriving newtype instance Dupable Semigroup.All++deriving newtype instance Dupable Semigroup.Any++-------------------+-- Generic deriving+-------------------++instance (Generic a, GDupable (Rep a)) => Dupable (Generically a) where+ dupR (Generically x) = lcoerce (Replicator.map (to :: Rep a x %1 -> a) (gdupR (from x)))++genericDupR :: (Generic a, GDupable (Rep a)) => a %1 -> Replicator a+genericDupR x = Replicator.map to (gdupR (from x))++class GConsumable f => GDupable f where+ gdupR :: f a %1 -> Replicator (f a)++instance GDupable f => GDupable (M1 i c f) where+ gdupR (M1 x) = lcoerce (gdupR x)+ {-# INLINE gdupR #-}++instance (GDupable f, GDupable g) => GDupable (f :*: g) where+ gdupR (x :*: y) = Replicator.liftA2 (:*:) (gdupR x) (gdupR y)+ {-# INLINE gdupR #-}++instance (GDupable f, GDupable g) => GDupable (f :+: g) where+ gdupR (L1 x) = Replicator.map L1 (gdupR x)+ gdupR (R1 y) = Replicator.map R1 (gdupR y)+ {-# INLINE gdupR #-}++instance Dupable c => GDupable (K1 i c) where+ gdupR = lcoerce (dupR @c)+ {-# INLINE gdupR #-}++instance GDupable U1 where+ gdupR U1 = Replicator.pure U1+ {-# INLINE gdupR #-}++instance GDupable V1 where+ gdupR = \case {}+ {-# INLINE gdupR #-}++instance GDupable (MP1 'Many f) where+ gdupR (MP1 x) = Replicator.pure (MP1 x)+ {-# INLINE gdupR #-}++instance GDupable f => GDupable (MP1 'One f) where+ gdupR (MP1 x) = Replicator.map MP1 (gdupR x)+ {-# INLINE gdupR #-}++instance GDupable UChar where+ gdupR = Unsafe.toLinear Replicator.pure++instance GDupable UDouble where+ gdupR = Unsafe.toLinear Replicator.pure++instance GDupable UFloat where+ gdupR = Unsafe.toLinear Replicator.pure++instance GDupable UInt where+ gdupR = Unsafe.toLinear Replicator.pure++instance GDupable UWord where+ gdupR = Unsafe.toLinear Replicator.pure
+ src/Data/Unrestricted/Linear/Internal/Instances.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_HADDOCK hide #-}++-- | This module exports instances of Consumable, Dupable and Movable+--+-- We export instances in this module to avoid a circular dependence+-- and keep things clean. Movable depends on the defintion of Ur yet+-- many instances of Movable which we might have put in the module with+-- Movable depend on Ur. So, we just put the instances of Movable and the+-- other classes (for cleanness) in this module to avoid this dependence.+module Data.Unrestricted.Linear.Internal.Instances where++import qualified Data.Functor.Linear.Internal.Applicative as Data+import qualified Data.Functor.Linear.Internal.Functor as Data+import Data.Monoid.Linear+import Data.Replicator.Linear.Internal.Instances ()+import Data.Unrestricted.Linear.Internal.Consumable+import Data.Unrestricted.Linear.Internal.Dupable+import Data.Unrestricted.Linear.Internal.Movable+import Data.Unrestricted.Linear.Internal.Ur+import Data.V.Linear.Internal (V (..))+import qualified Data.V.Linear.Internal as V+import qualified Data.Vector as Vector+import GHC.Int+import GHC.TypeLits+import GHC.Word+import Prelude.Linear.Internal+import qualified Unsafe.Linear as Unsafe+import qualified Prelude++-- | Newtype that must be used with @DerivingVia@ to get efficient 'Dupable'+-- and 'Consumable' implementations for 'Movable' types.+newtype AsMovable a = AsMovable a++instance Movable a => Movable (AsMovable a) where+ move (AsMovable x) =+ move x & \case+ Ur x' -> Ur (AsMovable x')++instance Movable a => Consumable (AsMovable a) where+ consume x =+ move x & \case+ Ur _ -> ()++instance Movable a => Dupable (AsMovable a) where+ dupR x =+ move x & \case+ Ur x' -> Data.pure x'++deriving via (AsMovable Int8) instance Consumable Int8++deriving via (AsMovable Int8) instance Dupable Int8++instance Movable Int8 where+ -- /!\ 'Int8#' is an unboxed unlifted data-types, therefore it cannot have any+ -- linear values hidden in a closure anywhere. Therefore it is safe to call+ -- non-linear functions linearly on this type: there is no difference between+ -- copying an 'Int8#' and using it several times. /!\+ move (I8# i) = Unsafe.toLinear (\j -> Ur (I8# j)) i++deriving via (AsMovable Int16) instance Consumable Int16++deriving via (AsMovable Int16) instance Dupable Int16++instance Movable Int16 where+ -- /!\ 'Int16#' is an unboxed unlifted data-types, therefore it cannot have any+ -- linear values hidden in a closure anywhere. Therefore it is safe to call+ -- non-linear functions linearly on this type: there is no difference between+ -- copying an 'Int16#' and using it several times. /!\+ move (I16# i) = Unsafe.toLinear (\j -> Ur (I16# j)) i++deriving via (AsMovable Int32) instance Consumable Int32++deriving via (AsMovable Int32) instance Dupable Int32++instance Movable Int32 where+ -- /!\ 'Int32#' is an unboxed unlifted data-types, therefore it cannot have any+ -- linear values hidden in a closure anywhere. Therefore it is safe to call+ -- non-linear functions linearly on this type: there is no difference between+ -- copying an 'Int32#' and using it several times. /!\+ move (I32# i) = Unsafe.toLinear (\j -> Ur (I32# j)) i++deriving via (AsMovable Int64) instance Consumable Int64++deriving via (AsMovable Int64) instance Dupable Int64++instance Movable Int64 where+ -- /!\ 'Int64#' is an unboxed unlifted data-types, therefore it cannot have any+ -- linear values hidden in a closure anywhere. Therefore it is safe to call+ -- non-linear functions linearly on this type: there is no difference between+ -- copying an 'Int64#' and using it several times. /!\+ move (I64# i) = Unsafe.toLinear (\j -> Ur (I64# j)) i++deriving via (AsMovable Word8) instance Consumable Word8++deriving via (AsMovable Word8) instance Dupable Word8++instance Movable Word8 where+ -- /!\ 'Word8#' is an unboxed unlifted data-types, therefore it cannot have any+ -- linear values hidden in a closure anywhere. Therefore it is safe to call+ -- non-linear functions linearly on this type: there is no difference between+ -- copying an 'Word8#' and using it several times. /!\+ move (W8# i) = Unsafe.toLinear (\j -> Ur (W8# j)) i++deriving via (AsMovable Word16) instance Consumable Word16++deriving via (AsMovable Word16) instance Dupable Word16++instance Movable Word16 where+ -- /!\ 'Word16#' is an unboxed unlifted data-types, therefore it cannot have any+ -- linear values hidden in a closure anywhere. Therefore it is safe to call+ -- non-linear functions linearly on this type: there is no difference between+ -- copying an 'Word16#' and using it several times. /!\+ move (W16# i) = Unsafe.toLinear (\j -> Ur (W16# j)) i++deriving via (AsMovable Word32) instance Consumable Word32++deriving via (AsMovable Word32) instance Dupable Word32++instance Movable Word32 where+ -- /!\ 'Word32#' is an unboxed unlifted data-types, therefore it cannot have any+ -- linear values hidden in a closure anywhere. Therefore it is safe to call+ -- non-linear functions linearly on this type: there is no difference between+ -- copying an 'Word32#' and using it several times. /!\+ move (W32# i) = Unsafe.toLinear (\j -> Ur (W32# j)) i++deriving via (AsMovable Word64) instance Consumable Word64++deriving via (AsMovable Word64) instance Dupable Word64++instance Movable Word64 where+ -- /!\ 'Word64#' is an unboxed unlifted data-types, therefore it cannot have any+ -- linear values hidden in a closure anywhere. Therefore it is safe to call+ -- non-linear functions linearly on this type: there is no difference between+ -- copying an 'Word64#' and using it several times. /!\+ move (W64# i) = Unsafe.toLinear (\j -> Ur (W64# j)) i++-- TODO: instances for longer primitive tuples+-- TODO: default instances based on the Generic framework++instance Consumable (V 0 a) where+ consume = V.consume++instance (KnownNat n, Consumable a) => Consumable (V n a) where+ consume (V xs) = consume (Unsafe.toLinear Vector.toList xs)++instance (KnownNat n, Dupable a) => Dupable (V n a) where+ dupR (V xs) =+ V . Unsafe.toLinear (Vector.fromListN (V.theLength @n))+ Data.<$> dupR (Unsafe.toLinear Vector.toList xs)++-- Some stock instances++newtype MovableMonoid a = MovableMonoid a+ deriving (Prelude.Semigroup, Prelude.Monoid)++instance (Movable a, Prelude.Semigroup a) => Semigroup (MovableMonoid a) where+ MovableMonoid a <> MovableMonoid b = MovableMonoid (combine (move a) (move b))+ where+ combine :: Prelude.Semigroup a => Ur a %1 -> Ur a %1 -> a+ combine (Ur x) (Ur y) = x Prelude.<> y++instance (Movable a, Prelude.Monoid a) => Monoid (MovableMonoid a) where+ mempty = MovableMonoid Prelude.mempty
+ src/Data/Unrestricted/Linear/Internal/Movable.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Unrestricted.Linear.Internal.Movable+ ( -- * Movable+ Movable (..),+ GMovable,+ genericMove,+ )+where++import qualified Data.Functor.Linear.Internal.Applicative as Data+import qualified Data.Functor.Linear.Internal.Functor as Data+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Semigroup as Semigroup+import Data.Unrestricted.Linear.Internal.Dupable+import Data.Unrestricted.Linear.Internal.Ur+import GHC.Tuple (Solo)+import GHC.Types (Multiplicity (..))+import Generics.Linear+import Prelude.Linear.Generically+import Prelude.Linear.Internal+import qualified Unsafe.Linear as Unsafe+import Prelude (Bool (..), Char, Double, Float, Int, Ordering (..), Word)+import qualified Prelude as Prelude++-- | Use @'Movable' a@ to represent a type which can be used many times even+-- when given linearly. Simple data types such as 'Bool' or @[]@ are 'Movable'.+-- Though, bear in mind that this typically induces a deep copy of the value.+--+-- Formally, @'Movable' a@ is the class of+-- [coalgebras](https://ncatlab.org/nlab/show/coalgebra+over+a+comonad) of the+-- 'Ur' comonad. That is+--+-- * @unur (move x) = x@+-- * @move \@(Ur a) (move \@a x) = fmap (move \@a) $ move \@a x@+--+-- Additionally, a 'Movable' instance must be compatible with its 'Dupable' parent instance. That is:+--+-- * @case move x of {Ur _ -> ()} = consume x@+-- * @case move x of {Ur x -> (x, x)} = dup2 x@+class Dupable a => Movable a where+ move :: a %1 -> Ur a++-- -------------+-- Instances++deriving via+ Generically Bool+ instance+ Movable Bool++deriving via+ Generically Char+ instance+ Movable Char++deriving via+ Generically Double+ instance+ Movable Double++deriving via+ Generically Float+ instance+ Movable Float++deriving via+ Generically Int+ instance+ Movable Int++deriving via+ Generically Word+ instance+ Movable Word++deriving via+ Generically Prelude.Ordering+ instance+ Movable Prelude.Ordering++instance Movable () where+ move () = Ur ()++deriving via+ Generically (Solo a)+ instance+ Movable a => Movable (Solo a)++deriving via+ Generically (a, b)+ instance+ (Movable a, Movable b) => Movable (a, b)++deriving via+ Generically (a, b, c)+ instance+ (Movable a, Movable b, Movable c) => Movable (a, b, c)++deriving via+ Generically (a, b, c, d)+ instance+ (Movable a, Movable b, Movable c, Movable d) => Movable (a, b, c, d)++deriving via+ Generically (a, b, c, d, e)+ instance+ (Movable a, Movable b, Movable c, Movable d, Movable e) => Movable (a, b, c, d, e)++instance Movable a => Movable (Prelude.Maybe a) where+ move (Prelude.Nothing) = Ur Prelude.Nothing+ move (Prelude.Just x) = Data.fmap Prelude.Just (move x)++instance (Movable a, Movable b) => Movable (Prelude.Either a b) where+ move (Prelude.Left a) = Data.fmap Prelude.Left (move a)+ move (Prelude.Right b) = Data.fmap Prelude.Right (move b)++instance Movable a => Movable [a] where+ -- The explicit go function lets this specialize.+ move = go+ where+ go :: [a] %1 -> Ur [a]+ go [] = Ur []+ go (a : l) = (:) Data.<$> move a Data.<*> go l++instance Movable a => Movable (NonEmpty a) where+ move (x :| xs) = (:|) Data.<$> move x Data.<*> move xs++instance Movable (Ur a) where+ move (Ur a) = Ur (Ur a)++-- Some stock instances+deriving newtype instance Movable a => Movable (Semigroup.Sum a)++deriving newtype instance Movable a => Movable (Semigroup.Product a)++deriving newtype instance Movable Semigroup.All++deriving newtype instance Movable Semigroup.Any++-- -------------+-- Generic deriving++instance (Generic a, GMovable (Rep a)) => Movable (Generically a) where+ move = Data.fmap (Generically . to) . gmove . from . unGenerically++genericMove :: (Generic a, GMovable (Rep a)) => a %1 -> Ur a+genericMove = Data.fmap to . gmove . from++class GDupable f => GMovable f where+ gmove :: f p %1 -> Ur (f p)++instance GMovable V1 where+ gmove = \case {}++instance GMovable U1 where+ gmove U1 = Ur U1++instance (GMovable f, GMovable g) => GMovable (f :+: g) where+ gmove (L1 a) = gmove a & \case (Ur x) -> Ur (L1 x)+ gmove (R1 a) = gmove a & \case (Ur x) -> Ur (R1 x)++instance (GMovable f, GMovable g) => GMovable (f :*: g) where+ gmove (a :*: b) =+ gmove a & \case+ (Ur x) ->+ gmove b & \case+ (Ur y) -> Ur (x :*: y)++instance Movable c => GMovable (K1 i c) where+ gmove (K1 c) = lcoerce (move c)++instance GMovable f => GMovable (M1 i t f) where+ gmove (M1 a) = lcoerce (gmove a)++instance GMovable (MP1 'Many f) where+ gmove (MP1 x) = Ur (MP1 x)++instance GMovable f => GMovable (MP1 'One f) where+ gmove (MP1 a) = gmove a & \case Ur x -> Ur (MP1 x)++instance GMovable UChar where+ gmove (UChar c) = Unsafe.toLinear (\x -> Ur (UChar x)) c++instance GMovable UDouble where+ gmove (UDouble c) = Unsafe.toLinear (\x -> Ur (UDouble x)) c++instance GMovable UFloat where+ gmove (UFloat c) = Unsafe.toLinear (\x -> Ur (UFloat x)) c++instance GMovable UInt where+ gmove (UInt c) = Unsafe.toLinear (\x -> Ur (UInt x)) c++instance GMovable UWord where+ gmove (UWord c) = Unsafe.toLinear (\x -> Ur (UWord x)) c
+ src/Data/Unrestricted/Linear/Internal/Ur.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+-- for GHC.Types+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Unrestricted.Linear.Internal.Ur+ ( Ur (..),+ unur,+ lift,+ lift2,+ )+where++import qualified GHC.Generics as GHCGen+import GHC.Types (Multiplicity (..))+import Generics.Linear+import Prelude.Linear.GenericUtil+import qualified Prelude++-- | @Ur a@ represents unrestricted values of type @a@ in a linear+-- context. The key idea is that because the contructor holds @a@ with a+-- regular arrow, a function that uses @Ur a@ linearly can use @a@+-- however it likes.+--+-- > someLinear :: Ur a %1-> (a,a)+-- > someLinear (Ur a) = (a,a)+data Ur a where+ Ur :: a -> Ur a++deriving instance GHCGen.Generic (Ur a)++deriving instance GHCGen.Generic1 Ur++-- | Get an @a@ out of an @Ur a@. If you call this function on a+-- linearly bound @Ur a@, then the @a@ you get out has to be used+-- linearly, for example:+--+-- > restricted :: Ur a %1-> b+-- > restricted x = f (unur x)+-- > where+-- > -- f __must__ be linear+-- > f :: a %1-> b+-- > f x = ...+unur :: Ur a %1 -> a+unur (Ur a) = a++-- | Lifts a function on a linear @Ur a@.+lift :: (a -> b) -> Ur a %1 -> Ur b+lift f (Ur a) = Ur (f a)++-- | Lifts a function to work on two linear @Ur a@.+lift2 :: (a -> b -> c) -> Ur a %1 -> Ur b %1 -> Ur c+lift2 f (Ur a) (Ur b) = Ur (f a b)++instance Prelude.Functor Ur where+ fmap f (Ur a) = Ur (f a)++instance Prelude.Foldable Ur where+ foldMap f (Ur x) = f x++instance Prelude.Traversable Ur where+ sequenceA (Ur x) = Prelude.fmap Ur x++instance Prelude.Applicative Ur where+ pure = Ur+ Ur f <*> Ur x = Ur (f x)++instance Prelude.Monad Ur where+ Ur a >>= f = f a++-- -------------------+-- Generic and Generic1 instances++instance Generic (Ur a) where+ type+ Rep (Ur a) =+ FixupMetaData+ (Ur a)+ ( D1+ Any+ ( C1+ Any+ ( S1+ Any+ (MP1 'Many (Rec0 a))+ )+ )+ )+ to rur = to' rur+ where+ to' :: Rep (Ur a) p %1 -> Ur a+ to' (M1 (M1 (M1 (MP1 (K1 a))))) = Ur a++ from ur = from' ur+ where+ from' :: Ur a %1 -> Rep (Ur a) p+ from' (Ur a) = M1 (M1 (M1 (MP1 (K1 a))))++instance Generic1 Ur where+ type+ Rep1 Ur =+ FixupMetaData1+ Ur+ ( D1+ Any+ ( C1+ Any+ ( S1+ Any+ (MP1 'Many Par1)+ )+ )+ )++ to1 rur = to1' rur+ where+ to1' :: Rep1 Ur a %1 -> Ur a+ to1' (M1 (M1 (M1 (MP1 (Par1 a))))) = Ur a++ from1 ur = from1' ur+ where+ from1' :: Ur a %1 -> Rep1 Ur a+ from1' (Ur a) = M1 (M1 (M1 (MP1 (Par1 a))))++type family Any :: Meta
+ src/Data/Unrestricted/Linear/Internal/UrT.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE LinearTypes #-}+{-# OPTIONS_HADDOCK hide #-}++-- | `UrT` creates non-linear monads from linear monads.+-- The effect of @UrT m@ is the same as the effect of @m@ with the same linearity.+-- It's just that the @a@ in @m a@ must be used linearly, but the @a@ in @UrT m a@ can be used unrestricted.+-- Since @UrT@ is a regular monad it can be used with the regular do-notation.+--+-- A good use case is when you have a linear resource, then you can use @UrT (`Linear.State` s) a@+-- to manipulate the resource linearly with regular do-notation.+module Data.Unrestricted.Linear.Internal.UrT+ ( UrT (..),+ runUrT,+ liftUrT,+ evalUrT,+ )+where++import qualified Control.Functor.Linear as Linear+import Data.Unrestricted.Linear.Internal.Movable+import Data.Unrestricted.Linear.Internal.Ur++-- | @UrT@ transforms linear control monads to non-linear monads.+--+-- * @UrT (`Linear.State` s) a@ is a non-linear monad with linear state.+newtype UrT m a = UrT (m (Ur a))++-- | Linearly unwrap the @UrT@ newtype wrapper.+runUrT :: UrT m a %1 -> m (Ur a)+runUrT (UrT ma) = ma++instance Linear.Functor m => Functor (UrT m) where+ fmap f (UrT ma) = UrT (Linear.fmap (\(Ur a) -> Ur (f a)) ma)++instance Linear.Applicative m => Applicative (UrT m) where+ pure a = UrT (Linear.pure (Ur a))+ UrT mf <*> UrT ma = UrT (Linear.liftA2 (\(Ur f) (Ur a) -> Ur (f a)) mf ma)++instance Linear.Monad m => Monad (UrT m) where+ UrT ma >>= f = UrT (ma Linear.>>= (\(Ur a) -> case f a of (UrT mb) -> mb))++-- | Lift a computation to the @UrT@ monad, provided that the type @a@ can be used unrestricted.+liftUrT :: (Movable a, Linear.Functor m) => m a %1 -> UrT m a+liftUrT ma = UrT (Linear.fmap move ma)++-- | Extract the inner computation linearly, the inverse of `liftUrT`.+--+-- > evalUrT (liftUrT m) = m+evalUrT :: Linear.Functor m => UrT m a %1 -> m a+evalUrT u = Linear.fmap unur (runUrT u)
src/Data/V/Linear.hs view
@@ -1,5 +1,6 @@-{-# OPTIONS_GHC -Wno-dodgy-exports #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-}+ -- | This module defines vectors of known length which can hold linear values. -- -- Having a known length matters with linear types, because many common vector@@ -21,11 +22,10 @@ -- -- >>> :{ -- isTrue :: Bool--- isTrue = V.elim (build 4 9) doSomething+-- isTrue = V.elim doSomething (build 4 9) -- where--- -- GHC can't figure out this type equality, so this is needed. -- build :: Int %1-> Int %1-> V.V 2 Int--- build = V.make @2 @Int+-- build = V.make -- :} -- -- A much more expensive library of vectors of known size (including matrices@@ -34,17 +34,29 @@ -- sense of [linear algebra](https://en.wikipedia.org/wiki/Linear_algebra), -- rather than linear types). module Data.V.Linear- ( V- , FunN- , elim- , make- , iterate- -- * Type-level utilities- , caseNat- , module Data.V.Linear.Internal.Instances- ) where+ ( V,+ empty,+ consume,+ map,+ pure,+ (<*>),+ uncons#,+ uncons,+ Elim,+ elim,+ cons,+ fromReplicator,+ dupV,+ theLength,+ Make,+ make, -import Data.V.Linear.Internal.V+ -- * Type-level helpers for staging+ ArityV,+ )+where++import Data.V.Linear.Internal import Data.V.Linear.Internal.Instances () {- Developers Note@@ -54,11 +66,10 @@ is as follows. Dupable depends on @V@ yet the instances of @V@ depend on a variety of things (data functors, control functors, traversable) which often end up depending on dupable. By moving the instances here, we-can make sure that Data.Unrestricted.Internal.Dupable only depends on the data+can make sure that Data.Unrestricted.Linear.Internal.Dupable only depends on the data type defintion in Data.V.Linear.V and does not require any of the dependencies of the instances. Remark: ideally the instances below would be in an internal `Instances` module. But we haven't got around to it yet. -}-
+ src/Data/V/Linear/Internal.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.V.Linear.Internal+ ( V (..),+ empty,+ consume,+ map,+ pure,+ (<*>),+ uncons#,+ uncons,+ Elim,+ elim,+ cons,+ fromReplicator,+ dupV,+ theLength,+ Make,+ make,+ ArityV,+ )+where++import Data.Arity.Linear.Internal+import Data.Kind+import Data.Replicator.Linear.Internal (Replicator)+import qualified Data.Replicator.Linear.Internal as Replicator+import Data.Unrestricted.Linear.Internal.Dupable (Dupable (dupR))+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import GHC.Exts (proxy#)+import GHC.TypeLits+import Prelude.Linear.Internal+import qualified Unsafe.Linear as Unsafe+import qualified Prelude++-- | @'V' n a@ represents an immutable sequence of @n@ elements of type @a@+-- (like a n-tuple), with a linear 'Data.Functor.Linear.Applicative' instance.+newtype V (n :: Nat) (a :: Type) = V (Vector a)+ deriving (Prelude.Eq, Prelude.Ord, Prelude.Functor)++-- Using vector rather than, say, 'Array' (or directly 'Array#') because it+-- offers many convenience function. Since all these unsafeCoerces probably+-- kill the fusion rules, it may be worth it going lower level since I+-- probably have to write my own fusion anyway. Therefore, starting from+-- Vectors at the moment.++-- | Returns an empty 'V'.+empty :: forall a. V 0 a+empty = V Vector.empty++consume :: V 0 a %1 -> ()+consume = Unsafe.toLinear (\_ -> ())+{-# INLINEABLE consume #-}++map :: (a %1 -> b) -> V n a %1 -> V n b+map f (V xs) = V $ Unsafe.toLinear (Vector.map (\x -> f x)) xs++(<*>) :: V n (a %1 -> b) %1 -> V n a %1 -> V n b+(V fs) <*> (V xs) =+ V $+ Unsafe.toLinear2 (Vector.zipWith (\f x -> f $ x)) fs xs++infixl 4 <*> -- same fixity as base.<*>++-- | Splits the head and tail of the 'V', returning an unboxed tuple.+uncons# :: 1 <= n => V n a %1 -> (# a, V (n - 1) a #)+uncons# = Unsafe.toLinear uncons'#+ where+ uncons'# :: 1 <= n => V n a -> (# a, V (n - 1) a #)+ uncons'# (V xs) = (# Vector.head xs, V (Vector.tail xs) #)+{-# INLINEABLE uncons# #-}++-- | Splits the head and tail of the 'V', returning a boxed tuple.+uncons :: 1 <= n => V n a %1 -> (a, V (n - 1) a)+uncons = Unsafe.toLinear uncons'+ where+ uncons' :: 1 <= n => V n a -> (a, V (n - 1) a)+ uncons' (V xs) = (Vector.head xs, V (Vector.tail xs))+{-# INLINEABLE uncons #-}++-- | Takes a function of type @a %1 -> a %1 -> ... %1 -> a %1 -> b@, and+-- returns a @b@ . The @'V' n a@ is used to supply all the items of type @a@+-- required by the function.+--+-- For instance:+--+-- > elim @1 :: (a %1 -> b) %1 -> V 1 a %1 -> b+-- > elim @2 :: (a %1 -> a %1 -> b) %1 -> V 2 a %1 -> b+-- > elim @3 :: (a %1 -> a %1 -> a %1 -> b) %1 -> V 3 a %1 -> b+--+-- It is not always necessary to give the arity argument. It can be+-- inferred from the function argument.+--+-- About the constraints of this function (they won't get in your way):+--+-- * @n ~ 'PeanoToNat' ('NatToPeano' n)@ is just there to help GHC, and will always be proved+-- * @'Elim' ('NatToPeano' n) a b@ provides the actual implementation of 'elim'; there is an instance of this class for any @(n, a, b)@+-- * @'IsFunN' a b f, f ~ 'FunN' ('NatToPeano' n) a b, n ~ 'Arity' b f@ indicate the shape of @f@ to the typechecker (see documentation of 'IsFunN').+elim ::+ forall (n :: Nat) a b f.+ ( -- GHC cannot prove it for any @n@, but can prove it at call site when+ -- @n@ is known+ n ~ PeanoToNat (NatToPeano n),+ Elim (NatToPeano n) a b,+ IsFunN a b f,+ f ~ FunN (NatToPeano n) a b,+ n ~ Arity b f+ ) =>+ f %1 ->+ V n a %1 ->+ b+elim f v = elim' @(NatToPeano n) f v++-- | @'Elim' n a b@ is used to implement 'elim' without recursion+-- so that we can guarantee that 'elim' will be inlined and unrolled.+--+-- 'Elim' is solely used in the signature of 'elim'.+type Elim :: Peano -> Type -> Type -> Constraint+class Elim n a b where+ -- Note that 'elim' is, in particular, used to force eta-expansion of+ -- 'elim\''. Otherwise, 'elim\'' might not get inlined (see+ -- https://github.com/tweag/linear-base/issues/369).+ elim' :: FunN n a b %1 -> V (PeanoToNat n) a %1 -> b++instance Elim 'Z a b where+ elim' b v =+ consume v & \case+ () -> b+ {-# INLINE elim' #-}++instance (1 <= 1 + PeanoToNat n, (1 + PeanoToNat n) - 1 ~ PeanoToNat n, Elim n a b) => Elim ('S n) a b where+ elim' g v =+ uncons v & \case+ (a, v') -> elim' @n (g a) v'+ {-# INLINE elim' #-}++-- | Prepends the given element to the 'V'.+cons :: forall n a. a %1 -> V (n - 1) a %1 -> V n a+cons = Unsafe.toLinear2 $ \x (V v) -> V (Vector.cons x v)++-- | The 'ArityV' type family exists to help the type checker compute the arity+-- @n ~ 'Arity' b f@ when @b ~ 'V' n a@.+type family ArityV f where+ ArityV (V _ _) = 0+ ArityV (a %1 -> f) = 1 + ArityV f+ ArityV f =+ TypeError+ ( 'Text "Arity: "+ ':<>: 'ShowType f+ ':<>: 'Text " isn't a linear function with head (V _ _)"+ )++-- | Builds a n-ary constructor for @'V' n a@ (i.e. a function taking @n@ linear+-- arguments of type @a@ and returning a @'V' n a@).+--+-- > myV :: V 3 Int+-- > myV = make 1 2 3+--+-- About the constraints of this function (they won't get in your way):+--+-- * @n ~ 'PeanoToNat' ('NatToPeano' n)@ is just there to help GHC, and will always be proved+-- * @'Make' ('NatToPeano' n) ('NatToPeano' n) a@ provides the actual implementation of 'make'; there is an instance of this class for any @(n, a)@+-- * @'IsFunN' a ('V' n a) f, f ~ 'FunN' ('NatToPeano' n) a ('V' n a), n ~ 'ArityV' f@ indicate the shape to the typechecker of @f@ (see documentation of 'IsFunN').+make ::+ forall (n :: Nat) a f.+ ( -- GHC cannot prove it for any @n@, but can prove it at call site when+ -- @n@ is known+ n ~ PeanoToNat (NatToPeano n),+ Make (NatToPeano n) (NatToPeano n) a,+ IsFunN a (V n a) f,+ f ~ FunN (NatToPeano n) a (V n a),+ n ~ ArityV f+ ) =>+ f+make = make' @(NatToPeano n) @(NatToPeano n) @a id+{-# INLINE make #-}++-- | @'Make' m n a@ is used to avoid recursion in the implementation of 'make'+-- so that 'make' can be inlined.+--+-- 'Make' is solely used in the signature of that function.+type Make :: Peano -> Peano -> Type -> Constraint+class Make m n a where+ -- The idea behind Make / make' / make is the following:+ --+ -- The function created by make' takes m values of type a, but returns a 'V n a' (with n ≥ m),+ -- so the n - m missing values must be supplied via the accumulator.+ --+ -- make' is initially called with m = n via make, and as m decreases,+ -- the number of lambda on the left increases and the captured values are put+ -- in the accumulator+ -- ('V[ ... ] <> ' represents the "extend" operation for 'V'):+ --+ -- > make @n+ -- > --> make' @n @n (V[] <>)+ -- > --> λx. make' @(n - 1) @n (V[x] <>)+ -- > --> λx. λy. make' @(n - 2) @n (V[x, y] <>)+ -- > --> ...+ -- > --> λx. λy. ... λz. make' @0 @n (V[x, y, ... z] <>) -- make' @0 @n f = f V[]+ -- > --> λx. λy. ... λz. V[x, y, ... z]+ make' :: (V (PeanoToNat m) a %1 -> V (PeanoToNat n) a) %1 -> FunN m a (V (PeanoToNat n) a)++instance Make 'Z n a where+ make' produceFrom = produceFrom empty+ {-# INLINE make' #-}++instance ((1 + PeanoToNat m) - 1 ~ PeanoToNat m, Make m n a) => Make ('S m) n a where+ make' produceFrom = \x -> make' @m @n @a (\s -> produceFrom $ cons x s)+ {-# INLINE make' #-}++-------------------------------------------------------------------------------+-- Functions below use AllowAmbiguousTypes+-------------------------------------------------------------------------------++-- | Returns the type-level 'Nat' of the context as a term-level integer.+theLength :: forall n. KnownNat n => Prelude.Int+theLength = Prelude.fromIntegral (natVal' @n (proxy# @_))++pure :: forall n a. KnownNat n => a -> V n a+pure a = V $ Vector.replicate (theLength @n) a++-- | Creates a 'V' of the specified size by consuming a 'Replicator'.+fromReplicator :: forall n a. KnownNat n => Replicator a %1 -> V n a+fromReplicator = let n' = theLength @n in V . Unsafe.toLinear Vector.fromList . Replicator.take n'++-- | Produces a @'V' n a@ from a 'Dupable' value @a@.+dupV :: forall n a. (KnownNat n, Dupable a) => a %1 -> V n a+dupV = fromReplicator . dupR
src/Data/V/Linear/Internal/Instances.hs view
@@ -1,37 +1,35 @@ {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} -- | This module contains all instances for V--- module Data.V.Linear.Internal.Instances where -import Data.V.Linear.Internal.V-import Prelude.Linear.Internal-import qualified Unsafe.Linear as Unsafe-import qualified Data.Functor.Linear.Internal.Functor as Data import qualified Data.Functor.Linear.Internal.Applicative as Data+import qualified Data.Functor.Linear.Internal.Functor as Data import qualified Data.Functor.Linear.Internal.Traversable as Data-import GHC.TypeLits+import Data.V.Linear.Internal (V (..))+import qualified Data.V.Linear.Internal as V import qualified Data.Vector as Vector-+import GHC.TypeLits+import Prelude.Linear.Internal+import qualified Unsafe.Linear as Unsafe -- # Instances of V ------------------------------------------------------------------------------- instance Data.Functor (V n) where- fmap f (V xs) = V $ Unsafe.toLinear (Vector.map (\x -> f x)) xs+ fmap = V.map instance KnownNat n => Data.Applicative (V n) where- pure a = V $ Vector.replicate (theLength @n) a- (V fs) <*> (V xs) = V $- Unsafe.toLinear2 (Vector.zipWith (\f x -> f $ x)) fs xs+ pure = V.pure+ a <*> b = a V.<*> b instance KnownNat n => Data.Traversable (V n) where traverse f (V xs) =- (V . Unsafe.toLinear (Vector.fromListN (theLength @n))) Data.<$>- Data.traverse f (Unsafe.toLinear Vector.toList xs)-+ (V . Unsafe.toLinear (Vector.fromListN (V.theLength @n)))+ Data.<$> Data.traverse f (Unsafe.toLinear Vector.toList xs)
− src/Data/V/Linear/Internal/V.hs
@@ -1,167 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE UndecidableInstances #-}-module Data.V.Linear.Internal.V- ( V(..)- , FunN- , theLength- , elim- , make- , iterate- -- * Type-level utilities- , caseNat- ) where--import Data.Kind (Type)-import Data.Proxy-import Data.Type.Equality-import Data.Vector (Vector)-import qualified Data.Vector as Vector-import GHC.Exts (Constraint, proxy#)-import GHC.TypeLits-import Prelude- ( Eq- , Ord- , Int- , Bool(..)- , Either(..)- , Maybe(..)- , fromIntegral- , error- , (-))-import qualified Prelude as Prelude-import Prelude.Linear.Internal-import qualified Unsafe.Linear as Unsafe--{- Developers Note--See the "Developers Note" in Data.V.Linear for an explanation of this module-structure.---}---- # Type Definitions----------------------------------------------------------------------------------newtype V (n :: Nat) (a :: Type) = V (Vector a)- deriving (Eq, Ord, Prelude.Functor)- -- Using vector rather than, say, 'Array' (or directly 'Array#') because it- -- offers many convenience function. Since all these unsafeCoerces probably- -- kill the fusion rules, it may be worth it going lower level since I- -- probably have to write my own fusion anyway. Therefore, starting from- -- Vectors at the moment.--type family FunN (n :: Nat) (a :: Type) (b :: Type) :: Type where- FunN 0 a b = b- FunN n a b = a %1-> FunN (n-1) a b---- # API----------------------------------------------------------------------------------theLength :: forall n. KnownNat n => Int-theLength = fromIntegral (natVal' @n (proxy# @_))--split :: 1 <= n => V n a %1-> (# a, V (n-1) a #)-split = Unsafe.toLinear split'- where- split' :: 1 <= n => V n a -> (# a, V (n-1) a #)- split' (V xs) = (# Vector.head xs, V (Vector.tail xs) #)--consumeV :: V 0 a %1-> b %1-> b-consumeV = Unsafe.toLinear (\_ -> id)--unsafeZero :: n :~: 0-unsafeZero = Unsafe.coerce Refl--unsafeNonZero :: (1 <=? n) :~: 'True-unsafeNonZero = Unsafe.coerce Refl---- Same as in the constraints library, but it's just as easy to avoid a--- dependency here.-data Dict (c :: Constraint) where- Dict :: c => Dict c--predNat :: forall n. (1 <= n, KnownNat n) => Dict (KnownNat (n-1))-predNat = case someNatVal (natVal' @n (proxy# @_) - 1) of- Just (SomeNat (_ :: Proxy p)) -> Unsafe.coerce (Dict @(KnownNat p))- Nothing -> error "Vector.pred: n-1 is necessarily a Nat, if 1<=n"--caseNat :: forall n. KnownNat n => Either (n :~: 0) ((1 <=? n) :~: 'True)-caseNat =- case theLength @n of- 0 -> Left $ unsafeZero @n- _ -> Right $ unsafeNonZero @n-{-# INLINE caseNat #-}---- By definition.-expandFunN :: forall n a b. (1 <= n) => FunN n a b %1-> a %1-> FunN (n-1) a b-expandFunN k = Unsafe.coerce k---- By definition.-contractFunN :: (1 <= n) => (a %1-> FunN (n-1) a b) %1-> FunN n a b-contractFunN k = Unsafe.coerce k---- TODO: consider using template haskell to make this expression more efficient.--- | This is like pattern-matching on a n-tuple. It will eventually be--- polymorphic the same way as a case expression.-elim :: forall n a b. KnownNat n => V n a %1-> FunN n a b %1-> b-elim xs f =- case caseNat @n of- Left Refl -> consumeV xs f- Right Refl -> elimS (split xs) f- where- elimS :: 1 <= n => (# a, V (n-1) a #) %1-> FunN n a b %1-> b- elimS (# x, xs' #) g = case predNat @n of- Dict -> elim xs' (expandFunN @n @a @b g x)---- XXX: This can probably be improved a lot.-make :: forall n a. KnownNat n => FunN n a (V n a)-make = case caseNat @n of- Left Refl -> V Vector.empty- Right Refl -> contractFunN @n @a @(V n a) prepend- where prepend :: a %1-> FunN (n-1) a (V n a)- prepend t = case predNat @n of- Dict -> continue @(n-1) @a @(V (n-1) a) (cons t) (make @(n-1) @a)--cons :: forall n a. a %1-> V (n-1) a %1-> V n a-cons = Unsafe.toLinear2 $ \x (V v) -> V (Vector.cons x v)--continue :: forall n a b c. KnownNat n => (b %1-> c) %1-> FunN n a b %1-> FunN n a c-continue = case caseNat @n of- Left Refl -> id- Right Refl -> \f t -> contractFunN @n @a @c (continueS f (expandFunN @n @a @b t))- where continueS :: (KnownNat n, 1 <= n) => (b %1-> c) %1-> (a %1-> FunN (n-1) a b) %1-> (a %1-> FunN (n-1) a c)- continueS f' x a = case predNat @n of Dict -> continue @(n-1) @a @b f' (x a)--iterate :: forall n a. (KnownNat n, 1 <= n) => (a %1-> (a, a)) -> a %1-> V n a-iterate dup init =- go @n init- where- go :: forall m. (KnownNat m, 1 <= m) => a %1-> V m a- go a =- case predNat @m of- Dict -> case caseNat @(m-1) of- Prelude.Left Refl ->- case pr1 @m Refl of- Refl ->- (make @m @a :: a %1-> V m a) a- Prelude.Right Refl ->- dup a & \(a', a'') ->- a' `cons` go @(m-1) a''-- -- An unsafe cast to prove the simple equality.- pr1 :: forall k. 0 :~: (k - 1) -> k :~: 1- pr1 Refl = Unsafe.coerce Refl-
src/Data/Vector/Mutable/Linear.hs view
@@ -1,13 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE UnboxedTuples #-}-{-# OPTIONS_GHC -Wno-unbanged-strict-patterns #-} -- | Mutable vectors with a linear API. --@@ -37,10 +28,12 @@ module Data.Vector.Mutable.Linear ( -- * A mutable vector Vector,+ -- * Run a computation with a vector empty, constant, fromList,+ -- * Mutators set, unsafeSet,@@ -52,6 +45,7 @@ mapMaybe, slice, shrinkToFit,+ -- * Accessors get, unsafeGet,@@ -59,317 +53,13 @@ capacity, toList, freeze,+ -- * Mutable-style interface read, unsafeRead, write,- unsafeWrite+ unsafeWrite, ) where -import GHC.Stack-import Prelude.Linear hiding (read, filter, mapMaybe)-import Data.Array.Mutable.Linear (Array)-import qualified Prelude-import Data.Monoid.Linear-import qualified Data.Array.Mutable.Linear as Array-import qualified Data.Functor.Linear as Data-import qualified Unsafe.Linear as Unsafe-import qualified Data.Vector as Vector---- # Constants------------------------------------------------------------------------------------ | When growing the vector, capacity will be multiplied by this number.------ This is usually chosen between 1.5 and 2; 2 being the most common.-constGrowthFactor :: Int-constGrowthFactor = 2---- # Core data types------------------------------------------------------------------------------------ | A dynamic mutable vector.-data Vector a where- Vec ::- -- ^ Current size- Int ->- -- ^ Underlying array (has size equal to or larger than the vectors)- Array a %1->- Vector a---- # API: Construction, Mutation, Queries------------------------------------------------------------------------------------ | Create a 'Vector' from an 'Array'. Result will have the size and capacity--- equal to the size of the given array.------ This is a constant time operation.-fromArray :: HasCallStack => Array a %1-> Vector a-fromArray arr =- Array.size arr- & \(Ur size', arr') -> Vec size' arr'---- Allocate an empty vector-empty :: (Vector a %1-> Ur b) %1-> Ur b-empty f = Array.fromList [] (f . fromArray)---- | Allocate a constant vector of a given non-negative size (and error on a--- bad size)-constant :: HasCallStack =>- Int -> a -> (Vector a %1-> Ur b) %1-> Ur b-constant size' x f- | size' < 0 =- (error ("Trying to construct a vector of size " ++ show size') :: x %1-> x)- (f undefined)- | otherwise = Array.alloc size' x (f . fromArray)---- | Allocator from a list-fromList :: HasCallStack => [a] -> (Vector a %1-> Ur b) %1-> Ur b-fromList xs f = Array.fromList xs (f . fromArray)---- | Number of elements inside the vector.------ This might be different than how much actual memory the vector is using.--- For that, see: 'capacity'.-size :: Vector a %1-> (Ur Int, Vector a)-size (Vec size' arr) = (Ur size', Vec size' arr)---- | Capacity of a vector. In other words, the number of elements--- the vector can contain before it is copied to a bigger array.-capacity :: Vector a %1-> (Ur Int, Vector a)-capacity (Vec s arr) =- Array.size arr & \(cap, arr') -> (cap, Vec s arr')---- | Insert at the end of the vector. This will grow the vector if there--- is no empty space.-push :: a -> Vector a %1-> Vector a-push x vec =- growToFit 1 vec & \(Vec s arr) ->- unsafeSet s x (Vec (s + 1) arr)---- | Pop from the end of the vector. This will never shrink the vector, use--- 'shrinkToFit' to remove the wasted space.-pop :: Vector a %1-> (Ur (Maybe a), Vector a)-pop vec =- size vec & \case- (Ur 0, vec') ->- (Ur Nothing, vec')- (Ur s, vec') ->- get (s-1) vec' & \(Ur a, Vec _ arr) ->- ( Ur (Just a)- , Vec (s-1) arr- )---- | Write to an element . Note: this will not write to elements beyond the--- current size of the vector and will error instead.-set :: HasCallStack => Int -> a -> Vector a %1-> Vector a-set ix val vec =- unsafeSet ix val (assertIndexInRange ix vec)---- | Same as 'write', but does not do bounds-checking. The behaviour is undefined--- when passed an invalid index.-unsafeSet :: HasCallStack => Int -> a -> Vector a %1-> Vector a-unsafeSet ix val (Vec size' arr) =- Vec size' (Array.unsafeSet ix val arr)---- | Read from a vector, with an in-range index and error for an index that is--- out of range (with the usual range @0..size-1@).-get :: HasCallStack => Int -> Vector a %1-> (Ur a, Vector a)-get ix vec =- unsafeGet ix (assertIndexInRange ix vec)---- | Same as 'read', but does not do bounds-checking. The behaviour is undefined--- when passed an invalid index.-unsafeGet :: HasCallStack => Int -> Vector a %1-> (Ur a, Vector a)-unsafeGet ix (Vec size' arr) =- Array.unsafeGet ix arr- & \(val, arr') -> (val, Vec size' arr')---- | Same as 'modify', but does not do bounds-checking.-unsafeModify :: HasCallStack => (a -> (a, b)) -> Int- -> Vector a %1-> (Ur b, Vector a)-unsafeModify f ix (Vec size' arr) =- Array.unsafeGet ix arr & \(Ur old, arr') ->- case f old of- (a, b) -> Array.unsafeSet ix a arr' & \arr'' ->- (Ur b, Vec size' arr'')---- | Modify a value inside a vector, with an ability to return an extra--- information. Errors if the index is out of bounds.-modify :: HasCallStack => (a -> (a, b)) -> Int- -> Vector a %1-> (Ur b, Vector a)-modify f ix vec = unsafeModify f ix (assertIndexInRange ix vec)---- | Same as 'modify', but without the ability to return extra information.-modify_ :: HasCallStack => (a -> a) -> Int -> Vector a %1-> Vector a-modify_ f ix vec =- modify (\a -> (f a, ())) ix vec- & \(Ur (), vec') -> vec'---- | Return the vector elements as a lazy list.-toList :: Vector a %1-> Ur [a]-toList (Vec s arr) =- Array.toList arr & \(Ur xs) ->- Ur (Prelude.take s xs)---- | Filters the vector in-place. It does not deallocate unused capacity,--- use 'shrinkToFit' for that if necessary.-filter :: Vector a %1-> (a -> Bool) -> Vector a-filter v f = mapMaybe v (\a -> if f a then Just a else Nothing)--- TODO A slightly more efficient version exists, where we skip the writes--- until the first time the predicate fails. However that requires duplicating--- most of the logic at `mapMaybe`, so lets not until we have benchmarks to--- see the advantage.---- | A version of 'fmap' which can throw out elements.-mapMaybe :: Vector a %1-> (a -> Maybe b) -> Vector b-mapMaybe vec (f :: a -> Maybe b) =- size vec & \(Ur s, vec') -> go 0 0 s vec'- where- go :: Int -- ^ read cursor- -> Int -- ^ write cursor- -> Int -- ^ input size- -> Vector a %1-> Vector b- go r w s vec'- -- If we processed all elements, set the capacity after the last written- -- index and coerce the result to the correct type.- | r == s =- vec' & \(Vec _ arr) ->- Vec w (Unsafe.coerce arr)- -- Otherwise, read an element, write if the predicate is true and advance- -- the write cursor; otherwise keep the write cursor skipping the element.- | otherwise =- unsafeGet r vec' & \case- (Ur a, vec'')- | Just b <- f a ->- go (r+1) (w+1) s (unsafeSet w (Unsafe.coerce b) vec'')- | otherwise ->- go (r+1) w s vec''---- | Resize the vector to not have any wasted memory (size == capacity). This--- returns a semantically identical vector.-shrinkToFit :: Vector a %1-> Vector a-shrinkToFit vec =- capacity vec & \(Ur cap, vec') ->- size vec' & \(Ur s', vec'') ->- if cap > s'- then unsafeResize s' vec''- else vec''---- | Return a slice of the vector with given size, starting from an offset.------ Start offset + target size should be within the input vector, and both should--- be non-negative.------ This is a constant time operation if the start offset is 0. Use 'shrinkToFit'--- to remove the possible wasted space if necessary.-slice :: Int -> Int -> Vector a %1-> Vector a-slice from newSize (Vec oldSize arr) =- if oldSize < from + newSize- then arr `lseq` error "Slice index out of bounds"- else if from == 0- then Vec newSize arr- else Array.slice from newSize arr & \(oldArr, newArr) ->- oldArr `lseq` fromArray newArr---- | /O(1)/ Convert a 'Vector' to an immutable 'Vector.Vector' (from--- 'vector' package).-freeze :: Vector a %1-> Ur (Vector.Vector a)-freeze (Vec sz arr) =- Array.freeze arr- & \(Ur vec) -> Ur (Vector.take sz vec)---- | Same as 'set', but takes the 'Vector' as the first parameter.-write :: HasCallStack => Vector a %1-> Int -> a -> Vector a-write arr i a = set i a arr---- | Same as 'unsafeSafe', but takes the 'Vector' as the first parameter.-unsafeWrite :: Vector a %1-> Int -> a -> Vector a-unsafeWrite arr i a = unsafeSet i a arr---- | Same as 'get', but takes the 'Vector' as the first parameter.-read :: HasCallStack => Vector a %1-> Int -> (Ur a, Vector a)-read arr i = get i arr---- | Same as 'unsafeGet', but takes the 'Vector' as the first parameter.-unsafeRead :: Vector a %1-> Int -> (Ur a, Vector a)-unsafeRead arr i = unsafeGet i arr---- # Instances----------------------------------------------------------------------------------instance Consumable (Vector a) where- consume (Vec _ arr) = consume arr--instance Dupable (Vector a) where- dup2 (Vec i arr) = dup2 arr & \(a1, a2) ->- (Vec i a1, Vec i a2)---- There is no way to get an unrestricted vector. So the below instance--- is just to satisfy the linear Semigroup's constraint.-instance Prelude.Semigroup (Vector a) where- v1 <> v2 = v1 Data.Monoid.Linear.<> v2--instance Semigroup (Vector a) where- -- This operation tries to use the existing capacity of v1 when possible.- v1 <> v2 =- size v2 & \(Ur s2, v2') ->- growToFit s2 v1 & \v1' ->- toList v2' & \(Ur xs) ->- go xs v1'- where- go :: [a] -> Vector a %1-> Vector a- go [] vec = vec- go (x:xs) (Vec sz arr) =- unsafeSet sz x (Vec (sz+1) arr)- & go xs--instance Data.Functor Vector where- fmap f vec = mapMaybe vec (\a -> Just (f a))---- # Internal library------------------------------------------------------------------------------------ | Grows the vector to the closest power of growthFactor to--- fit at least n more elements.-growToFit :: HasCallStack => Int -> Vector a %1-> Vector a-growToFit n vec =- capacity vec & \(Ur cap, vec') ->- size vec' & \(Ur s', vec'') ->- if s' + n <= cap- then vec''- else- let -- Calculate the closest power of growth factor- -- larger than required size.- newSize =- constGrowthFactor -- This constant is defined above.- ^ (ceiling :: Double -> Int)- (logBase- (fromIntegral constGrowthFactor)- (fromIntegral (s' + n))) -- this is always- -- > 0 because of- -- the if condition- in unsafeResize- newSize- vec''---- | Resize the vector to a non-negative size. In-range elements are preserved,--- the possible new elements are bottoms.-unsafeResize :: HasCallStack => Int -> Vector a %1-> Vector a-unsafeResize newSize (Vec size' ma) =- Vec- (min size' newSize)- (Array.resize- newSize- (error "access to uninitialized vector index")- ma- )---- | Check if given index is within the Vector, otherwise panic.-assertIndexInRange :: HasCallStack => Int -> Vector a %1-> Vector a-assertIndexInRange i vec =- size vec & \(Ur s, vec') ->- if 0 <= i && i < s- then vec'- else vec' `lseq` error "Vector: index out of bounds"+import Data.Vector.Mutable.Linear.Internal
+ src/Data/Vector/Mutable/Linear/Internal.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-unbanged-strict-patterns #-}+{-# OPTIONS_HADDOCK hide #-}++module Data.Vector.Mutable.Linear.Internal where++import Data.Array.Mutable.Linear (Array)+import qualified Data.Array.Mutable.Linear as Array+import qualified Data.Functor.Linear as Data+import Data.Monoid.Linear+import qualified Data.Vector as Vector+import GHC.Stack+import Prelude.Linear hiding (filter, mapMaybe, read)+import qualified Unsafe.Linear as Unsafe+import qualified Prelude++-- # Constants+-------------------------------------------------------------------------------++-- | When growing the vector, capacity will be multiplied by this number.+--+-- This is usually chosen between 1.5 and 2; 2 being the most common.+constGrowthFactor :: Int+constGrowthFactor = 2++-- # Core data types+-------------------------------------------------------------------------------++-- | A dynamic mutable vector.+data Vector a where+ -- | Current size+ Vec ::+ -- | Underlying array (has size equal to or larger than the vectors)+ Int ->+ Array a %1 ->+ Vector a++-- # API: Construction, Mutation, Queries+-------------------------------------------------------------------------------++-- | Create a 'Vector' from an 'Array'. Result will have the size and capacity+-- equal to the size of the given array.+--+-- This is a constant time operation.+fromArray :: HasCallStack => Array a %1 -> Vector a+fromArray arr =+ Array.size arr+ & \(Ur size', arr') -> Vec size' arr'++-- Allocate an empty vector+empty :: (Vector a %1 -> Ur b) %1 -> Ur b+empty f = Array.fromList [] (f . fromArray)++-- | Allocate a constant vector of a given non-negative size (and error on a+-- bad size)+constant ::+ HasCallStack =>+ Int ->+ a ->+ (Vector a %1 -> Ur b) %1 ->+ Ur b+constant size' x f+ | size' < 0 =+ (error ("Trying to construct a vector of size " ++ show size') :: x %1 -> x)+ (f undefined)+ | otherwise = Array.alloc size' x (f . fromArray)++-- | Allocator from a list+fromList :: HasCallStack => [a] -> (Vector a %1 -> Ur b) %1 -> Ur b+fromList xs f = Array.fromList xs (f . fromArray)++-- | Number of elements inside the vector.+--+-- This might be different than how much actual memory the vector is using.+-- For that, see: 'capacity'.+size :: Vector a %1 -> (Ur Int, Vector a)+size (Vec size' arr) = (Ur size', Vec size' arr)++-- | Capacity of a vector. In other words, the number of elements+-- the vector can contain before it is copied to a bigger array.+capacity :: Vector a %1 -> (Ur Int, Vector a)+capacity (Vec s arr) =+ Array.size arr & \(cap, arr') -> (cap, Vec s arr')++-- | Insert at the end of the vector. This will grow the vector if there+-- is no empty space.+push :: a -> Vector a %1 -> Vector a+push x vec =+ growToFit 1 vec & \(Vec s arr) ->+ unsafeSet s x (Vec (s + 1) arr)++-- | Pop from the end of the vector. This will never shrink the vector, use+-- 'shrinkToFit' to remove the wasted space.+pop :: Vector a %1 -> (Ur (Maybe a), Vector a)+pop vec =+ size vec & \case+ (Ur 0, vec') ->+ (Ur Nothing, vec')+ (Ur s, vec') ->+ get (s - 1) vec' & \(Ur a, Vec _ arr) ->+ ( Ur (Just a),+ Vec (s - 1) arr+ )++-- | Write to an element . Note: this will not write to elements beyond the+-- current size of the vector and will error instead.+set :: HasCallStack => Int -> a -> Vector a %1 -> Vector a+set ix val vec =+ unsafeSet ix val (assertIndexInRange ix vec)++-- | Same as 'write', but does not do bounds-checking. The behaviour is undefined+-- when passed an invalid index.+unsafeSet :: HasCallStack => Int -> a -> Vector a %1 -> Vector a+unsafeSet ix val (Vec size' arr) =+ Vec size' (Array.unsafeSet ix val arr)++-- | Read from a vector, with an in-range index and error for an index that is+-- out of range (with the usual range @0..size-1@).+get :: HasCallStack => Int -> Vector a %1 -> (Ur a, Vector a)+get ix vec =+ unsafeGet ix (assertIndexInRange ix vec)++-- | Same as 'read', but does not do bounds-checking. The behaviour is undefined+-- when passed an invalid index.+unsafeGet :: HasCallStack => Int -> Vector a %1 -> (Ur a, Vector a)+unsafeGet ix (Vec size' arr) =+ Array.unsafeGet ix arr+ & \(val, arr') -> (val, Vec size' arr')++-- | Same as 'modify', but does not do bounds-checking.+unsafeModify ::+ HasCallStack =>+ (a -> (a, b)) ->+ Int ->+ Vector a %1 ->+ (Ur b, Vector a)+unsafeModify f ix (Vec size' arr) =+ Array.unsafeGet ix arr & \(Ur old, arr') ->+ case f old of+ (a, b) ->+ Array.unsafeSet ix a arr' & \arr'' ->+ (Ur b, Vec size' arr'')++-- | Modify a value inside a vector, with an ability to return an extra+-- information. Errors if the index is out of bounds.+modify ::+ HasCallStack =>+ (a -> (a, b)) ->+ Int ->+ Vector a %1 ->+ (Ur b, Vector a)+modify f ix vec = unsafeModify f ix (assertIndexInRange ix vec)++-- | Same as 'modify', but without the ability to return extra information.+modify_ :: HasCallStack => (a -> a) -> Int -> Vector a %1 -> Vector a+modify_ f ix vec =+ modify (\a -> (f a, ())) ix vec+ & \(Ur (), vec') -> vec'++-- | Return the vector elements as a lazy list.+toList :: Vector a %1 -> Ur [a]+toList (Vec s arr) =+ Array.toList arr & \(Ur xs) ->+ Ur (Prelude.take s xs)++-- | Filters the vector in-place. It does not deallocate unused capacity,+-- use 'shrinkToFit' for that if necessary.+filter :: Vector a %1 -> (a -> Bool) -> Vector a+filter v f = mapMaybe v (\a -> if f a then Just a else Nothing)++-- TODO A slightly more efficient version exists, where we skip the writes+-- until the first time the predicate fails. However that requires duplicating+-- most of the logic at `mapMaybe`, so lets not until we have benchmarks to+-- see the advantage.++-- | A version of 'fmap' which can throw out elements.+mapMaybe :: Vector a %1 -> (a -> Maybe b) -> Vector b+mapMaybe vec (f :: a -> Maybe b) =+ size vec & \(Ur s, vec') -> go 0 0 s vec'+ where+ go ::+ Int -> -- read cursor+ Int -> -- write cursor+ Int -> -- input size+ Vector a %1 ->+ Vector b+ go r w s vec'+ -- If we processed all elements, set the capacity after the last written+ -- index and coerce the result to the correct type.+ | r == s =+ vec' & \(Vec _ arr) ->+ Vec w (Unsafe.coerce arr)+ -- Otherwise, read an element, write if the predicate is true and advance+ -- the write cursor; otherwise keep the write cursor skipping the element.+ | otherwise =+ unsafeGet r vec' & \case+ (Ur a, vec'')+ | Just b <- f a ->+ go (r + 1) (w + 1) s (unsafeSet w (Unsafe.coerce b) vec'')+ | otherwise ->+ go (r + 1) w s vec''++-- | Resize the vector to not have any wasted memory (size == capacity). This+-- returns a semantically identical vector.+shrinkToFit :: Vector a %1 -> Vector a+shrinkToFit vec =+ capacity vec & \(Ur cap, vec') ->+ size vec' & \(Ur s', vec'') ->+ if cap > s'+ then unsafeResize s' vec''+ else vec''++-- | Return a slice of the vector with given size, starting from an offset.+--+-- Start offset + target size should be within the input vector, and both should+-- be non-negative.+--+-- This is a constant time operation if the start offset is 0. Use 'shrinkToFit'+-- to remove the possible wasted space if necessary.+slice :: Int -> Int -> Vector a %1 -> Vector a+slice from newSize (Vec oldSize arr) =+ if oldSize < from + newSize+ then arr `lseq` error "Slice index out of bounds"+ else+ if from == 0+ then Vec newSize arr+ else+ Array.slice from newSize arr & \(oldArr, newArr) ->+ oldArr `lseq` fromArray newArr++-- | /O(1)/ Convert a 'Vector' to an immutable 'Vector.Vector' (from+-- 'vector' package).+freeze :: Vector a %1 -> Ur (Vector.Vector a)+freeze (Vec sz arr) =+ Array.freeze arr+ & \(Ur vec) -> Ur (Vector.take sz vec)++-- | Same as 'set', but takes the 'Vector' as the first parameter.+write :: HasCallStack => Vector a %1 -> Int -> a -> Vector a+write arr i a = set i a arr++-- | Same as 'unsafeSafe', but takes the 'Vector' as the first parameter.+unsafeWrite :: Vector a %1 -> Int -> a -> Vector a+unsafeWrite arr i a = unsafeSet i a arr++-- | Same as 'get', but takes the 'Vector' as the first parameter.+read :: HasCallStack => Vector a %1 -> Int -> (Ur a, Vector a)+read arr i = get i arr++-- | Same as 'unsafeGet', but takes the 'Vector' as the first parameter.+unsafeRead :: Vector a %1 -> Int -> (Ur a, Vector a)+unsafeRead arr i = unsafeGet i arr++-- # Instances+-------------------------------------------------------------------------------++instance Consumable (Vector a) where+ consume (Vec _ arr) = consume arr++instance Dupable (Vector a) where+ dup2 (Vec i arr) =+ dup2 arr & \(a1, a2) ->+ (Vec i a1, Vec i a2)++-- There is no way to get an unrestricted vector. So the below instance+-- is just to satisfy the linear Semigroup's constraint.+instance Prelude.Semigroup (Vector a) where+ v1 <> v2 = v1 Data.Monoid.Linear.<> v2++instance Semigroup (Vector a) where+ -- This operation tries to use the existing capacity of v1 when possible.+ v1 <> v2 =+ size v2 & \(Ur s2, v2') ->+ growToFit s2 v1 & \v1' ->+ toList v2' & \(Ur xs) ->+ go xs v1'+ where+ go :: [a] -> Vector a %1 -> Vector a+ go [] vec = vec+ go (x : xs) (Vec sz arr) =+ unsafeSet sz x (Vec (sz + 1) arr)+ & go xs++instance Data.Functor Vector where+ fmap f vec = mapMaybe vec (\a -> Just (f a))++-- # Internal library+-------------------------------------------------------------------------------++-- | Grows the vector to the closest power of growthFactor to+-- fit at least n more elements.+growToFit :: HasCallStack => Int -> Vector a %1 -> Vector a+growToFit n vec =+ capacity vec & \(Ur cap, vec') ->+ size vec' & \(Ur s', vec'') ->+ if s' + n <= cap+ then vec''+ else+ let -- Calculate the closest power of growth factor+ -- larger than required size.+ newSize =+ constGrowthFactor -- This constant is defined above.+ ^ (ceiling :: Double -> Int)+ ( logBase+ (fromIntegral constGrowthFactor)+ (fromIntegral (s' + n)) -- this is always+ -- > 0 because of+ -- the if condition+ )+ in unsafeResize+ newSize+ vec''++-- | Resize the vector to a non-negative size. In-range elements are preserved,+-- the possible new elements are bottoms.+unsafeResize :: HasCallStack => Int -> Vector a %1 -> Vector a+unsafeResize newSize (Vec size' ma) =+ Vec+ (min size' newSize)+ ( Array.resize+ newSize+ (error "access to uninitialized vector index")+ ma+ )++-- | Check if given index is within the Vector, otherwise panic.+assertIndexInRange :: HasCallStack => Int -> Vector a %1 -> Vector a+assertIndexInRange i vec =+ size vec & \(Ur s, vec') ->+ if 0 <= i && i < s+ then vec'+ else vec' `lseq` error "Vector: index out of bounds"
src/Debug/Trace/Linear.hs view
@@ -9,56 +9,59 @@ -- the original "Debug.Trace" module for more detailed information. module Debug.Trace.Linear ( -- * Tracing- trace- , traceShow- , traceId- , traceStack- , traceIO- , traceM- , traceShowM+ trace,+ traceShow,+ traceId,+ traceStack,+ traceIO,+ traceM,+ traceShowM,+ -- * Eventlog tracing- , traceEvent- , traceEventIO+ traceEvent,+ traceEventIO,+ -- * Execution phase markers- , traceMarker- , traceMarkerIO- ) where+ traceMarker,+ traceMarkerIO,+ )+where -import qualified Debug.Trace as NonLinear-import qualified Unsafe.Linear as Unsafe-import System.IO.Linear import Data.Functor.Linear import Data.Unrestricted.Linear-import Prelude (String, Show(..))+import qualified Debug.Trace as NonLinear import Prelude.Linear.Internal+import System.IO.Linear+import qualified Unsafe.Linear as Unsafe+import Prelude (Show (..), String) -- | The 'trace' function outputs the trace message given as its first -- argument, before returning the second argument as its result.-trace :: String %1-> a %1-> a+trace :: String %1 -> a %1 -> a trace = Unsafe.toLinear2 NonLinear.trace -- | Like 'trace', but uses 'show' on the argument to convert it to -- a 'String'.-traceShow :: Show a => a -> b %1-> b+traceShow :: Show a => a -> b %1 -> b traceShow a = Unsafe.toLinear (NonLinear.traceShow a) -- | Like 'trace' but returns the message instead of a third value.-traceId :: String %1-> String+traceId :: String %1 -> String traceId s = dup s & \(s', s'') -> trace s' s'' -- | Like 'trace', but additionally prints a call stack if one is -- available.-traceStack :: String %1-> a %1-> a+traceStack :: String %1 -> a %1 -> a traceStack = Unsafe.toLinear2 NonLinear.traceStack -- | The 'traceIO' function outputs the trace message from the IO monad. -- This sequences the output with respect to other IO actions.-traceIO :: String %1-> IO ()+traceIO :: String %1 -> IO () traceIO s = fromSystemIO (Unsafe.toLinear NonLinear.traceIO s) -- | Like 'trace' but returning unit in an arbitrary 'Applicative' -- context. Allows for convenient use in do-notation.-traceM :: Applicative f => String %1-> f ()+traceM :: Applicative f => String %1 -> f () traceM s = trace s $ pure () -- | Like 'traceM', but uses 'show' on the argument to convert it to a@@ -69,22 +72,22 @@ -- | The 'traceEvent' function behaves like 'trace' with the difference -- that the message is emitted to the eventlog, if eventlog profiling is -- available and enabled at runtime.-traceEvent :: String %1-> a %1-> a+traceEvent :: String %1 -> a %1 -> a traceEvent = Unsafe.toLinear2 NonLinear.traceEvent -- | The 'traceEventIO' function emits a message to the eventlog, if -- eventlog profiling is available and enabled at runtime.-traceEventIO :: String %1-> IO ()+traceEventIO :: String %1 -> IO () traceEventIO s = fromSystemIO (Unsafe.toLinear NonLinear.traceEventIO s) -- | The 'traceMarker' function emits a marker to the eventlog, if eventlog -- profiling is available and enabled at runtime. The @String@ is the name -- of the marker. The name is just used in the profiling tools to help you -- keep clear which marker is which.-traceMarker :: String %1-> a %1-> a+traceMarker :: String %1 -> a %1 -> a traceMarker = Unsafe.toLinear2 NonLinear.traceMarker -- | The 'traceMarkerIO' function emits a marker to the eventlog, if -- eventlog profiling is available and enabled at runtime.-traceMarkerIO :: String %1-> IO ()+traceMarkerIO :: String %1 -> IO () traceMarkerIO s = fromSystemIO (Unsafe.toLinear NonLinear.traceMarkerIO s)
src/Foreign/Marshal/Pure.hs view
@@ -1,20 +1,4 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--- XXX: deactivate orphan instance warning as we're defining a few Storable--- instances here. It's not worth fixing as I [aspiwack] intend to change the--- interface for something more appropriate, which won't require these Storable--- instances.-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-} -- | This module introduces primitives to /safely/ allocate and discard system -- heap memory (/not GC heap memory/) for storing values /explicitly/.@@ -37,6 +21,7 @@ -- A toy example: -- -- >>> :set -XLinearTypes+-- >>> import Prelude -- >>> import Data.Unrestricted.Linear -- >>> import qualified Foreign.Marshal.Pure as Manual -- >>> :{@@ -65,374 +50,19 @@ -- -- You can find example data structure implementations in @Foreign.List@ and -- @Foreign.Heap@ [here](https://github.com/tweag/linear-base/tree/master/examples/Foreign).- module Foreign.Marshal.Pure- (- -- * Allocating and using values on the heap- Pool- , withPool- , Box- , alloc- , deconstruct- -- * Typeclasses for values that can be allocated- , KnownRepresentable- , Representable(..)- , MkRepresentable(..)- ) where--import Control.Exception-import qualified Data.Functor.Linear as Data-import Data.Kind (Constraint, Type)-import Data.Word (Word8)-import Foreign.Marshal.Alloc-import Foreign.Marshal.Utils-import Foreign.Ptr-import Foreign.Storable-import Foreign.Storable.Tuple ()-import Prelude (($), return, (<*>), Eq(..), (<$>), (=<<))-import Prelude.Linear hiding (($), Eq(..))-import System.IO.Unsafe-import qualified Unsafe.Linear as Unsafe---- XXX: [2018-02-09] I'm having trouble with the `constraints` package (it seems--- that the version of Type.Reflection.Unsafe in the linear ghc compiler is not--- the one that was released with 8.2, and that `mtl` fails to compile against--- it), therefore, I'm redefining `Dict` here, as it's cheap.-data Dict :: Constraint -> Type where- Dict :: c => Dict c---- TODO: organise into sections---- | This abstract type class represents values natively known to have a GC-less--- implementation. Basically, these are sequences (represented as tuples) of--- base types.-class KnownRepresentable a where- storable :: Dict (Storable a)-- default storable :: Storable a => Dict (Storable a)- storable = Dict- -- This ought to be read a `newtype` around `Storable`. This type is abstract,- -- because using Storable this way is highly unsafe: Storable uses IO so we- -- will call unsafePerformIO, and Storable doesn't guarantee linearity. But- -- Storable comes with a lot of machinery, in particular for- -- architecture-independent alignment. So we can depend on it.- --- -- So, we restrict ourselves to known instances that we trust. For base types- -- there is no reason to expect problems. Tuples are a bit more subtle in that- -- they use non-linear operations. But the way they are used should be ok. At- -- any rate: in case a bug is found, the tuple instances are a good place to- -- look.--instance KnownRepresentable Word -- TODO: more word types-instance KnownRepresentable Int-instance KnownRepresentable (Ptr a)-instance KnownRepresentable ()-instance- (KnownRepresentable a, KnownRepresentable b)- => KnownRepresentable (a, b) where- storable =- case (storable @a, storable @b) of- (Dict, Dict) -> Dict-instance- (KnownRepresentable a, KnownRepresentable b, KnownRepresentable c)- => KnownRepresentable (a, b, c) where- storable =- case (storable @a, storable @b, storable @c) of- (Dict, Dict, Dict) -> Dict---- TODO: move to the definition of Ur-instance Storable a => Storable (Ur a) where- sizeOf _ = sizeOf (undefined :: a)- alignment _ = alignment (undefined :: a)- peek ptr = Ur <$> peek (castPtr ptr :: Ptr a)- poke ptr (Ur a) = poke (castPtr ptr :: Ptr a) a--instance KnownRepresentable a => KnownRepresentable (Ur a) where- storable | Dict <- storable @a = Dict---- Below is a KnownRepresentable instance for Maybe. The Storable instance is--- taken from--- https://www.schoolofhaskell.com/user/snoyberg/random-code-snippets/storable-instance-of-maybe------ aspiwack: This does not yield very good data representation for the general--- case. But I believe that to improve on it we need to rethink the abstraction--- in more depths.--instance Storable a => Storable (Maybe a) where- sizeOf x = sizeOf (stripMaybe x) + 1- alignment x = alignment (stripMaybe x)- peek ptr = do- filled <- peekByteOff ptr $ sizeOf $ stripMaybe $ stripPtr ptr- case filled == (1 :: Word8) of- True -> do- x <- peek (stripMaybePtr ptr)- return (Just x)- False ->- return Nothing- poke ptr Nothing = pokeByteOff ptr (sizeOf $ stripMaybe $ stripPtr ptr) (0 :: Word8)- poke ptr (Just a) = do- poke (stripMaybePtr ptr) a- pokeByteOff ptr (sizeOf a) (1 :: Word8)--stripMaybe :: Maybe a -> a-stripMaybe _ = error "stripMaybe"--stripMaybePtr :: Ptr (Maybe a) -> Ptr a-stripMaybePtr = castPtr--stripPtr :: Ptr a -> a-stripPtr _ = error "stripPtr"--instance KnownRepresentable a => KnownRepresentable (Maybe a) where- storable | Dict <- storable @a = Dict---- | Laws of 'Representable':------ * 'toKnown' must be total--- * 'ofKnown' may be partial, but must be total on the image of 'toKnown'--- * @ofKnown . toKnown == id@-class (KnownRepresentable (AsKnown a)) => Representable a where- type AsKnown a :: Type-- toKnown :: a %1-> AsKnown a- ofKnown :: AsKnown a %1-> a-- default toKnown- :: (MkRepresentable a b, AsKnown a ~ AsKnown b) => a %1-> AsKnown a- default ofKnown- :: (MkRepresentable a b, AsKnown a ~ AsKnown b) => AsKnown a %1-> a-- toKnown a = toKnown (toRepr a)- ofKnown b = ofRepr (ofKnown b)---- Some boilerplate: all the KnownRepresentable are Representable, by virtue of--- the identity being a retraction. We generalise a bit for the types of tuples:--- tuples of Representable (not only KnownRepresentable) are Representable.-instance Representable Word where- type AsKnown Word = Word- toKnown = id- ofKnown = id-instance Representable Int where- type AsKnown Int = Int- toKnown = id- ofKnown = id-instance Representable (Ptr a) where- type AsKnown (Ptr a) = Ptr a- toKnown = id- ofKnown = id-instance Representable () where- type AsKnown () = ()- toKnown = id- ofKnown = id-instance- (Representable a, Representable b)- => Representable (a, b) where- type AsKnown (a, b) = (AsKnown a, AsKnown b)- toKnown (a, b) = (toKnown a, toKnown b)- ofKnown (x, y) = (ofKnown x, ofKnown y)--instance- (Representable a, Representable b, Representable c)- => Representable (a, b, c) where- type AsKnown (a, b, c) = (AsKnown a, AsKnown b, AsKnown c)- toKnown (a, b, c) = (toKnown a, toKnown b, toKnown c)- ofKnown (x, y, z) = (ofKnown x, ofKnown y, ofKnown z)--instance Representable a => Representable (Maybe a) where- type AsKnown (Maybe a) = Maybe (AsKnown a)- toKnown (Just x) = Just (toKnown x)- toKnown Nothing = Nothing- ofKnown (Just x) = Just (ofKnown x)- ofKnown Nothing = Nothing---- | This is an easier way to create an instance of 'Representable'. It is a bit--- abusive to use a type class for this (after all, it almost never makes sense--- to use this as a constraint). But it works in practice.------ To use, define an instance of @MkRepresentable <myType> <intermediateType>@--- then declare the following instance:------ @instance Representable <myType> where {type AsKnown = AsKnown <intermediateType>}@------ And the default instance mechanism will create the appropriate--- 'Representable' instance.------ Laws of 'MkRepresentable':------ * 'toRepr' must be total--- * 'ofRepr' may be partial, but must be total on the image of 'toRepr'--- * @ofRepr . toRepr = id@-class Representable b => MkRepresentable a b | a -> b where- toRepr :: a %1-> b- ofRepr :: b %1-> a----- TODO: Briefly explain the Dupable-reader style of API, below, and fix--- details.---- | Pools represent collections of values. A 'Pool' can be 'consume'-ed. This--- is a no-op: it does not deallocate the data in that pool. It cannot do so,--- because accessible values might still exist. Consuming a pool simply makes it--- impossible to add new data to the pool.-data Pool where- Pool :: DLL (Ptr ()) -> Pool- -- /!\ Black magic: the pointers in the pool are only used to deallocate- -- dangling pointers. Therefore their 'sizeOf' does not matter. It is simpler- -- to cast all the pointers to some canonical type (here `Ptr ()`) so that we- -- don't have to deal with heterogeneous types. /!\---- Implementing a doubly-linked list with `Ptr`--data DLL a = DLL { prev :: Ptr (DLL a), elt :: Ptr a, next :: Ptr (DLL a) }- deriving Eq---- XXX: probably replaceable by storable-generic-instance Storable (DLL a) where- sizeOf _ = sizeOf (undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))- alignment _ = alignment (undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))-- peek ptr = do- (p, e, n) <- peek (castPtr ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a)))- return $ DLL p e n-- poke ptr (DLL p e n) =- poke (castPtr ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))) (p, e, n)---- Precondition: in `insertAfter start ptr`, `next start` must be initalised,--- and so must be `prev =<< peek (next start)`-insertAfter :: Storable a => DLL a -> a -> IO (Ptr (DLL a))-insertAfter start ptr = do- secondLink <- peek $ next start- newLink <- DLL <$> new start <*> new ptr <*> new secondLink- poke (next start) newLink- poke (prev secondLink) newLink- new newLink--delete :: DLL a -> IO ()-delete link = do- prevLink <- peek $ prev link- nextLink <- peek $ next link- poke (next prevLink) nextLink- poke (prev nextLink) prevLink---- /Doubly-linked list---- @freeAll start end@ frees all pointer in the linked list. Assumes that @end@--- doesn't have a pointer, and indeed terminates the list.----freeAll :: DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()-freeAll start end = do- nextLink <- peek (next start)- if nextLink == end then do- free (next start)- free (prev end)- else do- delete nextLink- free (prev nextLink)- free (elt nextLink)- free (next nextLink)- freeAll start end---- TODO: document individual functions---- | Given a linear computation that manages memory, run that computation.-withPool :: (Pool %1-> Ur b) %1-> Ur b-withPool scope = Unsafe.toLinear performScope scope- -- XXX: do ^ without `toLinear` by using linear IO- where- performScope :: (Pool %1-> Ur b) -> Ur b- performScope scope' = unsafeDupablePerformIO $ do- -- Initialise the pool- backPtr <- malloc- let end = DLL backPtr nullPtr nullPtr -- always at the end of the list- start <- DLL nullPtr nullPtr <$> new end -- always at the start of the list- poke backPtr start- -- Run the computation- evaluate (scope' (Pool start)) `finally`- -- Clean up remaining variables.- (freeAll start end)--instance Consumable Pool where- consume (Pool _) = ()--instance Dupable Pool where- dupV (Pool l) = Data.pure (Pool l)---- | 'Box a' is the abstract type of manually managed data. It can be used as--- part of data type definitions in order to store linked data structure off--- heap. See @Foreign.List@ and @Foreign.Pair@ in the @examples@ directory of--- the source repository.-data Box a where- Box :: Ptr (DLL (Ptr ())) -> Ptr a -> Box a---- XXX: if Box is a newtype, can be derived-instance Storable (Box a) where- sizeOf _ = sizeOf (undefined :: (Ptr (DLL (Ptr ())), Ptr a))- alignment _ = alignment (undefined :: (Ptr (DLL (Ptr ())), Ptr a))- peek ptr = do- (pool, ptr') <- peek (castPtr ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a))- return (Box pool ptr')- poke ptr (Box pool ptr') =- poke (castPtr ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a)) (pool, ptr')--instance KnownRepresentable (Box a) where-instance Representable (Box a) where- type AsKnown (Box a) = Box a- ofKnown = id- toKnown = id---- TODO: a way to store GC'd data using a StablePtr---- TODO: reference counted pointer. Remarks: rc pointers are Dupable but not--- Movable. In order to be useful, need some kind of borrowing on the values, I--- guess. 'Box' can be realloced, but not RC pointers.--reprPoke :: forall a. Representable a => Ptr a -> a %1-> IO ()-reprPoke ptr a | Dict <- storable @(AsKnown a) =- Unsafe.toLinear (poke (castPtr ptr :: Ptr (AsKnown a))) (toKnown a)--reprNew :: forall a. Representable a => a %1-> IO (Ptr a)-reprNew a =- Unsafe.toLinear mkPtr a- where- -- XXX: should be improved by using linear IO- mkPtr :: a -> IO (Ptr a)- mkPtr a' | Dict <- storable @(AsKnown a) =- do- ptr0 <- malloc @(AsKnown a)- let ptr = castPtr ptr0 :: Ptr a- reprPoke ptr a'- return ptr---- TODO: Ideally, we would like to avoid having a boxed representation of the--- data before a pointer is created. A better solution is to have a destination--- passing-style API (but there is still some design to be done there). This--- alloc primitive would then be derived (but most of the time we would rather--- write bespoke constructors).--- | Store a value @a@ on the system heap that is not managed by the GC.-alloc :: forall a. Representable a => a %1-> Pool %1-> Box a-alloc a (Pool pool) =- Unsafe.toLinear mkPtr a- where- -- XXX: should be improved by using linear IO- mkPtr :: a -> Box a- mkPtr a' = unsafeDupablePerformIO $ do- ptr <- reprNew a'- poolPtr <- insertAfter pool (castPtr ptr :: Ptr ())- return (Box poolPtr ptr)+ ( -- * Allocating and using values on the heap+ Pool,+ withPool,+ Box,+ alloc,+ deconstruct, --- TODO: would be better in linear IO, for we pretend that we are making an--- unrestricted 'a', where really we are not.-reprPeek :: forall a. Representable a => Ptr a -> IO a-reprPeek ptr | Dict <- storable @(AsKnown a) = do- knownRepr <- peek (castPtr ptr :: Ptr (AsKnown a))- return (ofKnown knownRepr)+ -- * Typeclasses for values that can be allocated+ KnownRepresentable,+ Representable (..),+ MkRepresentable (..),+ )+where --- | Retrieve the value stored on system heap memory.-deconstruct :: Representable a => Box a %1-> a-deconstruct (Box poolPtr ptr) = unsafeDupablePerformIO $ mask_ $ do- res <- reprPeek ptr- delete =<< peek poolPtr- free ptr- free poolPtr- return res+import Foreign.Marshal.Pure.Internal
+ src/Foreign/Marshal/Pure/Internal.hs view
@@ -0,0 +1,397 @@+-- XXX: deactivate orphan instance warning as we're defining a few Storable+-- instances here. It's not worth fixing as I [aspiwack] intend to change the+-- interface for something more appropriate, which won't require these Storable+-- instances.+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}++module Foreign.Marshal.Pure.Internal where++import Control.Exception+import qualified Data.Functor.Linear as Data+import Data.Kind (Constraint, Type)+import Data.Word (Word8)+import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import Foreign.Storable.Tuple ()+import Prelude.Linear hiding (Eq (..), ($))+import System.IO.Unsafe+import qualified Unsafe.Linear as Unsafe+import Prelude (Eq (..), return, ($), (<$>), (<*>), (=<<))++-- XXX: [2018-02-09] I'm having trouble with the `constraints` package (it seems+-- that the version of Type.Reflection.Unsafe in the linear ghc compiler is not+-- the one that was released with 8.2, and that `mtl` fails to compile against+-- it), therefore, I'm redefining `Dict` here, as it's cheap.+data Dict :: Constraint -> Type where+ Dict :: c => Dict c++-- TODO: organise into sections++-- | This abstract type class represents values natively known to have a GC-less+-- implementation. Basically, these are sequences (represented as tuples) of+-- base types.+class KnownRepresentable a where+ storable :: Dict (Storable a)+ default storable :: Storable a => Dict (Storable a)+ storable = Dict++-- This ought to be read a `newtype` around `Storable`. This type is abstract,+-- because using Storable this way is highly unsafe: Storable uses IO so we+-- will call unsafePerformIO, and Storable doesn't guarantee linearity. But+-- Storable comes with a lot of machinery, in particular for+-- architecture-independent alignment. So we can depend on it.+--+-- So, we restrict ourselves to known instances that we trust. For base types+-- there is no reason to expect problems. Tuples are a bit more subtle in that+-- they use non-linear operations. But the way they are used should be ok. At+-- any rate: in case a bug is found, the tuple instances are a good place to+-- look.++instance KnownRepresentable Word -- TODO: more word types++instance KnownRepresentable Int++instance KnownRepresentable (Ptr a)++instance KnownRepresentable ()++instance+ (KnownRepresentable a, KnownRepresentable b) =>+ KnownRepresentable (a, b)+ where+ storable =+ case (storable @a, storable @b) of+ (Dict, Dict) -> Dict++instance+ (KnownRepresentable a, KnownRepresentable b, KnownRepresentable c) =>+ KnownRepresentable (a, b, c)+ where+ storable =+ case (storable @a, storable @b, storable @c) of+ (Dict, Dict, Dict) -> Dict++-- TODO: move to the definition of Ur+instance Storable a => Storable (Ur a) where+ sizeOf _ = sizeOf (undefined :: a)+ alignment _ = alignment (undefined :: a)+ peek ptr = Ur <$> peek (castPtr ptr :: Ptr a)+ poke ptr (Ur a) = poke (castPtr ptr :: Ptr a) a++instance KnownRepresentable a => KnownRepresentable (Ur a) where+ storable | Dict <- storable @a = Dict++-- Below is a KnownRepresentable instance for Maybe. The Storable instance is+-- taken from+-- https://www.schoolofhaskell.com/user/snoyberg/random-code-snippets/storable-instance-of-maybe+--+-- aspiwack: This does not yield very good data representation for the general+-- case. But I believe that to improve on it we need to rethink the abstraction+-- in more depths.++instance Storable a => Storable (Maybe a) where+ sizeOf x = sizeOf (stripMaybe x) + 1+ alignment x = alignment (stripMaybe x)+ peek ptr = do+ filled <- peekByteOff ptr $ sizeOf $ stripMaybe $ stripPtr ptr+ case filled == (1 :: Word8) of+ True -> do+ x <- peek (stripMaybePtr ptr)+ return (Just x)+ False ->+ return Nothing+ poke ptr Nothing = pokeByteOff ptr (sizeOf $ stripMaybe $ stripPtr ptr) (0 :: Word8)+ poke ptr (Just a) = do+ poke (stripMaybePtr ptr) a+ pokeByteOff ptr (sizeOf a) (1 :: Word8)++stripMaybe :: Maybe a -> a+stripMaybe _ = error "stripMaybe"++stripMaybePtr :: Ptr (Maybe a) -> Ptr a+stripMaybePtr = castPtr++stripPtr :: Ptr a -> a+stripPtr _ = error "stripPtr"++instance KnownRepresentable a => KnownRepresentable (Maybe a) where+ storable | Dict <- storable @a = Dict++-- | Laws of 'Representable':+--+-- * 'toKnown' must be total+-- * 'ofKnown' may be partial, but must be total on the image of 'toKnown'+-- * @ofKnown . toKnown == id@+class (KnownRepresentable (AsKnown a)) => Representable a where+ type AsKnown a :: Type++ toKnown :: a %1 -> AsKnown a+ ofKnown :: AsKnown a %1 -> a++ default toKnown ::+ (MkRepresentable a b, AsKnown a ~ AsKnown b) => a %1 -> AsKnown a+ default ofKnown ::+ (MkRepresentable a b, AsKnown a ~ AsKnown b) => AsKnown a %1 -> a++ toKnown a = toKnown (toRepr a)+ ofKnown b = ofRepr (ofKnown b)++-- Some boilerplate: all the KnownRepresentable are Representable, by virtue of+-- the identity being a retraction. We generalise a bit for the types of tuples:+-- tuples of Representable (not only KnownRepresentable) are Representable.+instance Representable Word where+ type AsKnown Word = Word+ toKnown = id+ ofKnown = id++instance Representable Int where+ type AsKnown Int = Int+ toKnown = id+ ofKnown = id++instance Representable (Ptr a) where+ type AsKnown (Ptr a) = Ptr a+ toKnown = id+ ofKnown = id++instance Representable () where+ type AsKnown () = ()+ toKnown = id+ ofKnown = id++instance+ (Representable a, Representable b) =>+ Representable (a, b)+ where+ type AsKnown (a, b) = (AsKnown a, AsKnown b)+ toKnown (a, b) = (toKnown a, toKnown b)+ ofKnown (x, y) = (ofKnown x, ofKnown y)++instance+ (Representable a, Representable b, Representable c) =>+ Representable (a, b, c)+ where+ type AsKnown (a, b, c) = (AsKnown a, AsKnown b, AsKnown c)+ toKnown (a, b, c) = (toKnown a, toKnown b, toKnown c)+ ofKnown (x, y, z) = (ofKnown x, ofKnown y, ofKnown z)++instance Representable a => Representable (Maybe a) where+ type AsKnown (Maybe a) = Maybe (AsKnown a)+ toKnown (Just x) = Just (toKnown x)+ toKnown Nothing = Nothing+ ofKnown (Just x) = Just (ofKnown x)+ ofKnown Nothing = Nothing++-- | This is an easier way to create an instance of 'Representable'. It is a bit+-- abusive to use a type class for this (after all, it almost never makes sense+-- to use this as a constraint). But it works in practice.+--+-- To use, define an instance of @MkRepresentable <myType> <intermediateType>@+-- then declare the following instance:+--+-- @instance Representable <myType> where {type AsKnown = AsKnown <intermediateType>}@+--+-- And the default instance mechanism will create the appropriate+-- 'Representable' instance.+--+-- Laws of 'MkRepresentable':+--+-- * 'toRepr' must be total+-- * 'ofRepr' may be partial, but must be total on the image of 'toRepr'+-- * @ofRepr . toRepr = id@+class Representable b => MkRepresentable a b | a -> b where+ toRepr :: a %1 -> b+ ofRepr :: b %1 -> a++-- TODO: Briefly explain the Dupable-reader style of API, below, and fix+-- details.++-- | Pools represent collections of values. A 'Pool' can be 'consume'-ed. This+-- is a no-op: it does not deallocate the data in that pool. It cannot do so,+-- because accessible values might still exist. Consuming a pool simply makes it+-- impossible to add new data to the pool.+data Pool where+ Pool :: DLL (Ptr ()) -> Pool++-- /!\ Black magic: the pointers in the pool are only used to deallocate+-- dangling pointers. Therefore their 'sizeOf' does not matter. It is simpler+-- to cast all the pointers to some canonical type (here `Ptr ()`) so that we+-- don't have to deal with heterogeneous types. /!\++-- Implementing a doubly-linked list with `Ptr`++data DLL a = DLL {prev :: Ptr (DLL a), elt :: Ptr a, next :: Ptr (DLL a)}+ deriving (Eq)++-- XXX: probably replaceable by storable-generic+instance Storable (DLL a) where+ sizeOf _ = sizeOf (undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))+ alignment _ = alignment (undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))++ peek ptr = do+ (p, e, n) <- peek (castPtr ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a)))+ return $ DLL p e n++ poke ptr (DLL p e n) =+ poke (castPtr ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))) (p, e, n)++-- Precondition: in `insertAfter start ptr`, `next start` must be initalised,+-- and so must be `prev =<< peek (next start)`+insertAfter :: Storable a => DLL a -> a -> IO (Ptr (DLL a))+insertAfter start ptr = do+ secondLink <- peek $ next start+ newLink <- DLL <$> new start <*> new ptr <*> new secondLink+ poke (next start) newLink+ poke (prev secondLink) newLink+ new newLink++delete :: DLL a -> IO ()+delete link = do+ prevLink <- peek $ prev link+ nextLink <- peek $ next link+ poke (next prevLink) nextLink+ poke (prev nextLink) prevLink++-- /Doubly-linked list++-- @freeAll start end@ frees all pointer in the linked list. Assumes that @end@+-- doesn't have a pointer, and indeed terminates the list.+--+freeAll :: DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()+freeAll start end = do+ nextLink <- peek (next start)+ if nextLink == end+ then do+ free (next start)+ free (prev end)+ else do+ delete nextLink+ free (prev nextLink)+ free (elt nextLink)+ free (next nextLink)+ freeAll start end++-- TODO: document individual functions++-- | Given a linear computation that manages memory, run that computation.+withPool :: (Pool %1 -> Ur b) %1 -> Ur b+withPool scope = Unsafe.toLinear performScope scope+ where+ -- XXX: do ^ without `toLinear` by using linear IO++ performScope :: (Pool %1 -> Ur b) -> Ur b+ performScope scope' = unsafeDupablePerformIO $ do+ -- Initialise the pool+ backPtr <- malloc+ let end = DLL backPtr nullPtr nullPtr -- always at the end of the list+ start <- DLL nullPtr nullPtr <$> new end -- always at the start of the list+ poke backPtr start+ -- Run the computation+ evaluate (scope' (Pool start))+ `finally`+ -- Clean up remaining variables.+ (freeAll start end)++instance Consumable Pool where+ consume (Pool _) = ()++instance Dupable Pool where+ dupR (Pool l) = Data.pure (Pool l)++-- | 'Box a' is the abstract type of manually managed data. It can be used as+-- part of data type definitions in order to store linked data structure off+-- heap. See @Foreign.List@ and @Foreign.Pair@ in the @examples@ directory of+-- the source repository.+data Box a where+ Box :: Ptr (DLL (Ptr ())) -> Ptr a -> Box a++-- XXX: if Box is a newtype, can be derived+instance Storable (Box a) where+ sizeOf _ = sizeOf (undefined :: (Ptr (DLL (Ptr ())), Ptr a))+ alignment _ = alignment (undefined :: (Ptr (DLL (Ptr ())), Ptr a))+ peek ptr = do+ (pool, ptr') <- peek (castPtr ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a))+ return (Box pool ptr')+ poke ptr (Box pool ptr') =+ poke (castPtr ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a)) (pool, ptr')++instance KnownRepresentable (Box a)++instance Representable (Box a) where+ type AsKnown (Box a) = Box a+ ofKnown = id+ toKnown = id++-- TODO: a way to store GC'd data using a StablePtr++-- TODO: reference counted pointer. Remarks: rc pointers are Dupable but not+-- Movable. In order to be useful, need some kind of borrowing on the values, I+-- guess. 'Box' can be realloced, but not RC pointers.++reprPoke :: forall a. Representable a => Ptr a -> a %1 -> IO ()+reprPoke ptr a+ | Dict <- storable @(AsKnown a) =+ Unsafe.toLinear (poke (castPtr ptr :: Ptr (AsKnown a))) (toKnown a)++reprNew :: forall a. Representable a => a %1 -> IO (Ptr a)+reprNew a =+ Unsafe.toLinear mkPtr a+ where+ -- XXX: should be improved by using linear IO+ mkPtr :: a -> IO (Ptr a)+ mkPtr a' | Dict <- storable @(AsKnown a) =+ do+ ptr0 <- malloc @(AsKnown a)+ let ptr = castPtr ptr0 :: Ptr a+ reprPoke ptr a'+ return ptr++-- TODO: Ideally, we would like to avoid having a boxed representation of the+-- data before a pointer is created. A better solution is to have a destination+-- passing-style API (but there is still some design to be done there). This+-- alloc primitive would then be derived (but most of the time we would rather+-- write bespoke constructors).++-- | Store a value @a@ on the system heap that is not managed by the GC.+alloc :: forall a. Representable a => a %1 -> Pool %1 -> Box a+alloc a (Pool pool) =+ Unsafe.toLinear mkPtr a+ where+ -- XXX: should be improved by using linear IO+ mkPtr :: a -> Box a+ mkPtr a' = unsafeDupablePerformIO $ do+ ptr <- reprNew a'+ poolPtr <- insertAfter pool (castPtr ptr :: Ptr ())+ return (Box poolPtr ptr)++-- TODO: would be better in linear IO, for we pretend that we are making an+-- unrestricted 'a', where really we are not.+reprPeek :: forall a. Representable a => Ptr a -> IO a+reprPeek ptr | Dict <- storable @(AsKnown a) = do+ knownRepr <- peek (castPtr ptr :: Ptr (AsKnown a))+ return (ofKnown knownRepr)++-- | Retrieve the value stored on system heap memory.+deconstruct :: Representable a => Box a %1 -> a+deconstruct (Box poolPtr ptr) = unsafeDupablePerformIO $+ mask_ $ do+ res <- reprPeek ptr+ delete =<< peek poolPtr+ free ptr+ free poolPtr+ return res
src/Prelude/Linear.hs view
@@ -22,134 +22,150 @@ -- :} -- -- This module is designed to be imported unqualifed.-- module Prelude.Linear ( -- * Standard Types, Classes and Related Functions+ -- ** Basic data types- module Data.Bool.Linear- , Prelude.Char- , module Data.Maybe.Linear- , module Data.Either.Linear+ module Data.Bool.Linear,+ Prelude.Char,+ module Data.Maybe.Linear,+ module Data.Either.Linear,+ -- * Tuples- , Prelude.fst- , Prelude.snd- , curry- , uncurry+ Prelude.fst,+ Prelude.snd,+ curry,+ uncurry,+ -- ** Basic type classes- , module Data.Ord.Linear- , Prelude.Enum (..)- , Prelude.Bounded (..)+ module Data.Ord.Linear,+ Prelude.Enum (..),+ Prelude.Bounded (..),+ -- ** Numbers- , Prelude.Int- , Prelude.Integer- , Prelude.Float- , Prelude.Double- , Prelude.Rational- , Prelude.Word- , module Data.Num.Linear- , Prelude.Real (..)- , Prelude.Integral (..)- , Prelude.Floating (..)- , Prelude.Fractional (..)- , Prelude.RealFrac (..)- , Prelude.RealFloat (..)+ Prelude.Int,+ Prelude.Integer,+ Prelude.Float,+ Prelude.Double,+ Prelude.Rational,+ Prelude.Word,+ module Data.Num.Linear,+ Prelude.Real (..),+ Prelude.Integral (..),+ Prelude.Floating (..),+ Prelude.Fractional (..),+ Prelude.RealFrac (..),+ Prelude.RealFloat (..),+ -- *** Numeric functions- , Prelude.subtract- , Prelude.even- , Prelude.odd- , Prelude.gcd- , Prelude.lcm- , (Prelude.^)- , (Prelude.^^)- , Prelude.fromIntegral- , Prelude.realToFrac+ Prelude.subtract,+ Prelude.even,+ Prelude.odd,+ Prelude.gcd,+ Prelude.lcm,+ (Prelude.^),+ (Prelude.^^),+ Prelude.fromIntegral,+ Prelude.realToFrac,+ -- ** Monads and functors- , (<*)+ (<*),+ -- ** Semigroups and monoids- , module Data.Monoid.Linear+ module Data.Monoid.Linear,+ -- ** Miscellaneous functions- , id- , const- , (.)- , flip- , ($)- , (&)- , Prelude.until- , asTypeOf- , Prelude.error- , Prelude.errorWithoutStackTrace- , Prelude.undefined- , seq- , ($!)+ id,+ const,+ (.),+ flip,+ ($),+ (&),+ Prelude.until,+ Prelude.error,+ Prelude.errorWithoutStackTrace,+ Prelude.undefined,+ seq,+ ($!),+ -- * List operations- , module Data.List.Linear+ module Data.List.Linear,+ -- * Functions on strings+ -- TODO: Implement a linear counterpart of this- , module Data.String+ module Data.String,+ -- * Converting to and from String- , Prelude.ShowS- , Prelude.Show (..)- , Prelude.shows- , Prelude.showChar- , Prelude.showString- , Prelude.showParen- , Prelude.ReadS- , Prelude.Read (..)- , Prelude.reads- , Prelude.readParen- , Prelude.read- , Prelude.lex+ Prelude.ShowS,+ Prelude.Show (..),+ Prelude.shows,+ Prelude.showChar,+ Prelude.showString,+ Prelude.showParen,+ Prelude.ReadS,+ Prelude.Read (..),+ Prelude.reads,+ Prelude.readParen,+ Prelude.read,+ Prelude.lex,+ -- * Basic input and output- , Prelude.IO- , Prelude.putChar- , Prelude.putStr- , Prelude.putStrLn- , Prelude.print- , Prelude.getChar- , Prelude.getLine- , Prelude.getContents- , Prelude.interact+ Prelude.IO,+ Prelude.putChar,+ Prelude.putStr,+ Prelude.putStrLn,+ Prelude.print,+ Prelude.getChar,+ Prelude.getLine,+ Prelude.getContents,+ Prelude.interact,+ -- ** Files- , Prelude.FilePath- , Prelude.readFile- , Prelude.writeFile- , Prelude.appendFile- , Prelude.readIO- , Prelude.readLn+ Prelude.FilePath,+ Prelude.readFile,+ Prelude.writeFile,+ Prelude.appendFile,+ Prelude.readIO,+ Prelude.readLn,+ -- * Using 'Ur' values in linear code- -- $ unrestricted- , Ur(..)- , unur+ -- $+ Ur (..),+ unur,+ -- * Doing non-linear operations inside linear functions- -- $ comonoid- , Consumable(..)- , Dupable(..)- , Movable(..)- , lseq- , dup- , dup3- , forget- ) where+ -- $+ Consumable (..),+ Dupable (..),+ Movable (..),+ lseq,+ dup,+ dup3,+ forget,+ )+where -import qualified Data.Functor.Linear as Data-import Data.Unrestricted.Linear-import Data.Monoid.Linear-import Data.Num.Linear import Data.Bool.Linear import Data.Either.Linear+import qualified Data.Functor.Linear as Data+import Data.List.Linear import Data.Maybe.Linear+import Data.Monoid.Linear+import Data.Num.Linear import Data.Ord.Linear+import Data.String import Data.Tuple.Linear-import Data.List.Linear-import qualified Prelude+import Data.Unrestricted.Linear import Prelude.Linear.Internal-import Data.String+import qualified Prelude -- | Replacement for the flip function with generalized multiplicities. flip :: (a %p -> b %q -> c) %r -> b %q -> a %p -> c flip f b a = f a b -- | Linearly typed replacement for the standard '(Prelude.<*)' function.-(<*) :: (Data.Applicative f, Consumable b) => f a %1-> f b %1-> f a+(<*) :: (Data.Applicative f, Consumable b) => f a %1 -> f b %1 -> f a fa <* fb = Data.fmap (flip lseq) fa Data.<*> fb++infixl 4 <* -- same fixity as base.<*
+ src/Prelude/Linear/GenericUtil.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | @'FixupMetaData' a g@ copies the metadata from the+-- @"GHC.Generics".'GHC.Generics.Generic'@ representation of @a@ to the+-- representation @g@.+--+-- @'FixupMetaData1' f g@ does something similar when @f 'Any'@ is an instance+-- of @Generic@ and @g@ is a @Rep1@. See the individual type documentation+-- for details.+--+-- This is intended to help users instantiate 'Rep' and 'Rep1' for types with+-- nonlinear or multiplicity-polymorphic fields.+--+-- == Suggested use+--+-- You will need to derive a @"GHC.Generics.Generic"@ instance for the+-- type. This is used to obtain the correct metadata.+--+-- Next you need to construct a @Rep@ and/or @Rep1@ for your type, ignoring the+-- metadata.+--+-- Constructing the actual representations can be a bit annoying, but GHC can+-- help.+--+-- === For 'Rep'+--+-- Once you have derived @"GHC.Generics".'GHC.Generics.Generic'@ for your+-- type, define a value like+--+-- @+-- test :: Rep T a+-- test = _+-- @+--+-- Then compile. The stripped representation you need will be in the error+-- message.+--+-- === For 'Rep1'+--+-- Construct a type with the same shape as the one you wish to+-- instantiate, but with only linear fields. Strictness annotations+-- and @UNPACK@ pragmas are irrelevant here.+--+-- Instantiate @"Generics.Linear".'Generic1'@ for the lookalike using+-- 'Generics.Linear.TH.deriveGeneric1' and follow the same procedure+-- as above (but with @'Rep1' T@, of course) to get a metadata-stripped+-- representation.+--+-- === For either+--+-- To avoid confusion, replace at least the package and module names in the+-- representation with 'Any'. Wrap @MP1@ around any nonlinear/representation+-- polymorphic fields, just under the @S1@ type constructor. The first type+-- argument of @MP1@ will indicate the multiplicity.+module Prelude.Linear.GenericUtil+ ( FixupMetaData,+ FixupMetaData1,+ RemoveMetaData,+ )+where++import Data.Kind (Type)+import qualified GHC.Generics+import GHC.TypeLits+import Generics.Linear++-- | @FixupMetaData a g@ copies the metadata from the+-- @"GHC.Generics".'GHC.Generics.Generic'@ representation of @a@ to the+-- representation @g@. It also checks that the structure of @Rep a@ is the+-- same as @g@, except that @g@ may have @MP1@ applications under some @S1@+-- constructors.+--+-- === Example+--+-- @+-- instance 'Generic' ('Prelude.Linear.Ur' a) where+-- type Rep (Ur a) = FixupMetaData (Ur a)+-- (D1 Any+-- (C1 Any+-- (S1 Any+-- (MP1 \'Many (Rec0 a)))))+-- @+type FixupMetaData (a :: Type) (g :: Type -> Type) =+ Fixup (GHC.Generics.Rep a) g++-- | @FixupMetaData1 f g@ copies the metadata from the+-- @"GHC.Generics".'GHC.Generics.Generic'@ representation of @f 'Any'@+-- to the representation @g@. It also checks that the overall structure of+-- @Rep (f 'Any')@ is the same as @g@, but does not check that their fields+-- match.+--+-- === Example+--+-- @+-- instance 'Generic1' 'Prelude.Linear.Ur' where+-- type Rep1 Ur = FixupMetaData1 Ur+-- (D1 Any+-- (C1 Any+-- (S1 Any+-- (MP1 \'Many Par1))))+-- @+type FixupMetaData1 (f :: k -> Type) (g :: k -> Type) =+ Fixup1 (GHC.Generics.Rep (f Any)) g++type family Fixup (f :: Type -> Type) (g :: Type -> Type) :: Type -> Type where+ Fixup (D1 c f) (D1 _c g) = D1 c (Fixup f g)+ Fixup (C1 c f) (C1 _c g) = C1 c (Fixup f g)+ Fixup (S1 c f) (S1 _c (MP1 m f)) = S1 c (MP1 m f)+ Fixup (S1 c f) (S1 _c f) = S1 c f+ Fixup (f :*: g) (f' :*: g') = Fixup f f' :*: Fixup g g'+ Fixup (f :+: g) (f' :+: g') = Fixup f f' :+: Fixup g g'+ Fixup V1 V1 = V1+ Fixup _ _ = TypeError ('Text "FixupMetaData: representations do not match.")++type family Fixup1 (f :: Type -> Type) (g :: k -> Type) :: k -> Type where+ Fixup1 (D1 c f) (D1 _c g) = D1 c (Fixup1 f g)+ Fixup1 (C1 c f) (C1 _c g) = C1 c (Fixup1 f g)+ Fixup1 (f :*: g) (f' :*: g') = Fixup1 f f' :*: Fixup1 g g'+ Fixup1 (f :+: g) (f' :+: g') = Fixup1 f f' :+: Fixup1 g g'+ Fixup1 (S1 c _f) (S1 _c g) = S1 c g+ Fixup1 V1 V1 = V1+ Fixup1 _ _ = TypeError ('Text "Fixup1MetaData1: representations do not match.")++type family RemoveMetaData (f :: k -> Type) :: k -> Type where+ RemoveMetaData (D1 _c f) = D1 Any (RemoveMetaData f)+ RemoveMetaData (C1 _c f) = C1 Any (RemoveMetaData f)+ RemoveMetaData (S1 _c f) = S1 Any f+ RemoveMetaData (f :*: g) = RemoveMetaData f :*: RemoveMetaData g+ RemoveMetaData (f :+: g) = RemoveMetaData f :+: RemoveMetaData g+ RemoveMetaData x = x++type family Any :: k
+ src/Prelude/Linear/Generically.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Prelude.Linear.Generically+ ( Generically (..),+ unGenerically,+ Generically1 (..),+ unGenerically1,+ )+where++-- | A datatype whose instances are defined generically, using the+-- 'Generics.Linear.Generic' representation.+-- Generic instances can be derived via @'Generically' A@ using+-- @-XDerivingVia@.+newtype Generically a = Generically a++unGenerically :: Generically a %1 -> a+unGenerically (Generically a) = a++-- | A type whose instances are defined generically, using the+-- 'Generics.Linear.Generic1' representation. 'Generically1' is a higher-kinded+-- version of 'Generically'.+--+-- Generic instances can be derived for type constructors via+-- @'Generically1' F@ using @-XDerivingVia@.+newtype Generically1 f a = Generically1 (f a)++unGenerically1 :: Generically1 f a %1 -> f a+unGenerically1 (Generically1 fa) = fa
src/Prelude/Linear/Internal.hs view
@@ -1,76 +1,75 @@--- | This is a very very simple prelude, which doesn't depend on anything else--- in the linear-base library (except possibly "Unsafe.Linear").--{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LinearTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-} +-- | This is a very very simple prelude, which doesn't depend on anything else+-- in the linear-base library. module Prelude.Linear.Internal where -import qualified Prelude as Prelude-import qualified Unsafe.Linear as Unsafe+import Data.Coerce import Data.Functor.Identity+import GHC.Exts (TYPE) -- A note on implementation: to avoid silly mistakes, very easy functions are -- simply reimplemented here. For harder function, we reuse the Prelude -- definition and make an unsafe cast. --- | Beware: @($)@ is not compatible with the standard one because it is--- higher-order and we don't have multiplicity polymorphism yet.-($) :: (a %1-> b) %1-> a %1-> b--- XXX: Temporary as `($)` should get its typing rule directly from the type--- inference mechanism.+($) :: forall {rep} a (b :: TYPE rep) p q. (a %p -> b) %q -> a %p -> b ($) f x = f x-infixr 0 $ -(&) :: a %1-> (a %1-> b) %1-> b+infixr 0 $ -- same fixity as base.$++(&) :: forall {rep} a (b :: TYPE rep) p q. a %p -> (a %p -> b) %q -> b x & f = f x-infixl 1 & -id :: a %1-> a+infixl 1 & -- same fixity as base.&++id :: a %q -> a id x = x -const :: a %1-> b -> a+const :: a %q -> b -> a const x _ = x -asTypeOf :: a %1-> a -> a-asTypeOf = const- -- | @seq x y@ only forces @x@ to head normal form, therefore is not guaranteed -- to consume @x@ when the resulting computation is consumed. Therefore, @seq@ -- cannot be linear in it's first argument.-seq :: a -> b %1-> b-seq x = Unsafe.toLinear (Prelude.seq x)+seq :: a -> b %q -> b+seq !_ y = y -($!) :: (a %1-> b) %1-> a %1-> b+infixr 0 `seq` -- same fixity as base.seq++($!) :: forall {rep} a (b :: TYPE rep) p q. (a %p -> b) %q -> a %p -> b ($!) f !a = f a --- | Beware, 'curry' is not compatible with the standard one because it is--- higher-order and we don't have multiplicity polymorphism yet.-curry :: ((a, b) %1-> c) %1-> a %1-> b %1-> c+infixr 0 $! -- same fixity as base.$!++curry :: ((a, b) %p -> c) %q -> a %p -> b %p -> c curry f x y = f (x, y) --- | Beware, 'uncurry' is not compatible with the standard one because it is--- higher-order and we don't have multiplicity polymorphism yet.-uncurry :: (a %1-> b %1-> c) %1-> (a, b) %1-> c-uncurry f (x,y) = f x y+uncurry :: (a %p -> b %p -> c) %q -> (a, b) %p -> c+uncurry f (x, y) = f x y -- | Beware: @(.)@ is not compatible with the standard one because it is--- higher-order and we don't have multiplicity polymorphism yet.-(.) :: (b %1-> c) %1-> (a %1-> b) %1-> a %1-> c+-- higher-order and we don't have sufficient multiplicity polymorphism yet.+(.) :: forall {rep} b (c :: TYPE rep) a q m n. (b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c f . g = \x -> f (g x) --- XXX: temporary: with multiplicity polymorphism functions expecting a--- non-linear arrow would allow a linear arrow passed, so this would be--- redundant+infixr 9 . -- same fixity as base..+ -- | Convenience operator when a higher-order function expects a non-linear -- arrow but we have a linear arrow.-forget :: (a %1-> b) %1-> a -> b+forget :: forall {rep} a (b :: TYPE rep). (a %1 -> b) %1 -> a -> b forget f a = f a -- XXX: Temporary, until newtype record projections are linear.-runIdentity' :: Identity a %1-> a+runIdentity' :: Identity a %p -> a runIdentity' (Identity x) = x +-- | A linear version of 'Data.Coerce.coerce' for types of kind 'Data.Kind.Type'.+lcoerce :: forall a b. Coercible a b => a %1 -> b+lcoerce = coerce ((\x -> x) :: a %1 -> a)+{-# INLINE CONLIKE lcoerce #-}
+ src/Prelude/Linear/Unsatisfiable.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- | An ergonomic class for unsatisfiable constraints. This is based on+-- the @trivial-constraint@ package and the+-- <https://github.com/adamgundry/ghc-proposals/blob/unsatisfiable/proposals/0000-unsatisfiable.rst Unsatisfiable proposal>+-- Once that proposal is implemented, we can use it.+module Prelude.Linear.Unsatisfiable+ ( Unsatisfiable,+ unsatisfiable,+ Bottom,+ )+where++import Data.Void+import GHC.Exts (Any, TYPE)+import GHC.TypeLits (ErrorMessage, TypeError)++-- The 'Any' constraint prevents anyone from instantiating 'Bottom' with+-- unsatisfiable' = undefined if they don't understand what it's for.++-- | A constraint that cannot be satisfied. Users should normally use+-- 'Unsatisfiable' instead of using this class directly.+class Any => Bottom where+ unsatisfiable' :: Void++-- | An unsatisfiable constraint with a user-provided error message. Under an+-- @Unsatisfiable@ constraint, users can use 'unsatisfiable' to get a value of+-- any type (and runtime representation) they desire. For example,+--+-- @+-- instance Unsatisfiable+-- (\'Text \"V1 cannot have an Applicative instance because it cannot implement pure\")+-- => Applicative V1 where+-- pure = unsatisfiable+-- (<*>) = unsatisfiable+-- @+class (Bottom, TypeError e) => Unsatisfiable (e :: ErrorMessage)++-- | Produce a value of any type (and runtime representation) under+-- an 'Unsatisfiable' or 'Bottom' constraint.+unsatisfiable :: forall {rep} (a :: TYPE rep). Bottom => a+unsatisfiable = case unsatisfiable' of {}
− src/Streaming/Internal/Consume.hs
@@ -1,637 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | This module provides all functions that take input streams--- but do not return output streams.-module Streaming.Internal.Consume- ( -- * Consuming 'Stream's of elements- -- ** IO Consumers- stdoutLn- , stdoutLn'- , print- , toHandle- , writeFile- -- ** Basic Pure Consumers- , effects- , erase- , drained- , mapM_- -- ** Folds- , fold- , fold_- , foldM- , foldM_- , all- , all_- , any- , any_- , sum- , sum_- , product- , product_- , head- , head_- , last- , last_- , elem- , elem_- , notElem- , notElem_- , length- , length_- , toList- , toList_- , mconcat- , mconcat_- , minimum- , minimum_- , maximum- , maximum_- , foldrM- , foldrT- ) where--import Streaming.Internal.Type-import Streaming.Internal.Process-import System.IO.Linear-import System.IO.Resource-import qualified Data.Bool.Linear as Linear-import Prelude.Linear ((&), ($), (.))-import Prelude (Show(..), FilePath, (&&), Bool(..), id, (||),- Num(..), Maybe(..), Eq(..), Int, Ord(..))-import qualified Prelude as Prelude-import Data.Unrestricted.Linear-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.IO as Text-import Data.Functor.Identity-import qualified System.IO as System-import qualified Control.Functor.Linear as Control----- # IO Consumers------------------------------------------------------------------------------------ Note: crashes on a broken output pipe----{-| Write 'String's to 'System.stdout' using 'Text.putStrLn'; terminates on a broken output pipe- (The name and implementation are modelled on the @Pipes.Prelude@ @stdoutLn@).--\>\>\> withLinearIO $ Control.fmap move $ S.stdoutLn $ S.each $ words "one two three"-one-two-three--}-stdoutLn :: Stream (Of Text) IO () %1-> IO ()-stdoutLn stream = stdoutLn' stream-{-# INLINE stdoutLn #-}---- | Like stdoutLn but with an arbitrary return value-stdoutLn' :: forall r. Stream (Of Text) IO r %1-> IO r-stdoutLn' stream = loop stream where- loop :: Stream (Of Text) IO r %1-> IO r- loop stream = stream & \case- Return r -> Control.return r- Effect ms -> ms Control.>>= stdoutLn'- Step (str :> stream) -> Control.do- fromSystemIO $ Text.putStrLn str- stdoutLn' stream-{-# INLINABLE stdoutLn' #-}--{-| Print the elements of a stream as they arise.---}-print :: Show a => Stream (Of a) IO r %1-> IO r-print = stdoutLn' . map (Text.pack Prelude.. Prelude.show)---- | Write a stream to a handle and return the handle.-toHandle :: Handle %1-> Stream (Of Text) RIO r %1-> RIO (r, Handle)-toHandle handle stream = loop handle stream where- loop :: Handle %1-> Stream (Of Text) RIO r %1-> RIO (r, Handle)- loop handle stream = stream & \case- Return r -> Control.return (r, handle)- Effect ms -> ms Control.>>= toHandle handle- Step (text :> stream') -> Control.do- handle' <- hPutStrLn handle text- toHandle handle' stream'-{-# INLINABLE toHandle #-}---- | Write a stream of text as lines as lines to a file-writeFile :: FilePath -> Stream (Of Text) RIO r %1-> RIO r-writeFile filepath stream = Control.do- handle <- openFile filepath System.WriteMode- (r,handle') <- toHandle handle stream- hClose handle'- Control.return r----- # Basic Pure Consumers----------------------------------------------------------------------------------{- | Reduce a stream, performing its actions but ignoring its elements.--@-\>\>\> rest <- S.effects $ S.splitAt 2 $ each' [1..5]-\>\>\> S.print rest-3-4-5-@-- 'effects' should be understood together with 'copy' and is subject to the rules--> S.effects . S.copy = id-> hoist S.effects . S.copy = id-- The similar @effects@ and @copy@ operations in @Data.ByteString.Streaming@ obey the same rules.---}-effects :: forall a m r. Control.Monad m => Stream (Of a) m r %1-> m r-effects stream = loop stream where- loop :: Stream (Of a) m r %1-> m r- loop stream = stream & \case- Return r -> Control.return r- Effect ms -> ms Control.>>= effects- Step (_ :> stream') -> effects stream'-{-# INLINABLE effects #-}--{- | Remove the elements from a stream of values, retaining the structure of layers.--}-erase :: forall a m r. Control.Monad m => Stream (Of a) m r %1-> Stream Identity m r-erase stream = loop stream where- loop :: Stream (Of a) m r %1-> Stream Identity m r- loop stream = stream & \case- Return r -> Return r- Step (_ :> stream') -> Step $ Identity (erase stream')- Effect ms -> Effect $ ms Control.>>= (Control.return . erase)-{-# INLINABLE erase #-}--{-| Where a transformer returns a stream, run the effects of the stream, keeping- the return value. This is usually used at the type--> drained :: Control.Monad m => Stream (Of a) m (Stream (Of b) m r) -> Stream (Of a) m r-> drained = Control.join . Control.fmap (Control.lift . effects)-- Here, for example, we split a stream in two places and throw out the middle segment:--@-\>\>\> rest <- S.print $ S.drained $ S.splitAt 2 $ S.splitAt 5 $ each' [1..7]-1-2-\>\>\> S.print rest-6-7-@---}-drained ::- ( Control.Monad m- , Control.Monad (t m)- , Control.Functor (t m)- , Control.MonadTrans t) =>- t m (Stream (Of a) m r) %1-> t m r-drained = Control.join . Control.fmap (Control.lift . effects)-{-# INLINE drained #-}--{-| Reduce a stream to its return value with a monadic action.--@-\>\>\> S.mapM_ Prelude.print $ each' [1..3]-1-2-3-@--@-\>\>\> rest <- S.mapM_ Prelude.print $ S.splitAt 3 $ each' [1..10]-1-2-3-\>\>\> S.sum rest-49 :> ()-@---}-mapM_ :: forall a m b r. (Consumable b, Control.Monad m) =>- (a -> m b) -> Stream (Of a) m r %1-> m r-mapM_ f stream = loop stream where- loop :: Stream (Of a) m r %1-> m r- loop stream = stream & \case- Return r -> Control.return r- Effect ms -> ms Control.>>= mapM_ f- Step (a :> stream') -> Control.do- b <- f a- Control.return $ consume b- mapM_ f stream'-{-# INLINABLE mapM_ #-}----- # Folds-----------------------------------------------------------------------------------{-| Strict fold of a 'Stream' of elements that preserves the return value.- This does not short circuit and all effects are performed.- The third parameter will often be 'id' where a fold is written by hand:--@-\>\>\> S.fold (+) 0 id $ each' [1..10]-55 :> ()-@--@-\>\>\> S.fold (*) 1 id $ S.fold (+) 0 id $ S.copy $ each' [1..10]-3628800 :> (55 :> ())-@-- It can be used to replace a standard Haskell type with one more suited to- writing a strict accumulation function. It is also crucial to the- Applicative instance for @Control.Foldl.Fold@ We can apply such a fold- @purely@--> Control.Foldl.purely S.fold :: Control.Monad m => Fold a b -> Stream (Of a) m r %1-> m (Of b r)-- Thus, specializing a bit:--> L.purely S.fold L.sum :: Stream (Of Int) Int r %1-> m (Of Int r)-> mapped (L.purely S.fold L.sum) :: Stream (Stream (Of Int)) IO r %1-> Stream (Of Int) IO r-- Here we use the Applicative instance for @Control.Foldl.Fold@ to- stream three-item segments of a stream together with their sums and products.--@-\>\>\> S.print $ mapped (L.purely S.fold (liftA3 (,,) L.list L.product L.sum)) $ chunksOf 3 $ each' [1..10]-([1,2,3],6,6)-([4,5,6],120,15)-([7,8,9],504,24)-([10],10,10)-@---}-fold :: forall x a b m r. Control.Monad m =>- (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> m (Of b r)-fold f x g stream = loop stream where- loop :: Stream (Of a) m r %1-> m (Of b r)- loop stream = stream & \case- Return r -> Control.return $ g x :> r- Effect ms -> ms Control.>>= fold f x g- Step (a :> stream') -> fold f (f x a) g stream'-{-# INLINABLE fold #-}--{-| Strict fold of a 'Stream' of elements, preserving only the result of the fold, not- the return value of the stream. This does not short circuit and all effects- are performed. The third parameter will often be 'id' where a fold- is written by hand:--@-\>\>\> S.fold_ (+) 0 id $ each [1..10]-55-@-- It can be used to replace a standard Haskell type with one more suited to- writing a strict accumulation function. It is also crucial to the- Applicative instance for @Control.Foldl.Fold@--> Control.Foldl.purely fold :: Control.Monad m => Fold a b -> Stream (Of a) m () %1-> m b---}-fold_ :: forall x a b m r. (Control.Monad m, Consumable r) =>- (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> m b-fold_ f x g stream = loop stream where- loop :: Stream (Of a) m r %1-> m b- loop stream = stream & \case- Return r -> lseq r $ Control.return $ g x- Effect ms -> ms Control.>>= fold_ f x g- Step (a :> stream') -> fold_ f (f x a) g stream'-{-# INLINABLE fold_ #-}---- Note: We can't use 'Of' since the left component is unrestricted.--- Remark: to use the (`m x`) in the folding function that is the first--- argument, we must bind to it. Since `m` is a `Control.Monad`, we need--- the folding function to consume `x` linearly.----{-| Strict, monadic fold of the elements of a @Stream (Of a)@--> Control.Foldl.impurely foldM :: Control.Monad m => FoldM a b -> Stream (Of a) m r %1-> m (b, r)-- Thus to accumulate the elements of a stream as a vector, together with a random- element we might write:--@-\>\>\> L.impurely S.foldM (liftA2 (,) L.vectorM L.random) $ each' [1..10::Int] :: IO (Of (Vector Int, Maybe Int) ())-([1,2,3,4,5,6,7,8,9,10],Just 9) :> ()-@--}-foldM :: forall x a m b r. Control.Monad m =>- (x %1-> a -> m x) -> m x -> (x %1-> m b) -> Stream (Of a) m r %1-> m (b,r)-foldM f mx g stream = loop stream where- loop :: Stream (Of a) m r %1-> m (b,r)- loop stream = stream & \case- Return r -> mx Control.>>= g Control.>>= (\b -> Control.return (b,r))- Effect ms -> ms Control.>>= foldM f mx g- Step (a :> stream') -> foldM f (mx Control.>>= \x -> f x a) g stream'-{-# INLINABLE foldM #-}--{-| Strict, monadic fold of the elements of a @Stream (Of a)@--> Control.Foldl.impurely foldM_ :: Control.Monad m => FoldM a b -> Stream (Of a) m () %1-> m b--}-foldM_ :: forall a m x b r. (Control.Monad m, Consumable r) =>- (x %1-> a -> m x) -> m x -> (x %1-> m b) -> Stream (Of a) m r %1-> m b-foldM_ f mx g stream = loop stream where- loop :: Stream (Of a) m r %1-> m b- loop stream = stream & \case- Return r -> lseq r $ mx Control.>>= g- Effect ms -> ms Control.>>= foldM_ f mx g- Step (a :> stream') -> foldM_ f (mx Control.>>= \x -> f x a) g stream'-{-# INLINABLE foldM_ #-}---- | Note: does not short circuit-all :: Control.Monad m => (a -> Bool) -> Stream (Of a) m r %1-> m (Of Bool r)-all f stream = fold (&&) True id (map f stream)-{-# INLINABLE all #-}---- | Note: does not short circuit-all_ :: (Consumable r, Control.Monad m) => (a -> Bool) -> Stream (Of a) m r %1-> m Bool-all_ f stream = fold_ (&&) True id (map f stream)-{-# INLINABLE all_ #-}---- | Note: does not short circuit-any :: Control.Monad m => (a -> Bool) -> Stream (Of a) m r %1-> m (Of Bool r)-any f stream = fold (||) False id (map f stream)-{-# INLINABLE any #-}---- | Note: does not short circuit-any_ :: (Consumable r, Control.Monad m) => (a -> Bool) -> Stream (Of a) m r %1-> m Bool-any_ f stream = fold_ (||) False id (map f stream)-{-# INLINABLE any_ #-}--{-| Fold a 'Stream' of numbers into their sum with the return value--> mapped S.sum :: Stream (Stream (Of Int)) m r %1-> Stream (Of Int) m r--@-\>\>\> S.sum $ each' [1..10]-55 :> ()-@--@-\>\>\> (n :> rest) <- S.sum $ S.splitAt 3 $ each' [1..10]-\>\>\> System.IO.print n-6-\>\>\> (m :> rest') <- S.sum $ S.splitAt 3 rest-\>\>\> System.IO.print m-15-\>\>\> S.print rest'-7-8-9-10-@--}-sum :: (Control.Monad m, Num a) => Stream (Of a) m r %1-> m (Of a r)-sum stream = fold (+) 0 id stream-{-# INLINE sum #-}---- | Fold a 'Stream' of numbers into their sum-sum_ :: (Control.Monad m, Num a) => Stream (Of a) m () %1-> m a-sum_ stream = fold_ (+) 0 id stream-{-# INLINE sum_ #-}--{-| Fold a 'Stream' of numbers into their product with the return value--> mapped product :: Stream (Stream (Of Int)) m r -> Stream (Of Int) m r--}-product :: (Control.Monad m, Num a) => Stream (Of a) m r %1-> m (Of a r)-product stream = fold (*) 1 id stream-{-# INLINE product #-}---- | Fold a 'Stream' of numbers into their product-product_ :: (Control.Monad m, Num a) => Stream (Of a) m () %1-> m a-product_ stream = fold_ (*) 1 id stream-{-# INLINE product_ #-}---- | Note that 'head' exhausts the rest of the stream following the--- first element, performing all monadic effects via 'effects'-head :: Control.Monad m => Stream (Of a) m r %1-> m (Of (Maybe a) r)-head str = str & \case- Return r -> Control.return (Nothing :> r)- Effect m -> m Control.>>= head- Step (a :> rest) ->- effects rest Control.>>= \r -> Control.return (Just a :> r)-{-# INLINABLE head #-}---- | Note that 'head' exhausts the rest of the stream following the--- first element, performing all monadic effects via 'effects'-head_ :: (Consumable r, Control.Monad m) => Stream (Of a) m r %1-> m (Maybe a)-head_ str = str & \case- Return r -> lseq r $ Control.return Nothing- Effect m -> m Control.>>= head_- Step (a :> rest) ->- effects rest Control.>>= \r -> lseq r $ Control.return (Just a)-{-# INLINABLE head_ #-}--last :: Control.Monad m => Stream (Of a) m r %1-> m (Of (Maybe a) r)-last = loop Nothing where- loop :: Control.Monad m =>- Maybe a -> Stream (Of a) m r %1-> m (Of (Maybe a) r)- loop m s = s & \case- Return r -> Control.return (m :> r)- Effect m -> m Control.>>= last- Step (a :> rest) -> loop (Just a) rest-{-# INLINABLE last #-}--last_ :: (Consumable r, Control.Monad m) => Stream (Of a) m r %1-> m (Maybe a)-last_ = loop Nothing where- loop :: (Consumable r, Control.Monad m) =>- Maybe a -> Stream (Of a) m r %1-> m (Maybe a)- loop m s = s & \case- Return r -> lseq r $ Control.return m- Effect m -> m Control.>>= last_- Step (a :> rest) -> loop (Just a) rest-{-# INLINABLE last_ #-}--elem :: forall a m r. (Control.Monad m, Eq a) =>- a -> Stream (Of a) m r %1-> m (Of Bool r)-elem a stream = loop stream where- loop :: Stream (Of a) m r %1-> m (Of Bool r)- loop stream = stream & \case- Return r -> Control.return $ False :> r- Effect ms -> ms Control.>>= elem a- Step (a' :> stream') -> case a == a' of- True -> effects stream' Control.>>= (\r -> Control.return $ True :> r)- False -> elem a stream'-{-# INLINABLE elem #-}--elem_ :: forall a m r. (Consumable r, Control.Monad m, Eq a) =>- a -> Stream (Of a) m r %1-> m Bool-elem_ a stream = loop stream where- loop :: Stream (Of a) m r %1-> m Bool- loop stream = stream & \case- Return r -> lseq r $ Control.return False- Effect ms -> ms Control.>>= elem_ a- Step (a' :> stream') -> case a == a' of- True -> effects stream' Control.>>= \r -> lseq r $ Control.return True- False -> elem_ a stream'-{-# INLINABLE elem_ #-}--{-| Exhaust a stream deciding whether @a@ was an element.---}-notElem :: (Control.Monad m, Eq a) => a -> Stream (Of a) m r %1-> m (Of Bool r)-notElem a stream = Control.fmap negate $ elem a stream- where- negate :: Of Bool r %1-> Of Bool r- negate (b :> r) = Prelude.not b :> r-{-# INLINE notElem #-}--notElem_ :: (Consumable r, Control.Monad m, Eq a) => a -> Stream (Of a) m r %1-> m Bool-notElem_ a stream = Control.fmap Linear.not $ elem_ a stream-{-# INLINE notElem_ #-}--{-| Run a stream, keeping its length and its return value.--@-\>\>\> S.print $ mapped S.length $ chunksOf 3 $ S.each' [1..10]-3-3-3-1-@---}-length :: Control.Monad m => Stream (Of a) m r %1-> m (Of Int r)-length = fold (\n _ -> n + 1) 0 id-{-# INLINE length #-}---{-| Run a stream, remembering only its length:--@-\>\>\> runIdentity $ S.length_ (S.each [1..10] :: Stream (Of Int) Identity ())-10-@--}-length_ :: (Consumable r, Control.Monad m) => Stream (Of a) m r %1-> m Int-length_ = fold_ (\n _ -> n + 1) 0 id-{-# INLINE length_ #-}--{-| Convert an effectful 'Stream' into a list alongside the return value--> mapped toList :: Stream (Stream (Of a) m) m r %1-> Stream (Of [a]) m r-- Like 'toList_', 'toList' breaks streaming; unlike 'toList_' it /preserves the return value/- and thus is frequently useful with e.g. 'mapped'--@-\>\>\> S.print $ mapped S.toList $ chunksOf 3 $ each' [1..9]-[1,2,3]-[4,5,6]-[7,8,9]-@--@-\>\>\> S.print $ mapped S.toList $ chunksOf 2 $ S.replicateM 4 getLine-s<Enter>-t<Enter>-["s","t"]-u<Enter>-v<Enter>-["u","v"]-@--}-toList :: Control.Monad m => Stream (Of a) m r %1-> m (Of [a] r)-toList = fold (\diff a ls -> diff (a: ls)) id (\diff -> diff [])-{-# INLINE toList #-}--{-| Convert an effectful @Stream (Of a)@ into a list of @as@-- Note: Needless to say, this function does not stream properly.- It is basically the same as Prelude 'mapM' which, like 'replicateM',- 'sequence' and similar operations on traversable containers- is a leading cause of space leaks.---}-toList_ :: Control.Monad m => Stream (Of a) m () %1-> m [a]-toList_ = fold_ (\diff a ls -> diff (a: ls)) id (\diff -> diff [])-{-# INLINE toList_ #-}--{-| Fold streamed items into their monoidal sum- -}-mconcat :: (Control.Monad m, Prelude.Monoid w) => Stream (Of w) m r %1-> m (Of w r)-mconcat = fold (Prelude.<>) Prelude.mempty id-{-# INLINE mconcat #-}--mconcat_ :: (Consumable r, Control.Monad m, Prelude.Monoid w) =>- Stream (Of w) m r %1-> m w-mconcat_ = fold_ (Prelude.<>) Prelude.mempty id-{-# INLINE mconcat_ #-}--minimum :: (Control.Monad m, Ord a) => Stream (Of a) m r %1-> m (Of (Maybe a) r)-minimum = fold getMin Nothing id . map Just-{-# INLINE minimum #-}--minimum_ :: (Consumable r, Control.Monad m, Ord a) =>- Stream (Of a) m r %1-> m (Maybe a)-minimum_ = fold_ getMin Nothing id . map Just-{-# INLINE minimum_ #-}--maximum :: (Control.Monad m, Ord a) => Stream (Of a) m r %1-> m (Of (Maybe a) r)-maximum = fold getMax Nothing id . map Just-{-# INLINE maximum #-}--maximum_ :: (Consumable r, Control.Monad m, Ord a) =>- Stream (Of a) m r %1-> m (Maybe a)-maximum_ = fold_ getMax Nothing id . map Just-{-# INLINE maximum_ #-}--getMin :: Ord a => Maybe a -> Maybe a -> Maybe a-getMin = mCompare Prelude.min--getMax :: Ord a => Maybe a -> Maybe a -> Maybe a-getMax = mCompare Prelude.max--mCompare :: Ord a => (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a-mCompare _ Nothing Nothing = Nothing-mCompare _ (Just a) Nothing = Just a-mCompare _ Nothing (Just a) = Just a-mCompare comp (Just x) (Just y) = Just $ comp x y--{-| A natural right fold for consuming a stream of elements.- See also the more general 'iterT' in the 'Streaming' module and the- still more general 'destroy'--}-foldrM :: forall a m r. Control.Monad m- => (a -> m r %1-> m r) -> Stream (Of a) m r %1-> m r-foldrM step stream = loop stream where- loop :: Stream (Of a) m r %1-> m r- loop stream = stream & \case- Return r -> Control.return r- Effect m -> m Control.>>= foldrM step- Step (a :> as) -> step a (foldrM step as)-{-# INLINABLE foldrM #-}--{-| A natural right fold for consuming a stream of elements.- See also the more general 'iterTM' in the 'Streaming' module- and the still more general 'destroy'--> foldrT (\a p -> Streaming.yield a >> p) = id---}-foldrT :: forall a t m r.- (Control.Monad m, Control.MonadTrans t, Control.Monad (t m)) =>- (a -> t m r %1-> t m r) -> Stream (Of a) m r %1-> t m r-foldrT step stream = loop stream where- loop :: Stream (Of a) m r %1-> t m r- loop stream = stream & \case- Return r -> Control.return r- Effect ms -> (Control.lift ms) Control.>>= foldrT step- Step (a :> as) -> step a (foldrT step as)-{-# INLINABLE foldrT #-}-
− src/Streaming/Internal/Interop.hs
@@ -1,40 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE RecordWildCards #-}---- | This module contains functions for interoperating with other--- streaming libraries.-module Streaming.Internal.Interop- ( -- * Interoperating with other streaming libraries- reread- ) where--import Streaming.Internal.Type-import Streaming.Internal.Produce-import Data.Unrestricted.Linear-import Prelude.Linear (($))-import Prelude (Maybe(..))-import qualified Control.Functor.Linear as Control--{-| Read an @IORef (Maybe a)@ or a similar device until it reads @Nothing@.- @reread@ provides convenient exit from the @io-streams@ library--> reread readIORef :: IORef (Maybe a) -> Stream (Of a) IO ()-> reread Streams.read :: System.IO.Streams.InputStream a -> Stream (Of a) IO ()--}-reread :: Control.Monad m =>- (s -> m (Ur (Maybe a))) -> s -> Stream (Of a) m ()-reread f s = reread' f s- where- reread' :: Control.Monad m =>- (s -> m (Ur (Maybe a))) -> s -> Stream (Of a) m ()- reread' f s = Effect $ Control.do- Ur maybeA <- f s- case maybeA of- Nothing -> Control.return $ Return ()- Just a -> Control.return $ (yield a Control.>> reread f s)-{-# INLINABLE reread #-}-
− src/Streaming/Internal/Many.hs
@@ -1,371 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | This module contains all functions that do something with--- multiple streams as input or output. This includes combining--- streams, splitting a stream, etc.-module Streaming.Internal.Many- (- -- * Operations that use or return multiple 'Stream's- -- ** Zips and Unzip- unzip- , ZipResidual- , ZipResidual3- , zip- , zipR- , zipWith- , zipWithR- , zip3- , zip3R- , zipWith3- , zipWith3R- , Either3 (..)- -- ** Merging- -- $ merging- , merge- , mergeOn- , mergeBy- ) where--import Streaming.Internal.Type-import Streaming.Internal.Consume-import Prelude (Either(..), Ord(..), Ordering(..))-import Prelude.Linear (($), (&))-import qualified Control.Functor.Linear as Control----- # Zips and Unzip----------------------------------------------------------------------------------{-| The type--> Data.List.unzip :: [(a,b)] -> ([a],[b])-- might lead us to expect--> Streaming.unzip :: Stream (Of (a,b)) m r -> Stream (Of a) m (Stream (Of b) m r)-- which would not stream, since it would have to accumulate the second stream (of @b@s).- Of course, @Data.List@ 'Data.List.unzip' doesn't stream either.-- This @unzip@ does- stream, though of course you can spoil this by using e.g. 'toList':--@-\>\>\> let xs = Prelude.map (\x -> (x, Prelude.show x)) [1..5 :: Int]--\>\>\> S.toList $ S.toList $ S.unzip (S.each' xs)-["1","2","3","4","5"] :> ([1,2,3,4,5] :> ())--\>\>\> Prelude.unzip xs-([1,2,3,4,5],["1","2","3","4","5"])-@-- Note the difference of order in the results. It may be of some use to think why.- The first application of 'toList' was applied to a stream of integers:--@-\>\>\> :t S.unzip $ S.each' xs-S.unzip $ S.each' xs :: Control.Monad m => Stream (Of Int) (Stream (Of String) m) ()-@-- Like any fold, 'toList' takes no notice of the monad of effects.--> toList :: Control.Monad m => Stream (Of a) m r %1-> m (Of [a] r)-- In the case at hand (since I am in @ghci@) @m = Stream (Of String) IO@.- So when I apply 'toList', I exhaust that stream of integers, folding- it into a list:--@-\>\>\> :t S.toList $ S.unzip $ S.each' xs-S.toList $ S.unzip $ S.each' xs- :: Control.Monad m => Stream (Of String) m (Of [Int] ())-@-- When I apply 'toList' to /this/, I reduce everything to an ordinary action in @IO@,- and return a list of strings:--@-\>\>\> S.toList $ S.toList $ S.unzip (S.each' xs)-["1","2","3","4","5"] :> ([1,2,3,4,5] :> ())-@--'unzip' can be considered a special case of either 'unzips' or 'expand':--@- unzip = 'unzips' . 'maps' (\((a,b) :> x) -> Compose (a :> b :> x))- unzip = 'expand' $ \p ((a,b) :> abs) -> b :> p (a :> abs)-@--}-unzip :: Control.Monad m =>- Stream (Of (a, b)) m r %1-> Stream (Of a) (Stream (Of b) m) r-unzip = loop- where- loop :: Control.Monad m =>- Stream (Of (a, b)) m r %1-> Stream (Of a) (Stream (Of b) m) r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop $ Control.lift m- Step ((a,b):> rest) -> Step (a :> Effect (Step (b :> Return (loop rest))))-{-# INLINABLE unzip #-}---{- Remarks on the design of zip functions--Zip functions have two design choices:-(1) What do we do with the end-of-stream values of both streams?-(2) If the streams are of different length, do we keep or throw out the-remainder of the longer stream?--* We are assuming not to take infinite streams as input and instead deal with-reasonably small finite streams.-* To avoid making choices for the user, we keep both end-of-stream payloads-* The default zips (ones without a prime in the name) use @effects@ to consume-the remainder stream after zipping. We include zip function variants that-return no remainder (for equal length streams), or the remainder of the-longer stream.---}--data Either3 a b c where- Left3 :: a %1-> Either3 a b c- Middle3 :: b %1-> Either3 a b c- Right3 :: c %1-> Either3 a b c---- | The remainder of zipping two streams-type ZipResidual a b m r1 r2 =- Either3- (r1, r2)- (r1, Stream (Of b) m r2)- (Stream (Of a) m r1, r2)---- | @zipWithR@ zips two streams applying a function along the way,--- keeping the remainder of zipping if there is one. Note. If two streams have--- the same length, but one needs to perform some effects to obtain the--- end-of-stream result, that stream is treated as a residual.-zipWithR :: Control.Monad m =>- (a -> b -> c) ->- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of c) m (ZipResidual a b m r1 r2)-zipWithR = loop- where- loop :: Control.Monad m =>- (a -> b -> c) ->- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of c) m (ZipResidual a b m r1 r2)- loop f st1 st2 = st1 & \case- Effect ms -> Effect $ Control.fmap (\s -> loop f s st2) ms- Return r1 -> st2 & \case- Return r2 -> Return $ Left3 (r1,r2)- st2' -> Return $ Middle3 (r1,st2')- Step (a :> as) -> st2 & \case- Effect ms ->- Effect $ Control.fmap (\s -> loop f (Step (a :> as)) s) ms- Return r2 -> Return $ Right3 (Step (a :> as), r2)- Step (b :> bs) -> Step $ (f a b) :> loop f as bs-{-# INLINABLE zipWithR #-}--zipWith :: Control.Monad m =>- (a -> b -> c) ->- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of c) m (r1,r2)-zipWith f s1 s2 = Control.do- result <- zipWithR f s1 s2- result & \case- Left3 rets -> Control.return rets- Middle3 (r1, s2') -> Control.do- r2 <- Control.lift $ effects s2'- Control.return (r1, r2)- Right3 (s1', r2) -> Control.do- r1 <- Control.lift $ effects s1'- Control.return (r1, r2)-{-# INLINABLE zipWith #-}---- | @zip@ zips two streams exhausing the remainder of the longer--- stream and consuming its effects.-zip :: Control.Monad m =>- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of (a,b)) m (r1, r2)-zip = zipWith (,)-{-# INLINE zip #-}---- | @zipR@ zips two streams keeping the remainder if there is one.-zipR :: Control.Monad m =>- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of (a,b)) m (ZipResidual a b m r1 r2)-zipR = zipWithR (,)-{-# INLINE zipR #-}---- Remark. For simplicity, we do not create an @Either7@ which is the--- proper remainder type for 'zip3R'. Our type simply has one impossible--- case which is when all three streams have a remainder.---- | The (liberal) remainder of zipping three streams.--- This has the downside that the possibility of three remainders--- is allowed, though it will never occur.-type ZipResidual3 a b c m r1 r2 r3 =- ( Either r1 (Stream (Of a) m r1)- , Either r2 (Stream (Of b) m r2)- , Either r3 (Stream (Of c) m r3)- )---- | Like @zipWithR@ but with three streams.-zipWith3R :: Control.Monad m =>- (a -> b -> c -> d) ->- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of c) m r3 %1->- Stream (Of d) m (ZipResidual3 a b c m r1 r2 r3)-zipWith3R = loop- where- loop :: Control.Monad m =>- (a -> b -> c -> d) ->- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of c) m r3 %1->- Stream (Of d) m (ZipResidual3 a b c m r1 r2 r3)- loop f s1 s2 s3 = s1 & \case- Effect ms -> Effect $ Control.fmap (\s -> loop f s s2 s3) ms- Return r1 -> (s2, s3) & \case- (Return r2, Return r3) -> Return (Left r1, Left r2, Left r3)- (s2', s3') -> Return (Left r1, Right s2', Right s3')- Step (a :> as) -> s2 & \case- Effect ms -> Effect $- Control.fmap (\s -> loop f (Step $ a :> as) s s3) ms- Return r2 -> Return (Right (Step $ a :> as), Left r2, Right s3)- Step (b :> bs) -> s3 & \case- Effect ms -> Effect $- Control.fmap (\s -> loop f (Step $ a :> as) (Step $ b :> bs) s) ms- Return r3 ->- Return (Right (Step $ a :> as), Right (Step $ b :> bs), Left r3)- Step (c :> cs) -> Step $ (f a b c) :> loop f as bs cs-{-# INLINABLE zipWith3R #-}---- | Like @zipWith@ but with three streams-zipWith3 :: Control.Monad m =>- (a -> b -> c -> d) ->- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of c) m r3 %1->- Stream (Of d) m (r1, r2, r3)-zipWith3 f s1 s2 s3 = Control.do- result <- zipWith3R f s1 s2 s3- result & \case- (res1, res2, res3) -> Control.do- r1 <- Control.lift $ extractResult res1- r2 <- Control.lift $ extractResult res2- r3 <- Control.lift $ extractResult res3- Control.return (r1, r2, r3)-{-# INLINABLE zipWith3 #-}---- | Like @zipR@ but with three streams.-zip3 :: Control.Monad m =>- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of c) m r3 %1->- Stream (Of (a,b,c)) m (r1, r2, r3)-zip3 = zipWith3 (,,)-{-# INLINABLE zip3 #-}---- | Like @zipR@ but with three streams.-zip3R :: Control.Monad m =>- Stream (Of a) m r1 %1->- Stream (Of b) m r2 %1->- Stream (Of c) m r3 %1->- Stream (Of (a,b,c)) m (ZipResidual3 a b c m r1 r2 r3)-zip3R = zipWith3R (,,)-{-# INLINABLE zip3R #-}---- | Internal function to consume a stream remainder to--- get the payload-extractResult :: Control.Monad m => Either r (Stream (Of a) m r) %1-> m r-extractResult (Left r) = Control.return r-extractResult (Right s) = effects s----- # Merging----------------------------------------------------------------------------------{- $merging- These functions combine two sorted streams of orderable elements- into one sorted stream. The elements of the merged stream are- guaranteed to be in a sorted order if the two input streams are- also sorted.-- The merge operation is /left-biased/: when merging two elements- that compare as equal, the left element is chosen first.--}--{- | Merge two streams of elements ordered with their 'Ord' instance.-- The return values of both streams are returned.--@-\>\>\> S.print $ merge (each [1,3,5]) (each [2,4])-1-2-3-4-5-((), ())-@---}-merge :: (Control.Monad m, Ord a) =>- Stream (Of a) m r %1-> Stream (Of a) m s %1-> Stream (Of a) m (r,s)-merge = mergeBy compare-{-# INLINE merge #-}--{- | Merge two streams, ordering them by applying the given function to- each element before comparing.-- The return values of both streams are returned.--}-mergeOn :: (Control.Monad m, Ord b) =>- (a -> b) ->- Stream (Of a) m r %1->- Stream (Of a) m s %1->- Stream (Of a) m (r,s)-mergeOn f = mergeBy (\x y -> compare (f x) (f y))-{-# INLINE mergeOn #-}--{- | Merge two streams, ordering the elements using the given comparison function.-- The return values of both streams are returned.--}-mergeBy :: forall m a r s . Control.Monad m =>- (a -> a -> Ordering) ->- Stream (Of a) m r %1->- Stream (Of a) m s %1->- Stream (Of a) m (r,s)-mergeBy comp s1 s2 = loop s1 s2- where- loop :: Stream (Of a) m r %1-> Stream (Of a) m s %1-> Stream (Of a) m (r,s)- loop s1 s2 = s1 & \case- Return r ->- Effect $ effects s2 Control.>>= \s -> Control.return $ Return (r, s)- Effect ms -> Effect $- ms Control.>>= \s1' -> Control.return $ mergeBy comp s1' s2- Step (a :> as) -> s2 & \case- Return s ->- Effect $ effects as Control.>>= \r -> Control.return $ Return (r, s)- Effect ms -> Effect $- ms Control.>>= \s2' ->- Control.return $ mergeBy comp (Step (a :> as)) s2'- Step (b :> bs) -> case comp a b of- LT -> Step (a :> Step (b :> mergeBy comp as bs))- _ -> Step (b :> Step (a :> mergeBy comp as bs))-{-# INLINABLE mergeBy #-}-
− src/Streaming/Internal/Process.hs
@@ -1,1474 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | This module provides functions that take one input--- stream and produce one output stream. These are functions that--- process a single stream.-module Streaming.Internal.Process- (- -- * Stream processors- -- ** Splitting and inspecting streams of elements- next- , uncons- , splitAt- , split- , breaks- , break- , breakWhen- , breakWhen'- , span- , group- , groupBy- -- ** Sum and compose manipulation- , distinguish- , switch- , separate- , unseparate- , eitherToSum- , sumToEither- , sumToCompose- , composeToSum- -- ** Partitions- , partitionEithers- , partition- -- ** Maybes- , catMaybes- , mapMaybe- , mapMaybeM- -- ** Direct Transformations- , hoist- , map- , mapM- , maps- , mapped- , mapsPost- , mapsMPost- , mappedPost- , for- , with- , subst- , copy- , duplicate- , store- , chain- , sequence- , nubOrd- , nubOrdOn- , nubInt- , nubIntOn- , filter- , filterM- , intersperse- , drop- , dropWhile- , scan- , scanM- , scanned- , delay- , read- , show- , cons- , slidingWindow- , wrapEffect- -- ** Internal- , destroyExposed- ) where--import Streaming.Internal.Type-import Prelude.Linear ((&), ($), (.))-import Prelude (Maybe(..), Either(..), Bool(..), Int,- Ordering(..), Num(..), Eq(..), id, Ord(..), Read(..),- String, Double)-import qualified Prelude-import Data.Unrestricted.Linear-import qualified Control.Functor.Linear as Control-import System.IO.Linear-import Data.Functor.Sum-import Data.Functor.Compose-import qualified Data.Set as Set-import qualified Data.Sequence as Seq-import qualified Data.IntSet as IntSet-import Text.Read (readMaybe)-import Control.Concurrent (threadDelay)-import GHC.Stack----- # Internal Library------------------------------------------------------------------------------------ | When chunking streams, it's useful to have a combinator--- that can add an element to the functor that is itself a stream.--- Basically `consFirstChunk 42 [[1,2,3],[4,5]] = [[42,1,2,3],[4,5]]`.-consFirstChunk :: Control.Monad m =>- a -> Stream (Stream (Of a) m) m r %1-> Stream (Stream (Of a) m) m r-consFirstChunk a stream = stream & \case- Return r -> Step (Step (a :> Return (Return r)))- Effect m -> Effect $ Control.fmap (consFirstChunk a) m- Step f -> Step (Step (a :> f))---- This is an internal function used in 'seperate' from the original source.--- It removes functoral and monadic steps and reduces to some type 'b'.--- Here it's adapted to consume the stream linearly.-destroyExposed- :: forall f m r b. (Control.Functor f, Control.Monad m) =>- Stream f m r %1-> (f b %1-> b) -> (m b %1-> b) -> (r %1-> b) -> b-destroyExposed stream0 construct theEffect done = loop stream0- where- loop :: (Control.Functor f, Control.Monad m) =>- Stream f m r %1-> b- loop stream = stream & \case- Return r -> done r- Effect m -> theEffect (Control.fmap loop m)- Step f -> construct (Control.fmap loop f)----- # Splitting and inspecting streams of elements------------------------------------------------------------------------------------ Remark. Since the 'a' is not held linearly in the 'Of' pair,--- we return it inside an 'Ur'.----{-| The standard way of inspecting the first item in a stream of elements, if the- stream is still \'running\'. The @Right@ case contains a- Haskell pair, where the more general @inspect@ would return a left-strict pair.- There is no reason to prefer @inspect@ since, if the @Right@ case is exposed,- the first element in the pair will have been evaluated to whnf.--> next :: Control.Monad m => Stream (Of a) m r %1-> m (Either r (a, Stream (Of a) m r))-> inspect :: Control.Monad m => Stream (Of a) m r %1-> m (Either r (Of a (Stream (Of a) m r)))--}-next :: forall a m r. Control.Monad m =>- Stream (Of a) m r %1-> m (Either r (Ur a, Stream (Of a) m r))-next stream = loop stream- where- loop :: Stream (Of a) m r %1-> m (Either r (Ur a, Stream (Of a) m r))- loop stream = stream & \case- Return r -> Control.return $ Left r- Effect ms -> ms Control.>>= next- Step (a :> as) -> Control.return $ Right (Ur a, as)-{-# INLINABLE next #-}--{-| Inspect the first item in a stream of elements, without a return value.---}-uncons :: forall a m r. (Consumable r, Control.Monad m) =>- Stream (Of a) m r %1-> m (Maybe (a, Stream (Of a) m r))-uncons stream = loop stream- where- loop :: Stream (Of a) m r %1-> m (Maybe (a, Stream (Of a) m r))- loop stream = stream & \case- Return r -> lseq r $ Control.return Nothing- Effect ms -> ms Control.>>= uncons- Step (a :> as) -> Control.return $ Just (a, as)-{-# INLINABLE uncons #-}--{-| Split a succession of layers after some number, returning a streaming or- effectful pair. This function is the same as the 'splitsAt' exported by the- @Streaming@ module, but since this module is imported qualified, it can- usurp a Prelude name. It specializes to:--> splitAt :: Control.Monad m => Int -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)---}-splitAt :: forall f m r. (Control.Monad m, Control.Functor f) =>- Int -> Stream f m r %1-> Stream f m (Stream f m r)-splitAt n stream = loop n stream where- loop :: Int -> Stream f m r %1-> Stream f m (Stream f m r)- loop n stream = case Prelude.compare n 0 of- GT -> stream & \case- Return r -> Return (Return r)- Effect m -> Effect $ m Control.>>= (Control.return . splitAt n)- Step f -> Step $ Control.fmap (splitAt (n-1)) f- _ -> Return stream-{-# INLINABLE splitAt #-}--{-| Split a stream of elements wherever a given element arises.- The action is like that of 'Prelude.words'.--@-\>\>\> S.stdoutLn $ mapped S.toList $ S.split ' ' $ each' "hello world "-hello-world-@--}-split :: forall a m r. (Eq a, Control.Monad m) =>- a -> Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r-split x stream = loop stream- where- loop :: Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ m Control.>>= (Control.return . split x)- Step (a :> as) -> case a == x of- True -> split x as- False -> consFirstChunk a (split x as)-{-# INLINABLE split #-}--{-| Break a sequence upon meeting an element that falls under a predicate,- keeping it and the rest of the stream as the return value.--@-\>\>\> rest <- S.print $ S.break even $ each' [1,1,2,3]-1-1-\>\>\> S.print rest-2-3-@--}-break :: forall a m r. Control.Monad m =>- (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)-break f stream = loop stream- where- loop :: Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)- loop stream = stream & \case- Return r -> Return (Return r)- Effect m -> Effect $ Control.fmap (break f) m- Step (a :> as) -> case f a of- True -> Return $ Step (a :> as)- False -> Step (a :> (break f as))-{-# INLINABLE break #-}--{-| Break during periods where the predicate is not satisfied,- grouping the periods when it is.--@-\>\>\> S.print $ mapped S.toList $ S.breaks not $ S.each' [False,True,True,False,True,True,False]-[True,True]-[True,True]-\>\>\> S.print $ mapped S.toList $ S.breaks id $ S.each' [False,True,True,False,True,True,False]-[False]-[False]-[False]-@--}-breaks :: forall a m r. Control.Monad m =>- (a -> Bool) -> Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r-breaks f stream = loop stream- where- loop :: Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (breaks f) m- Step (a :> as) -> case f a of- True -> breaks f as- False -> consFirstChunk a (breaks f as)-{-# INLINABLE breaks #-}---- Remark. The funny type of this seems to be made to interoperate well with--- `purely` from the `foldl` package.----{-| Yield elements, using a fold to maintain state, until the accumulated- value satifies the supplied predicate. The fold will then be short-circuited- and the element that breaks it will be put after the break.- This function is easiest to use with 'Control.Foldl.purely'--@-\>\>\> rest <- each' [1..10] & L.purely S.breakWhen L.sum (>10) & S.print-1-2-3-4-\>\>\> S.print rest-5-6-7-8-9-10-@--}-breakWhen :: forall m a x b r. Control.Monad m- => (x -> a -> x) -> x -> (x -> b) -> (b -> Bool)- -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)-breakWhen step x end pred stream = loop stream- where- loop :: Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)- loop stream = stream & \case- Return r -> Return (Return r)- Effect m -> Effect $ Control.fmap (breakWhen step x end pred) m- Step (a :> as) -> case pred (end (step x a)) of- False -> Step $ a :> (breakWhen step (step x a) end pred as)- True -> Return (Step (a :> as))-{-# INLINABLE breakWhen #-}---- | Breaks on the first element to satisfy the predicate-breakWhen' :: Control.Monad m =>- (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)-breakWhen' f stream = breakWhen (\_ a -> f a) True id id stream-{-# INLINE breakWhen' #-}---- | Stream elements until one fails the condition, return the rest.-span :: Control.Monad m =>- (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)-span f = break (Prelude.not Prelude.. f)-{-# INLINE span #-}--{-| Group elements of a stream in accordance with the supplied comparison.--@-\>\>\> S.print $ mapped S.toList $ S.groupBy (>=) $ each' [1,2,3,1,2,3,4,3,2,4,5,6,7,6,5]-[1]-[2]-[3,1,2,3]-[4,3,2,4]-[5]-[6]-[7,6,5]-@--}-groupBy :: forall a m r. Control.Monad m =>- (a -> a -> Bool) -> Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r-groupBy equals stream = loop stream- where- loop :: Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (groupBy equals) m- Step (a :> as) -> as & \case- Return r -> Step (Step (a :> Return (Return r)))- Effect m -> Effect $- m Control.>>= (\s -> Control.return $ groupBy equals (Step (a :> s)))- Step (a' :> as') -> case equals a a' of- False ->- Step $ Step $ a :> (Return $ groupBy equals (Step (a' :> as')))- True ->- Step $ Step $ a :> (Step $ a' :> (Return $ groupBy equals as'))-{-# INLINABLE groupBy #-}--{-| Group successive equal items together--@-\>\>\> S.toList $ mapped S.toList $ S.group $ each' "baaaaad"-["b","aaaaa","d"] :> ()-@--@-\>\>\> S.toList $ concats $ maps (S.drained . S.splitAt 1) $ S.group $ each' "baaaaaaad"-"bad" :> ()-@--}-group :: (Control.Monad m, Eq a) =>- Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r-group = groupBy (==)-{-# INLINE group #-}---- # Sum and compose manipulation------------------------------------------------------------------------------------ Remark. Most of these functions are general and were merely cut and pasted--- from the original library.--distinguish :: (a -> Bool) -> Of a r -> Sum (Of a) (Of a) r-distinguish predicate (a :> b) = case predicate a of- True -> InR (a :> b)- False -> InL (a :> b)-{-# INLINE distinguish #-}--{-| Swap the order of functors in a sum of functors.--@-\>\>\> S.toList $ S.print $ separate $ maps S.switch $ maps (S.distinguish (=='a')) $ S.each' "banana"-'a'-'a'-'a'-"bnn" :> ()-\>\>\> S.toList $ S.print $ separate $ maps (S.distinguish (=='a')) $ S.each' "banana"-'b'-'n'-'n'-"aaa" :> ()-@--}-switch :: Sum f g r -> Sum g f r-switch s = case s of InL a -> InR a; InR a -> InL a-{-# INLINE switch #-}--sumToEither :: Sum (Of a) (Of b) r -> Of (Either a b) r-sumToEither s = case s of- InL (a :> r) -> Left a :> r- InR (b :> r) -> Right b :> r-{-# INLINE sumToEither #-}--eitherToSum :: Of (Either a b) r -> Sum (Of a) (Of b) r-eitherToSum s = case s of- Left a :> r -> InL (a :> r)- Right b :> r -> InR (b :> r)-{-# INLINE eitherToSum #-}--composeToSum :: Compose (Of Bool) f r -> Sum f f r-composeToSum x = case x of- Compose (True :> f) -> InR f- Compose (False :> f) -> InL f-{-# INLINE composeToSum #-}--sumToCompose :: Sum f f r -> Compose (Of Bool) f r-sumToCompose x = case x of- InR f -> Compose (True :> f)- InL f -> Compose (False :> f)-{-# INLINE sumToCompose #-}--{-| Given a stream on a sum of functors, make it a stream on the left functor,- with the streaming on the other functor as the governing monad. This is- useful for acting on one or the other functor with a fold, leaving the- other material for another treatment. It generalizes- 'Data.Either.partitionEithers', but actually streams properly.--@-\>\>\> let odd_even = S.maps (S.distinguish even) $ S.each' [1..10::Int]-\>\>\> :t separate odd_even-separate odd_even- :: Monad m => Stream (Of Int) (Stream (Of Int) m) ()-@-- Now, for example, it is convenient to fold on the left and right values separately:--@-\>\>\> S.toList $ S.toList $ separate odd_even-[2,4,6,8,10] :> ([1,3,5,7,9] :> ())-@-- Or we can write them to separate files or whatever.-- Of course, in the special case of @Stream (Of a) m r@, we can achieve the above- effects more simply by using 'Streaming.Prelude.copy'--@-\>\>\> S.toList . S.filter even $ S.toList . S.filter odd $ S.copy $ each' [1..10::Int]-[2,4,6,8,10] :> ([1,3,5,7,9] :> ())-@-- But 'separate' and 'unseparate' are functor-general.---}-separate :: forall m f g r.- (Control.Monad m, Control.Functor f, Control.Functor g) =>- Stream (Sum f g) m r -> Stream f (Stream g m) r-separate stream = destroyExposed stream fromSum (Effect . Control.lift) Return- where- fromSum :: Sum f g (Stream f (Stream g m) r) %1-> (Stream f (Stream g m) r)- fromSum x = x & \case- InL fss -> Step fss- InR gss -> Effect (Step $ Control.fmap Return gss)-{-# INLINABLE separate #-}--unseparate :: (Control.Monad m, Control.Functor f, Control.Functor g) =>- Stream f (Stream g m) r -> Stream (Sum f g) m r-unseparate stream =- destroyExposed stream (Step . InL) (Control.join . maps InR) Control.return-{-# INLINABLE unseparate #-}---- # Partitions----------------------------------------------------------------------------------{-|-> filter p = hoist effects (partition p)-- -}-partition :: forall a m r. Control.Monad m =>- (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r-partition pred = loop- where- loop :: Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect (Control.fmap loop (Control.lift m))- Step (a :> as) -> case pred a of- True -> Step (a :> loop as)- False -> Effect $ Step $ a :> (Return (loop as))--{-| Separate left and right values in distinct streams. ('separate' is- a more powerful, functor-general, equivalent using 'Sum' in place of 'Either').--> partitionEithers = separate . maps S.eitherToSum-> lefts = hoist S.effects . partitionEithers-> rights = S.effects . partitionEithers-> rights = S.concat---}-partitionEithers :: Control.Monad m =>- Stream (Of (Either a b)) m r %1-> Stream (Of a) (Stream (Of b) m) r-partitionEithers = loop- where- loop :: Control.Monad m =>- Stream (Of (Either a b)) m r %1-> Stream (Of a) (Stream (Of b) m) r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop (Control.lift m)- Step (Left a :> as) -> Step (a :> loop as)- Step (Right b :> as) -> Effect $ (Step $ b :> Return (loop as))----- # Maybes----------------------------------------------------------------------------------{-| The 'catMaybes' function takes a 'Stream' of 'Maybe's and returns- a 'Stream' of all of the 'Just' values. 'concat' has the same behavior,- but is more general; it works for any foldable container type.--}-catMaybes :: Control.Monad m => Stream (Of (Maybe a)) m r %1-> Stream (Of a) m r-catMaybes stream = loop stream- where- loop :: Control.Monad m => Stream (Of (Maybe a)) m r %1-> Stream (Of a) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap catMaybes m- Step (maybe :> as) -> case maybe of- Nothing -> catMaybes as- Just a -> Step $ a :> (catMaybes as)-{-# INLINABLE catMaybes #-}--{-| The 'mapMaybe' function is a version of 'map' which can throw out elements. In particular,- the functional argument returns something of type @'Maybe' b@. If this is 'Nothing', no element- is added on to the result 'Stream'. If it is @'Just' b@, then @b@ is included in the result 'Stream'.---}-mapMaybe :: forall a b m r. Control.Monad m =>- (a -> Maybe b) -> Stream (Of a) m r %1-> Stream (Of b) m r-mapMaybe f stream = loop stream- where- loop :: Stream (Of a) m r %1-> Stream (Of b) m r- loop stream = stream & \case- Return r -> Return r- Effect ms -> Effect $ ms Control.>>= (Control.return . mapMaybe f)- Step (a :> s) -> case f a of- Just b -> Step $ b :> (mapMaybe f s)- Nothing -> mapMaybe f s-{-# INLINABLE mapMaybe #-}---- Note: the first function needs to wrap the 'b' in an 'Ur'--- since the control monad is bound and the 'b' ends up in the first--- unrestricted spot of 'Of'.------ | Map monadically over a stream, producing a new stream--- only containing the 'Just' values.-mapMaybeM :: forall a m b r. Control.Monad m =>- (a -> m (Maybe (Ur b))) -> Stream (Of a) m r %1-> Stream (Of b) m r-mapMaybeM f stream = loop stream- where- loop :: Stream (Of a) m r %1-> Stream (Of b) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (mapMaybeM f) m- Step (a :> as) -> Effect $ Control.do- mb <- f a- mb & \case- Nothing -> Control.return $ mapMaybeM f as- Just (Ur b) -> Control.return $ Step (b :> mapMaybeM f as)-{-# INLINABLE mapMaybeM #-}---- # Direct Transformations----------------------------------------------------------------------------------{-| Change the effects of one monad to another with a transformation.- This is one of the fundamental transformations on streams.- Compare with 'maps':--> maps :: (Control.Monad m, Control.Functor f) => (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r-> hoist :: (Control.Monad m, Control.Functor f) => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r---}-hoist :: forall f m n r. (Control.Monad m, Control.Functor f) =>- (forall a. m a %1-> n a) ->- Stream f m r %1-> Stream f n r-hoist f stream = loop stream where- loop :: Stream f m r %1-> Stream f n r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ f $ Control.fmap loop m- Step f -> Step $ Control.fmap loop f-{-# INLINABLE hoist #-}--{-| Standard map on the elements of a stream.--@-\>\>\> S.stdoutLn $ S.map reverse $ each' (words "alpha beta")-ahpla-ateb-@--}-map :: Control.Monad m => (a -> b) -> Stream (Of a) m r %1-> Stream (Of b) m r-map f = maps (\(x :> rest) -> f x :> rest)-{-# INLINABLE map #-}---- Remark.------ The functor transformation in functions like maps, mapped, mapsPost,--- and such must be linear since the 'Stream' data type holds each--- functor step with a linear arrow.--{- | Map layers of one functor to another with a transformation. Compare- hoist, which has a similar effect on the 'monadic' parameter.--> maps id = id-> maps f . maps g = maps (f . g)---}-maps :: forall f g m r . (Control.Monad m, Control.Functor f) =>- (forall x . f x %1-> g x) -> Stream f m r %1-> Stream g m r-maps phi = loop- where- loop :: Stream f m r %1-> Stream g m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (maps phi) m- Step f -> Step (phi (Control.fmap loop f))-{-# INLINABLE maps #-}---- Remark: Since the mapping function puts its result in a control monad,--- it must be used exactly once after the monadic value is bound.--- As a result the mapping function needs to return an 'Ur b'--- so that we can place the 'b' in the first argument of the--- 'Of' constructor, which is unrestricted.----{-| Replace each element of a stream with the result of a monadic action--@-\>\>\> S.print $ S.mapM readIORef $ S.chain (\ior -> modifyIORef ior (*100)) $ S.mapM newIORef $ each' [1..6]-100-200-300-400-500-600-@--See also 'chain' for a variant of this which ignores the return value of the function and just uses the side effects.--}-mapM :: Control.Monad m =>- (a -> m (Ur b)) -> Stream (Of a) m r %1-> Stream (Of b) m r-mapM f s = loop f s- where- loop :: Control.Monad m =>- (a -> m (Ur b)) -> Stream (Of a) m r %1-> Stream (Of b) m r- loop f stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (loop f) m- Step (a :> as) -> Effect $ Control.do- Ur b <- f a- Control.return $ Step (b :> (loop f as))-{-# INLINABLE mapM #-}--{- | Map layers of one functor to another with a transformation. Compare- hoist, which has a similar effect on the 'monadic' parameter.--> mapsPost id = id-> mapsPost f . mapsPost g = mapsPost (f . g)-> mapsPost f = maps f-- @mapsPost@ is essentially the same as 'maps', but it imposes a @Control.Functor@ constraint on- its target functor rather than its source functor. It should be preferred if 'fmap'- is cheaper for the target functor than for the source functor.--}-mapsPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>- (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r-mapsPost phi = loop- where- loop :: Stream f m r %1-> Stream g m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step f -> Step $ Control.fmap loop $ phi f-{-# INLINABLE mapsPost #-}--{- | Map layers of one functor to another with a transformation involving the base monad.-- This function is completely functor-general. It is often useful with the more concrete type--@-mapped :: (forall x. Stream (Of a) IO x -> IO (Of b x)) -> Stream (Stream (Of a) IO) IO r -> Stream (Of b) IO r-@-- to process groups which have been demarcated in an effectful, @IO@-based- stream by grouping functions like 'Streaming.Prelude.group',- 'Streaming.Prelude.split' or 'Streaming.Prelude.breaks'. Summary functions- like 'Streaming.Prelude.fold', 'Streaming.Prelude.foldM',- 'Streaming.Prelude.mconcat' or 'Streaming.Prelude.toList' are often used- to define the transformation argument. For example:--@-\>\>\> S.toList_ $ S.mapped S.toList $ S.split 'c' (S.each' "abcde")-["ab","de"]-@-- 'Streaming.Prelude.maps' and 'Streaming.Prelude.mapped' obey these rules:--> maps id = id-> mapped return = id-> maps f . maps g = maps (f . g)-> mapped f . mapped g = mapped (f <=< g)-> maps f . mapped g = mapped (fmap f . g)-> mapped f . maps g = mapped (f <=< fmap g)-- where @f@ and @g@ are @Control.Monad@s-- 'Streaming.Prelude.maps' is more fundamental than- 'Streaming.Prelude.mapped', which is best understood as a convenience for- effecting this frequent composition:--> mapped phi = decompose . maps (Compose . phi)----}-mapped :: forall f g m r . (Control.Monad m, Control.Functor f) =>- (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r-mapped phi = loop- where- loop :: Stream f m r %1-> Stream g m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step f -> Effect $ Control.fmap Step $ phi $ Control.fmap loop f--{- | Map layers of one functor to another with a transformation involving the base monad.- @mapsMPost@ is essentially the same as 'mapsM', but it imposes a @Control.Functor@ constraint on- its target functor rather than its source functor. It should be preferred if 'fmap'- is cheaper for the target functor than for the source functor.-- @mapsPost@ is more fundamental than @mapsMPost@, which is best understood as a convenience- for effecting this frequent composition:--> mapsMPost phi = decompose . mapsPost (Compose . phi)-- The streaming prelude exports the same function under the better name @mappedPost@,- which overlaps with the lens libraries.---}-{-# INLINABLE mapped #-}--mapsMPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>- (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r-mapsMPost phi = loop- where- loop :: Stream f m r %1-> Stream g m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step f -> Effect $ Control.fmap (Step . Control.fmap loop) $ phi f-{-# INLINABLE mapsMPost #-}--{-| A version of 'mapped' that imposes a @Control.Functor@ constraint on the target functor rather- than the source functor. This version should be preferred if 'fmap' on the target- functor is cheaper.---}-mappedPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>- (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r-mappedPost phi = loop- where- loop :: Stream f m r %1-> Stream g m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step f -> Effect $ Control.fmap (Step . Control.fmap loop) $ phi f-{-# INLINABLE mappedPost #-}---- | @for@ replaces each element of a stream with an associated stream. Note that the--- associated stream may layer any control functor.-for :: forall f m r a x . (Control.Monad m, Control.Functor f, Consumable x) =>- Stream (Of a) m r %1-> (a -> Stream f m x) -> Stream f m r-for stream expand = loop stream- where- loop :: Stream (Of a) m r %1-> Stream f m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step (a :> as) -> Control.do- x <- expand a- lseq x $ loop as-{-# INLINABLE for #-}---- Note: since the 'x' is discarded inside a control functor,--- we need it to be consumable----{-| Replace each element in a stream of individual Haskell values (a @Stream (Of a) m r@) with an associated 'functorial' step.--> for str f = concats (with str f)-> with str f = for str (yields . f)-> with str f = maps (\(a:>r) -> r <$ f a) str-> with = flip subst-> subst = flip with--@-\>\>\> with (each' [1..3]) (yield . Prelude.show) & intercalates (yield "--") & S.stdoutLn-1----2----3-@- -}-with :: forall f m r a x . (Control.Monad m, Control.Functor f, Consumable x) =>- Stream (Of a) m r %1-> (a -> f x) -> Stream f m r-with s f = loop s- where- loop :: Stream (Of a) m r %1-> Stream f m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step (a :> as) -> Step $ Control.fmap (`lseq` (loop as)) (f a)-{-# INLINABLE with #-}--{-| Replace each element in a stream of individual values with a functorial- layer of any sort. @subst = flip with@ and is more convenient in- a sequence of compositions that transform a stream.--> with = flip subst-> for str f = concats $ subst f str-> subst f = maps (\(a:>r) -> r <$ f a)-> S.concat = concats . subst each---}-subst :: (Control.Monad m, Control.Functor f, Consumable x) =>- (a -> f x) -> Stream (Of a) m r %1-> Stream f m r-subst = flip with where- flip :: (a %1-> b -> c) -> b -> a %1-> c- flip f b a = f a b-{-# INLINE subst #-}--{-| Duplicate the content of a stream, so that it can be acted on twice in different ways,- but without breaking streaming. Thus, with @each' [1,2]@ I might do:--@-\>\>\> S.print $ each' ["one","two"]-"one"-"two"-\>\>\> S.stdoutLn $ each' ["one","two"]-one-two-@-- With copy, I can do these simultaneously:--@-\>\>\> S.print $ S.stdoutLn $ S.copy $ each' ["one","two"]-"one"-one-"two"-two-@-- 'copy' should be understood together with 'effects' and is subject to the rules--> S.effects . S.copy = id-> hoist S.effects . S.copy = id-- The similar operations in 'Data.ByteString.Streaming' obey the same rules.-- Where the actions you are contemplating are each simple folds over- the elements, or a selection of elements, then the coupling of the- folds is often more straightforwardly effected with `Control.Foldl`,- e.g.--@-\>\>\> L.purely S.fold (liftA2 (,) L.sum L.product) $ each' [1..10]-(55,3628800) :> ()-@-- rather than--@-\>\>\> S.sum $ S.product . S.copy $ each' [1..10]-55 :> (3628800 :> ())-@-- A @Control.Foldl@ fold can be altered to act on a selection of elements by- using 'Control.Foldl.handles' on an appropriate lens. Some such- manipulations are simpler and more 'Data.List'-like, using 'copy':--@-\>\>\> L.purely S.fold (liftA2 (,) (L.handles (L.filtered odd) L.sum) (L.handles (L.filtered even) L.product)) $ each' [1..10]-(25,3840) :> ()-@-- becomes--@-\>\>\> S.sum $ S.filter odd $ S.product $ S.filter even $ S.copy' $ each' [1..10]-25 :> (3840 :> ())-@-- or using 'store'--@-\>\>\> S.sum $ S.filter odd $ S.store (S.product . S.filter even) $ each' [1..10]-25 :> (3840 :> ())-@-- But anything that fold of a @Stream (Of a) m r@ into e.g. an @m (Of b r)@- that has a constraint on @m@ that is carried over into @Stream f m@ -- e.g. @Control.Monad@, @Control.Functor@, etc. can be used on the stream.- Thus, I can fold over different groupings of the original stream:--@-\>\>\> (S.toList . mapped S.toList . chunksOf 5) $ (S.toList . mapped S.toList . chunksOf 3) $ S.copy $ each' [1..10]-[[1,2,3,4,5],[6,7,8,9,10]] :> ([[1,2,3],[4,5,6],[7,8,9],[10]] :> ())-@-- The procedure can be iterated as one pleases, as one can see from this (otherwise unadvisable!) example:--@-\>\>\> (S.toList . mapped S.toList . chunksOf 4) $ (S.toList . mapped S.toList . chunksOf 3) $ S.copy $ (S.toList . mapped S.toList . chunksOf 2) $ S.copy $ each' [1..12]-[[1,2,3,4],[5,6,7,8],[9,10,11,12]] :> ([[1,2,3],[4,5,6],[7,8,9],[10,11,12]] :> ([[1,2],[3,4],[5,6],[7,8],[9,10],[11,12]] :> ()))-@--@copy@ can be considered a special case of 'expand':--@- copy = 'expand' $ \p (a :> as) -> a :> p (a :> as)-@--If 'Of' were an instance of 'Control.Comonad.Comonad', then one could write--@- copy = 'expand' extend-@--}-copy :: forall a m r . Control.Monad m =>- Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r-copy = Effect . Control.return . loop- where- loop :: Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop (Control.lift m)- Step (a :> as) -> Effect $ Step (a :> Return (Step (a :> loop as)))-{-# INLINABLE copy#-}--{-| An alias for @copy@.--}-duplicate :: forall a m r . Control.Monad m =>- Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r-duplicate = copy-{-# INLINE duplicate#-}----- Note: to use the stream linearly the first argument--- must be a linear function----{-| Store the result of any suitable fold over a stream, keeping the stream for- further manipulation. @store f = f . copy@ :--@-\>\>\> S.print $ S.store S.product $ each' [1..4]-1-2-3-4-24 :> ()-@--@-\>\>\> S.print $ S.store S.sum $ S.store S.product $ each' [1..4]-1-2-3-4-10 :> (24 :> ())-@-- Here the sum (10) and the product (24) have been \'stored\' for use when- finally we have traversed the stream with 'print' . Needless to say,- a second 'pass' is excluded conceptually, so the- folds that you apply successively with @store@ are performed- simultaneously, and in constant memory -- as they would be if,- say, you linked them together with @Control.Fold@:--@-\>\>\> L.impurely S.foldM (liftA3 (\a b c -> (b, c)) (L.sink Prelude.print) (L.generalize L.sum) (L.generalize L.product)) $ each' [1..4]-1-2-3-4-(10,24) :> ()-@-- Fusing folds after the fashion of @Control.Foldl@ will generally be a bit faster- than the corresponding succession of uses of 'store', but by- constant factor that will be completely dwarfed when any IO is at issue.-- But 'store' \/ 'copy' is /much/ more powerful, as you can see by reflecting on- uses like this:--@-\>\>\> S.sum $ S.store (S.sum . mapped S.product . chunksOf 2) $ S.store (S.product . mapped S.sum . chunksOf 2) $ each' [1..6]-21 :> (44 :> (231 :> ()))-@-- It will be clear that this cannot be reproduced with any combination of lenses,- @Control.Fold@ folds, or the like. (See also the discussion of 'copy'.)-- It would conceivably be clearer to import a series of specializations of 'store'.- It is intended to be used at types like this:--> storeM :: (forall s m . Control.Monad m => Stream (Of a) m s %1-> m (Of b s))-> -> (Control.Monad n => Stream (Of a) n r %1-> Stream (Of a) n (Of b r))-> storeM = store-- It is clear from this type that we are just using the general instance:--> instance (Control.Functor f, Control.Monad m) => Control.Monad (Stream f m)-- We thus can't be touching the elements of the stream, or the final return value.- It is the same with other constraints that @Stream (Of a)@ inherits from the underlying monad.- Thus I can independently filter and write to one file, but- nub and write to another, or interact with a database and a logfile and the like:--@-\>\>\> (S.writeFile "hello2.txt" . S.nubOrd) $ store (S.writeFile "hello.txt" . S.filter (/= "world")) $ each' ["hello", "world", "goodbye", "world"]-\>\>\> :! cat hello.txt-hello-goodbye-\>\>\> :! cat hello2.txt-hello-world-goodbye-@---}-store :: Control.Monad m =>- (Stream (Of a) (Stream (Of a) m) r %1-> t) -> Stream (Of a) m r %1-> t-store f x = f (copy x)-{-# INLINE store #-}---- Note: since we discard the 'y' inside a control monad, it needs to be--- consumable----{-| Apply an action to all values, re-yielding each.- The return value (@y@) of the function is ignored.--@-\>\>\> S.product $ S.chain Prelude.print $ S.each' [1..5]-1-2-3-4-5-120 :> ()-@--See also 'mapM' for a variant of this which uses the return value of the function to transorm the values in the stream.--}-chain :: forall a m r y . (Control.Monad m, Consumable y) =>- (a -> m y) -> Stream (Of a) m r %1-> Stream (Of a) m r-chain f = loop- where- loop :: Stream (Of a) m r %1-> Stream (Of a) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step (a :> as) -> Effect $ Control.do- y <- f a- Control.return $ lseq y $ Step (a :> loop as)-{-# INLINABLE chain #-}---- Note: since the value of type 'a' is inside a control monad but--- needs to be used in an unrestricted position in 'Of', the input stream--- needs to hold values of type 'm (Ur a)'.----{-| Like the 'Data.List.sequence' but streaming. The result type is a- stream of a\'s, /but is not accumulated/; the effects of the elements- of the original stream are interleaved in the resulting stream. Compare:--> sequence :: Monad m => [m a] -> m [a]-> sequence :: Control.Monad m => Stream (Of (m a)) m r %1-> Stream (Of a) m r---}-sequence :: forall a m r . Control.Monad m =>- Stream (Of (m (Ur a))) m r %1-> Stream (Of a) m r-sequence = loop- where- loop :: Stream (Of (m (Ur a))) m r %1-> Stream (Of a) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step (ma :> mas) -> Effect $ Control.do- Ur a <- ma- Control.return $ Step (a :> loop mas)-{-# INLINABLE sequence #-}--{-| Remove repeated elements from a Stream. 'nubOrd' of course accumulates a 'Data.Set.Set' of- elements that have already been seen and should thus be used with care.---}-nubOrd :: (Control.Monad m, Ord a) => Stream (Of a) m r %1-> Stream (Of a) m r-nubOrd = nubOrdOn id-{-# INLINE nubOrd #-}--{-| Use 'nubOrdOn' to have a custom ordering function for your elements. -}-nubOrdOn :: forall m a b r . (Control.Monad m, Ord b) =>- (a -> b) -> Stream (Of a) m r %1-> Stream (Of a) m r-nubOrdOn f xs = loop Set.empty xs- where- loop :: Set.Set b -> Stream (Of a) m r %1-> Stream (Of a) m r- loop !set stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (loop set) m- Step (a :> as) -> case Set.member (f a) set of- True -> loop set as- False-> Step (a :> loop (Set.insert (f a) set) as)--{-| More efficient versions of above when working with 'Int's that use 'Data.IntSet.IntSet'. -}-nubInt :: Control.Monad m => Stream (Of Int) m r %1-> Stream (Of Int) m r-nubInt = nubIntOn id-{-# INLINE nubInt #-}--nubIntOn :: forall m a r . (Control.Monad m) =>- (a -> Int) -> Stream (Of a) m r %1-> Stream (Of a) m r-nubIntOn f xs = loop IntSet.empty xs- where- loop :: IntSet.IntSet -> Stream (Of a) m r %1-> Stream (Of a) m r- loop !set stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (loop set) m- Step (a :> as) -> case IntSet.member (f a) set of- True -> loop set as- False-> Step (a :> loop (IntSet.insert (f a) set) as)---- | Skip elements of a stream that fail a predicate-filter :: forall a m r . Control.Monad m =>- (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m r-filter pred = loop- where- loop :: Stream (Of a) m r %1-> Stream (Of a) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step (a :> as) -> case pred a of- True -> Step (a :> loop as)- False -> loop as-{-# INLINE filter #-}---- | Skip elements of a stream that fail a monadic test-filterM :: forall a m r . Control.Monad m =>- (a -> m Bool) -> Stream (Of a) m r %1-> Stream (Of a) m r-filterM pred = loop- where- loop :: Stream (Of a) m r %1-> Stream (Of a) m r- loop stream = stream & \case- Return r -> Return r- Effect m-> Effect $ Control.fmap loop m- Step (a :> as) -> Effect $ Control.do- bool <- pred a- bool & \case- True -> Control.return $ Step (a :> loop as)- False -> Control.return $ loop as-{-# INLINE filterM #-}--{-| Intersperse given value between each element of the stream.--@-\>\>\> S.print $ S.intersperse 0 $ each [1,2,3]-1-0-2-0-3-@---}-intersperse :: forall a m r . Control.Monad m =>- a -> Stream (Of a) m r %1-> Stream (Of a) m r-intersperse x stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (intersperse x) m- Step (a :> as) -> loop a as- where- -- Given the first element of a stream, intersperse the bound- -- element named 'x'- loop :: a -> Stream (Of a) m r %1-> Stream (Of a) m r- loop !a stream = stream & \case- Return r -> Step (a :> Return r)- Effect m -> Effect $ Control.fmap (loop a) m- Step (a' :> as) -> Step (a :> Step (x :> loop a' as))-{-# INLINABLE intersperse #-}--{-| Ignore the first n elements of a stream, but carry out the actions--@-\>\>\> S.toList $ S.drop 2 $ S.replicateM 5 getLine-a<Enter>-b<Enter>-c<Enter>-d<Enter>-e<Enter>-["c","d","e"] :> ()-@-- Because it retains the final return value, @drop n@ is a suitable argument- for @maps@:--@-\>\>\> S.toList $ concats $ maps (S.drop 4) $ chunksOf 5 $ each [1..20]-[5,10,15,20] :> ()-@- -}-drop :: forall a m r. (HasCallStack, Control.Monad m) =>- Int -> Stream (Of a) m r %1-> Stream (Of a) m r-drop n stream = case compare n 0 of- LT -> Prelude.error "drop called with negative int" $ stream- EQ -> stream- GT -> loop stream where- loop :: Stream (Of a) m r %1-> Stream (Of a) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (drop n) m- Step (_ :> as) -> drop (n-1) as-{-# INLINABLE drop #-}--{- | Ignore elements of a stream until a test succeeds, retaining the rest.--@-\>\>\> S.print $ S.dropWhile ((< 5) . length) S.stdinLn-one<Enter>-two<Enter>-three<Enter>-"three"-four<Enter>-"four"-^CInterrupted.-@---}-dropWhile :: forall a m r . Control.Monad m =>- (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m r-dropWhile pred = loop- where- loop :: Stream (Of a) m r %1-> Stream (Of a) m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step (a :> as) -> case pred a of- True -> loop as- False -> Step (a :> as)-{-# INLINABLE dropWhile #-}--{-| Strict left scan, streaming, e.g. successive partial results. The seed- is yielded first, before any action of finding the next element is performed.--@-\>\>\> S.print $ S.scan (++) "" id $ each' (words "a b c d")-""-"a"-"ab"-"abc"-"abcd"-@-- 'scan' is fitted for use with @Control.Foldl@, thus:--@-\>\>\> S.print $ L.purely S.scan L.list $ each' [3..5]-[]-[3]-[3,4]-[3,4,5]-@--}-scan :: forall a x b m r . Control.Monad m =>- (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> Stream (Of b) m r-scan step begin done stream = Step (done begin :> loop begin stream)- where- loop :: x -> Stream (Of a) m r %1-> Stream (Of b) m r- loop !acc stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (loop acc) m- Step (a :> as) -> Step (done acc' :> loop acc' as) where- !acc' = step acc a-{-# INLINABLE scan #-}---- Note: since the accumulated value (inside the control monad) is used both in--- populating the output stream and in accumulation, it needs to be wrapped in--- an 'Ur' accross the function----{-| Strict left scan, accepting a monadic function. It can be used with- 'FoldM's from @Control.Foldl@ using 'impurely'. Here we yield- a succession of vectors each recording--@-\>\>\> let v = L.impurely scanM L.vectorM $ each' [1..4::Int] :: Stream (Of (Vector Int)) IO ()-\>\>\> S.print v-[]-[1]-[1,2]-[1,2,3]-[1,2,3,4]-@--}-scanM :: forall a x b m r . Control.Monad m =>- (x %1-> a -> m (Ur x)) ->- m (Ur x) ->- (x %1-> m (Ur b)) ->- Stream (Of a) m r %1->- Stream (Of b) m r-scanM step mx done stream = loop stream- where- loop :: Stream (Of a) m r %1-> Stream (Of b) m r- loop stream = stream & \case- Return r -> Effect $ Control.do- Ur x <- mx- Ur b <- done x- Control.return $ Step $ b :> Return r- Effect m -> Effect $ Control.fmap (scanM step mx done) m- Step (a :> as) -> Effect $ Control.do- Ur x <- mx- Ur b <- done x- Control.return $ Step $ b :> (scanM step (step x a) done as)-{-# INLINABLE scanM #-}--{-| Label each element in a stream with a value accumulated according to a fold.--@-\>\>\> S.print $ S.scanned (*) 1 id $ S.each' [100,200,300]-(100,100)-(200,20000)-(300,6000000)-@--@-\>\>\> S.print $ L.purely S.scanned' L.product $ S.each [100,200,300]-(100,100)-(200,20000)-(300,6000000)-@--}-scanned :: forall a x b m r . Control.Monad m =>- (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> Stream (Of (a,b)) m r-scanned step begin done = loop begin- where- loop :: x -> Stream (Of a) m r %1-> Stream (Of (a,b)) m r- loop !x stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap (loop x) m- Step (a :> as) -> Control.do- let !acc = done (step x a)- Step $ (a, acc) :> Return () -- same as yield- loop (step x a) as-{-# INLINABLE scanned #-}---- Note: this skips failed parses--- XXX re-write with Text----{- | Make a stream of strings into a stream of parsed values, skipping bad cases--@-\>\>\> S.sum_ $ S.read $ S.takeWhile (/= "total") S.stdinLn :: IO Int-1000<Enter>-2000<Enter>-total<Enter>-3000-@---}-read :: (Control.Monad m, Read a) =>- Stream (Of String) m r %1-> Stream (Of a) m r-read = mapMaybe readMaybe-{-# INLINE read #-}--{-| Interpolate a delay of n seconds between yields.--}-delay :: forall a r. Double -> Stream (Of a) IO r %1-> Stream (Of a) IO r-delay seconds = loop- where- pico = Prelude.truncate (seconds * 1000000)- loop :: Stream (Of a) IO r %1-> Stream (Of a) IO r- loop stream = Control.do- e <- Control.lift $ next stream- e & \case- Left r -> Return r- Right (Ur a,rest) -> Control.do- Step (a :> Return ()) -- same as yield- Control.lift $ fromSystemIO $ threadDelay pico- loop rest-{-# INLINABLE delay #-}--show :: (Control.Monad m, Prelude.Show a) =>- Stream (Of a) m r %1-> Stream (Of String) m r-show = map Prelude.show-{-# INLINE show #-}---{-| The natural @cons@ for a @Stream (Of a)@.--> cons a stream = yield a Control.>> stream-- Useful for interoperation:--> Data.Text.foldr S.cons (return ()) :: Text -> Stream (Of Char) m ()-> Lazy.foldrChunks S.cons (return ()) :: Lazy.ByteString -> Stream (Of Strict.ByteString) m ()-- and so on.--}-cons :: Control.Monad m => a -> Stream (Of a) m r %1-> Stream (Of a) m r-cons a str = Step (a :> str)-{-# INLINE cons #-}---- Note. The action function that is the second argument must be linear since--- it gets its argument from binding to the first argument, which uses a--- control monad.----{-| Before evaluating the monadic action returning the next step in the 'Stream', @wrapEffect@- extracts the value in a monadic computation @m a@ and passes it to a computation @a -> m y@.---}-wrapEffect :: (Control.Monad m, Control.Functor f, Consumable y) =>- m a -> (a %1-> m y) -> Stream f m r %1-> Stream f m r-wrapEffect ma action stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.do- a <- ma- y <- action a- lseq y $ m- Step f -> Effect $ Control.do- a <- ma- y <- action a- Control.return $ lseq y $ Step f--{-| 'slidingWindow' accumulates the first @n@ elements of a stream,- update thereafter to form a sliding window of length @n@.- It follows the behavior of the slidingWindow function in- <https://hackage.haskell.org/package/conduit-combinators-1.0.4/docs/Data-Conduit-Combinators.html#v:slidingWindow conduit-combinators>.--@-\>\>\> S.print $ S.slidingWindow 4 $ S.each "123456"-fromList "1234"-fromList "2345"-fromList "3456"-@--}-slidingWindow :: forall a b m. Control.Monad m => Int -> Stream (Of a) m b- %1-> Stream (Of (Seq.Seq a)) m b-slidingWindow n = setup (max 1 n :: Int) Seq.empty- where- -- Given the current sliding window, yield it and then recurse with- -- updated sliding window- window :: Seq.Seq a -> Stream (Of a) m b %1-> Stream (Of (Seq.Seq a)) m b- window !sequ str = Control.do- e <- Control.lift (next str)- e & \case- Left r -> Control.return r- Right (Ur a,rest) -> Control.do- Step $ (sequ Seq.|> a) :> Return () -- same as yield- window (Seq.drop 1 sequ Seq.|> a) rest- -- Collect the first n elements in a sequence and call 'window'- setup ::- Int -> Seq.Seq a -> Stream (Of a) m b %1-> Stream (Of (Seq.Seq a)) m b- setup 0 !sequ str = Control.do- Step (sequ :> Return ()) -- same as yield- window (Seq.drop 1 sequ) str- setup n' sequ str = Control.do- e <- Control.lift $ next str- e & \case- Left r -> Control.do- Step (sequ :> Return ()) -- same as yield- Control.return r- Right (Ur x,rest) -> setup (n'-1) (sequ Seq.|> x) rest-{-# INLINABLE slidingWindow #-}-
− src/Streaming/Internal/Produce.hs
@@ -1,486 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | This module provides all functions which produce a--- 'Stream (Of a) m r' from some given non-stream inputs.-module Streaming.Internal.Produce- ( -- * Constructing Finite 'Stream's- yield- , each'- , unfoldr- , fromHandle- , readFile- , replicate- , replicateM- , replicateZip- , untilRight- -- * Working with infinite 'Stream's- , stdinLnN- , stdinLnUntil- , stdinLnUntilM- , stdinLnZip- , readLnN- , readLnUntil- , readLnUntilM- , readLnZip- , iterateN- , iterateZip- , iterateMN- , iterateMZip- , cycleN- , cycleZip- , enumFromN- , enumFromZip- , enumFromThenN- , enumFromThenZip- ) where--import Streaming.Internal.Type-import Streaming.Internal.Process-import Streaming.Internal.Consume (effects)-import Prelude.Linear (($), (&))-import Prelude (Either(..), Read, Bool(..), FilePath, Enum, otherwise,- Num(..), Int, otherwise, Eq(..), Ord(..), fromEnum, toEnum)-import qualified Prelude-import qualified Control.Functor.Linear as Control-import Data.Unrestricted.Linear-import System.IO.Linear-import System.IO.Resource-import qualified System.IO as System-import Data.Text (Text)-import qualified Data.Text as Text-import GHC.Stack----- # The Finite Stream Constructors----------------------------------------------------------------------------------{-| A singleton stream--@-\>\>\> stdoutLn $ yield "hello"-hello-@--@-\>\>\> S.sum $ do {yield 1; yield 2; yield 3}-6 :> ()-@--}-yield :: Control.Monad m => a -> Stream (Of a) m ()-yield x = Step $ x :> Return ()-{-# INLINE yield #-}--{- | Stream the elements of a pure, foldable container.--@-\>\>\> S.print $ each' [1..3]-1-2-3-@--}-each' :: Control.Monad m => [a] -> Stream (Of a) m ()-each' xs = Prelude.foldr (\a stream -> Step $ a :> stream) (Return ()) xs-{-# INLINABLE each' #-}--{-| Build a @Stream@ by unfolding steps starting from a seed. In particular note- that @S.unfoldr S.next = id@.---}-unfoldr :: Control.Monad m =>- (s %1-> m (Either r (Ur a, s))) -> s %1-> Stream (Of a) m r-unfoldr step s = unfoldr' step s- where- unfoldr' :: Control.Monad m =>- (s %1-> m (Either r (Ur a, s))) -> s %1-> Stream (Of a) m r- unfoldr' step s = Effect $ step s Control.>>= \case- Left r -> Control.return $ Return r- Right (Ur a,s') ->- Control.return $ Step $ a :> unfoldr step s'-{-# INLINABLE unfoldr #-}---- Note: we use the RIO monad from linear base to enforce--- the protocol of file handles and file I/O-fromHandle :: Handle %1-> Stream (Of Text) RIO ()-fromHandle h = loop h- where- loop :: Handle %1-> Stream (Of Text) RIO ()- loop h = Control.do- (Ur isEOF, h') <- Control.lift $ hIsEOF h- case isEOF of- True -> Control.do- Control.lift $ hClose h'- Control.return ()- False -> Control.do- (Ur text, h'') <- Control.lift $ hGetLine h'- yield text- fromHandle h''-{-# INLINABLE fromHandle #-}--{-| Read the lines of a file given the filename.---}-readFile :: FilePath -> Stream (Of Text) RIO ()-readFile path = Control.do- handle <- Control.lift $ openFile path System.ReadMode- fromHandle handle---- | Repeat an element several times.-replicate :: (HasCallStack, Control.Monad m) => Int -> a -> Stream (Of a) m ()-replicate n a- | n < 0 = Prelude.error "Cannot replicate a stream of negative length"- | otherwise = loop n a- where- loop :: Control.Monad m => Int -> a -> Stream (Of a) m ()- loop n a- | n == 0 = Return ()- | otherwise = Effect $ Control.return $ Step $ a :> loop (n-1) a-{-# INLINABLE replicate #-}--{-| Repeat an action several times, streaming its results.--@-\>\>\> import qualified Unsafe.Linear as Unsafe-\>\>\> import qualified Data.Time as Time-\>\>\> let getCurrentTime = fromSystemIO (Unsafe.coerce Time.getCurrentTime)-\>\>\> S.print $ S.replicateM 2 getCurrentTime-2015-08-18 00:57:36.124508 UTC-2015-08-18 00:57:36.124785 UTC-@--}-replicateM :: Control.Monad m =>- Int -> m (Ur a) -> Stream (Of a) m ()-replicateM n ma- | n < 0 = Prelude.error "Cannot replicate a stream of negative length"- | otherwise = loop n ma- where- loop :: Control.Monad m => Int -> m (Ur a) -> Stream (Of a) m ()- loop n ma- | n == 0 = Return ()- | otherwise = Effect $ Control.do- Ur a <- ma- Control.return $ Step $ a :> (replicateM (n-1) ma)---- | Replicate a constant element and zip it with the finite stream which--- is the first argument.-replicateZip :: Control.Monad m =>- Stream (Of x) m r -> a -> Stream (Of (a,x)) m r-replicateZip stream a = map ((,) a) stream-{-# INLINABLE replicateZip #-}--untilRight :: forall m a r . Control.Monad m =>- m (Either (Ur a) r) -> Stream (Of a) m r-untilRight mEither = Effect loop- where- loop :: m (Stream (Of a) m r)- loop = Control.do- either <- mEither- either & \case- Left (Ur a) ->- Control.return $ Step $ a :> (untilRight mEither)- Right r -> Control.return $ Return r-{-# INLINABLE untilRight #-}----- # The \"Affine\" 'Stream'------------------------------------------------------------------------------------ | An *affine stream is represented with a state of type @x@,--- a possibly terminating step function of type @(x %1-> m (Either (f x) r))@,--- and a stop-short function @(x %1-> m r)@.------ This mirrors the unfold of a normal stream:------ > data Stream f m r where--- > Stream :: x %1-> (x %1-> m (Either (f x) r)) -> Stream f m r------ *Though referred to as an \"affine stream\" this might not be the correct--- definition for affine streams. Sorting this out requires a bit more--- careful thought.-data AffineStream f m r where- AffineStream ::- x %1->- (x %1-> m (Either (f x) r)) ->- (x %1-> m r) ->- AffineStream f m r---- | Take @n@ number of elements from the affine stream, for non-negative--- @n@. (Negative @n@ is treated as 0.)-take :: forall f m r. (Control.Monad m, Control.Functor f) =>- Int -> AffineStream f m r %1-> Stream f m r-take = loop where- loop :: Int -> AffineStream f m r %1-> Stream f m r- loop n (AffineStream s step end)- | n <= 0 = Effect $ Control.fmap Control.return $ end s- | otherwise = Effect $ Control.do- next <- step s- next & \case- Right r -> Control.return (Return r)- Left fx -> Control.return $ Step $- Control.fmap (\x -> loop (n-1) (AffineStream x step end)) fx-{-# INLINABLE take #-}---- | Run an affine stream until it ends or a monadic test succeeds.--- Drop the element it succeeds on.-untilM :: forall a m r. Control.Monad m =>- (a -> m Bool) -> AffineStream (Of a) m r %1-> Stream (Of a) m r-untilM = loop where- loop :: (a -> m Bool) -> AffineStream (Of a) m r %1-> Stream (Of a) m r- loop test (AffineStream s step end) = Effect $ Control.do- next <- step s- next & \case- Right r -> Control.return (Return r)- Left (a :> next) -> Control.do- testResult <- test a- testResult & \case- False -> Control.return $- Step $ a :> loop test (AffineStream next step end)- True -> Control.fmap Control.return $ end next-{-# INLINABLE untilM #-}---- | Like 'untilM' but without the monadic test.-until :: forall a m r. Control.Monad m =>- (a -> Bool) -> AffineStream (Of a) m r %1-> Stream (Of a) m r-until = loop where- loop :: (a -> Bool) -> AffineStream (Of a) m r %1-> Stream (Of a) m r- loop test (AffineStream s step end) = Effect $ Control.do- next <- step s- next & \case- Right r -> Control.return (Return r)- Left (a :> next) -> case test a of- True -> Control.fmap Control.return $ end next- False -> Control.return $ Step $- a :> loop test (AffineStream next step end)-{-# INLINABLE until #-}---- | Zip a finite stream with an affine stream.-zip :: forall a x m r1 r2. Control.Monad m =>- Stream (Of x) m r1 %1->- AffineStream (Of a) m r2 %1->- Stream (Of (x,a)) m (r1,r2)-zip = loop where- loop ::- Stream (Of x) m r1 %1->- AffineStream (Of a) m r2 %1->- Stream (Of (x,a)) m (r1,r2)- loop stream (AffineStream s step end) = stream & \case- Return r1 -> Effect $- Control.fmap (\r2 -> Control.return $ (r1,r2)) $ end s- Effect m -> Effect $- Control.fmap (\str -> loop str (AffineStream s step end)) m- Step (x :> rest) -> Effect $ Control.do- next <- step s- next & \case- Right r2 -> Control.do- r1 <- effects rest- Control.return (Return (r1,r2))- Left (a :> rest') -> Control.return $ Step $- (x,a) :> loop rest (AffineStream rest' step end)-{-# INLINABLE zip #-}---- | An affine stream of standard input lines.-stdinLn :: AffineStream (Of Text) IO ()-stdinLn = AffineStream () getALine Control.pure where- getALine :: () %1-> IO (Either (Of Text ()) ())- getALine () = Control.do- Ur line <- fromSystemIOU System.getLine- Control.return $ Left (Text.pack line :> ())---- | An affine stream of reading lines, crashing on failed parse.-readLn :: Read a => AffineStream (Of a) IO ()-readLn = AffineStream () readALine Control.pure where- readALine :: Read a => () %1-> IO (Either (Of a ()) ())- readALine () = Control.do- Ur line <- fromSystemIOU System.getLine- Control.return $ Left (Prelude.read line :> ())---- | An affine stream iterating an initial state forever.-iterate :: forall a m.- Control.Monad m => a -> (a -> a) -> AffineStream (Of a) m ()-iterate a step =- AffineStream (Ur a) stepper (\x -> Control.return $ consume x)- where- stepper :: Ur a %1-> m (Either (Of a (Ur a)) ())- stepper (Ur a) = Control.return $- Left $ a :> Ur (step a)---- | An affine stream monadically iterating an initial state forever.-iterateM :: forall a m. Control.Monad m =>- m (Ur a) -> (a -> m (Ur a)) -> AffineStream (Of a) m ()-iterateM ma step =- AffineStream ma stepper (Control.fmap consume)- where- stepper :: m (Ur a) %1-> m (Either (Of a (m (Ur a))) ())- stepper ma = Control.do- Ur a <- ma- Control.return $ Left $ a :> (step a)---- Remark. In order to implement the affine break function, which is the third--- argument of the constructor, we need to specify the functor as @Of@.--- Approaches to keeping it functor general seem messy.---- | An affine stream cycling through a given finite stream forever.-cycle :: forall a m r. (Control.Monad m, Consumable r) =>- Stream (Of a) m r -> AffineStream (Of a) m r-cycle stream =- -- Note. The state is (original stream, stream_in_current_cycle)- AffineStream (Ur stream, stream) stepStream leftoverEffects- where- leftoverEffects ::- (Ur (Stream (Of a) m r), Stream (Of a) m r) %1-> m r- leftoverEffects (Ur _, str) = effects str-- stepStream :: Control.Functor f =>- (Ur (Stream f m r), Stream f m r) %1->- m (Either (f (Ur (Stream f m r), Stream f m r)) r)- stepStream (Ur s, str) = str & \case- Return r -> lseq r $ stepStream (Ur s, s)- Effect m ->- m Control.>>= (\stream -> stepStream (Ur s, stream))- Step f -> Control.return $- Left $ Control.fmap ((,) (Ur s)) f---- | An affine stream iterating an enumerated stream forever.-enumFrom :: (Control.Monad m, Enum e) => e -> AffineStream (Of e) m ()-enumFrom e = iterate e Prelude.succ---- | An affine stream iterating an enumerated stream forever, using the--- first two elements to determine the gap to skip by.--- E.g., @enumFromThen 3 5@ is like @[3,5..]@.-enumFromThen :: forall e m. (Control.Monad m, Enum e) =>- e -> e -> AffineStream (Of e) m ()-enumFromThen e e' = iterate e enumStep where- enumStep :: e -> e- enumStep enum = toEnum Prelude.$- (fromEnum enum) + ((fromEnum e') - (fromEnum e))- -- Think: \enum -> enum + stepSize where stepSize = (e1 - e0)----- # Working with infinite 'Stream's------------------------------------------------------------------------------------ | @stdinLnN n@ is a stream of @n@ lines from standard input-stdinLnN :: Int -> Stream (Of Text) IO ()-stdinLnN n = take n stdinLn-{-# INLINE stdinLnN #-}---- | Provides a stream of standard input and omits the first line--- that satisfies the predicate, possibly requiring IO-stdinLnUntilM :: (Text -> IO Bool) -> Stream (Of Text) IO ()-stdinLnUntilM test = untilM test stdinLn-{-# INLINE stdinLnUntilM #-}---- | Provides a stream of standard input and omits the first line--- that satisfies the predicate-stdinLnUntil :: (Text -> Bool) -> Stream (Of Text) IO ()-stdinLnUntil test = until test stdinLn-{-# INLINE stdinLnUntil #-}---- | Given a finite stream, provide a stream of lines of standard input--- zipped with that finite stream-stdinLnZip :: Stream (Of x) IO r %1-> Stream (Of (x, Text)) IO r-stdinLnZip stream = Control.fmap (\(r,()) -> r) $ zip stream stdinLn-{-# INLINE stdinLnZip #-}--readLnN :: Read a => Int -> Stream (Of a) IO ()-readLnN n = take n readLn-{-# INLINE readLnN #-}--readLnUntilM :: Read a => (a -> IO Bool) -> Stream (Of a) IO ()-readLnUntilM test = untilM test readLn-{-# INLINE readLnUntilM #-}--readLnUntil :: Read a => (a -> Bool) -> Stream (Of a) IO ()-readLnUntil test = until test readLn-{-# INLINE readLnUntil #-}--readLnZip :: Read a => Stream (Of x) IO r %1-> Stream (Of (x, a)) IO r-readLnZip stream = Control.fmap (\(r,()) -> r) $ zip stream readLn-{-# INLINE readLnZip #-}---- | Iterate a pure function from a seed value,--- streaming the results forever.-iterateN :: Control.Monad m => Int -> (a -> a) -> a -> Stream (Of a) m ()-iterateN n step a = take n $ iterate a step-{-# INLINE iterateN #-}--iterateZip :: Control.Monad m => Stream (Of x) m r ->- (a -> a) -> a -> Stream (Of (x,a)) m r-iterateZip stream step a =- Control.fmap (\(r,()) -> r) $ zip stream $ iterate a step-{-# INLINE iterateZip #-}---- | Iterate a monadic function from a seed value,--- streaming the results forever.-iterateMN :: Control.Monad m =>- Int -> (a -> m (Ur a)) -> m (Ur a) -> Stream (Of a) m ()-iterateMN n step ma = take n $ iterateM ma step-{-# INLINE iterateMN #-}--iterateMZip :: Control.Monad m =>- Stream (Of x) m r %1->- (a -> m (Ur a)) -> m (Ur a) -> Stream (Of (x,a)) m r-iterateMZip stream step ma =- Control.fmap (\(r,()) -> r) $ zip stream $ iterateM ma step-{-# INLINE iterateMZip #-}---- | Cycle a stream a finite number of times-cycleN :: (Control.Monad m, Consumable r) =>- Int -> Stream (Of a) m r -> Stream (Of a) m r-cycleN n stream = take n $ cycle stream-{-# INLINE cycleN #-}---- | @cycleZip s1 s2@ will cycle @s2@ just enough to zip with the given finite--- stream @s1@. Note that we consume all the effects of the remainder of the--- cycled stream @s2@. That is, we consume @s2@ the smallest natural number of--- times we need to zip.-cycleZip :: (Control.Monad m, Consumable s) =>- Stream (Of a) m r %1-> Stream (Of b) m s -> Stream (Of (a,b)) m (r,s)-cycleZip str stream = zip str $ cycle stream-{-# INLINE cycleZip #-}--{-| An finite sequence of enumerable values at a fixed distance, determined- by the first and second values.--@-\>\>\> S.print $ S.enumFromThenN 3 100 200-100-200-300-@--}-enumFromThenN :: (Control.Monad m, Enum e) => Int -> e -> e -> Stream (Of e) m ()-enumFromThenN n e e' = take n $ enumFromThen e e'-{-# INLINE enumFromThenN #-}---- | A finite sequence of enumerable values at a fixed distance determined--- by the first and second values. The length is limited by zipping--- with a given finite stream, i.e., the first argument.-enumFromThenZip :: (Control.Monad m, Enum e) =>- Stream (Of a) m r %1-> e -> e -> Stream (Of (a,e)) m r-enumFromThenZip stream e e'=- Control.fmap (\(r,()) -> r) $ zip stream $ enumFromThen e e'-{-# INLINE enumFromThenZip #-}---- | Like 'enumFromThenN' but where the next element in the enumeration is just--- the successor @succ n@ for a given enum @n@.-enumFromN :: (Control.Monad m, Enum e) => Int -> e -> Stream (Of e) m ()-enumFromN n e = take n $ enumFrom e-{-# INLINE enumFromN #-}---- | Like 'enumFromThenZip' but where the next element in the enumeration is just--- the successor @succ n@ for a given enum @n@.-enumFromZip :: (Control.Monad m, Enum e) =>- Stream (Of a) m r %1-> e -> Stream (Of (a,e)) m r-enumFromZip str e =- Control.fmap (\(r,()) -> r) $ zip str $ enumFrom e-{-# INLINE enumFromZip #-}-
− src/Streaming/Internal/Type.hs
@@ -1,164 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE RecordWildCards #-}--module Streaming.Internal.Type- ( -- * The 'Stream' and 'Of' types- -- $stream- Stream (..)- , Of (..)- ) where--import qualified Data.Functor.Linear as Data-import qualified Control.Functor.Linear as Control-import qualified Prelude.Linear as Linear-import Prelude.Linear (($), (.))----- # Data Definitions-----------------------------------------------------------------------------------{- $stream-- The 'Stream' data type is equivalent to @FreeT@ and can represent any effectful- succession of steps, where the form of the steps or 'commands' is- specified by the first (functor) parameter. The effects are performed- exactly once since the monad is a @Control.Monad@ from- <https://github.com/tweag/linear-base linear-base>.--> data Stream f m r = Step !(f (Stream f m r)) | Effect (m (Stream f m r)) | Return r-- The /producer/ concept uses the simple functor @ (a,_) @ \- or the stricter- @ Of a _ @. Then the news at each step or layer is just: an individual item of type @a@.- Since @Stream (Of a) m r@ is equivalent to @Pipe.Producer a m r@, much of- the @pipes@ @Prelude@ can easily be mirrored in a @streaming@ @Prelude@. Similarly,- a simple @Consumer a m r@ or @Parser a m r@ concept arises when the base functor is- @ (a -> _) @ . @Stream ((->) input) m result@ consumes @input@ until it returns a- @result@.-- To avoid breaking reasoning principles, the constructors- should not be used directly. A pattern-match should go by way of 'inspect' \- \- or, in the producer case, 'Streaming.Prelude.next'--}-data Stream f m r where- Step :: !(f (Stream f m r)) %1-> Stream f m r- Effect :: m (Stream f m r) %1-> Stream f m r- Return :: r %1-> Stream f m r---- | A left-strict pair; the base functor for streams of individual elements.-data Of a b where- (:>) :: !a -> b %1-> Of a b--infixr 5 :>----- # Control.Monad instance for (Stream f m)------------------------------------------------------------------------------------ Note: we have maintained the weakest prerequisite constraints possible.---- Note: to consume the 'Stream f m a' in the 'Cons' case, you--- need 'fmap' to consume the stream. This implies at minimum--- Data.Functor m and Data.Functor m.-instance (Data.Functor m, Data.Functor f) => Data.Functor (Stream f m) where- fmap :: (Data.Functor m, Data.Functor f) =>- (a %1-> b) -> Stream f m a %1-> Stream f m b- fmap f s = fmap' f s- {-# INLINABLE fmap #-}--fmap' :: (Data.Functor m, Data.Functor f) =>- (a %1-> b) -> Stream f m a %1-> Stream f m b-fmap' f (Return r) = Return (f r)-fmap' f (Step fs) = Step $ Data.fmap (Data.fmap f) fs-fmap' f (Effect ms) = Effect $ Data.fmap (Data.fmap f) ms---- Note: the 'Control.Functor f' instance is needed.--- Weaker constraints won't do.-instance (Control.Functor m, Control.Functor f) =>- Data.Applicative (Stream f m) where- pure :: a -> Stream f m a- pure = Return- {-# INLINE pure #-}-- (<*>) :: (Control.Functor m, Control.Functor f) =>- Stream f m (a %1-> b) %1-> Stream f m a %1-> Stream f m b- (<*>) s1 s2 = app s1 s2- {-# INLINABLE (<*>) #-}--app :: (Control.Functor m, Control.Functor f) =>- Stream f m (a %1-> b) %1-> Stream f m a %1-> Stream f m b-app (Return f) stream = Control.fmap f stream-app (Step fs) stream = Step $ Control.fmap (Data.<*> stream) fs-app (Effect ms) stream = Effect $ Control.fmap (Data.<*> stream) ms----instance (Control.Functor m, Control.Functor f) =>- Control.Functor (Stream f m) where- fmap :: (Data.Functor m, Data.Functor f) =>- (a %1-> b) %1-> Stream f m a %1-> Stream f m b- fmap f s = fmap'' f s- {-# INLINABLE fmap #-}--fmap'' :: (Control.Functor m, Control.Functor f) =>- (a %1-> b) %1-> Stream f m a %1-> Stream f m b-fmap'' f (Return r) = Return (f r)-fmap'' f (Step fs) = Step $ Control.fmap (Control.fmap f) fs-fmap'' f (Effect ms) = Effect $ Control.fmap (Control.fmap f) ms---instance (Control.Functor m, Control.Functor f) =>- Control.Applicative (Stream f m) where- pure :: a %1-> Stream f m a- pure = Return- {-# INLINE pure #-}-- (<*>) :: (Control.Functor m, Control.Functor f) =>- Stream f m (a %1-> b) %1-> Stream f m a %1-> Stream f m b- (<*>) = (Data.<*>)- {-# INLINE (<*>) #-}--instance (Control.Functor m, Control.Functor f) =>- Control.Monad (Stream f m) where- (>>=) :: Stream f m a %1-> (a %1-> Stream f m b) %1-> Stream f m b- (>>=) = bind- {-# INLINABLE (>>=) #-}--bind :: (Control.Functor m, Control.Functor f) =>- Stream f m a %1-> (a %1-> Stream f m b) %1-> Stream f m b-bind (Return a) f = f a-bind (Step fs) f = Step $ Control.fmap (Control.>>= f) fs-bind (Effect ms) f = Effect $ Control.fmap (Control.>>= f) ms----- # MonadTrans for (Stream f m)----------------------------------------------------------------------------------instance Control.Functor f => Control.MonadTrans (Stream f) where- lift :: (Control.Functor m, Control.Functor f) => m a %1-> Stream f m a- lift = Effect . Control.fmap Control.return- {-# INLINE lift #-}----- # Control.Functor for (Of)----------------------------------------------------------------------------------ofFmap :: (a %1-> b) %1-> (Of x a) %1-> (Of x b)-ofFmap f (a :> b) = a :> f b-{-# INLINE ofFmap #-}--instance Data.Functor (Of a) where- fmap = Linear.forget ofFmap- {-# INLINE fmap #-}--instance Control.Functor (Of a) where- fmap = ofFmap- {-# INLINE fmap #-}-
src/Streaming/Linear.hs view
@@ -1,818 +1,922 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}---module Streaming.Linear- (- -- $stream- module Streaming.Internal.Type- -- * Constructing a 'Stream' on a given functor- , yields- , effect- , wrap- , replicates- , replicatesM- , unfold- , untilJust- , streamBuild- , delays- -- * Transforming streams- , maps- , mapsPost- , mapsM- , mapsMPost- , mapped- , mappedPost- , hoistUnexposed- , groups- -- * Inspecting a stream- , inspect- -- * Splitting and joining 'Stream's- , splitsAt- , chunksOf- , concats- , intercalates- -- * Zipping, unzipping, separating and unseparating streams- , unzips- , separate- , unseparate- , decompose- , expand- , expandPost- -- * Eliminating a 'Stream'- , mapsM_- , run- , streamFold- , iterTM- , iterT- , destroy- ) where--import Streaming.Internal.Type-import Streaming.Internal.Process (destroyExposed)-import Data.Functor.Sum-import Data.Functor.Compose-import qualified Streaming.Prelude.Linear as Stream-import System.IO.Linear-import Prelude.Linear (($), (.), (&))-import Prelude (Ordering(..), Ord(..), Num(..), Int, Either(..), Double,- Maybe(..), fromInteger)-import qualified Prelude-import qualified Control.Functor.Linear as Control-import qualified Data.Functor.Linear as Data-import Data.Unrestricted.Linear-import Control.Concurrent (threadDelay)-import GHC.Stack--{- $stream- The 'Stream' data type is an effectful series of steps with some- payload value at the bottom. The steps are represented with functors.- The effects are represented with some /control/ monad. (Control monads- must be bound to exactly once; see the documentation in- <https://github.com/tweag/linear-base/tree/master/src/Control/Monad/Linear.hs linear-base> to learn more- about control monads, control applicatives and control functors.)-- In words, a @Stream f m r@ is either a payload of type @r@, or- a step of type @f (Stream f m r)@ or an effect of type @m (Stream f m r)@- where @f@ is a @Control.Functor@ and @m@ is a @Control.Monad@.-- This module exports combinators that pertain to this general case.- Some of these are quite abstract and pervade any use of the library,- e.g.--> maps :: (forall x . f x %1-> g x) -> Stream f m r %1-> Stream g m r-> mapped :: (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r-> concats :: Stream (Stream f m) m r %1-> Stream f m r-- (assuming here and thoughout that @m@ or @n@ satisfies- a @Control.Monad@ constraint, and @f@ or @g@ a @Control.Functor@- constraint).-- Others are surprisingly determinate in content:--> chunksOf :: Int -> Stream f m r %1-> Stream (Stream f m) m r-> splitsAt :: Int -> Stream f m r %1-> Stream f m (Stream f m r)-> intercalates :: Stream f m () -> Stream (Stream f m) m r %1-> Stream f m r-> unzips :: Stream (Compose f g) m r %1-> Stream f (Stream g m) r-> separate :: Stream (Sum f g) m r -> Stream f (Stream g m) r -- cp. partitionEithers-> unseparate :: Stream f (Stream g) m r -> Stream (Sum f g) m r-> groups :: Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r-- One way to see that /any/ streaming library needs some such general type is- that it is required to represent the segmentation of a stream, and to- express the equivalents of @Prelude/Data.List@ combinators that involve- 'lists of lists' and the like. See for example this- <http://www.haskellforall.com/2013/09/perfect-streaming-using-pipes-bytestring.html post>- on the correct expression of a streaming \'lines\' function.- The module @Streaming.Prelude@ exports combinators relating to-> Stream (Of a) m r- where @Of a r = !a :> r@ is a left-strict pair.- This expresses the concept of a 'Producer' or 'Source' or 'Generator' and- easily inter-operates with types with such names in e.g. 'conduit',- 'iostreams' and 'pipes'.--}---- # Constructing a 'Stream' on a given functor------------------------------------------------------------------------------------ Remark. By default we require `Control.Monad` and `Control.Functor`--- instances for the `m` and `f` in a `Stream f m r` since these allow the--- stream to have a `Control.Monad` instance--{-| @yields@ is like @lift@ for items in the streamed functor.- It makes a singleton or one-layer succession.--> lift :: (Control.Monad m, Control.Functor f) => m r %1-> Stream f m r-> yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r-- Viewed in another light, it is like a functor-general version of @yield@:--> S.yield a = yields (a :> ())---}-yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r-yields fr = Step $ Control.fmap Return fr-{-# INLINE yields #-}---- Note: This must consume its input linearly since it must bind to a--- `Control.Monad`.-{- | Wrap an effect that returns a stream--> effect = join . lift---}-effect :: (Control.Monad m, Control.Functor f) =>- m (Stream f m r) %1-> Stream f m r-effect = Effect-{-# INLINE effect #-}--{-| Wrap a new layer of a stream. So, e.g.--> S.cons :: Control.Monad m => a -> Stream (Of a) m r %1-> Stream (Of a) m r-> S.cons a str = wrap (a :> str)-- and, recursively:--> S.each' :: Control.Monad m => [a] -> Stream (Of a) m ()-> S.each' = foldr (\a b -> wrap (a :> b)) (return ())-- The two operations--> wrap :: (Control.Monad m, Control.Functor f) =>-> f (Stream f m r) %1-> Stream f m r-> effect :: (Control.Monad m, Control.Functor f) =>-> m (Stream f m r) %1-> Stream f m r-- are fundamental. We can define the parallel operations @yields@ and @lift@- in terms of them--> yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r-> yields = wrap . Control.fmap Control.return-> lift :: (Control.Monad m, Control.Functor f) => m r %1-> Stream f m r-> lift = effect . Control.fmap Control.return---}-wrap :: (Control.Monad m, Control.Functor f) =>- f (Stream f m r) %1-> Stream f m r-wrap = Step-{-# INLINE wrap #-}--{- | Repeat a functorial layer, command or instruction a fixed number of times.---}-replicates :: (HasCallStack, Control.Monad m, Control.Functor f) =>- Int -> f () -> Stream f m ()-replicates n f = replicates' n f- where- replicates' :: (HasCallStack, Control.Monad m, Control.Functor f) =>- Int -> f () -> Stream f m ()- replicates' n f = case compare n 0 of- LT -> Prelude.error "replicates called with negative integer"- EQ -> Return ()- GT -> Step $ Control.fmap (\() -> replicates (n-1) f) f-{-# INLINE replicates #-}---- | @replicatesM n@ repeats an effect containing a functorial layer, command--- or instruction @n@ times.-replicatesM :: forall f m . (Control.Monad m, Control.Functor f) =>- Int -> m (f ()) -> Stream f m ()-replicatesM = loop- where- loop :: Int -> m (f ()) -> Stream f m ()- loop n mfstep- | n <= 0 = Return ()- | Prelude.otherwise = Effect $- Control.fmap (Step . Control.fmap (\() -> loop (n-1) mfstep)) mfstep-{-# INLINABLE replicatesM #-}--unfold :: (Control.Monad m, Control.Functor f) =>- (s %1-> m (Either r (f s))) -> s %1-> Stream f m r-unfold step state = unfold' step state- where- unfold' :: (Control.Monad m, Control.Functor f) =>- (s %1-> m (Either r (f s))) -> s %1-> Stream f m r- unfold' step state = Effect $ Control.do- either <- step state- either & \case- Left r -> Control.return $ Return r- Right (fs) -> Control.return $ Step $ Control.fmap (unfold step) fs-{-# INLINABLE unfold #-}---- Note. To keep restrictions minimal, we use the `Data.Applicative`--- instance.-untilJust :: forall f m r . (Control.Monad m, Data.Applicative f) =>- m (Maybe r) -> Stream f m r-untilJust action = loop- where- loop :: Stream f m r- loop = Effect $ Control.do- maybeVal <- action- maybeVal & \case- Nothing -> Control.return $ Step $ Data.pure loop- Just r -> Control.return $ Return r-{-# INLINABLE untilJust #-}---- Remark. The linear church encoding of streams has linear--- return, effect and step functions.-{- | Reflect a church-encoded stream; cp. @GHC.Exts.build@--> streamFold return_ effect_ step_ (streamBuild psi) = psi return_ effect_ step_--}-streamBuild ::- (forall b. (r %1-> b) -> (m b %1-> b) -> (f b %1-> b) -> b) -> Stream f m r-streamBuild = \phi -> phi Return Effect Step-{-# INLINE streamBuild #-}---- Note. To keep requirements minimal, we use the `Data.Applicative`--- instance instead of the `Control.Applicative` instance.-delays :: forall f r . (Data.Applicative f) => Double -> Stream f IO r-delays seconds = loop- where- loop :: Stream f IO r- loop = Effect $ Control.do- let delay = fromInteger (Prelude.truncate (1000000 * seconds))- () <- fromSystemIO $ threadDelay delay- Control.return $ Step $ Data.pure loop-{-# INLINABLE delays #-}----- # Transforming streams----------------------------------------------------------------------------------{- | Map layers of one functor to another with a transformation.--> maps id = id-> maps f . maps g = maps (f . g)---}-maps :: forall f g m r . (Control.Monad m, Control.Functor f) =>- (forall x . f x %1-> g x) -> Stream f m r %1-> Stream g m r-maps = Stream.maps-{-# INLINE maps #-}--{- | Map layers of one functor to another with a transformation.--> mapsPost id = id-> mapsPost f . mapsPost g = mapsPost (f . g)-> mapsPost f = maps f-- @mapsPost@ is essentially the same as 'maps', but it imposes a @Control.Functor@ constraint on- its target functor rather than its source functor. It should be preferred if @Control.fmap@- is cheaper for the target functor than for the source functor.--}-mapsPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>- (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r-mapsPost = Stream.mapsPost-{-# INLINE mapsPost #-}---- Note. The transformation function must be linear so that the stream--- held inside a control functor is used linearly.-{- | Map layers of one functor to another with a transformation involving the base monad.- 'maps' is more fundamental than @mapsM@, which is best understood as a convenience- for effecting this frequent composition:--> mapsM phi = decompose . maps (Compose . phi)-- The streaming prelude exports the same function under the better name @mapped@,- which overlaps with the lens libraries.---}-mapsM :: forall f g m r . (Control.Monad m, Control.Functor f) =>- (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r-mapsM transform = loop where- loop :: Stream f m r %1-> Stream g m r- loop stream = stream & \case- Return r -> Return r- Step f -> Effect $ Control.fmap Step $ transform $ Control.fmap loop f- Effect m -> Effect $ Control.fmap loop m-{-# INLINE mapsM #-}--{- | Map layers of one functor to another with a transformation involving the base monad.- @mapsMPost@ is essentially the same as 'mapsM', but it imposes a @Control.Functor@ constraint on- its target functor rather than its source functor. It should be preferred if @Control.fmap@- is cheaper for the target functor than for the source functor.-- @mapsPost@ is more fundamental than @mapsMPost@, which is best understood as a convenience- for effecting this frequent composition:--> mapsMPost phi = decompose . mapsPost (Compose . phi)-- The streaming prelude exports the same function under the better name @mappedPost@,- which overlaps with the lens libraries.---}-mapsMPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>- (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r-mapsMPost = Stream.mapsMPost-{-# INLINE mapsMPost #-}--{- | Map layers of one functor to another with a transformation involving the base monad.- This could be trivial, e.g.--> let noteBeginning text x = (fromSystemIO (System.putStrLn text)) Control.>> (Control.return x)-- this is completely functor-general-- @maps@ and @mapped@ obey these rules:--> maps id = id-> mapped return = id-> maps f . maps g = maps (f . g)-> mapped f . mapped g = mapped (f <=< g)-> maps f . mapped g = mapped (fmap f . g)-> mapped f . maps g = mapped (f <=< fmap g)-- @maps@ is more fundamental than @mapped@, which is best understood as a convenience- for effecting this frequent composition:--> mapped phi = decompose . maps (Compose . phi)----}-mapped :: forall f g m r . (Control.Monad m, Control.Functor f) =>- (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r-mapped = mapsM-{-# INLINE mapped #-}--{-| A version of 'mapped' that imposes a @Control.Functor@ constraint on the target functor rather- than the source functor. This version should be preferred if @Control.fmap@ on the target- functor is cheaper.---}-mappedPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>- (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r-mappedPost = mapsMPost-{-# INLINE mappedPost #-}---- | A less-efficient version of 'hoist' that works properly even when its--- argument is not a monad morphism.-hoistUnexposed :: forall f m n r. (Control.Monad m, Control.Functor f)- => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r-hoistUnexposed trans = loop where- loop :: Stream f m r %1-> Stream f n r- loop = Effect- . trans- . inspectC- (Control.return . Return)- (Control.return . Step . Control.fmap loop)-{-# INLINABLE hoistUnexposed #-}---- A version of 'inspect' that takes explicit continuations.--- Note that due to the linear constructors of 'Stream', these continuations--- are linear.-inspectC :: forall f m r a. Control.Monad m =>- (r %1-> m a) -> (f (Stream f m r) %1-> m a) -> Stream f m r %1-> m a-inspectC f g = loop where- loop :: Stream f m r %1-> m a- loop (Return r) = f r- loop (Step x) = g x- loop (Effect m) = m Control.>>= loop-{-# INLINE inspectC #-}--{-| Group layers in an alternating stream into adjoining sub-streams- of one type or another.--}-groups :: forall f g m r .- (Control.Monad m, Control.Functor f, Control.Functor g) =>- Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r-groups = loop- where- loop :: Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r- loop str = Control.do- e <- Control.lift $ inspect str- e & \case- Left r -> Control.return r- Right ostr -> ostr & \case- InR gstr -> Step $ InR $ Control.fmap loop $ cleanR (Step (InR gstr))- InL fstr -> Step $ InL $ Control.fmap loop $ cleanL (Step (InL fstr))-- cleanL :: Stream (Sum f g) m r %1-> Stream f m (Stream (Sum f g) m r)- cleanL = go- where- go :: Stream (Sum f g) m r %1-> Stream f m (Stream (Sum f g) m r)- go s = Control.do- e <- Control.lift $ inspect s- e & \case- Left r -> Control.return $ Control.return r- Right (InL fstr) -> Step $ Control.fmap go fstr- Right (InR gstr) -> Control.return $ Step (InR gstr)-- cleanR :: Stream (Sum f g) m r %1-> Stream g m (Stream (Sum f g) m r)- cleanR = go- where- go :: Stream (Sum f g) m r %1-> Stream g m (Stream (Sum f g) m r)- go s = Control.do- e <- Control.lift $ inspect s- e & \case- Left r -> Control.return $ Control.return r- Right (InL fstr) -> Control.return $ Step (InL fstr)- Right (InR gstr) -> Step$ Control.fmap go gstr-{-# INLINABLE groups #-}----- # Inspecting a Stream----------------------------------------------------------------------------------{-| Inspect the first stage of a freely layered sequence.- Compare @Pipes.next@ and the replica @Streaming.Prelude.next@.- This is the 'uncons' for the general 'unfold'.--> unfold inspect = id-> Streaming.Prelude.unfoldr StreamingPrelude.next = id--}-inspect :: forall f m r . Control.Monad m =>- Stream f m r %1-> m (Either r (f (Stream f m r)))-inspect = loop- where- loop :: Stream f m r %1-> m (Either r (f (Stream f m r)))- loop stream = stream & \case- Return r -> Control.return (Left r)- Effect m -> m Control.>>= loop- Step fs -> Control.return (Right fs)-{-# INLINABLE inspect #-}----- # Splitting and joining 'Stream's----------------------------------------------------------------------------------{-| Split a succession of layers after some number, returning a streaming or- effectful pair.--\>\>\> rest <- S.print $ S.splitAt 1 $ each' [1..3]-1-\>\>\> S.print rest-2-3--> splitAt 0 = return-> (\stream -> splitAt n stream >>= splitAt m) = splitAt (m+n)-- Thus, e.g.--\>\>\> rest <- S.print $ (\s -> splitsAt 2 s >>= splitsAt 2) each' [1..5]-1-2-3-4-\>\>\> S.print rest-5---}-splitsAt :: forall f m r .- (HasCallStack, Control.Monad m, Control.Functor f) =>- Int -> Stream f m r %1-> Stream f m (Stream f m r)-splitsAt n stream = loop n stream- where- loop :: Int -> Stream f m r %1-> Stream f m (Stream f m r)- loop n stream = case compare n 0 of- LT -> Prelude.error "splitsAt called with negative index" $ stream- EQ -> Return stream- GT -> stream & \case- Return r -> Return $ Return r- Effect m -> Effect $ Control.fmap (loop n) m- Step f -> Step $ Control.fmap (loop (n-1)) f-{-# INLINABLE splitsAt #-}---{-| Break a stream into substreams each with n functorial layers.--\>\>\> S.print $ mapped S.sum $ chunksOf 2 $ each' [1,1,1,1,1]-2-2-1--}-chunksOf :: forall f m r .- (HasCallStack, Control.Monad m, Control.Functor f) =>- Int -> Stream f m r %1-> Stream (Stream f m) m r-chunksOf n stream = loop n stream- where- loop :: Int -> Stream f m r %1-> Stream (Stream f m) m r- loop _ (Return r) = Return r- loop n stream = Step $ Control.fmap (loop n) $ splitsAt n stream-{-# INLINABLE chunksOf #-}--{-| Dissolves the segmentation into layers of @Stream f m@ layers.---}-concats :: forall f m r . (Control.Monad m, Control.Functor f) =>- Stream (Stream f m) m r %1-> Stream f m r-concats = loop- where- loop :: Stream (Stream f m) m r %1-> Stream f m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step f -> Control.do- rest <- Control.fmap loop f- rest-{-# INLINE concats #-}---- Note. To keep the monad of the stream a control monad, we need--- `(t m)` to be a control monad, and hence `t` to be a control--- monad transformer.-{-| Interpolate a layer at each segment. This specializes to e.g.--> intercalates :: Stream f m () -> Stream (Stream f m) m r %1-> Stream f m r--}-intercalates :: forall t m r x .- (Control.Monad m, Control.Monad (t m), Control.MonadTrans t, Consumable x) =>- t m x -> Stream (t m) m r %1-> t m r-intercalates sep = go0- where- go0 :: Stream (t m) m r %1-> t m r- go0 f = f & \case- Return r -> Control.return r- Effect m -> Control.lift m Control.>>= go0- Step fstr -> Control.do- f' <- fstr- go1 f'-- go1 :: Stream (t m) m r %1-> t m r- go1 f = f & \case- Return r -> Control.return r- Effect m -> Control.lift m Control.>>= go1- Step fstr -> Control.do- x <- sep- Control.return $ consume x- f' <- fstr- go1 f'-{-# INLINABLE intercalates #-}----- # Zipping, unzipping, separating and unseparating streams----------------------------------------------------------------------------------unzips :: forall f g m r .- (Control.Monad m, Control.Functor f, Control.Functor g) =>- Stream (Compose f g) m r %1-> Stream f (Stream g m) r-unzips str = destroyExposed- str- (\(Compose fgstr) -> Step (Control.fmap (Effect . yields) fgstr))- (Effect . Control.lift)- Return-{-# INLINABLE unzips #-}--{-| Given a stream on a sum of functors, make it a stream on the left functor,- with the streaming on the other functor as the governing monad. This is- useful for acting on one or the other functor with a fold, leaving the- other material for another treatment. It generalizes- 'Data.Either.partitionEithers', but actually streams properly.--\>\>\> let odd_even = S.maps (S.distinguish even) $ S.each' [1..10::Int]-\>\>\> :t separate odd_even-separate odd_even- :: Monad m => Stream (Of Int) (Stream (Of Int) m) ()-- Now, for example, it is convenient to fold on the left and right values separately:--\>\>\> S.toList $ S.toList $ separate odd_even-[2,4,6,8,10] :> ([1,3,5,7,9] :> ())--- Or we can write them to separate files or whatever:--\>\>\> S.writeFile "even.txt" . S.show $ S.writeFile "odd.txt" . S.show $ S.separate odd_even-\>\>\> :! cat even.txt-2-4-6-8-10-\>\>\> :! cat odd.txt-1-3-5-7-9-- Of course, in the special case of @Stream (Of a) m r@, we can achieve the above- effects more simply by using 'Streaming.Prelude.copy'--\>\>\> S.toList . S.filter even $ S.toList . S.filter odd $ S.copy $ each [1..10::Int]-[2,4,6,8,10] :> ([1,3,5,7,9] :> ())--- But 'separate' and 'unseparate' are functor-general.---}-separate :: forall f g m r .- (Control.Monad m, Control.Functor f, Control.Functor g) =>- Stream (Sum f g) m r -> Stream f (Stream g m) r-separate str = destroyExposed str construct (Effect . Control.lift) Return- where- construct :: Sum f g (Stream f (Stream g m) r) %1-> Stream f (Stream g m) r- construct (InL fss) = Step fss- construct (InR gss) = Effect (yields gss)-{-# INLINABLE separate #-}--unseparate :: (Control.Monad m, Control.Functor f, Control.Functor g) =>- Stream f (Stream g m) r -> Stream (Sum f g) m r-unseparate str = destroyExposed- str- (Step . InL)- (Control.join . maps InR)- Return-{-# INLINABLE unseparate #-}--{-| Rearrange a succession of layers of the form @Compose m (f x)@.-- we could as well define @decompose@ by @mapsM@:--> decompose = mapped getCompose-- but @mapped@ is best understood as:--> mapped phi = decompose . maps (Compose . phi)-- since @maps@ and @hoist@ are the really fundamental operations that preserve the- shape of the stream:--> maps :: (Control.Monad m, Control.Functor f) => (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r-> hoist :: (Control.Monad m, Control.Functor f) => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r---}-decompose :: forall f m r . (Control.Monad m, Control.Functor f) =>- Stream (Compose m f) m r %1-> Stream f m r-decompose = loop where- loop :: Stream (Compose m f) m r %1-> Stream f m r- loop stream = stream & \case- Return r -> Return r- Effect m -> Effect $ Control.fmap loop m- Step (Compose mfs) -> Effect $ Control.do- fstream <- mfs- Control.return $ Step (Control.fmap loop fstream)-{-# INLINABLE decompose #-}---- Note. For 'loop' to recurse over functoral steps, it must be a--- linear function, and hence, `ext` must be linear in its second argument.--- Further, the first argument of `ext` ought to be a linear function,--- because it is typically applied to the input stream in `ext`, and hence--- should be linear.--- | If 'Of' had a @Comonad@ instance, then we'd have------ @copy = expand extend@------ See 'expandPost' for a version that requires a @Control.Functor g@--- instance instead.-expand :: forall f m r g h . (Control.Monad m, Control.Functor f) =>- (forall a b. (g a %1-> b) -> f a %1-> h b) ->- Stream f m r %1-> Stream g (Stream h m) r-expand ext = loop where- loop :: Stream f m r %1-> Stream g (Stream h m) r- loop (Return r) = Return r- loop (Step f) = Effect $ Step $ ext (Return . Step) (Control.fmap loop f)- loop (Effect m) = Effect $ Effect $ Control.fmap (Return . loop) m-{-# INLINABLE expand #-}---- See note on 'expand'.--- | If 'Of' had a @Comonad@ instance, then we'd have------ @copy = expandPost extend@------ See 'expand' for a version that requires a @Control.Functor f@ instance--- instead.-expandPost :: forall f m r g h . (Control.Monad m, Control.Functor g) =>- (forall a b. (g a %1-> b) -> f a %1-> h b) ->- Stream f m r %1-> Stream g (Stream h m) r-expandPost ext = loop where- loop :: Stream f m r %1-> Stream g (Stream h m) r- loop (Return r) = Return r- loop (Step f) = Effect $ Step $ ext (Return . Step . Control.fmap loop) f- loop (Effect m) = Effect $ Effect $ Control.fmap (Return . loop) m-{-# INLINABLE expandPost #-}----- # Eliminating a 'Stream'------------------------------------------------------------------------------------ Note. Since the functor step is held linearly in the--- 'Stream' datatype, the first argument must be a linear function--- in order to linearly consume the 'Step' case of a stream.-{-| Map each layer to an effect, and run them all.--}-mapsM_ :: (Control.Functor f, Control.Monad m) =>- (forall x . f x %1-> m x) -> Stream f m r %1-> m r-mapsM_ f = run . maps f-{-# INLINE mapsM_ #-}--{-| Run the effects in a stream that merely layers effects.--}-run :: Control.Monad m => Stream m m r %1-> m r-run = loop- where- loop :: Control.Monad m => Stream m m r %1-> m r- loop stream = stream & \case- Return r -> Control.return r- Effect m -> m Control.>>= loop- Step mrest -> mrest Control.>>= loop-{-# INLINABLE run #-}--{-| 'streamFold' reorders the arguments of 'destroy' to be more akin- to @foldr@ It is more convenient to query in ghci to figure out- what kind of \'algebra\' you need to write.--\>\>\> :t streamFold Control.return Control.join-(Control.Monad m, Control.Functor f) =>- (f (m a) %1-> m a) -> Stream f m a %1-> m a -- iterT--\>\>\> :t streamFold Control.return (Control.join . Control.lift)-(Control.Monad m, Control.Monad (t m), Control.Functor f, Control.MonadTrans t) =>- (f (t m a) %1-> t m a) -> Stream f m a %1-> t m a -- iterTM--\>\>\> :t streamFold Control.return effect-(Control.Monad m, Control.Functor f, Control.Functor g) =>- (f (Stream g m r) %1-> Stream g m r) -> Stream f m r %1-> Stream g m r--\>\>\> :t \f -> streamFold Control.return effect (wrap . f)-(Control.Monad m, Control.Functor f, Control.Functor g) =>- (f (Stream g m a) %1-> g (Stream g m a))- -> Stream f m a %1-> Stream g m a -- maps--\>\>\> :t \f -> streamFold Control.return effect (effect . Control.fmap wrap . f)-(Control.Monad m, Control.Functor f, Control.Functor g) =>- (f (Stream g m a) %1-> m (g (Stream g m a)))- -> Stream f m a %1-> Stream g m a -- mapped--@- streamFold done eff construct- = eff . iterT (Control.return . construct . Control.fmap eff) . Control.fmap done-@--}-streamFold :: (Control.Functor f, Control.Monad m) =>- (r %1-> b) -> (m b %1-> b) -> (f b %1-> b) -> Stream f m r %1-> b-streamFold done theEffect construct stream =- destroy stream construct theEffect done-{-# INLINE streamFold #-}--{-| Specialized fold following the usage of @Control.Monad.Trans.Free@--> iterT alg = streamFold Control.return Control.join alg-> iterT alg = runIdentityT . iterTM (IdentityT . alg . Control.fmap runIdentityT)--}-iterT :: (Control.Functor f, Control.Monad m) =>- (f (m a) %1-> m a) -> Stream f m a %1-> m a-iterT out stream = destroyExposed stream out Control.join Control.return-{-# INLINE iterT #-}--{-| Specialized fold following the usage of @Control.Monad.Trans.Free@--> iterTM alg = streamFold Control.return (Control.join . Control.lift)-> iterTM alg = iterT alg . hoist Control.lift--}-iterTM ::- ( Control.Functor f, Control.Monad m- , Control.MonadTrans t, Control.Monad (t m)) =>- (f (t m a) %1-> t m a) -> Stream f m a %1-> t m a-iterTM out stream =- destroyExposed stream out (Control.join . Control.lift) Control.return-{-# INLINE iterTM #-}---- Note. 'destroy' needs to use linear functions in its church encoding--- to consume the stream linearly.-{-| Map a stream to its church encoding; compare @Data.List.foldr@.- 'destroyExposed' may be more efficient in some cases when- applicable, but it is less safe.-- @- destroy s construct eff done- = eff .- iterT (Control.return . construct . Control.fmap eff) .- Control.fmap done $ s- @--}-destroy :: forall f m r b . (Control.Functor f, Control.Monad m) =>- Stream f m r %1-> (f b %1-> b) -> (m b %1-> b) -> (r %1-> b) -> b-destroy stream0 construct theEffect done = theEffect (loop stream0)- where- loop :: Stream f m r %1-> m b- loop stream = stream & \case- Return r -> Control.return $ done r- Effect m -> m Control.>>= loop- Step f -> Control.return $ construct $ Control.fmap (theEffect . loop) f-{-# INLINABLE destroy #-}-+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Streaming.Linear+ ( -- $stream+ module Streaming.Linear.Internal.Type,++ -- * Constructing a 'Stream' on a given functor+ yields,+ effect,+ wrap,+ replicates,+ replicatesM,+ unfold,+ untilJust,+ streamBuild,+ delays,++ -- * Transforming streams+ maps,+ mapsPost,+ mapsM,+ mapsMPost,+ mapped,+ mappedPost,+ hoistUnexposed,+ groups,++ -- * Inspecting a stream+ inspect,++ -- * Splitting and joining 'Stream's+ splitsAt,+ chunksOf,+ concats,+ intercalates,++ -- * Zipping, unzipping, separating and unseparating streams+ unzips,+ separate,+ unseparate,+ decompose,+ expand,+ expandPost,++ -- * Eliminating a 'Stream'+ mapsM_,+ run,+ streamFold,+ iterTM,+ iterT,+ destroy,+ )+where++import Control.Concurrent (threadDelay)+import qualified Control.Functor.Linear as Control+import Data.Functor.Compose+import qualified Data.Functor.Linear as Data+import Data.Functor.Sum+import Data.Unrestricted.Linear+import GHC.Stack+import Prelude.Linear (($), (&), (.))+import Streaming.Linear.Internal.Process (destroyExposed)+import Streaming.Linear.Internal.Type+import qualified Streaming.Prelude.Linear as Stream+import System.IO.Linear+import Prelude+ ( Double,+ Either (..),+ Int,+ Maybe (..),+ Num (..),+ Ord (..),+ Ordering (..),+ fromInteger,+ )+import qualified Prelude++-- $stream+-- The 'Stream' data type is an effectful series of steps with some+-- payload value at the bottom. The steps are represented with functors.+-- The effects are represented with some /control/ monad. (Control monads+-- must be bound to exactly once; see the documentation in+-- <https://github.com/tweag/linear-base/tree/master/src/Control/Monad/Linear.hs linear-base> to learn more+-- about control monads, control applicatives and control functors.)+--+-- In words, a @Stream f m r@ is either a payload of type @r@, or+-- a step of type @f (Stream f m r)@ or an effect of type @m (Stream f m r)@+-- where @f@ is a @Control.Functor@ and @m@ is a @Control.Monad@.+--+-- This module exports combinators that pertain to this general case.+-- Some of these are quite abstract and pervade any use of the library,+-- e.g.+--+-- > maps :: (forall x . f x %1-> g x) -> Stream f m r %1-> Stream g m r+-- > mapped :: (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r+-- > concats :: Stream (Stream f m) m r %1-> Stream f m r+--+-- (assuming here and thoughout that @m@ or @n@ satisfies+-- a @Control.Monad@ constraint, and @f@ or @g@ a @Control.Functor@+-- constraint).+--+-- Others are surprisingly determinate in content:+--+-- > chunksOf :: Int -> Stream f m r %1-> Stream (Stream f m) m r+-- > splitsAt :: Int -> Stream f m r %1-> Stream f m (Stream f m r)+-- > intercalates :: Stream f m () -> Stream (Stream f m) m r %1-> Stream f m r+-- > unzips :: Stream (Compose f g) m r %1-> Stream f (Stream g m) r+-- > separate :: Stream (Sum f g) m r -> Stream f (Stream g m) r -- cp. partitionEithers+-- > unseparate :: Stream f (Stream g) m r -> Stream (Sum f g) m r+-- > groups :: Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r+--+-- One way to see that /any/ streaming library needs some such general type is+-- that it is required to represent the segmentation of a stream, and to+-- express the equivalents of @Prelude/Data.List@ combinators that involve+-- 'lists of lists' and the like. See for example this+-- <http://www.haskellforall.com/2013/09/perfect-streaming-using-pipes-bytestring.html post>+-- on the correct expression of a streaming \'lines\' function.+-- The module @Streaming.Prelude@ exports combinators relating to+-- > Stream (Of a) m r+-- where @Of a r = !a :> r@ is a left-strict pair.+-- This expresses the concept of a 'Producer' or 'Source' or 'Generator' and+-- easily inter-operates with types with such names in e.g. 'conduit',+-- 'iostreams' and 'pipes'.++-- # Constructing a 'Stream' on a given functor+-------------------------------------------------------------------------------++-- Remark. By default we require `Control.Monad` and `Control.Functor`+-- instances for the `m` and `f` in a `Stream f m r` since these allow the+-- stream to have a `Control.Monad` instance++-- | @yields@ is like @lift@ for items in the streamed functor.+-- It makes a singleton or one-layer succession.+--+-- > lift :: (Control.Monad m, Control.Functor f) => m r %1-> Stream f m r+-- > yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r+--+-- Viewed in another light, it is like a functor-general version of @yield@:+--+-- > S.yield a = yields (a :> ())+yields :: (Control.Monad m, Control.Functor f) => f r %1 -> Stream f m r+yields fr = Step $ Control.fmap Return fr+{-# INLINE yields #-}++-- Note: This must consume its input linearly since it must bind to a+-- `Control.Monad`.++-- | Wrap an effect that returns a stream+--+-- > effect = join . lift+effect ::+ (Control.Monad m, Control.Functor f) =>+ m (Stream f m r) %1 ->+ Stream f m r+effect = Effect+{-# INLINE effect #-}++-- | Wrap a new layer of a stream. So, e.g.+--+-- > S.cons :: Control.Monad m => a -> Stream (Of a) m r %1-> Stream (Of a) m r+-- > S.cons a str = wrap (a :> str)+--+-- and, recursively:+--+-- > S.each' :: Control.Monad m => [a] -> Stream (Of a) m ()+-- > S.each' = foldr (\a b -> wrap (a :> b)) (return ())+--+-- The two operations+--+-- > wrap :: (Control.Monad m, Control.Functor f) =>+-- > f (Stream f m r) %1-> Stream f m r+-- > effect :: (Control.Monad m, Control.Functor f) =>+-- > m (Stream f m r) %1-> Stream f m r+--+-- are fundamental. We can define the parallel operations @yields@ and @lift@+-- in terms of them+--+-- > yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r+-- > yields = wrap . Control.fmap Control.return+-- > lift :: (Control.Monad m, Control.Functor f) => m r %1-> Stream f m r+-- > lift = effect . Control.fmap Control.return+wrap ::+ (Control.Monad m, Control.Functor f) =>+ f (Stream f m r) %1 ->+ Stream f m r+wrap = Step+{-# INLINE wrap #-}++-- | Repeat a functorial layer, command or instruction a fixed number of times.+replicates ::+ (HasCallStack, Control.Monad m, Control.Functor f) =>+ Int ->+ f () ->+ Stream f m ()+replicates n f = replicates' n f+ where+ replicates' ::+ (HasCallStack, Control.Monad m, Control.Functor f) =>+ Int ->+ f () ->+ Stream f m ()+ replicates' n f = case compare n 0 of+ LT -> Prelude.error "replicates called with negative integer"+ EQ -> Return ()+ GT -> Step $ Control.fmap (\() -> replicates (n - 1) f) f+{-# INLINE replicates #-}++-- | @replicatesM n@ repeats an effect containing a functorial layer, command+-- or instruction @n@ times.+replicatesM ::+ forall f m.+ (Control.Monad m, Control.Functor f) =>+ Int ->+ m (f ()) ->+ Stream f m ()+replicatesM = loop+ where+ loop :: Int -> m (f ()) -> Stream f m ()+ loop n mfstep+ | n <= 0 = Return ()+ | Prelude.otherwise =+ Effect $+ Control.fmap (Step . Control.fmap (\() -> loop (n - 1) mfstep)) mfstep+{-# INLINEABLE replicatesM #-}++unfold ::+ (Control.Monad m, Control.Functor f) =>+ (s %1 -> m (Either r (f s))) ->+ s %1 ->+ Stream f m r+unfold step state = unfold' step state+ where+ unfold' ::+ (Control.Monad m, Control.Functor f) =>+ (s %1 -> m (Either r (f s))) ->+ s %1 ->+ Stream f m r+ unfold' step state = Effect $ Control.do+ either <- step state+ either & \case+ Left r -> Control.return $ Return r+ Right (fs) -> Control.return $ Step $ Control.fmap (unfold step) fs+{-# INLINEABLE unfold #-}++-- Note. To keep restrictions minimal, we use the `Data.Applicative`+-- instance.+untilJust ::+ forall f m r.+ (Control.Monad m, Data.Applicative f) =>+ m (Maybe r) ->+ Stream f m r+untilJust action = loop+ where+ loop :: Stream f m r+ loop = Effect $ Control.do+ maybeVal <- action+ maybeVal & \case+ Nothing -> Control.return $ Step $ Data.pure loop+ Just r -> Control.return $ Return r+{-# INLINEABLE untilJust #-}++-- Remark. The linear church encoding of streams has linear+-- return, effect and step functions.++-- | Reflect a church-encoded stream; cp. @GHC.Exts.build@+--+-- > streamFold return_ effect_ step_ (streamBuild psi) = psi return_ effect_ step_+streamBuild ::+ (forall b. (r %1 -> b) -> (m b %1 -> b) -> (f b %1 -> b) -> b) -> Stream f m r+streamBuild = \phi -> phi Return Effect Step+{-# INLINE streamBuild #-}++-- Note. To keep requirements minimal, we use the `Data.Applicative`+-- instance instead of the `Control.Applicative` instance.+delays :: forall f r. (Data.Applicative f) => Double -> Stream f IO r+delays seconds = loop+ where+ loop :: Stream f IO r+ loop = Effect $ Control.do+ let delay = fromInteger (Prelude.truncate (1000000 * seconds))+ () <- fromSystemIO $ threadDelay delay+ Control.return $ Step $ Data.pure loop+{-# INLINEABLE delays #-}++-- # Transforming streams+-------------------------------------------------------------------------------++-- | Map layers of one functor to another with a transformation.+--+-- > maps id = id+-- > maps f . maps g = maps (f . g)+maps ::+ forall f g m r.+ (Control.Monad m, Control.Functor f) =>+ (forall x. f x %1 -> g x) ->+ Stream f m r %1 ->+ Stream g m r+maps = Stream.maps+{-# INLINE maps #-}++-- | Map layers of one functor to another with a transformation.+--+-- > mapsPost id = id+-- > mapsPost f . mapsPost g = mapsPost (f . g)+-- > mapsPost f = maps f+--+-- @mapsPost@ is essentially the same as 'maps', but it imposes a @Control.Functor@ constraint on+-- its target functor rather than its source functor. It should be preferred if @Control.fmap@+-- is cheaper for the target functor than for the source functor.+mapsPost ::+ forall m f g r.+ (Control.Monad m, Control.Functor g) =>+ (forall x. f x %1 -> g x) ->+ Stream f m r %1 ->+ Stream g m r+mapsPost = Stream.mapsPost+{-# INLINE mapsPost #-}++-- Note. The transformation function must be linear so that the stream+-- held inside a control functor is used linearly.++-- | Map layers of one functor to another with a transformation involving the base monad.+-- 'maps' is more fundamental than @mapsM@, which is best understood as a convenience+-- for effecting this frequent composition:+--+-- > mapsM phi = decompose . maps (Compose . phi)+--+-- The streaming prelude exports the same function under the better name @mapped@,+-- which overlaps with the lens libraries.+mapsM ::+ forall f g m r.+ (Control.Monad m, Control.Functor f) =>+ (forall x. f x %1 -> m (g x)) ->+ Stream f m r %1 ->+ Stream g m r+mapsM transform = loop+ where+ loop :: Stream f m r %1 -> Stream g m r+ loop stream =+ stream & \case+ Return r -> Return r+ Step f -> Effect $ Control.fmap Step $ transform $ Control.fmap loop f+ Effect m -> Effect $ Control.fmap loop m+{-# INLINE mapsM #-}++-- | Map layers of one functor to another with a transformation involving the base monad.+-- @mapsMPost@ is essentially the same as 'mapsM', but it imposes a @Control.Functor@ constraint on+-- its target functor rather than its source functor. It should be preferred if @Control.fmap@+-- is cheaper for the target functor than for the source functor.+--+-- @mapsPost@ is more fundamental than @mapsMPost@, which is best understood as a convenience+-- for effecting this frequent composition:+--+-- > mapsMPost phi = decompose . mapsPost (Compose . phi)+--+-- The streaming prelude exports the same function under the better name @mappedPost@,+-- which overlaps with the lens libraries.+mapsMPost ::+ forall m f g r.+ (Control.Monad m, Control.Functor g) =>+ (forall x. f x %1 -> m (g x)) ->+ Stream f m r %1 ->+ Stream g m r+mapsMPost = Stream.mapsMPost+{-# INLINE mapsMPost #-}++-- | Map layers of one functor to another with a transformation involving the base monad.+-- This could be trivial, e.g.+--+-- > let noteBeginning text x = (fromSystemIO (System.putStrLn text)) Control.>> (Control.return x)+--+-- this is completely functor-general+--+-- @maps@ and @mapped@ obey these rules:+--+-- > maps id = id+-- > mapped return = id+-- > maps f . maps g = maps (f . g)+-- > mapped f . mapped g = mapped (f <=< g)+-- > maps f . mapped g = mapped (fmap f . g)+-- > mapped f . maps g = mapped (f <=< fmap g)+--+-- @maps@ is more fundamental than @mapped@, which is best understood as a convenience+-- for effecting this frequent composition:+--+-- > mapped phi = decompose . maps (Compose . phi)+mapped ::+ forall f g m r.+ (Control.Monad m, Control.Functor f) =>+ (forall x. f x %1 -> m (g x)) ->+ Stream f m r %1 ->+ Stream g m r+mapped = mapsM+{-# INLINE mapped #-}++-- | A version of 'mapped' that imposes a @Control.Functor@ constraint on the target functor rather+-- than the source functor. This version should be preferred if @Control.fmap@ on the target+-- functor is cheaper.+mappedPost ::+ forall m f g r.+ (Control.Monad m, Control.Functor g) =>+ (forall x. f x %1 -> m (g x)) ->+ Stream f m r %1 ->+ Stream g m r+mappedPost = mapsMPost+{-# INLINE mappedPost #-}++-- | A less-efficient version of 'hoist' that works properly even when its+-- argument is not a monad morphism.+hoistUnexposed ::+ forall f m n r.+ (Control.Monad m, Control.Functor f) =>+ (forall a. m a %1 -> n a) ->+ Stream f m r %1 ->+ Stream f n r+hoistUnexposed trans = loop+ where+ loop :: Stream f m r %1 -> Stream f n r+ loop =+ Effect+ . trans+ . inspectC+ (Control.return . Return)+ (Control.return . Step . Control.fmap loop)+{-# INLINEABLE hoistUnexposed #-}++-- A version of 'inspect' that takes explicit continuations.+-- Note that due to the linear constructors of 'Stream', these continuations+-- are linear.+inspectC ::+ forall f m r a.+ Control.Monad m =>+ (r %1 -> m a) ->+ (f (Stream f m r) %1 -> m a) ->+ Stream f m r %1 ->+ m a+inspectC f g = loop+ where+ loop :: Stream f m r %1 -> m a+ loop (Return r) = f r+ loop (Step x) = g x+ loop (Effect m) = m Control.>>= loop+{-# INLINE inspectC #-}++-- | Group layers in an alternating stream into adjoining sub-streams+-- of one type or another.+groups ::+ forall f g m r.+ (Control.Monad m, Control.Functor f, Control.Functor g) =>+ Stream (Sum f g) m r %1 ->+ Stream (Sum (Stream f m) (Stream g m)) m r+groups = loop+ where+ loop :: Stream (Sum f g) m r %1 -> Stream (Sum (Stream f m) (Stream g m)) m r+ loop str = Control.do+ e <- Control.lift $ inspect str+ e & \case+ Left r -> Control.return r+ Right ostr ->+ ostr & \case+ InR gstr -> Step $ InR $ Control.fmap loop $ cleanR (Step (InR gstr))+ InL fstr -> Step $ InL $ Control.fmap loop $ cleanL (Step (InL fstr))++ cleanL :: Stream (Sum f g) m r %1 -> Stream f m (Stream (Sum f g) m r)+ cleanL = go+ where+ go :: Stream (Sum f g) m r %1 -> Stream f m (Stream (Sum f g) m r)+ go s = Control.do+ e <- Control.lift $ inspect s+ e & \case+ Left r -> Control.return $ Control.return r+ Right (InL fstr) -> Step $ Control.fmap go fstr+ Right (InR gstr) -> Control.return $ Step (InR gstr)++ cleanR :: Stream (Sum f g) m r %1 -> Stream g m (Stream (Sum f g) m r)+ cleanR = go+ where+ go :: Stream (Sum f g) m r %1 -> Stream g m (Stream (Sum f g) m r)+ go s = Control.do+ e <- Control.lift $ inspect s+ e & \case+ Left r -> Control.return $ Control.return r+ Right (InL fstr) -> Control.return $ Step (InL fstr)+ Right (InR gstr) -> Step $ Control.fmap go gstr+{-# INLINEABLE groups #-}++-- # Inspecting a Stream+-------------------------------------------------------------------------------++-- | Inspect the first stage of a freely layered sequence.+-- Compare @Pipes.next@ and the replica @Streaming.Prelude.next@.+-- This is the 'uncons' for the general 'unfold'.+--+-- > unfold inspect = id+-- > Streaming.Prelude.unfoldr StreamingPrelude.next = id+inspect ::+ forall f m r.+ Control.Monad m =>+ Stream f m r %1 ->+ m (Either r (f (Stream f m r)))+inspect = loop+ where+ loop :: Stream f m r %1 -> m (Either r (f (Stream f m r)))+ loop stream =+ stream & \case+ Return r -> Control.return (Left r)+ Effect m -> m Control.>>= loop+ Step fs -> Control.return (Right fs)+{-# INLINEABLE inspect #-}++-- # Splitting and joining 'Stream's+-------------------------------------------------------------------------------++-- | Split a succession of layers after some number, returning a streaming or+-- effectful pair.+--+-- \>\>\> rest <- S.print $ S.splitAt 1 $ each' [1..3]+-- 1+-- \>\>\> S.print rest+-- 2+-- 3+--+-- > splitAt 0 = return+-- > (\stream -> splitAt n stream >>= splitAt m) = splitAt (m+n)+--+-- Thus, e.g.+--+-- \>\>\> rest <- S.print $ (\s -> splitsAt 2 s >>= splitsAt 2) each' [1..5]+-- 1+-- 2+-- 3+-- 4+-- \>\>\> S.print rest+-- 5+splitsAt ::+ forall f m r.+ (HasCallStack, Control.Monad m, Control.Functor f) =>+ Int ->+ Stream f m r %1 ->+ Stream f m (Stream f m r)+splitsAt n stream = loop n stream+ where+ loop :: Int -> Stream f m r %1 -> Stream f m (Stream f m r)+ loop n stream = case compare n 0 of+ LT -> Prelude.error "splitsAt called with negative index" $ stream+ EQ -> Return stream+ GT ->+ stream & \case+ Return r -> Return $ Return r+ Effect m -> Effect $ Control.fmap (loop n) m+ Step f -> Step $ Control.fmap (loop (n - 1)) f+{-# INLINEABLE splitsAt #-}++-- | Break a stream into substreams each with n functorial layers.+--+-- \>\>\> S.print $ mapped S.sum $ chunksOf 2 $ each' [1,1,1,1,1]+-- 2+-- 2+-- 1+chunksOf ::+ forall f m r.+ (HasCallStack, Control.Monad m, Control.Functor f) =>+ Int ->+ Stream f m r %1 ->+ Stream (Stream f m) m r+chunksOf n stream = loop n stream+ where+ loop :: Int -> Stream f m r %1 -> Stream (Stream f m) m r+ loop _ (Return r) = Return r+ loop n stream = Step $ Control.fmap (loop n) $ splitsAt n stream+{-# INLINEABLE chunksOf #-}++-- | Dissolves the segmentation into layers of @Stream f m@ layers.+concats ::+ forall f m r.+ (Control.Monad m, Control.Functor f) =>+ Stream (Stream f m) m r %1 ->+ Stream f m r+concats = loop+ where+ loop :: Stream (Stream f m) m r %1 -> Stream f m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step f -> Control.do+ rest <- Control.fmap loop f+ rest+{-# INLINE concats #-}++-- Note. To keep the monad of the stream a control monad, we need+-- `(t m)` to be a control monad, and hence `t` to be a control+-- monad transformer.++-- | Interpolate a layer at each segment. This specializes to e.g.+--+-- > intercalates :: Stream f m () -> Stream (Stream f m) m r %1-> Stream f m r+intercalates ::+ forall t m r x.+ (Control.Monad m, Control.Monad (t m), Control.MonadTrans t, Consumable x) =>+ t m x ->+ Stream (t m) m r %1 ->+ t m r+intercalates sep = go0+ where+ go0 :: Stream (t m) m r %1 -> t m r+ go0 f =+ f & \case+ Return r -> Control.return r+ Effect m -> Control.lift m Control.>>= go0+ Step fstr -> Control.do+ f' <- fstr+ go1 f'++ go1 :: Stream (t m) m r %1 -> t m r+ go1 f =+ f & \case+ Return r -> Control.return r+ Effect m -> Control.lift m Control.>>= go1+ Step fstr -> Control.do+ x <- sep+ Control.return $ consume x+ f' <- fstr+ go1 f'+{-# INLINEABLE intercalates #-}++-- # Zipping, unzipping, separating and unseparating streams+-------------------------------------------------------------------------------++unzips ::+ forall f g m r.+ (Control.Monad m, Control.Functor f, Control.Functor g) =>+ Stream (Compose f g) m r %1 ->+ Stream f (Stream g m) r+unzips str =+ destroyExposed+ str+ (\(Compose fgstr) -> Step (Control.fmap (Effect . yields) fgstr))+ (Effect . Control.lift)+ Return+{-# INLINEABLE unzips #-}++-- | Given a stream on a sum of functors, make it a stream on the left functor,+-- with the streaming on the other functor as the governing monad. This is+-- useful for acting on one or the other functor with a fold, leaving the+-- other material for another treatment. It generalizes+-- 'Data.Either.partitionEithers', but actually streams properly.+--+-- \>\>\> let odd_even = S.maps (S.distinguish even) $ S.each' [1..10::Int]+-- \>\>\> :t separate odd_even+-- separate odd_even+-- :: Monad m => Stream (Of Int) (Stream (Of Int) m) ()+--+-- Now, for example, it is convenient to fold on the left and right values separately:+--+-- \>\>\> S.toList $ S.toList $ separate odd_even+-- [2,4,6,8,10] :> ([1,3,5,7,9] :> ())+--+--+-- Or we can write them to separate files or whatever:+--+-- \>\>\> S.writeFile "even.txt" . S.show $ S.writeFile "odd.txt" . S.show $ S.separate odd_even+-- \>\>\> :! cat even.txt+-- 2+-- 4+-- 6+-- 8+-- 10+-- \>\>\> :! cat odd.txt+-- 1+-- 3+-- 5+-- 7+-- 9+--+-- Of course, in the special case of @Stream (Of a) m r@, we can achieve the above+-- effects more simply by using 'Streaming.Prelude.copy'+--+-- \>\>\> S.toList . S.filter even $ S.toList . S.filter odd $ S.copy $ each [1..10::Int]+-- [2,4,6,8,10] :> ([1,3,5,7,9] :> ())+--+--+-- But 'separate' and 'unseparate' are functor-general.+separate ::+ forall f g m r.+ (Control.Monad m, Control.Functor f, Control.Functor g) =>+ Stream (Sum f g) m r ->+ Stream f (Stream g m) r+separate str = destroyExposed str construct (Effect . Control.lift) Return+ where+ construct :: Sum f g (Stream f (Stream g m) r) %1 -> Stream f (Stream g m) r+ construct (InL fss) = Step fss+ construct (InR gss) = Effect (yields gss)+{-# INLINEABLE separate #-}++unseparate ::+ (Control.Monad m, Control.Functor f, Control.Functor g) =>+ Stream f (Stream g m) r ->+ Stream (Sum f g) m r+unseparate str =+ destroyExposed+ str+ (Step . InL)+ (Control.join . maps InR)+ Return+{-# INLINEABLE unseparate #-}++-- | Rearrange a succession of layers of the form @Compose m (f x)@.+--+-- we could as well define @decompose@ by @mapsM@:+--+-- > decompose = mapped getCompose+--+-- but @mapped@ is best understood as:+--+-- > mapped phi = decompose . maps (Compose . phi)+--+-- since @maps@ and @hoist@ are the really fundamental operations that preserve the+-- shape of the stream:+--+-- > maps :: (Control.Monad m, Control.Functor f) => (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r+-- > hoist :: (Control.Monad m, Control.Functor f) => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r+decompose ::+ forall f m r.+ (Control.Monad m, Control.Functor f) =>+ Stream (Compose m f) m r %1 ->+ Stream f m r+decompose = loop+ where+ loop :: Stream (Compose m f) m r %1 -> Stream f m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step (Compose mfs) -> Effect $ Control.do+ fstream <- mfs+ Control.return $ Step (Control.fmap loop fstream)+{-# INLINEABLE decompose #-}++-- Note. For 'loop' to recurse over functoral steps, it must be a+-- linear function, and hence, `ext` must be linear in its second argument.+-- Further, the first argument of `ext` ought to be a linear function,+-- because it is typically applied to the input stream in `ext`, and hence+-- should be linear.++-- | If 'Of' had a @Comonad@ instance, then we'd have+--+-- @copy = expand extend@+--+-- See 'expandPost' for a version that requires a @Control.Functor g@+-- instance instead.+expand ::+ forall f m r g h.+ (Control.Monad m, Control.Functor f) =>+ (forall a b. (g a %1 -> b) -> f a %1 -> h b) ->+ Stream f m r %1 ->+ Stream g (Stream h m) r+expand ext = loop+ where+ loop :: Stream f m r %1 -> Stream g (Stream h m) r+ loop (Return r) = Return r+ loop (Step f) = Effect $ Step $ ext (Return . Step) (Control.fmap loop f)+ loop (Effect m) = Effect $ Effect $ Control.fmap (Return . loop) m+{-# INLINEABLE expand #-}++-- See note on 'expand'.++-- | If 'Of' had a @Comonad@ instance, then we'd have+--+-- @copy = expandPost extend@+--+-- See 'expand' for a version that requires a @Control.Functor f@ instance+-- instead.+expandPost ::+ forall f m r g h.+ (Control.Monad m, Control.Functor g) =>+ (forall a b. (g a %1 -> b) -> f a %1 -> h b) ->+ Stream f m r %1 ->+ Stream g (Stream h m) r+expandPost ext = loop+ where+ loop :: Stream f m r %1 -> Stream g (Stream h m) r+ loop (Return r) = Return r+ loop (Step f) = Effect $ Step $ ext (Return . Step . Control.fmap loop) f+ loop (Effect m) = Effect $ Effect $ Control.fmap (Return . loop) m+{-# INLINEABLE expandPost #-}++-- # Eliminating a 'Stream'+-------------------------------------------------------------------------------++-- Note. Since the functor step is held linearly in the+-- 'Stream' datatype, the first argument must be a linear function+-- in order to linearly consume the 'Step' case of a stream.++-- | Map each layer to an effect, and run them all.+mapsM_ ::+ (Control.Functor f, Control.Monad m) =>+ (forall x. f x %1 -> m x) ->+ Stream f m r %1 ->+ m r+mapsM_ f = run . maps f+{-# INLINE mapsM_ #-}++-- | Run the effects in a stream that merely layers effects.+run :: Control.Monad m => Stream m m r %1 -> m r+run = loop+ where+ loop :: Control.Monad m => Stream m m r %1 -> m r+ loop stream =+ stream & \case+ Return r -> Control.return r+ Effect m -> m Control.>>= loop+ Step mrest -> mrest Control.>>= loop+{-# INLINEABLE run #-}++-- | 'streamFold' reorders the arguments of 'destroy' to be more akin+-- to @foldr@ It is more convenient to query in ghci to figure out+-- what kind of \'algebra\' you need to write.+--+-- \>\>\> :t streamFold Control.return Control.join+-- (Control.Monad m, Control.Functor f) =>+-- (f (m a) %1-> m a) -> Stream f m a %1-> m a -- iterT+--+-- \>\>\> :t streamFold Control.return (Control.join . Control.lift)+-- (Control.Monad m, Control.Monad (t m), Control.Functor f, Control.MonadTrans t) =>+-- (f (t m a) %1-> t m a) -> Stream f m a %1-> t m a -- iterTM+--+-- \>\>\> :t streamFold Control.return effect+-- (Control.Monad m, Control.Functor f, Control.Functor g) =>+-- (f (Stream g m r) %1-> Stream g m r) -> Stream f m r %1-> Stream g m r+--+-- \>\>\> :t \f -> streamFold Control.return effect (wrap . f)+-- (Control.Monad m, Control.Functor f, Control.Functor g) =>+-- (f (Stream g m a) %1-> g (Stream g m a))+-- -> Stream f m a %1-> Stream g m a -- maps+--+-- \>\>\> :t \f -> streamFold Control.return effect (effect . Control.fmap wrap . f)+-- (Control.Monad m, Control.Functor f, Control.Functor g) =>+-- (f (Stream g m a) %1-> m (g (Stream g m a)))+-- -> Stream f m a %1-> Stream g m a -- mapped+--+-- @+-- streamFold done eff construct+-- = eff . iterT (Control.return . construct . Control.fmap eff) . Control.fmap done+-- @+streamFold ::+ (Control.Functor f, Control.Monad m) =>+ (r %1 -> b) ->+ (m b %1 -> b) ->+ (f b %1 -> b) ->+ Stream f m r %1 ->+ b+streamFold done theEffect construct stream =+ destroy stream construct theEffect done+{-# INLINE streamFold #-}++-- | Specialized fold following the usage of @Control.Monad.Trans.Free@+--+-- > iterT alg = streamFold Control.return Control.join alg+-- > iterT alg = runIdentityT . iterTM (IdentityT . alg . Control.fmap runIdentityT)+iterT ::+ (Control.Functor f, Control.Monad m) =>+ (f (m a) %1 -> m a) ->+ Stream f m a %1 ->+ m a+iterT out stream = destroyExposed stream out Control.join Control.return+{-# INLINE iterT #-}++-- | Specialized fold following the usage of @Control.Monad.Trans.Free@+--+-- > iterTM alg = streamFold Control.return (Control.join . Control.lift)+-- > iterTM alg = iterT alg . hoist Control.lift+iterTM ::+ ( Control.Functor f,+ Control.Monad m,+ Control.MonadTrans t,+ Control.Monad (t m)+ ) =>+ (f (t m a) %1 -> t m a) ->+ Stream f m a %1 ->+ t m a+iterTM out stream =+ destroyExposed stream out (Control.join . Control.lift) Control.return+{-# INLINE iterTM #-}++-- Note. 'destroy' needs to use linear functions in its church encoding+-- to consume the stream linearly.++-- | Map a stream to its church encoding; compare @Data.List.foldr@.+-- 'destroyExposed' may be more efficient in some cases when+-- applicable, but it is less safe.+--+-- @+-- destroy s construct eff done+-- = eff .+-- iterT (Control.return . construct . Control.fmap eff) .+-- Control.fmap done $ s+-- @+destroy ::+ forall f m r b.+ (Control.Functor f, Control.Monad m) =>+ Stream f m r %1 ->+ (f b %1 -> b) ->+ (m b %1 -> b) ->+ (r %1 -> b) ->+ b+destroy stream0 construct theEffect done = theEffect (loop stream0)+ where+ loop :: Stream f m r %1 -> m b+ loop stream =+ stream & \case+ Return r -> Control.return $ done r+ Effect m -> m Control.>>= loop+ Step f -> Control.return $ construct $ Control.fmap (theEffect . loop) f+{-# INLINEABLE destroy #-}
+ src/Streaming/Linear/Internal/Consume.hs view
@@ -0,0 +1,709 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++-- | This module provides all functions that take input streams+-- but do not return output streams.+module Streaming.Linear.Internal.Consume+ ( -- * Consuming 'Stream's of elements++ -- ** IO Consumers+ stdoutLn,+ stdoutLn',+ print,+ toHandle,+ writeFile,++ -- ** Basic Pure Consumers+ effects,+ erase,+ drained,+ mapM_,++ -- ** Folds+ fold,+ fold_,+ foldM,+ foldM_,+ all,+ all_,+ any,+ any_,+ sum,+ sum_,+ product,+ product_,+ head,+ head_,+ last,+ last_,+ elem,+ elem_,+ notElem,+ notElem_,+ length,+ length_,+ toList,+ toList_,+ mconcat,+ mconcat_,+ minimum,+ minimum_,+ maximum,+ maximum_,+ foldrM,+ foldrT,+ )+where++import qualified Control.Functor.Linear as Control+import qualified Data.Bool.Linear as Linear+import Data.Functor.Identity+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Unrestricted.Linear+import Prelude.Linear (($), (&), (.))+import Streaming.Linear.Internal.Process+import Streaming.Linear.Internal.Type+import qualified System.IO as System+import System.IO.Linear+import System.IO.Resource.Linear+import Prelude+ ( Bool (..),+ Eq (..),+ FilePath,+ Int,+ Maybe (..),+ Num (..),+ Ord (..),+ Show (..),+ id,+ (&&),+ (||),+ )+import qualified Prelude as Prelude++-- # IO Consumers+-------------------------------------------------------------------------------++-- Note: crashes on a broken output pipe+--++-- | Write 'String's to 'System.stdout' using 'Text.putStrLn'; terminates on a broken output pipe+-- (The name and implementation are modelled on the @Pipes.Prelude@ @stdoutLn@).+--+-- \>\>\> withLinearIO $ Control.fmap move $ S.stdoutLn $ S.each $ words "one two three"+-- one+-- two+-- three+stdoutLn :: Stream (Of Text) IO () %1 -> IO ()+stdoutLn stream = stdoutLn' stream+{-# INLINE stdoutLn #-}++-- | Like stdoutLn but with an arbitrary return value+stdoutLn' :: forall r. Stream (Of Text) IO r %1 -> IO r+stdoutLn' stream = loop stream+ where+ loop :: Stream (Of Text) IO r %1 -> IO r+ loop stream =+ stream & \case+ Return r -> Control.return r+ Effect ms -> ms Control.>>= stdoutLn'+ Step (str :> stream) -> Control.do+ fromSystemIO $ Text.putStrLn str+ stdoutLn' stream+{-# INLINEABLE stdoutLn' #-}++-- | Print the elements of a stream as they arise.+print :: Show a => Stream (Of a) IO r %1 -> IO r+print = stdoutLn' . map (Text.pack Prelude.. Prelude.show)++-- | Write a stream to a handle and return the handle.+toHandle :: Handle %1 -> Stream (Of Text) RIO r %1 -> RIO (r, Handle)+toHandle handle stream = loop handle stream+ where+ loop :: Handle %1 -> Stream (Of Text) RIO r %1 -> RIO (r, Handle)+ loop handle stream =+ stream & \case+ Return r -> Control.return (r, handle)+ Effect ms -> ms Control.>>= toHandle handle+ Step (text :> stream') -> Control.do+ handle' <- hPutStrLn handle text+ toHandle handle' stream'+{-# INLINEABLE toHandle #-}++-- | Write a stream of text as lines as lines to a file+writeFile :: FilePath -> Stream (Of Text) RIO r %1 -> RIO r+writeFile filepath stream = Control.do+ handle <- openFile filepath System.WriteMode+ (r, handle') <- toHandle handle stream+ hClose handle'+ Control.return r++-- # Basic Pure Consumers+-------------------------------------------------------------------------------++-- | Reduce a stream, performing its actions but ignoring its elements.+--+-- @+-- \>\>\> rest <- S.effects $ S.splitAt 2 $ each' [1..5]+-- \>\>\> S.print rest+-- 3+-- 4+-- 5+-- @+--+-- 'effects' should be understood together with 'copy' and is subject to the rules+--+-- > S.effects . S.copy = id+-- > hoist S.effects . S.copy = id+--+-- The similar @effects@ and @copy@ operations in @Data.ByteString.Streaming@ obey the same rules.+effects :: forall a m r. Control.Monad m => Stream (Of a) m r %1 -> m r+effects stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m r+ loop stream =+ stream & \case+ Return r -> Control.return r+ Effect ms -> ms Control.>>= effects+ Step (_ :> stream') -> effects stream'+{-# INLINEABLE effects #-}++-- | Remove the elements from a stream of values, retaining the structure of layers.+erase :: forall a m r. Control.Monad m => Stream (Of a) m r %1 -> Stream Identity m r+erase stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream Identity m r+ loop stream =+ stream & \case+ Return r -> Return r+ Step (_ :> stream') -> Step $ Identity (erase stream')+ Effect ms -> Effect $ ms Control.>>= (Control.return . erase)+{-# INLINEABLE erase #-}++-- | Where a transformer returns a stream, run the effects of the stream, keeping+-- the return value. This is usually used at the type+--+-- > drained :: Control.Monad m => Stream (Of a) m (Stream (Of b) m r) -> Stream (Of a) m r+-- > drained = Control.join . Control.fmap (Control.lift . effects)+--+-- Here, for example, we split a stream in two places and throw out the middle segment:+--+-- @+-- \>\>\> rest <- S.print $ S.drained $ S.splitAt 2 $ S.splitAt 5 $ each' [1..7]+-- 1+-- 2+-- \>\>\> S.print rest+-- 6+-- 7+-- @+drained ::+ ( Control.Monad m,+ Control.Monad (t m),+ Control.Functor (t m),+ Control.MonadTrans t+ ) =>+ t m (Stream (Of a) m r) %1 ->+ t m r+drained = Control.join . Control.fmap (Control.lift . effects)+{-# INLINE drained #-}++-- | Reduce a stream to its return value with a monadic action.+--+-- @+-- \>\>\> S.mapM_ Prelude.print $ each' [1..3]+-- 1+-- 2+-- 3+-- @+--+-- @+-- \>\>\> rest <- S.mapM_ Prelude.print $ S.splitAt 3 $ each' [1..10]+-- 1+-- 2+-- 3+-- \>\>\> S.sum rest+-- 49 :> ()+-- @+mapM_ ::+ forall a m b r.+ (Consumable b, Control.Monad m) =>+ (a -> m b) ->+ Stream (Of a) m r %1 ->+ m r+mapM_ f stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m r+ loop stream =+ stream & \case+ Return r -> Control.return r+ Effect ms -> ms Control.>>= mapM_ f+ Step (a :> stream') -> Control.do+ b <- f a+ Control.return $ consume b+ mapM_ f stream'+{-# INLINEABLE mapM_ #-}++-- # Folds+-------------------------------------------------------------------------------++-- | Strict fold of a 'Stream' of elements that preserves the return value.+-- This does not short circuit and all effects are performed.+-- The third parameter will often be 'id' where a fold is written by hand:+--+-- @+-- \>\>\> S.fold (+) 0 id $ each' [1..10]+-- 55 :> ()+-- @+--+-- @+-- \>\>\> S.fold (*) 1 id $ S.fold (+) 0 id $ S.copy $ each' [1..10]+-- 3628800 :> (55 :> ())+-- @+--+-- It can be used to replace a standard Haskell type with one more suited to+-- writing a strict accumulation function. It is also crucial to the+-- Applicative instance for @Control.Foldl.Fold@ We can apply such a fold+-- @purely@+--+-- > Control.Foldl.purely S.fold :: Control.Monad m => Fold a b -> Stream (Of a) m r %1-> m (Of b r)+--+-- Thus, specializing a bit:+--+-- > L.purely S.fold L.sum :: Stream (Of Int) Int r %1-> m (Of Int r)+-- > mapped (L.purely S.fold L.sum) :: Stream (Stream (Of Int)) IO r %1-> Stream (Of Int) IO r+--+-- Here we use the Applicative instance for @Control.Foldl.Fold@ to+-- stream three-item segments of a stream together with their sums and products.+--+-- @+-- \>\>\> S.print $ mapped (L.purely S.fold (liftA3 (,,) L.list L.product L.sum)) $ chunksOf 3 $ each' [1..10]+-- ([1,2,3],6,6)+-- ([4,5,6],120,15)+-- ([7,8,9],504,24)+-- ([10],10,10)+-- @+fold ::+ forall x a b m r.+ Control.Monad m =>+ (x -> a -> x) ->+ x ->+ (x -> b) ->+ Stream (Of a) m r %1 ->+ m (Of b r)+fold f x g stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m (Of b r)+ loop stream =+ stream & \case+ Return r -> Control.return $ g x :> r+ Effect ms -> ms Control.>>= fold f x g+ Step (a :> stream') -> fold f (f x a) g stream'+{-# INLINEABLE fold #-}++-- | Strict fold of a 'Stream' of elements, preserving only the result of the fold, not+-- the return value of the stream. This does not short circuit and all effects+-- are performed. The third parameter will often be 'id' where a fold+-- is written by hand:+--+-- @+-- \>\>\> S.fold_ (+) 0 id $ each [1..10]+-- 55+-- @+--+-- It can be used to replace a standard Haskell type with one more suited to+-- writing a strict accumulation function. It is also crucial to the+-- Applicative instance for @Control.Foldl.Fold@+--+-- > Control.Foldl.purely fold :: Control.Monad m => Fold a b -> Stream (Of a) m () %1-> m b+fold_ ::+ forall x a b m r.+ (Control.Monad m, Consumable r) =>+ (x -> a -> x) ->+ x ->+ (x -> b) ->+ Stream (Of a) m r %1 ->+ m b+fold_ f x g stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m b+ loop stream =+ stream & \case+ Return r -> lseq r $ Control.return $ g x+ Effect ms -> ms Control.>>= fold_ f x g+ Step (a :> stream') -> fold_ f (f x a) g stream'+{-# INLINEABLE fold_ #-}++-- Note: We can't use 'Of' since the left component is unrestricted.+-- Remark: to use the (`m x`) in the folding function that is the first+-- argument, we must bind to it. Since `m` is a `Control.Monad`, we need+-- the folding function to consume `x` linearly.+--++-- | Strict, monadic fold of the elements of a @Stream (Of a)@+--+-- > Control.Foldl.impurely foldM :: Control.Monad m => FoldM a b -> Stream (Of a) m r %1-> m (b, r)+--+-- Thus to accumulate the elements of a stream as a vector, together with a random+-- element we might write:+--+-- @+-- \>\>\> L.impurely S.foldM (liftA2 (,) L.vectorM L.random) $ each' [1..10::Int] :: IO (Of (Vector Int, Maybe Int) ())+-- ([1,2,3,4,5,6,7,8,9,10],Just 9) :> ()+-- @+foldM ::+ forall x a m b r.+ Control.Monad m =>+ (x %1 -> a -> m x) ->+ m x ->+ (x %1 -> m b) ->+ Stream (Of a) m r %1 ->+ m (b, r)+foldM f mx g stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m (b, r)+ loop stream =+ stream & \case+ Return r -> mx Control.>>= g Control.>>= (\b -> Control.return (b, r))+ Effect ms -> ms Control.>>= foldM f mx g+ Step (a :> stream') -> foldM f (mx Control.>>= \x -> f x a) g stream'+{-# INLINEABLE foldM #-}++-- | Strict, monadic fold of the elements of a @Stream (Of a)@+--+-- > Control.Foldl.impurely foldM_ :: Control.Monad m => FoldM a b -> Stream (Of a) m () %1-> m b+foldM_ ::+ forall a m x b r.+ (Control.Monad m, Consumable r) =>+ (x %1 -> a -> m x) ->+ m x ->+ (x %1 -> m b) ->+ Stream (Of a) m r %1 ->+ m b+foldM_ f mx g stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m b+ loop stream =+ stream & \case+ Return r -> lseq r $ mx Control.>>= g+ Effect ms -> ms Control.>>= foldM_ f mx g+ Step (a :> stream') -> foldM_ f (mx Control.>>= \x -> f x a) g stream'+{-# INLINEABLE foldM_ #-}++-- | Note: does not short circuit+all :: Control.Monad m => (a -> Bool) -> Stream (Of a) m r %1 -> m (Of Bool r)+all f stream = fold (&&) True id (map f stream)+{-# INLINEABLE all #-}++-- | Note: does not short circuit+all_ :: (Consumable r, Control.Monad m) => (a -> Bool) -> Stream (Of a) m r %1 -> m Bool+all_ f stream = fold_ (&&) True id (map f stream)+{-# INLINEABLE all_ #-}++-- | Note: does not short circuit+any :: Control.Monad m => (a -> Bool) -> Stream (Of a) m r %1 -> m (Of Bool r)+any f stream = fold (||) False id (map f stream)+{-# INLINEABLE any #-}++-- | Note: does not short circuit+any_ :: (Consumable r, Control.Monad m) => (a -> Bool) -> Stream (Of a) m r %1 -> m Bool+any_ f stream = fold_ (||) False id (map f stream)+{-# INLINEABLE any_ #-}++-- | Fold a 'Stream' of numbers into their sum with the return value+--+-- > mapped S.sum :: Stream (Stream (Of Int)) m r %1-> Stream (Of Int) m r+--+-- @+-- \>\>\> S.sum $ each' [1..10]+-- 55 :> ()+-- @+--+-- @+-- \>\>\> (n :> rest) <- S.sum $ S.splitAt 3 $ each' [1..10]+-- \>\>\> System.IO.print n+-- 6+-- \>\>\> (m :> rest') <- S.sum $ S.splitAt 3 rest+-- \>\>\> System.IO.print m+-- 15+-- \>\>\> S.print rest'+-- 7+-- 8+-- 9+-- 10+-- @+sum :: (Control.Monad m, Num a) => Stream (Of a) m r %1 -> m (Of a r)+sum stream = fold (+) 0 id stream+{-# INLINE sum #-}++-- | Fold a 'Stream' of numbers into their sum+sum_ :: (Control.Monad m, Num a) => Stream (Of a) m () %1 -> m a+sum_ stream = fold_ (+) 0 id stream+{-# INLINE sum_ #-}++-- | Fold a 'Stream' of numbers into their product with the return value+--+-- > mapped product :: Stream (Stream (Of Int)) m r -> Stream (Of Int) m r+product :: (Control.Monad m, Num a) => Stream (Of a) m r %1 -> m (Of a r)+product stream = fold (*) 1 id stream+{-# INLINE product #-}++-- | Fold a 'Stream' of numbers into their product+product_ :: (Control.Monad m, Num a) => Stream (Of a) m () %1 -> m a+product_ stream = fold_ (*) 1 id stream+{-# INLINE product_ #-}++-- | Note that 'head' exhausts the rest of the stream following the+-- first element, performing all monadic effects via 'effects'+head :: Control.Monad m => Stream (Of a) m r %1 -> m (Of (Maybe a) r)+head str =+ str & \case+ Return r -> Control.return (Nothing :> r)+ Effect m -> m Control.>>= head+ Step (a :> rest) ->+ effects rest Control.>>= \r -> Control.return (Just a :> r)+{-# INLINEABLE head #-}++-- | Note that 'head' exhausts the rest of the stream following the+-- first element, performing all monadic effects via 'effects'+head_ :: (Consumable r, Control.Monad m) => Stream (Of a) m r %1 -> m (Maybe a)+head_ str =+ str & \case+ Return r -> lseq r $ Control.return Nothing+ Effect m -> m Control.>>= head_+ Step (a :> rest) ->+ effects rest Control.>>= \r -> lseq r $ Control.return (Just a)+{-# INLINEABLE head_ #-}++last :: Control.Monad m => Stream (Of a) m r %1 -> m (Of (Maybe a) r)+last = loop Nothing+ where+ loop ::+ Control.Monad m =>+ Maybe a ->+ Stream (Of a) m r %1 ->+ m (Of (Maybe a) r)+ loop m s =+ s & \case+ Return r -> Control.return (m :> r)+ Effect m -> m Control.>>= last+ Step (a :> rest) -> loop (Just a) rest+{-# INLINEABLE last #-}++last_ :: (Consumable r, Control.Monad m) => Stream (Of a) m r %1 -> m (Maybe a)+last_ = loop Nothing+ where+ loop ::+ (Consumable r, Control.Monad m) =>+ Maybe a ->+ Stream (Of a) m r %1 ->+ m (Maybe a)+ loop m s =+ s & \case+ Return r -> lseq r $ Control.return m+ Effect m -> m Control.>>= last_+ Step (a :> rest) -> loop (Just a) rest+{-# INLINEABLE last_ #-}++elem ::+ forall a m r.+ (Control.Monad m, Eq a) =>+ a ->+ Stream (Of a) m r %1 ->+ m (Of Bool r)+elem a stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m (Of Bool r)+ loop stream =+ stream & \case+ Return r -> Control.return $ False :> r+ Effect ms -> ms Control.>>= elem a+ Step (a' :> stream') -> case a == a' of+ True -> effects stream' Control.>>= (\r -> Control.return $ True :> r)+ False -> elem a stream'+{-# INLINEABLE elem #-}++infix 4 `elem` -- same fixity as base.elem++elem_ ::+ forall a m r.+ (Consumable r, Control.Monad m, Eq a) =>+ a ->+ Stream (Of a) m r %1 ->+ m Bool+elem_ a stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m Bool+ loop stream =+ stream & \case+ Return r -> lseq r $ Control.return False+ Effect ms -> ms Control.>>= elem_ a+ Step (a' :> stream') -> case a == a' of+ True -> effects stream' Control.>>= \r -> lseq r $ Control.return True+ False -> elem_ a stream'+{-# INLINEABLE elem_ #-}++-- | Exhaust a stream deciding whether @a@ was an element.+notElem :: (Control.Monad m, Eq a) => a -> Stream (Of a) m r %1 -> m (Of Bool r)+notElem a stream = Control.fmap negate $ elem a stream+ where+ negate :: Of Bool r %1 -> Of Bool r+ negate (b :> r) = Prelude.not b :> r+{-# INLINE notElem #-}++notElem_ :: (Consumable r, Control.Monad m, Eq a) => a -> Stream (Of a) m r %1 -> m Bool+notElem_ a stream = Control.fmap Linear.not $ elem_ a stream+{-# INLINE notElem_ #-}++-- | Run a stream, keeping its length and its return value.+--+-- @+-- \>\>\> S.print $ mapped S.length $ chunksOf 3 $ S.each' [1..10]+-- 3+-- 3+-- 3+-- 1+-- @+length :: Control.Monad m => Stream (Of a) m r %1 -> m (Of Int r)+length = fold (\n _ -> n + 1) 0 id+{-# INLINE length #-}++-- | Run a stream, remembering only its length:+--+-- @+-- \>\>\> runIdentity $ S.length_ (S.each [1..10] :: Stream (Of Int) Identity ())+-- 10+-- @+length_ :: (Consumable r, Control.Monad m) => Stream (Of a) m r %1 -> m Int+length_ = fold_ (\n _ -> n + 1) 0 id+{-# INLINE length_ #-}++-- | Convert an effectful 'Stream' into a list alongside the return value+--+-- > mapped toList :: Stream (Stream (Of a) m) m r %1-> Stream (Of [a]) m r+--+-- Like 'toList_', 'toList' breaks streaming; unlike 'toList_' it /preserves the return value/+-- and thus is frequently useful with e.g. 'mapped'+--+-- @+-- \>\>\> S.print $ mapped S.toList $ chunksOf 3 $ each' [1..9]+-- [1,2,3]+-- [4,5,6]+-- [7,8,9]+-- @+--+-- @+-- \>\>\> S.print $ mapped S.toList $ chunksOf 2 $ S.replicateM 4 getLine+-- s<Enter>+-- t<Enter>+-- ["s","t"]+-- u<Enter>+-- v<Enter>+-- ["u","v"]+-- @+toList :: Control.Monad m => Stream (Of a) m r %1 -> m (Of [a] r)+toList = fold (\diff a ls -> diff (a : ls)) id (\diff -> diff [])+{-# INLINE toList #-}++-- | Convert an effectful @Stream (Of a)@ into a list of @as@+--+-- Note: Needless to say, this function does not stream properly.+-- It is basically the same as Prelude 'mapM' which, like 'replicateM',+-- 'sequence' and similar operations on traversable containers+-- is a leading cause of space leaks.+toList_ :: Control.Monad m => Stream (Of a) m () %1 -> m [a]+toList_ = fold_ (\diff a ls -> diff (a : ls)) id (\diff -> diff [])+{-# INLINE toList_ #-}++-- | Fold streamed items into their monoidal sum+mconcat :: (Control.Monad m, Prelude.Monoid w) => Stream (Of w) m r %1 -> m (Of w r)+mconcat = fold (Prelude.<>) Prelude.mempty id+{-# INLINE mconcat #-}++mconcat_ ::+ (Consumable r, Control.Monad m, Prelude.Monoid w) =>+ Stream (Of w) m r %1 ->+ m w+mconcat_ = fold_ (Prelude.<>) Prelude.mempty id+{-# INLINE mconcat_ #-}++minimum :: (Control.Monad m, Ord a) => Stream (Of a) m r %1 -> m (Of (Maybe a) r)+minimum = fold getMin Nothing id . map Just+{-# INLINE minimum #-}++minimum_ ::+ (Consumable r, Control.Monad m, Ord a) =>+ Stream (Of a) m r %1 ->+ m (Maybe a)+minimum_ = fold_ getMin Nothing id . map Just+{-# INLINE minimum_ #-}++maximum :: (Control.Monad m, Ord a) => Stream (Of a) m r %1 -> m (Of (Maybe a) r)+maximum = fold getMax Nothing id . map Just+{-# INLINE maximum #-}++maximum_ ::+ (Consumable r, Control.Monad m, Ord a) =>+ Stream (Of a) m r %1 ->+ m (Maybe a)+maximum_ = fold_ getMax Nothing id . map Just+{-# INLINE maximum_ #-}++getMin :: Ord a => Maybe a -> Maybe a -> Maybe a+getMin = mCompare Prelude.min++getMax :: Ord a => Maybe a -> Maybe a -> Maybe a+getMax = mCompare Prelude.max++mCompare :: Ord a => (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a+mCompare _ Nothing Nothing = Nothing+mCompare _ (Just a) Nothing = Just a+mCompare _ Nothing (Just a) = Just a+mCompare comp (Just x) (Just y) = Just $ comp x y++-- | A natural right fold for consuming a stream of elements.+-- See also the more general 'iterT' in the 'Streaming' module and the+-- still more general 'destroy'+foldrM ::+ forall a m r.+ Control.Monad m =>+ (a -> m r %1 -> m r) ->+ Stream (Of a) m r %1 ->+ m r+foldrM step stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m r+ loop stream =+ stream & \case+ Return r -> Control.return r+ Effect m -> m Control.>>= foldrM step+ Step (a :> as) -> step a (foldrM step as)+{-# INLINEABLE foldrM #-}++-- | A natural right fold for consuming a stream of elements.+-- See also the more general 'iterTM' in the 'Streaming' module+-- and the still more general 'destroy'+--+-- > foldrT (\a p -> Streaming.yield a >> p) = id+foldrT ::+ forall a t m r.+ (Control.Monad m, Control.MonadTrans t, Control.Monad (t m)) =>+ (a -> t m r %1 -> t m r) ->+ Stream (Of a) m r %1 ->+ t m r+foldrT step stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> t m r+ loop stream =+ stream & \case+ Return r -> Control.return r+ Effect ms -> (Control.lift ms) Control.>>= foldrT step+ Step (a :> as) -> step a (foldrT step as)+{-# INLINEABLE foldrT #-}
+ src/Streaming/Linear/Internal/Interop.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++-- | This module contains functions for interoperating with other+-- streaming libraries.+module Streaming.Linear.Internal.Interop+ ( -- * Interoperating with other streaming libraries+ reread,+ )+where++import qualified Control.Functor.Linear as Control+import Data.Unrestricted.Linear+import Prelude.Linear (($))+import Streaming.Linear.Internal.Produce+import Streaming.Linear.Internal.Type+import Prelude (Maybe (..))++-- | Read an @IORef (Maybe a)@ or a similar device until it reads @Nothing@.+-- @reread@ provides convenient exit from the @io-streams@ library+--+-- > reread readIORef :: IORef (Maybe a) -> Stream (Of a) IO ()+-- > reread Streams.read :: System.IO.Streams.InputStream a -> Stream (Of a) IO ()+reread ::+ Control.Monad m =>+ (s -> m (Ur (Maybe a))) ->+ s ->+ Stream (Of a) m ()+reread f s = reread' f s+ where+ reread' ::+ Control.Monad m =>+ (s -> m (Ur (Maybe a))) ->+ s ->+ Stream (Of a) m ()+ reread' f s = Effect $ Control.do+ Ur maybeA <- f s+ case maybeA of+ Nothing -> Control.return $ Return ()+ Just a -> Control.return $ (yield a Control.>> reread f s)+{-# INLINEABLE reread #-}
+ src/Streaming/Linear/Internal/Many.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++-- | This module contains all functions that do something with+-- multiple streams as input or output. This includes combining+-- streams, splitting a stream, etc.+module Streaming.Linear.Internal.Many+ ( -- * Operations that use or return multiple 'Stream's++ -- ** Zips and Unzip+ unzip,+ ZipResidual,+ ZipResidual3,+ zip,+ zipR,+ zipWith,+ zipWithR,+ zip3,+ zip3R,+ zipWith3,+ zipWith3R,+ Either3 (..),++ -- ** Merging+ -- $+ merge,+ mergeOn,+ mergeBy,+ )+where++import qualified Control.Functor.Linear as Control+import Prelude.Linear (($), (&))+import Streaming.Linear.Internal.Consume+import Streaming.Linear.Internal.Type+import Prelude (Either (..), Ord (..), Ordering (..))++-- # Zips and Unzip+-------------------------------------------------------------------------------++-- | The type+--+-- > Data.List.unzip :: [(a,b)] -> ([a],[b])+--+-- might lead us to expect+--+-- > Streaming.unzip :: Stream (Of (a,b)) m r -> Stream (Of a) m (Stream (Of b) m r)+--+-- which would not stream, since it would have to accumulate the second stream (of @b@s).+-- Of course, @Data.List@ 'Data.List.unzip' doesn't stream either.+--+-- This @unzip@ does+-- stream, though of course you can spoil this by using e.g. 'toList':+--+-- @+-- \>\>\> let xs = Prelude.map (\x -> (x, Prelude.show x)) [1..5 :: Int]+--+-- \>\>\> S.toList $ S.toList $ S.unzip (S.each' xs)+-- ["1","2","3","4","5"] :> ([1,2,3,4,5] :> ())+--+-- \>\>\> Prelude.unzip xs+-- ([1,2,3,4,5],["1","2","3","4","5"])+-- @+--+-- Note the difference of order in the results. It may be of some use to think why.+-- The first application of 'toList' was applied to a stream of integers:+--+-- @+-- \>\>\> :t S.unzip $ S.each' xs+-- S.unzip $ S.each' xs :: Control.Monad m => Stream (Of Int) (Stream (Of String) m) ()+-- @+--+-- Like any fold, 'toList' takes no notice of the monad of effects.+--+-- > toList :: Control.Monad m => Stream (Of a) m r %1-> m (Of [a] r)+--+-- In the case at hand (since I am in @ghci@) @m = Stream (Of String) IO@.+-- So when I apply 'toList', I exhaust that stream of integers, folding+-- it into a list:+--+-- @+-- \>\>\> :t S.toList $ S.unzip $ S.each' xs+-- S.toList $ S.unzip $ S.each' xs+-- :: Control.Monad m => Stream (Of String) m (Of [Int] ())+-- @+--+-- When I apply 'toList' to /this/, I reduce everything to an ordinary action in @IO@,+-- and return a list of strings:+--+-- @+-- \>\>\> S.toList $ S.toList $ S.unzip (S.each' xs)+-- ["1","2","3","4","5"] :> ([1,2,3,4,5] :> ())+-- @+--+-- 'unzip' can be considered a special case of either 'unzips' or 'expand':+--+-- @+-- unzip = 'unzips' . 'maps' (\((a,b) :> x) -> Compose (a :> b :> x))+-- unzip = 'expand' $ \p ((a,b) :> abs) -> b :> p (a :> abs)+-- @+unzip ::+ Control.Monad m =>+ Stream (Of (a, b)) m r %1 ->+ Stream (Of a) (Stream (Of b) m) r+unzip = loop+ where+ loop ::+ Control.Monad m =>+ Stream (Of (a, b)) m r %1 ->+ Stream (Of a) (Stream (Of b) m) r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop $ Control.lift m+ Step ((a, b) :> rest) -> Step (a :> Effect (Step (b :> Return (loop rest))))+{-# INLINEABLE unzip #-}++{- Remarks on the design of zip functions++Zip functions have two design choices:+(1) What do we do with the end-of-stream values of both streams?+(2) If the streams are of different length, do we keep or throw out the+remainder of the longer stream?++* We are assuming not to take infinite streams as input and instead deal with+reasonably small finite streams.+* To avoid making choices for the user, we keep both end-of-stream payloads+* The default zips (ones without a prime in the name) use @effects@ to consume+the remainder stream after zipping. We include zip function variants that+return no remainder (for equal length streams), or the remainder of the+longer stream.++-}++data Either3 a b c where+ Left3 :: a %1 -> Either3 a b c+ Middle3 :: b %1 -> Either3 a b c+ Right3 :: c %1 -> Either3 a b c++-- | The remainder of zipping two streams+type ZipResidual a b m r1 r2 =+ Either3+ (r1, r2)+ (r1, Stream (Of b) m r2)+ (Stream (Of a) m r1, r2)++-- | @zipWithR@ zips two streams applying a function along the way,+-- keeping the remainder of zipping if there is one. Note. If two streams have+-- the same length, but one needs to perform some effects to obtain the+-- end-of-stream result, that stream is treated as a residual.+zipWithR ::+ Control.Monad m =>+ (a -> b -> c) ->+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of c) m (ZipResidual a b m r1 r2)+zipWithR = loop+ where+ loop ::+ Control.Monad m =>+ (a -> b -> c) ->+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of c) m (ZipResidual a b m r1 r2)+ loop f st1 st2 =+ st1 & \case+ Effect ms -> Effect $ Control.fmap (\s -> loop f s st2) ms+ Return r1 ->+ st2 & \case+ Return r2 -> Return $ Left3 (r1, r2)+ st2' -> Return $ Middle3 (r1, st2')+ Step (a :> as) ->+ st2 & \case+ Effect ms ->+ Effect $ Control.fmap (\s -> loop f (Step (a :> as)) s) ms+ Return r2 -> Return $ Right3 (Step (a :> as), r2)+ Step (b :> bs) -> Step $ (f a b) :> loop f as bs+{-# INLINEABLE zipWithR #-}++zipWith ::+ Control.Monad m =>+ (a -> b -> c) ->+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of c) m (r1, r2)+zipWith f s1 s2 = Control.do+ result <- zipWithR f s1 s2+ result & \case+ Left3 rets -> Control.return rets+ Middle3 (r1, s2') -> Control.do+ r2 <- Control.lift $ effects s2'+ Control.return (r1, r2)+ Right3 (s1', r2) -> Control.do+ r1 <- Control.lift $ effects s1'+ Control.return (r1, r2)+{-# INLINEABLE zipWith #-}++-- | @zip@ zips two streams exhausing the remainder of the longer+-- stream and consuming its effects.+zip ::+ Control.Monad m =>+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of (a, b)) m (r1, r2)+zip = zipWith (,)+{-# INLINE zip #-}++-- | @zipR@ zips two streams keeping the remainder if there is one.+zipR ::+ Control.Monad m =>+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of (a, b)) m (ZipResidual a b m r1 r2)+zipR = zipWithR (,)+{-# INLINE zipR #-}++-- Remark. For simplicity, we do not create an @Either7@ which is the+-- proper remainder type for 'zip3R'. Our type simply has one impossible+-- case which is when all three streams have a remainder.++-- | The (liberal) remainder of zipping three streams.+-- This has the downside that the possibility of three remainders+-- is allowed, though it will never occur.+type ZipResidual3 a b c m r1 r2 r3 =+ ( Either r1 (Stream (Of a) m r1),+ Either r2 (Stream (Of b) m r2),+ Either r3 (Stream (Of c) m r3)+ )++-- | Like @zipWithR@ but with three streams.+zipWith3R ::+ Control.Monad m =>+ (a -> b -> c -> d) ->+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of c) m r3 %1 ->+ Stream (Of d) m (ZipResidual3 a b c m r1 r2 r3)+zipWith3R = loop+ where+ loop ::+ Control.Monad m =>+ (a -> b -> c -> d) ->+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of c) m r3 %1 ->+ Stream (Of d) m (ZipResidual3 a b c m r1 r2 r3)+ loop f s1 s2 s3 =+ s1 & \case+ Effect ms -> Effect $ Control.fmap (\s -> loop f s s2 s3) ms+ Return r1 ->+ (s2, s3) & \case+ (Return r2, Return r3) -> Return (Left r1, Left r2, Left r3)+ (s2', s3') -> Return (Left r1, Right s2', Right s3')+ Step (a :> as) ->+ s2 & \case+ Effect ms ->+ Effect $+ Control.fmap (\s -> loop f (Step $ a :> as) s s3) ms+ Return r2 -> Return (Right (Step $ a :> as), Left r2, Right s3)+ Step (b :> bs) ->+ s3 & \case+ Effect ms ->+ Effect $+ Control.fmap (\s -> loop f (Step $ a :> as) (Step $ b :> bs) s) ms+ Return r3 ->+ Return (Right (Step $ a :> as), Right (Step $ b :> bs), Left r3)+ Step (c :> cs) -> Step $ (f a b c) :> loop f as bs cs+{-# INLINEABLE zipWith3R #-}++-- | Like @zipWith@ but with three streams+zipWith3 ::+ Control.Monad m =>+ (a -> b -> c -> d) ->+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of c) m r3 %1 ->+ Stream (Of d) m (r1, r2, r3)+zipWith3 f s1 s2 s3 = Control.do+ result <- zipWith3R f s1 s2 s3+ result & \case+ (res1, res2, res3) -> Control.do+ r1 <- Control.lift $ extractResult res1+ r2 <- Control.lift $ extractResult res2+ r3 <- Control.lift $ extractResult res3+ Control.return (r1, r2, r3)+{-# INLINEABLE zipWith3 #-}++-- | Like @zipR@ but with three streams.+zip3 ::+ Control.Monad m =>+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of c) m r3 %1 ->+ Stream (Of (a, b, c)) m (r1, r2, r3)+zip3 = zipWith3 (,,)+{-# INLINEABLE zip3 #-}++-- | Like @zipR@ but with three streams.+zip3R ::+ Control.Monad m =>+ Stream (Of a) m r1 %1 ->+ Stream (Of b) m r2 %1 ->+ Stream (Of c) m r3 %1 ->+ Stream (Of (a, b, c)) m (ZipResidual3 a b c m r1 r2 r3)+zip3R = zipWith3R (,,)+{-# INLINEABLE zip3R #-}++-- | Internal function to consume a stream remainder to+-- get the payload+extractResult :: Control.Monad m => Either r (Stream (Of a) m r) %1 -> m r+extractResult (Left r) = Control.return r+extractResult (Right s) = effects s++-- # Merging+-------------------------------------------------------------------------------++-- $merging+-- These functions combine two sorted streams of orderable elements+-- into one sorted stream. The elements of the merged stream are+-- guaranteed to be in a sorted order if the two input streams are+-- also sorted.+--+-- The merge operation is /left-biased/: when merging two elements+-- that compare as equal, the left element is chosen first.++-- | Merge two streams of elements ordered with their 'Ord' instance.+--+-- The return values of both streams are returned.+--+-- @+-- \>\>\> S.print $ merge (each [1,3,5]) (each [2,4])+-- 1+-- 2+-- 3+-- 4+-- 5+-- ((), ())+-- @+merge ::+ (Control.Monad m, Ord a) =>+ Stream (Of a) m r %1 ->+ Stream (Of a) m s %1 ->+ Stream (Of a) m (r, s)+merge = mergeBy compare+{-# INLINE merge #-}++-- | Merge two streams, ordering them by applying the given function to+-- each element before comparing.+--+-- The return values of both streams are returned.+mergeOn ::+ (Control.Monad m, Ord b) =>+ (a -> b) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m s %1 ->+ Stream (Of a) m (r, s)+mergeOn f = mergeBy (\x y -> compare (f x) (f y))+{-# INLINE mergeOn #-}++-- | Merge two streams, ordering the elements using the given comparison function.+--+-- The return values of both streams are returned.+mergeBy ::+ forall m a r s.+ Control.Monad m =>+ (a -> a -> Ordering) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m s %1 ->+ Stream (Of a) m (r, s)+mergeBy comp s1 s2 = loop s1 s2+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) m s %1 -> Stream (Of a) m (r, s)+ loop s1 s2 =+ s1 & \case+ Return r ->+ Effect $ effects s2 Control.>>= \s -> Control.return $ Return (r, s)+ Effect ms ->+ Effect $+ ms Control.>>= \s1' -> Control.return $ mergeBy comp s1' s2+ Step (a :> as) ->+ s2 & \case+ Return s ->+ Effect $ effects as Control.>>= \r -> Control.return $ Return (r, s)+ Effect ms ->+ Effect $+ ms Control.>>= \s2' ->+ Control.return $ mergeBy comp (Step (a :> as)) s2'+ Step (b :> bs) -> case comp a b of+ LT -> Step (a :> Step (b :> mergeBy comp as bs))+ _ -> Step (b :> Step (a :> mergeBy comp as bs))+{-# INLINEABLE mergeBy #-}
+ src/Streaming/Linear/Internal/Process.hs view
@@ -0,0 +1,1661 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++-- | This module provides functions that take one input+-- stream and produce one output stream. These are functions that+-- process a single stream.+module Streaming.Linear.Internal.Process+ ( -- * Stream processors++ -- ** Splitting and inspecting streams of elements+ next,+ uncons,+ splitAt,+ split,+ breaks,+ break,+ breakWhen,+ breakWhen',+ span,+ group,+ groupBy,++ -- ** Sum and compose manipulation+ distinguish,+ switch,+ separate,+ unseparate,+ eitherToSum,+ sumToEither,+ sumToCompose,+ composeToSum,++ -- ** Partitions+ partitionEithers,+ partition,++ -- ** Maybes+ catMaybes,+ mapMaybe,+ mapMaybeM,++ -- ** Direct Transformations+ hoist,+ map,+ mapM,+ maps,+ mapped,+ mapsPost,+ mapsMPost,+ mappedPost,+ for,+ with,+ subst,+ copy,+ duplicate,+ store,+ chain,+ sequence,+ nubOrd,+ nubOrdOn,+ nubInt,+ nubIntOn,+ filter,+ filterM,+ intersperse,+ drop,+ dropWhile,+ scan,+ scanM,+ scanned,+ delay,+ read,+ show,+ cons,+ slidingWindow,+ wrapEffect,++ -- ** Internal+ destroyExposed,+ )+where++import Control.Concurrent (threadDelay)+import qualified Control.Functor.Linear as Control+import Data.Functor.Compose+import Data.Functor.Sum+import qualified Data.IntSet as IntSet+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import Data.Unrestricted.Linear+import GHC.Stack+import Prelude.Linear (($), (&), (.))+import Streaming.Linear.Internal.Type+import System.IO.Linear+import Text.Read (readMaybe)+import Prelude+ ( Bool (..),+ Double,+ Either (..),+ Eq (..),+ Int,+ Maybe (..),+ Num (..),+ Ord (..),+ Ordering (..),+ Read (..),+ String,+ id,+ )+import qualified Prelude++-- # Internal Library+-------------------------------------------------------------------------------++-- | When chunking streams, it's useful to have a combinator+-- that can add an element to the functor that is itself a stream.+-- Basically `consFirstChunk 42 [[1,2,3],[4,5]] = [[42,1,2,3],[4,5]]`.+consFirstChunk ::+ Control.Monad m =>+ a ->+ Stream (Stream (Of a) m) m r %1 ->+ Stream (Stream (Of a) m) m r+consFirstChunk a stream =+ stream & \case+ Return r -> Step (Step (a :> Return (Return r)))+ Effect m -> Effect $ Control.fmap (consFirstChunk a) m+ Step f -> Step (Step (a :> f))++-- This is an internal function used in 'seperate' from the original source.+-- It removes functoral and monadic steps and reduces to some type 'b'.+-- Here it's adapted to consume the stream linearly.+destroyExposed ::+ forall f m r b.+ (Control.Functor f, Control.Monad m) =>+ Stream f m r %1 ->+ (f b %1 -> b) ->+ (m b %1 -> b) ->+ (r %1 -> b) ->+ b+destroyExposed stream0 construct theEffect done = loop stream0+ where+ loop ::+ (Control.Functor f, Control.Monad m) =>+ Stream f m r %1 ->+ b+ loop stream =+ stream & \case+ Return r -> done r+ Effect m -> theEffect (Control.fmap loop m)+ Step f -> construct (Control.fmap loop f)++-- # Splitting and inspecting streams of elements+-------------------------------------------------------------------------------++-- Remark. Since the 'a' is not held linearly in the 'Of' pair,+-- we return it inside an 'Ur'.+--++-- | The standard way of inspecting the first item in a stream of elements, if the+-- stream is still \'running\'. The @Right@ case contains a+-- Haskell pair, where the more general @inspect@ would return a left-strict pair.+-- There is no reason to prefer @inspect@ since, if the @Right@ case is exposed,+-- the first element in the pair will have been evaluated to whnf.+--+-- > next :: Control.Monad m => Stream (Of a) m r %1-> m (Either r (a, Stream (Of a) m r))+-- > inspect :: Control.Monad m => Stream (Of a) m r %1-> m (Either r (Of a (Stream (Of a) m r)))+next ::+ forall a m r.+ Control.Monad m =>+ Stream (Of a) m r %1 ->+ m (Either r (Ur a, Stream (Of a) m r))+next stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m (Either r (Ur a, Stream (Of a) m r))+ loop stream =+ stream & \case+ Return r -> Control.return $ Left r+ Effect ms -> ms Control.>>= next+ Step (a :> as) -> Control.return $ Right (Ur a, as)+{-# INLINEABLE next #-}++-- | Inspect the first item in a stream of elements, without a return value.+uncons ::+ forall a m r.+ (Consumable r, Control.Monad m) =>+ Stream (Of a) m r %1 ->+ m (Maybe (a, Stream (Of a) m r))+uncons stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> m (Maybe (a, Stream (Of a) m r))+ loop stream =+ stream & \case+ Return r -> lseq r $ Control.return Nothing+ Effect ms -> ms Control.>>= uncons+ Step (a :> as) -> Control.return $ Just (a, as)+{-# INLINEABLE uncons #-}++-- | Split a succession of layers after some number, returning a streaming or+-- effectful pair. This function is the same as the 'splitsAt' exported by the+-- @Streaming@ module, but since this module is imported qualified, it can+-- usurp a Prelude name. It specializes to:+--+-- > splitAt :: Control.Monad m => Int -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)+splitAt ::+ forall f m r.+ (Control.Monad m, Control.Functor f) =>+ Int ->+ Stream f m r %1 ->+ Stream f m (Stream f m r)+splitAt n stream = loop n stream+ where+ loop :: Int -> Stream f m r %1 -> Stream f m (Stream f m r)+ loop n stream = case Prelude.compare n 0 of+ GT ->+ stream & \case+ Return r -> Return (Return r)+ Effect m -> Effect $ m Control.>>= (Control.return . splitAt n)+ Step f -> Step $ Control.fmap (splitAt (n - 1)) f+ _ -> Return stream+{-# INLINEABLE splitAt #-}++-- | Split a stream of elements wherever a given element arises.+-- The action is like that of 'Prelude.words'.+--+-- @+-- \>\>\> S.stdoutLn $ mapped S.toList $ S.split ' ' $ each' "hello world "+-- hello+-- world+-- @+split ::+ forall a m r.+ (Eq a, Control.Monad m) =>+ a ->+ Stream (Of a) m r %1 ->+ Stream (Stream (Of a) m) m r+split x stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream (Stream (Of a) m) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ m Control.>>= (Control.return . split x)+ Step (a :> as) -> case a == x of+ True -> split x as+ False -> consFirstChunk a (split x as)+{-# INLINEABLE split #-}++-- | Break a sequence upon meeting an element that falls under a predicate,+-- keeping it and the rest of the stream as the return value.+--+-- @+-- \>\>\> rest <- S.print $ S.break even $ each' [1,1,2,3]+-- 1+-- 1+-- \>\>\> S.print rest+-- 2+-- 3+-- @+break ::+ forall a m r.+ Control.Monad m =>+ (a -> Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m (Stream (Of a) m r)+break f stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) m (Stream (Of a) m r)+ loop stream =+ stream & \case+ Return r -> Return (Return r)+ Effect m -> Effect $ Control.fmap (break f) m+ Step (a :> as) -> case f a of+ True -> Return $ Step (a :> as)+ False -> Step (a :> (break f as))+{-# INLINEABLE break #-}++-- | Break during periods where the predicate is not satisfied,+-- grouping the periods when it is.+--+-- @+-- \>\>\> S.print $ mapped S.toList $ S.breaks not $ S.each' [False,True,True,False,True,True,False]+-- [True,True]+-- [True,True]+-- \>\>\> S.print $ mapped S.toList $ S.breaks id $ S.each' [False,True,True,False,True,True,False]+-- [False]+-- [False]+-- [False]+-- @+breaks ::+ forall a m r.+ Control.Monad m =>+ (a -> Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Stream (Of a) m) m r+breaks f stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream (Stream (Of a) m) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (breaks f) m+ Step (a :> as) -> case f a of+ True -> breaks f as+ False -> consFirstChunk a (breaks f as)+{-# INLINEABLE breaks #-}++-- Remark. The funny type of this seems to be made to interoperate well with+-- `purely` from the `foldl` package.+--++-- | Yield elements, using a fold to maintain state, until the accumulated+-- value satifies the supplied predicate. The fold will then be short-circuited+-- and the element that breaks it will be put after the break.+-- This function is easiest to use with 'Control.Foldl.purely'+--+-- @+-- \>\>\> rest <- each' [1..10] & L.purely S.breakWhen L.sum (>10) & S.print+-- 1+-- 2+-- 3+-- 4+-- \>\>\> S.print rest+-- 5+-- 6+-- 7+-- 8+-- 9+-- 10+-- @+breakWhen ::+ forall m a x b r.+ Control.Monad m =>+ (x -> a -> x) ->+ x ->+ (x -> b) ->+ (b -> Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m (Stream (Of a) m r)+breakWhen step x end pred stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) m (Stream (Of a) m r)+ loop stream =+ stream & \case+ Return r -> Return (Return r)+ Effect m -> Effect $ Control.fmap (breakWhen step x end pred) m+ Step (a :> as) -> case pred (end (step x a)) of+ False -> Step $ a :> (breakWhen step (step x a) end pred as)+ True -> Return (Step (a :> as))+{-# INLINEABLE breakWhen #-}++-- | Breaks on the first element to satisfy the predicate+breakWhen' ::+ Control.Monad m =>+ (a -> Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m (Stream (Of a) m r)+breakWhen' f stream = breakWhen (\_ a -> f a) True id id stream+{-# INLINE breakWhen' #-}++-- | Stream elements until one fails the condition, return the rest.+span ::+ Control.Monad m =>+ (a -> Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m (Stream (Of a) m r)+span f = break (Prelude.not Prelude.. f)+{-# INLINE span #-}++-- | Group elements of a stream in accordance with the supplied comparison.+--+-- @+-- \>\>\> S.print $ mapped S.toList $ S.groupBy (>=) $ each' [1,2,3,1,2,3,4,3,2,4,5,6,7,6,5]+-- [1]+-- [2]+-- [3,1,2,3]+-- [4,3,2,4]+-- [5]+-- [6]+-- [7,6,5]+-- @+groupBy ::+ forall a m r.+ Control.Monad m =>+ (a -> a -> Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Stream (Of a) m) m r+groupBy equals stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream (Stream (Of a) m) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (groupBy equals) m+ Step (a :> as) ->+ as & \case+ Return r -> Step (Step (a :> Return (Return r)))+ Effect m ->+ Effect $+ m Control.>>= (\s -> Control.return $ groupBy equals (Step (a :> s)))+ Step (a' :> as') -> case equals a a' of+ False ->+ Step $ Step $ a :> (Return $ groupBy equals (Step (a' :> as')))+ True ->+ Step $ Step $ a :> (Step $ a' :> (Return $ groupBy equals as'))+{-# INLINEABLE groupBy #-}++-- | Group successive equal items together+--+-- @+-- \>\>\> S.toList $ mapped S.toList $ S.group $ each' "baaaaad"+-- ["b","aaaaa","d"] :> ()+-- @+--+-- @+-- \>\>\> S.toList $ concats $ maps (S.drained . S.splitAt 1) $ S.group $ each' "baaaaaaad"+-- "bad" :> ()+-- @+group ::+ (Control.Monad m, Eq a) =>+ Stream (Of a) m r %1 ->+ Stream (Stream (Of a) m) m r+group = groupBy (==)+{-# INLINE group #-}++-- # Sum and compose manipulation+-------------------------------------------------------------------------------++-- Remark. Most of these functions are general and were merely cut and pasted+-- from the original library.++distinguish :: (a -> Bool) -> Of a r -> Sum (Of a) (Of a) r+distinguish predicate (a :> b) = case predicate a of+ True -> InR (a :> b)+ False -> InL (a :> b)+{-# INLINE distinguish #-}++-- | Swap the order of functors in a sum of functors.+--+-- @+-- \>\>\> S.toList $ S.print $ separate $ maps S.switch $ maps (S.distinguish (=='a')) $ S.each' "banana"+-- 'a'+-- 'a'+-- 'a'+-- "bnn" :> ()+-- \>\>\> S.toList $ S.print $ separate $ maps (S.distinguish (=='a')) $ S.each' "banana"+-- 'b'+-- 'n'+-- 'n'+-- "aaa" :> ()+-- @+switch :: Sum f g r -> Sum g f r+switch s = case s of InL a -> InR a; InR a -> InL a+{-# INLINE switch #-}++sumToEither :: Sum (Of a) (Of b) r -> Of (Either a b) r+sumToEither s = case s of+ InL (a :> r) -> Left a :> r+ InR (b :> r) -> Right b :> r+{-# INLINE sumToEither #-}++eitherToSum :: Of (Either a b) r -> Sum (Of a) (Of b) r+eitherToSum s = case s of+ Left a :> r -> InL (a :> r)+ Right b :> r -> InR (b :> r)+{-# INLINE eitherToSum #-}++composeToSum :: Compose (Of Bool) f r -> Sum f f r+composeToSum x = case x of+ Compose (True :> f) -> InR f+ Compose (False :> f) -> InL f+{-# INLINE composeToSum #-}++sumToCompose :: Sum f f r -> Compose (Of Bool) f r+sumToCompose x = case x of+ InR f -> Compose (True :> f)+ InL f -> Compose (False :> f)+{-# INLINE sumToCompose #-}++-- | Given a stream on a sum of functors, make it a stream on the left functor,+-- with the streaming on the other functor as the governing monad. This is+-- useful for acting on one or the other functor with a fold, leaving the+-- other material for another treatment. It generalizes+-- 'Data.Either.partitionEithers', but actually streams properly.+--+-- @+-- \>\>\> let odd_even = S.maps (S.distinguish even) $ S.each' [1..10::Int]+-- \>\>\> :t separate odd_even+-- separate odd_even+-- :: Monad m => Stream (Of Int) (Stream (Of Int) m) ()+-- @+--+-- Now, for example, it is convenient to fold on the left and right values separately:+--+-- @+-- \>\>\> S.toList $ S.toList $ separate odd_even+-- [2,4,6,8,10] :> ([1,3,5,7,9] :> ())+-- @+--+-- Or we can write them to separate files or whatever.+--+-- Of course, in the special case of @Stream (Of a) m r@, we can achieve the above+-- effects more simply by using 'Streaming.Prelude.copy'+--+-- @+-- \>\>\> S.toList . S.filter even $ S.toList . S.filter odd $ S.copy $ each' [1..10::Int]+-- [2,4,6,8,10] :> ([1,3,5,7,9] :> ())+-- @+--+-- But 'separate' and 'unseparate' are functor-general.+separate ::+ forall m f g r.+ (Control.Monad m, Control.Functor f, Control.Functor g) =>+ Stream (Sum f g) m r ->+ Stream f (Stream g m) r+separate stream = destroyExposed stream fromSum (Effect . Control.lift) Return+ where+ fromSum :: Sum f g (Stream f (Stream g m) r) %1 -> (Stream f (Stream g m) r)+ fromSum x =+ x & \case+ InL fss -> Step fss+ InR gss -> Effect (Step $ Control.fmap Return gss)+{-# INLINEABLE separate #-}++unseparate ::+ (Control.Monad m, Control.Functor f, Control.Functor g) =>+ Stream f (Stream g m) r ->+ Stream (Sum f g) m r+unseparate stream =+ destroyExposed stream (Step . InL) (Control.join . maps InR) Control.return+{-# INLINEABLE unseparate #-}++-- # Partitions+-------------------------------------------------------------------------------++-- |+-- > filter p = hoist effects (partition p)+partition ::+ forall a m r.+ Control.Monad m =>+ (a -> Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) (Stream (Of a) m) r+partition pred = loop+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) (Stream (Of a) m) r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect (Control.fmap loop (Control.lift m))+ Step (a :> as) -> case pred a of+ True -> Step (a :> loop as)+ False -> Effect $ Step $ a :> (Return (loop as))++-- | Separate left and right values in distinct streams. ('separate' is+-- a more powerful, functor-general, equivalent using 'Sum' in place of 'Either').+--+-- > partitionEithers = separate . maps S.eitherToSum+-- > lefts = hoist S.effects . partitionEithers+-- > rights = S.effects . partitionEithers+-- > rights = S.concat+partitionEithers ::+ Control.Monad m =>+ Stream (Of (Either a b)) m r %1 ->+ Stream (Of a) (Stream (Of b) m) r+partitionEithers = loop+ where+ loop ::+ Control.Monad m =>+ Stream (Of (Either a b)) m r %1 ->+ Stream (Of a) (Stream (Of b) m) r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop (Control.lift m)+ Step (Left a :> as) -> Step (a :> loop as)+ Step (Right b :> as) -> Effect $ (Step $ b :> Return (loop as))++-- # Maybes+-------------------------------------------------------------------------------++-- | The 'catMaybes' function takes a 'Stream' of 'Maybe's and returns+-- a 'Stream' of all of the 'Just' values. 'concat' has the same behavior,+-- but is more general; it works for any foldable container type.+catMaybes :: Control.Monad m => Stream (Of (Maybe a)) m r %1 -> Stream (Of a) m r+catMaybes stream = loop stream+ where+ loop :: Control.Monad m => Stream (Of (Maybe a)) m r %1 -> Stream (Of a) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap catMaybes m+ Step (maybe :> as) -> case maybe of+ Nothing -> catMaybes as+ Just a -> Step $ a :> (catMaybes as)+{-# INLINEABLE catMaybes #-}++-- | The 'mapMaybe' function is a version of 'map' which can throw out elements. In particular,+-- the functional argument returns something of type @'Maybe' b@. If this is 'Nothing', no element+-- is added on to the result 'Stream'. If it is @'Just' b@, then @b@ is included in the result 'Stream'.+mapMaybe ::+ forall a b m r.+ Control.Monad m =>+ (a -> Maybe b) ->+ Stream (Of a) m r %1 ->+ Stream (Of b) m r+mapMaybe f stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of b) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect ms -> Effect $ ms Control.>>= (Control.return . mapMaybe f)+ Step (a :> s) -> case f a of+ Just b -> Step $ b :> (mapMaybe f s)+ Nothing -> mapMaybe f s+{-# INLINEABLE mapMaybe #-}++-- Note: the first function needs to wrap the 'b' in an 'Ur'+-- since the control monad is bound and the 'b' ends up in the first+-- unrestricted spot of 'Of'.+--++-- | Map monadically over a stream, producing a new stream+-- only containing the 'Just' values.+mapMaybeM ::+ forall a m b r.+ Control.Monad m =>+ (a -> m (Maybe (Ur b))) ->+ Stream (Of a) m r %1 ->+ Stream (Of b) m r+mapMaybeM f stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of b) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (mapMaybeM f) m+ Step (a :> as) -> Effect $ Control.do+ mb <- f a+ mb & \case+ Nothing -> Control.return $ mapMaybeM f as+ Just (Ur b) -> Control.return $ Step (b :> mapMaybeM f as)+{-# INLINEABLE mapMaybeM #-}++-- # Direct Transformations+-------------------------------------------------------------------------------++-- | Change the effects of one monad to another with a transformation.+-- This is one of the fundamental transformations on streams.+-- Compare with 'maps':+--+-- > maps :: (Control.Monad m, Control.Functor f) => (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r+-- > hoist :: (Control.Monad m, Control.Functor f) => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r+hoist ::+ forall f m n r.+ (Control.Monad m, Control.Functor f) =>+ (forall a. m a %1 -> n a) ->+ Stream f m r %1 ->+ Stream f n r+hoist f stream = loop stream+ where+ loop :: Stream f m r %1 -> Stream f n r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ f $ Control.fmap loop m+ Step f -> Step $ Control.fmap loop f+{-# INLINEABLE hoist #-}++-- | Standard map on the elements of a stream.+--+-- @+-- \>\>\> S.stdoutLn $ S.map reverse $ each' (words "alpha beta")+-- ahpla+-- ateb+-- @+map :: Control.Monad m => (a -> b) -> Stream (Of a) m r %1 -> Stream (Of b) m r+map f = maps (\(x :> rest) -> f x :> rest)+{-# INLINEABLE map #-}++-- Remark.+--+-- The functor transformation in functions like maps, mapped, mapsPost,+-- and such must be linear since the 'Stream' data type holds each+-- functor step with a linear arrow.++-- | Map layers of one functor to another with a transformation. Compare+-- hoist, which has a similar effect on the 'monadic' parameter.+--+-- > maps id = id+-- > maps f . maps g = maps (f . g)+maps ::+ forall f g m r.+ (Control.Monad m, Control.Functor f) =>+ (forall x. f x %1 -> g x) ->+ Stream f m r %1 ->+ Stream g m r+maps phi = loop+ where+ loop :: Stream f m r %1 -> Stream g m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (maps phi) m+ Step f -> Step (phi (Control.fmap loop f))+{-# INLINEABLE maps #-}++-- Remark: Since the mapping function puts its result in a control monad,+-- it must be used exactly once after the monadic value is bound.+-- As a result the mapping function needs to return an 'Ur b'+-- so that we can place the 'b' in the first argument of the+-- 'Of' constructor, which is unrestricted.+--++-- | Replace each element of a stream with the result of a monadic action+--+-- @+-- \>\>\> S.print $ S.mapM readIORef $ S.chain (\ior -> modifyIORef ior (*100)) $ S.mapM newIORef $ each' [1..6]+-- 100+-- 200+-- 300+-- 400+-- 500+-- 600+-- @+--+-- See also 'chain' for a variant of this which ignores the return value of the function and just uses the side effects.+mapM ::+ Control.Monad m =>+ (a -> m (Ur b)) ->+ Stream (Of a) m r %1 ->+ Stream (Of b) m r+mapM f s = loop f s+ where+ loop ::+ Control.Monad m =>+ (a -> m (Ur b)) ->+ Stream (Of a) m r %1 ->+ Stream (Of b) m r+ loop f stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (loop f) m+ Step (a :> as) -> Effect $ Control.do+ Ur b <- f a+ Control.return $ Step (b :> (loop f as))+{-# INLINEABLE mapM #-}++-- | Map layers of one functor to another with a transformation. Compare+-- hoist, which has a similar effect on the 'monadic' parameter.+--+-- > mapsPost id = id+-- > mapsPost f . mapsPost g = mapsPost (f . g)+-- > mapsPost f = maps f+--+-- @mapsPost@ is essentially the same as 'maps', but it imposes a @Control.Functor@ constraint on+-- its target functor rather than its source functor. It should be preferred if 'fmap'+-- is cheaper for the target functor than for the source functor.+mapsPost ::+ forall m f g r.+ (Control.Monad m, Control.Functor g) =>+ (forall x. f x %1 -> g x) ->+ Stream f m r %1 ->+ Stream g m r+mapsPost phi = loop+ where+ loop :: Stream f m r %1 -> Stream g m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step f -> Step $ Control.fmap loop $ phi f+{-# INLINEABLE mapsPost #-}++-- | Map layers of one functor to another with a transformation involving the base monad.+--+-- This function is completely functor-general. It is often useful with the more concrete type+--+-- @+-- mapped :: (forall x. Stream (Of a) IO x -> IO (Of b x)) -> Stream (Stream (Of a) IO) IO r -> Stream (Of b) IO r+-- @+--+-- to process groups which have been demarcated in an effectful, @IO@-based+-- stream by grouping functions like 'Streaming.Prelude.group',+-- 'Streaming.Prelude.split' or 'Streaming.Prelude.breaks'. Summary functions+-- like 'Streaming.Prelude.fold', 'Streaming.Prelude.foldM',+-- 'Streaming.Prelude.mconcat' or 'Streaming.Prelude.toList' are often used+-- to define the transformation argument. For example:+--+-- @+-- \>\>\> S.toList_ $ S.mapped S.toList $ S.split 'c' (S.each' "abcde")+-- ["ab","de"]+-- @+--+-- 'Streaming.Prelude.maps' and 'Streaming.Prelude.mapped' obey these rules:+--+-- > maps id = id+-- > mapped return = id+-- > maps f . maps g = maps (f . g)+-- > mapped f . mapped g = mapped (f <=< g)+-- > maps f . mapped g = mapped (fmap f . g)+-- > mapped f . maps g = mapped (f <=< fmap g)+--+-- where @f@ and @g@ are @Control.Monad@s+--+-- 'Streaming.Prelude.maps' is more fundamental than+-- 'Streaming.Prelude.mapped', which is best understood as a convenience for+-- effecting this frequent composition:+--+-- > mapped phi = decompose . maps (Compose . phi)+mapped ::+ forall f g m r.+ (Control.Monad m, Control.Functor f) =>+ (forall x. f x %1 -> m (g x)) ->+ Stream f m r %1 ->+ Stream g m r+mapped phi = loop+ where+ loop :: Stream f m r %1 -> Stream g m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step f -> Effect $ Control.fmap Step $ phi $ Control.fmap loop f++-- | Map layers of one functor to another with a transformation involving the base monad.+-- @mapsMPost@ is essentially the same as 'mapsM', but it imposes a @Control.Functor@ constraint on+-- its target functor rather than its source functor. It should be preferred if 'fmap'+-- is cheaper for the target functor than for the source functor.+--+-- @mapsPost@ is more fundamental than @mapsMPost@, which is best understood as a convenience+-- for effecting this frequent composition:+--+-- > mapsMPost phi = decompose . mapsPost (Compose . phi)+--+-- The streaming prelude exports the same function under the better name @mappedPost@,+-- which overlaps with the lens libraries.+{-# INLINEABLE mapped #-}++mapsMPost ::+ forall m f g r.+ (Control.Monad m, Control.Functor g) =>+ (forall x. f x %1 -> m (g x)) ->+ Stream f m r %1 ->+ Stream g m r+mapsMPost phi = loop+ where+ loop :: Stream f m r %1 -> Stream g m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step f -> Effect $ Control.fmap (Step . Control.fmap loop) $ phi f+{-# INLINEABLE mapsMPost #-}++-- | A version of 'mapped' that imposes a @Control.Functor@ constraint on the target functor rather+-- than the source functor. This version should be preferred if 'fmap' on the target+-- functor is cheaper.+mappedPost ::+ forall m f g r.+ (Control.Monad m, Control.Functor g) =>+ (forall x. f x %1 -> m (g x)) ->+ Stream f m r %1 ->+ Stream g m r+mappedPost phi = loop+ where+ loop :: Stream f m r %1 -> Stream g m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step f -> Effect $ Control.fmap (Step . Control.fmap loop) $ phi f+{-# INLINEABLE mappedPost #-}++-- | @for@ replaces each element of a stream with an associated stream. Note that the+-- associated stream may layer any control functor.+for ::+ forall f m r a x.+ (Control.Monad m, Control.Functor f, Consumable x) =>+ Stream (Of a) m r %1 ->+ (a -> Stream f m x) ->+ Stream f m r+for stream expand = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream f m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step (a :> as) -> Control.do+ x <- expand a+ lseq x $ loop as+{-# INLINEABLE for #-}++-- Note: since the 'x' is discarded inside a control functor,+-- we need it to be consumable+--++-- | Replace each element in a stream of individual Haskell values (a @Stream (Of a) m r@) with an associated 'functorial' step.+--+-- > for str f = concats (with str f)+-- > with str f = for str (yields . f)+-- > with str f = maps (\(a:>r) -> r <$ f a) str+-- > with = flip subst+-- > subst = flip with+--+-- @+-- \>\>\> with (each' [1..3]) (yield . Prelude.show) & intercalates (yield "--") & S.stdoutLn+-- 1+-- --+-- 2+-- --+-- 3+-- @+with ::+ forall f m r a x.+ (Control.Monad m, Control.Functor f, Consumable x) =>+ Stream (Of a) m r %1 ->+ (a -> f x) ->+ Stream f m r+with s f = loop s+ where+ loop :: Stream (Of a) m r %1 -> Stream f m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step (a :> as) -> Step $ Control.fmap (`lseq` (loop as)) (f a)+{-# INLINEABLE with #-}++-- | Replace each element in a stream of individual values with a functorial+-- layer of any sort. @subst = flip with@ and is more convenient in+-- a sequence of compositions that transform a stream.+--+-- > with = flip subst+-- > for str f = concats $ subst f str+-- > subst f = maps (\(a:>r) -> r <$ f a)+-- > S.concat = concats . subst each+subst ::+ (Control.Monad m, Control.Functor f, Consumable x) =>+ (a -> f x) ->+ Stream (Of a) m r %1 ->+ Stream f m r+subst = flip with+ where+ flip :: (a %1 -> b -> c) -> b -> a %1 -> c+ flip f b a = f a b+{-# INLINE subst #-}++-- | Duplicate the content of a stream, so that it can be acted on twice in different ways,+-- but without breaking streaming. Thus, with @each' [1,2]@ I might do:+--+-- @+-- \>\>\> S.print $ each' ["one","two"]+-- "one"+-- "two"+-- \>\>\> S.stdoutLn $ each' ["one","two"]+-- one+-- two+-- @+--+-- With copy, I can do these simultaneously:+--+-- @+-- \>\>\> S.print $ S.stdoutLn $ S.copy $ each' ["one","two"]+-- "one"+-- one+-- "two"+-- two+-- @+--+-- 'copy' should be understood together with 'effects' and is subject to the rules+--+-- > S.effects . S.copy = id+-- > hoist S.effects . S.copy = id+--+-- The similar operations in 'Data.ByteString.Streaming' obey the same rules.+--+-- Where the actions you are contemplating are each simple folds over+-- the elements, or a selection of elements, then the coupling of the+-- folds is often more straightforwardly effected with `Control.Foldl`,+-- e.g.+--+-- @+-- \>\>\> L.purely S.fold (liftA2 (,) L.sum L.product) $ each' [1..10]+-- (55,3628800) :> ()+-- @+--+-- rather than+--+-- @+-- \>\>\> S.sum $ S.product . S.copy $ each' [1..10]+-- 55 :> (3628800 :> ())+-- @+--+-- A @Control.Foldl@ fold can be altered to act on a selection of elements by+-- using 'Control.Foldl.handles' on an appropriate lens. Some such+-- manipulations are simpler and more 'Data.List'-like, using 'copy':+--+-- @+-- \>\>\> L.purely S.fold (liftA2 (,) (L.handles (L.filtered odd) L.sum) (L.handles (L.filtered even) L.product)) $ each' [1..10]+-- (25,3840) :> ()+-- @+--+-- becomes+--+-- @+-- \>\>\> S.sum $ S.filter odd $ S.product $ S.filter even $ S.copy' $ each' [1..10]+-- 25 :> (3840 :> ())+-- @+--+-- or using 'store'+--+-- @+-- \>\>\> S.sum $ S.filter odd $ S.store (S.product . S.filter even) $ each' [1..10]+-- 25 :> (3840 :> ())+-- @+--+-- But anything that fold of a @Stream (Of a) m r@ into e.g. an @m (Of b r)@+-- that has a constraint on @m@ that is carried over into @Stream f m@ -+-- e.g. @Control.Monad@, @Control.Functor@, etc. can be used on the stream.+-- Thus, I can fold over different groupings of the original stream:+--+-- @+-- \>\>\> (S.toList . mapped S.toList . chunksOf 5) $ (S.toList . mapped S.toList . chunksOf 3) $ S.copy $ each' [1..10]+-- [[1,2,3,4,5],[6,7,8,9,10]] :> ([[1,2,3],[4,5,6],[7,8,9],[10]] :> ())+-- @+--+-- The procedure can be iterated as one pleases, as one can see from this (otherwise unadvisable!) example:+--+-- @+-- \>\>\> (S.toList . mapped S.toList . chunksOf 4) $ (S.toList . mapped S.toList . chunksOf 3) $ S.copy $ (S.toList . mapped S.toList . chunksOf 2) $ S.copy $ each' [1..12]+-- [[1,2,3,4],[5,6,7,8],[9,10,11,12]] :> ([[1,2,3],[4,5,6],[7,8,9],[10,11,12]] :> ([[1,2],[3,4],[5,6],[7,8],[9,10],[11,12]] :> ()))+-- @+--+-- @copy@ can be considered a special case of 'expand':+--+-- @+-- copy = 'expand' $ \p (a :> as) -> a :> p (a :> as)+-- @+--+-- If 'Of' were an instance of 'Control.Comonad.Comonad', then one could write+--+-- @+-- copy = 'expand' extend+-- @+copy ::+ forall a m r.+ Control.Monad m =>+ Stream (Of a) m r %1 ->+ Stream (Of a) (Stream (Of a) m) r+copy = Effect . Control.return . loop+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) (Stream (Of a) m) r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop (Control.lift m)+ Step (a :> as) -> Effect $ Step (a :> Return (Step (a :> loop as)))+{-# INLINEABLE copy #-}++-- | An alias for @copy@.+duplicate ::+ forall a m r.+ Control.Monad m =>+ Stream (Of a) m r %1 ->+ Stream (Of a) (Stream (Of a) m) r+duplicate = copy+{-# INLINE duplicate #-}++-- Note: to use the stream linearly the first argument+-- must be a linear function+--++-- | Store the result of any suitable fold over a stream, keeping the stream for+-- further manipulation. @store f = f . copy@ :+--+-- @+-- \>\>\> S.print $ S.store S.product $ each' [1..4]+-- 1+-- 2+-- 3+-- 4+-- 24 :> ()+-- @+--+-- @+-- \>\>\> S.print $ S.store S.sum $ S.store S.product $ each' [1..4]+-- 1+-- 2+-- 3+-- 4+-- 10 :> (24 :> ())+-- @+--+-- Here the sum (10) and the product (24) have been \'stored\' for use when+-- finally we have traversed the stream with 'print' . Needless to say,+-- a second 'pass' is excluded conceptually, so the+-- folds that you apply successively with @store@ are performed+-- simultaneously, and in constant memory -- as they would be if,+-- say, you linked them together with @Control.Fold@:+--+-- @+-- \>\>\> L.impurely S.foldM (liftA3 (\a b c -> (b, c)) (L.sink Prelude.print) (L.generalize L.sum) (L.generalize L.product)) $ each' [1..4]+-- 1+-- 2+-- 3+-- 4+-- (10,24) :> ()+-- @+--+-- Fusing folds after the fashion of @Control.Foldl@ will generally be a bit faster+-- than the corresponding succession of uses of 'store', but by+-- constant factor that will be completely dwarfed when any IO is at issue.+--+-- But 'store' \/ 'copy' is /much/ more powerful, as you can see by reflecting on+-- uses like this:+--+-- @+-- \>\>\> S.sum $ S.store (S.sum . mapped S.product . chunksOf 2) $ S.store (S.product . mapped S.sum . chunksOf 2) $ each' [1..6]+-- 21 :> (44 :> (231 :> ()))+-- @+--+-- It will be clear that this cannot be reproduced with any combination of lenses,+-- @Control.Fold@ folds, or the like. (See also the discussion of 'copy'.)+--+-- It would conceivably be clearer to import a series of specializations of 'store'.+-- It is intended to be used at types like this:+--+-- > storeM :: (forall s m . Control.Monad m => Stream (Of a) m s %1-> m (Of b s))+-- > -> (Control.Monad n => Stream (Of a) n r %1-> Stream (Of a) n (Of b r))+-- > storeM = store+--+-- It is clear from this type that we are just using the general instance:+--+-- > instance (Control.Functor f, Control.Monad m) => Control.Monad (Stream f m)+--+-- We thus can't be touching the elements of the stream, or the final return value.+-- It is the same with other constraints that @Stream (Of a)@ inherits from the underlying monad.+-- Thus I can independently filter and write to one file, but+-- nub and write to another, or interact with a database and a logfile and the like:+--+-- @+-- \>\>\> (S.writeFile "hello2.txt" . S.nubOrd) $ store (S.writeFile "hello.txt" . S.filter (/= "world")) $ each' ["hello", "world", "goodbye", "world"]+-- \>\>\> :! cat hello.txt+-- hello+-- goodbye+-- \>\>\> :! cat hello2.txt+-- hello+-- world+-- goodbye+-- @+store ::+ Control.Monad m =>+ (Stream (Of a) (Stream (Of a) m) r %1 -> t) ->+ Stream (Of a) m r %1 ->+ t+store f x = f (copy x)+{-# INLINE store #-}++-- Note: since we discard the 'y' inside a control monad, it needs to be+-- consumable+--++-- | Apply an action to all values, re-yielding each.+-- The return value (@y@) of the function is ignored.+--+-- @+-- \>\>\> S.product $ S.chain Prelude.print $ S.each' [1..5]+-- 1+-- 2+-- 3+-- 4+-- 5+-- 120 :> ()+-- @+--+-- See also 'mapM' for a variant of this which uses the return value of the function to transorm the values in the stream.+chain ::+ forall a m r y.+ (Control.Monad m, Consumable y) =>+ (a -> m y) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m r+chain f = loop+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step (a :> as) -> Effect $ Control.do+ y <- f a+ Control.return $ lseq y $ Step (a :> loop as)+{-# INLINEABLE chain #-}++-- Note: since the value of type 'a' is inside a control monad but+-- needs to be used in an unrestricted position in 'Of', the input stream+-- needs to hold values of type 'm (Ur a)'.+--++-- | Like the 'Data.List.sequence' but streaming. The result type is a+-- stream of a\'s, /but is not accumulated/; the effects of the elements+-- of the original stream are interleaved in the resulting stream. Compare:+--+-- > sequence :: Monad m => [m a] -> m [a]+-- > sequence :: Control.Monad m => Stream (Of (m a)) m r %1-> Stream (Of a) m r+sequence ::+ forall a m r.+ Control.Monad m =>+ Stream (Of (m (Ur a))) m r %1 ->+ Stream (Of a) m r+sequence = loop+ where+ loop :: Stream (Of (m (Ur a))) m r %1 -> Stream (Of a) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step (ma :> mas) -> Effect $ Control.do+ Ur a <- ma+ Control.return $ Step (a :> loop mas)+{-# INLINEABLE sequence #-}++-- | Remove repeated elements from a Stream. 'nubOrd' of course accumulates a 'Data.Set.Set' of+-- elements that have already been seen and should thus be used with care.+nubOrd :: (Control.Monad m, Ord a) => Stream (Of a) m r %1 -> Stream (Of a) m r+nubOrd = nubOrdOn id+{-# INLINE nubOrd #-}++-- | Use 'nubOrdOn' to have a custom ordering function for your elements.+nubOrdOn ::+ forall m a b r.+ (Control.Monad m, Ord b) =>+ (a -> b) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m r+nubOrdOn f xs = loop Set.empty xs+ where+ loop :: Set.Set b -> Stream (Of a) m r %1 -> Stream (Of a) m r+ loop !set stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (loop set) m+ Step (a :> as) -> case Set.member (f a) set of+ True -> loop set as+ False -> Step (a :> loop (Set.insert (f a) set) as)++-- | More efficient versions of above when working with 'Int's that use 'Data.IntSet.IntSet'.+nubInt :: Control.Monad m => Stream (Of Int) m r %1 -> Stream (Of Int) m r+nubInt = nubIntOn id+{-# INLINE nubInt #-}++nubIntOn ::+ forall m a r.+ (Control.Monad m) =>+ (a -> Int) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m r+nubIntOn f xs = loop IntSet.empty xs+ where+ loop :: IntSet.IntSet -> Stream (Of a) m r %1 -> Stream (Of a) m r+ loop !set stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (loop set) m+ Step (a :> as) -> case IntSet.member (f a) set of+ True -> loop set as+ False -> Step (a :> loop (IntSet.insert (f a) set) as)++-- | Skip elements of a stream that fail a predicate+filter ::+ forall a m r.+ Control.Monad m =>+ (a -> Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m r+filter pred = loop+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step (a :> as) -> case pred a of+ True -> Step (a :> loop as)+ False -> loop as+{-# INLINE filter #-}++-- | Skip elements of a stream that fail a monadic test+filterM ::+ forall a m r.+ Control.Monad m =>+ (a -> m Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m r+filterM pred = loop+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step (a :> as) -> Effect $ Control.do+ bool <- pred a+ bool & \case+ True -> Control.return $ Step (a :> loop as)+ False -> Control.return $ loop as+{-# INLINE filterM #-}++-- | Intersperse given value between each element of the stream.+--+-- @+-- \>\>\> S.print $ S.intersperse 0 $ each [1,2,3]+-- 1+-- 0+-- 2+-- 0+-- 3+-- @+intersperse ::+ forall a m r.+ Control.Monad m =>+ a ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m r+intersperse x stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (intersperse x) m+ Step (a :> as) -> loop a as+ where+ -- Given the first element of a stream, intersperse the bound+ -- element named 'x'+ loop :: a -> Stream (Of a) m r %1 -> Stream (Of a) m r+ loop !a stream =+ stream & \case+ Return r -> Step (a :> Return r)+ Effect m -> Effect $ Control.fmap (loop a) m+ Step (a' :> as) -> Step (a :> Step (x :> loop a' as))+{-# INLINEABLE intersperse #-}++-- | Ignore the first n elements of a stream, but carry out the actions+--+-- @+-- \>\>\> S.toList $ S.drop 2 $ S.replicateM 5 getLine+-- a<Enter>+-- b<Enter>+-- c<Enter>+-- d<Enter>+-- e<Enter>+-- ["c","d","e"] :> ()+-- @+--+-- Because it retains the final return value, @drop n@ is a suitable argument+-- for @maps@:+--+-- @+-- \>\>\> S.toList $ concats $ maps (S.drop 4) $ chunksOf 5 $ each [1..20]+-- [5,10,15,20] :> ()+-- @+drop ::+ forall a m r.+ (HasCallStack, Control.Monad m) =>+ Int ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m r+drop n stream = case compare n 0 of+ LT -> Prelude.error "drop called with negative int" $ stream+ EQ -> stream+ GT -> loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (drop n) m+ Step (_ :> as) -> drop (n - 1) as+{-# INLINEABLE drop #-}++-- | Ignore elements of a stream until a test succeeds, retaining the rest.+--+-- @+-- \>\>\> S.print $ S.dropWhile ((< 5) . length) S.stdinLn+-- one<Enter>+-- two<Enter>+-- three<Enter>+-- "three"+-- four<Enter>+-- "four"+-- ^CInterrupted.+-- @+dropWhile ::+ forall a m r.+ Control.Monad m =>+ (a -> Bool) ->+ Stream (Of a) m r %1 ->+ Stream (Of a) m r+dropWhile pred = loop+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of a) m r+ loop stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap loop m+ Step (a :> as) -> case pred a of+ True -> loop as+ False -> Step (a :> as)+{-# INLINEABLE dropWhile #-}++-- | Strict left scan, streaming, e.g. successive partial results. The seed+-- is yielded first, before any action of finding the next element is performed.+--+-- @+-- \>\>\> S.print $ S.scan (++) "" id $ each' (words "a b c d")+-- ""+-- "a"+-- "ab"+-- "abc"+-- "abcd"+-- @+--+-- 'scan' is fitted for use with @Control.Foldl@, thus:+--+-- @+-- \>\>\> S.print $ L.purely S.scan L.list $ each' [3..5]+-- []+-- [3]+-- [3,4]+-- [3,4,5]+-- @+scan ::+ forall a x b m r.+ Control.Monad m =>+ (x -> a -> x) ->+ x ->+ (x -> b) ->+ Stream (Of a) m r %1 ->+ Stream (Of b) m r+scan step begin done stream = Step (done begin :> loop begin stream)+ where+ loop :: x -> Stream (Of a) m r %1 -> Stream (Of b) m r+ loop !acc stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (loop acc) m+ Step (a :> as) -> Step (done acc' :> loop acc' as)+ where+ !acc' = step acc a+{-# INLINEABLE scan #-}++-- Note: since the accumulated value (inside the control monad) is used both in+-- populating the output stream and in accumulation, it needs to be wrapped in+-- an 'Ur' accross the function+--++-- | Strict left scan, accepting a monadic function. It can be used with+-- 'FoldM's from @Control.Foldl@ using 'impurely'. Here we yield+-- a succession of vectors each recording+--+-- @+-- \>\>\> let v = L.impurely scanM L.vectorM $ each' [1..4::Int] :: Stream (Of (Vector Int)) IO ()+-- \>\>\> S.print v+-- []+-- [1]+-- [1,2]+-- [1,2,3]+-- [1,2,3,4]+-- @+scanM ::+ forall a x b m r.+ Control.Monad m =>+ (x %1 -> a -> m (Ur x)) ->+ m (Ur x) ->+ (x %1 -> m (Ur b)) ->+ Stream (Of a) m r %1 ->+ Stream (Of b) m r+scanM step mx done stream = loop stream+ where+ loop :: Stream (Of a) m r %1 -> Stream (Of b) m r+ loop stream =+ stream & \case+ Return r -> Effect $ Control.do+ Ur x <- mx+ Ur b <- done x+ Control.return $ Step $ b :> Return r+ Effect m -> Effect $ Control.fmap (scanM step mx done) m+ Step (a :> as) -> Effect $ Control.do+ Ur x <- mx+ Ur b <- done x+ Control.return $ Step $ b :> (scanM step (step x a) done as)+{-# INLINEABLE scanM #-}++-- | Label each element in a stream with a value accumulated according to a fold.+--+-- @+-- \>\>\> S.print $ S.scanned (*) 1 id $ S.each' [100,200,300]+-- (100,100)+-- (200,20000)+-- (300,6000000)+-- @+--+-- @+-- \>\>\> S.print $ L.purely S.scanned' L.product $ S.each [100,200,300]+-- (100,100)+-- (200,20000)+-- (300,6000000)+-- @+scanned ::+ forall a x b m r.+ Control.Monad m =>+ (x -> a -> x) ->+ x ->+ (x -> b) ->+ Stream (Of a) m r %1 ->+ Stream (Of (a, b)) m r+scanned step begin done = loop begin+ where+ loop :: x -> Stream (Of a) m r %1 -> Stream (Of (a, b)) m r+ loop !x stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.fmap (loop x) m+ Step (a :> as) -> Control.do+ let !acc = done (step x a)+ Step $ (a, acc) :> Return () -- same as yield+ loop (step x a) as+{-# INLINEABLE scanned #-}++-- Note: this skips failed parses+-- XXX re-write with Text+--++-- | Make a stream of strings into a stream of parsed values, skipping bad cases+--+-- @+-- \>\>\> S.sum_ $ S.read $ S.takeWhile (/= "total") S.stdinLn :: IO Int+-- 1000<Enter>+-- 2000<Enter>+-- total<Enter>+-- 3000+-- @+read ::+ (Control.Monad m, Read a) =>+ Stream (Of String) m r %1 ->+ Stream (Of a) m r+read = mapMaybe readMaybe+{-# INLINE read #-}++-- | Interpolate a delay of n seconds between yields.+delay :: forall a r. Double -> Stream (Of a) IO r %1 -> Stream (Of a) IO r+delay seconds = loop+ where+ pico = Prelude.truncate (seconds * 1000000)+ loop :: Stream (Of a) IO r %1 -> Stream (Of a) IO r+ loop stream = Control.do+ e <- Control.lift $ next stream+ e & \case+ Left r -> Return r+ Right (Ur a, rest) -> Control.do+ Step (a :> Return ()) -- same as yield+ Control.lift $ fromSystemIO $ threadDelay pico+ loop rest+{-# INLINEABLE delay #-}++show ::+ (Control.Monad m, Prelude.Show a) =>+ Stream (Of a) m r %1 ->+ Stream (Of String) m r+show = map Prelude.show+{-# INLINE show #-}++-- | The natural @cons@ for a @Stream (Of a)@.+--+-- > cons a stream = yield a Control.>> stream+--+-- Useful for interoperation:+--+-- > Data.Text.foldr S.cons (return ()) :: Text -> Stream (Of Char) m ()+-- > Lazy.foldrChunks S.cons (return ()) :: Lazy.ByteString -> Stream (Of Strict.ByteString) m ()+--+-- and so on.+cons :: Control.Monad m => a -> Stream (Of a) m r %1 -> Stream (Of a) m r+cons a str = Step (a :> str)+{-# INLINE cons #-}++-- Note. The action function that is the second argument must be linear since+-- it gets its argument from binding to the first argument, which uses a+-- control monad.+--++-- | Before evaluating the monadic action returning the next step in the 'Stream', @wrapEffect@+-- extracts the value in a monadic computation @m a@ and passes it to a computation @a -> m y@.+wrapEffect ::+ (Control.Monad m, Control.Functor f, Consumable y) =>+ m a ->+ (a %1 -> m y) ->+ Stream f m r %1 ->+ Stream f m r+wrapEffect ma action stream =+ stream & \case+ Return r -> Return r+ Effect m -> Effect $ Control.do+ a <- ma+ y <- action a+ lseq y $ m+ Step f -> Effect $ Control.do+ a <- ma+ y <- action a+ Control.return $ lseq y $ Step f++-- | 'slidingWindow' accumulates the first @n@ elements of a stream,+-- update thereafter to form a sliding window of length @n@.+-- It follows the behavior of the slidingWindow function in+-- <https://hackage.haskell.org/package/conduit-combinators-1.0.4/docs/Data-Conduit-Combinators.html#v:slidingWindow conduit-combinators>.+--+-- @+-- \>\>\> S.print $ S.slidingWindow 4 $ S.each "123456"+-- fromList "1234"+-- fromList "2345"+-- fromList "3456"+-- @+slidingWindow ::+ forall a b m.+ Control.Monad m =>+ Int ->+ Stream (Of a) m b %1 ->+ Stream (Of (Seq.Seq a)) m b+slidingWindow n = setup (max 1 n :: Int) Seq.empty+ where+ -- Given the current sliding window, yield it and then recurse with+ -- updated sliding window+ window :: Seq.Seq a -> Stream (Of a) m b %1 -> Stream (Of (Seq.Seq a)) m b+ window !sequ str = Control.do+ e <- Control.lift (next str)+ e & \case+ Left r -> Control.return r+ Right (Ur a, rest) -> Control.do+ Step $ (sequ Seq.|> a) :> Return () -- same as yield+ window (Seq.drop 1 sequ Seq.|> a) rest+ -- Collect the first n elements in a sequence and call 'window'+ setup ::+ Int -> Seq.Seq a -> Stream (Of a) m b %1 -> Stream (Of (Seq.Seq a)) m b+ setup 0 !sequ str = Control.do+ Step (sequ :> Return ()) -- same as yield+ window (Seq.drop 1 sequ) str+ setup n' sequ str = Control.do+ e <- Control.lift $ next str+ e & \case+ Left r -> Control.do+ Step (sequ :> Return ()) -- same as yield+ Control.return r+ Right (Ur x, rest) -> setup (n' - 1) (sequ Seq.|> x) rest+{-# INLINEABLE slidingWindow #-}
+ src/Streaming/Linear/Internal/Produce.hs view
@@ -0,0 +1,581 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++-- | This module provides all functions which produce a+-- 'Stream (Of a) m r' from some given non-stream inputs.+module Streaming.Linear.Internal.Produce+ ( -- * Constructing Finite 'Stream's+ yield,+ each',+ unfoldr,+ fromHandle,+ readFile,+ replicate,+ replicateM,+ replicateZip,+ untilRight,++ -- * Working with infinite 'Stream's+ stdinLnN,+ stdinLnUntil,+ stdinLnUntilM,+ stdinLnZip,+ readLnN,+ readLnUntil,+ readLnUntilM,+ readLnZip,+ iterateN,+ iterateZip,+ iterateMN,+ iterateMZip,+ cycleN,+ cycleZip,+ enumFromN,+ enumFromZip,+ enumFromThenN,+ enumFromThenZip,+ )+where++import qualified Control.Functor.Linear as Control+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Unrestricted.Linear+import GHC.Stack+import Prelude.Linear (($), (&))+import Streaming.Linear.Internal.Consume (effects)+import Streaming.Linear.Internal.Process+import Streaming.Linear.Internal.Type+import qualified System.IO as System+import System.IO.Linear+import System.IO.Resource.Linear+import Prelude+ ( Bool (..),+ Either (..),+ Enum,+ Eq (..),+ FilePath,+ Int,+ Num (..),+ Ord (..),+ Read,+ fromEnum,+ otherwise,+ toEnum,+ )+import qualified Prelude++-- # The Finite Stream Constructors+-------------------------------------------------------------------------------++-- | A singleton stream+--+-- @+-- \>\>\> stdoutLn $ yield "hello"+-- hello+-- @+--+-- @+-- \>\>\> S.sum $ do {yield 1; yield 2; yield 3}+-- 6 :> ()+-- @+yield :: Control.Monad m => a -> Stream (Of a) m ()+yield x = Step $ x :> Return ()+{-# INLINE yield #-}++-- | Stream the elements of a pure, foldable container.+--+-- @+-- \>\>\> S.print $ each' [1..3]+-- 1+-- 2+-- 3+-- @+each' :: Control.Monad m => [a] -> Stream (Of a) m ()+each' xs = Prelude.foldr (\a stream -> Step $ a :> stream) (Return ()) xs+{-# INLINEABLE each' #-}++-- | Build a @Stream@ by unfolding steps starting from a seed. In particular note+-- that @S.unfoldr S.next = id@.+unfoldr ::+ Control.Monad m =>+ (s %1 -> m (Either r (Ur a, s))) ->+ s %1 ->+ Stream (Of a) m r+unfoldr step s = unfoldr' step s+ where+ unfoldr' ::+ Control.Monad m =>+ (s %1 -> m (Either r (Ur a, s))) ->+ s %1 ->+ Stream (Of a) m r+ unfoldr' step s =+ Effect $+ step s Control.>>= \case+ Left r -> Control.return $ Return r+ Right (Ur a, s') ->+ Control.return $ Step $ a :> unfoldr step s'+{-# INLINEABLE unfoldr #-}++-- Note: we use the RIO monad from linear base to enforce+-- the protocol of file handles and file I/O+fromHandle :: Handle %1 -> Stream (Of Text) RIO ()+fromHandle h = loop h+ where+ loop :: Handle %1 -> Stream (Of Text) RIO ()+ loop h = Control.do+ (Ur isEOF, h') <- Control.lift $ hIsEOF h+ case isEOF of+ True -> Control.do+ Control.lift $ hClose h'+ Control.return ()+ False -> Control.do+ (Ur text, h'') <- Control.lift $ hGetLine h'+ yield text+ fromHandle h''+{-# INLINEABLE fromHandle #-}++-- | Read the lines of a file given the filename.+readFile :: FilePath -> Stream (Of Text) RIO ()+readFile path = Control.do+ handle <- Control.lift $ openFile path System.ReadMode+ fromHandle handle++-- | Repeat an element several times.+replicate :: (HasCallStack, Control.Monad m) => Int -> a -> Stream (Of a) m ()+replicate n a+ | n < 0 = Prelude.error "Cannot replicate a stream of negative length"+ | otherwise = loop n a+ where+ loop :: Control.Monad m => Int -> a -> Stream (Of a) m ()+ loop n a+ | n == 0 = Return ()+ | otherwise = Effect $ Control.return $ Step $ a :> loop (n - 1) a+{-# INLINEABLE replicate #-}++-- | Repeat an action several times, streaming its results.+--+-- @+-- \>\>\> import qualified Unsafe.Linear as Unsafe+-- \>\>\> import qualified Data.Time as Time+-- \>\>\> let getCurrentTime = fromSystemIO (Unsafe.coerce Time.getCurrentTime)+-- \>\>\> S.print $ S.replicateM 2 getCurrentTime+-- 2015-08-18 00:57:36.124508 UTC+-- 2015-08-18 00:57:36.124785 UTC+-- @+replicateM ::+ Control.Monad m =>+ Int ->+ m (Ur a) ->+ Stream (Of a) m ()+replicateM n ma+ | n < 0 = Prelude.error "Cannot replicate a stream of negative length"+ | otherwise = loop n ma+ where+ loop :: Control.Monad m => Int -> m (Ur a) -> Stream (Of a) m ()+ loop n ma+ | n == 0 = Return ()+ | otherwise = Effect $ Control.do+ Ur a <- ma+ Control.return $ Step $ a :> (replicateM (n - 1) ma)++-- | Replicate a constant element and zip it with the finite stream which+-- is the first argument.+replicateZip ::+ Control.Monad m =>+ Stream (Of x) m r ->+ a ->+ Stream (Of (a, x)) m r+replicateZip stream a = map ((,) a) stream+{-# INLINEABLE replicateZip #-}++untilRight ::+ forall m a r.+ Control.Monad m =>+ m (Either (Ur a) r) ->+ Stream (Of a) m r+untilRight mEither = Effect loop+ where+ loop :: m (Stream (Of a) m r)+ loop = Control.do+ either <- mEither+ either & \case+ Left (Ur a) ->+ Control.return $ Step $ a :> (untilRight mEither)+ Right r -> Control.return $ Return r+{-# INLINEABLE untilRight #-}++-- # The \"Affine\" 'Stream'+-------------------------------------------------------------------------------++-- | An *affine stream is represented with a state of type @x@,+-- a possibly terminating step function of type @(x %1-> m (Either (f x) r))@,+-- and a stop-short function @(x %1-> m r)@.+--+-- This mirrors the unfold of a normal stream:+--+-- > data Stream f m r where+-- > Stream :: x %1-> (x %1-> m (Either (f x) r)) -> Stream f m r+--+-- *Though referred to as an \"affine stream\" this might not be the correct+-- definition for affine streams. Sorting this out requires a bit more+-- careful thought.+data AffineStream f m r where+ AffineStream ::+ x %1 ->+ (x %1 -> m (Either (f x) r)) ->+ (x %1 -> m r) ->+ AffineStream f m r++-- | Take @n@ number of elements from the affine stream, for non-negative+-- @n@. (Negative @n@ is treated as 0.)+take ::+ forall f m r.+ (Control.Monad m, Control.Functor f) =>+ Int ->+ AffineStream f m r %1 ->+ Stream f m r+take = loop+ where+ loop :: Int -> AffineStream f m r %1 -> Stream f m r+ loop n (AffineStream s step end)+ | n <= 0 = Effect $ Control.fmap Control.return $ end s+ | otherwise = Effect $ Control.do+ next <- step s+ next & \case+ Right r -> Control.return (Return r)+ Left fx ->+ Control.return $+ Step $+ Control.fmap (\x -> loop (n - 1) (AffineStream x step end)) fx+{-# INLINEABLE take #-}++-- | Run an affine stream until it ends or a monadic test succeeds.+-- Drop the element it succeeds on.+untilM ::+ forall a m r.+ Control.Monad m =>+ (a -> m Bool) ->+ AffineStream (Of a) m r %1 ->+ Stream (Of a) m r+untilM = loop+ where+ loop :: (a -> m Bool) -> AffineStream (Of a) m r %1 -> Stream (Of a) m r+ loop test (AffineStream s step end) = Effect $ Control.do+ next <- step s+ next & \case+ Right r -> Control.return (Return r)+ Left (a :> next) -> Control.do+ testResult <- test a+ testResult & \case+ False ->+ Control.return $+ Step $ a :> loop test (AffineStream next step end)+ True -> Control.fmap Control.return $ end next+{-# INLINEABLE untilM #-}++-- | Like 'untilM' but without the monadic test.+until ::+ forall a m r.+ Control.Monad m =>+ (a -> Bool) ->+ AffineStream (Of a) m r %1 ->+ Stream (Of a) m r+until = loop+ where+ loop :: (a -> Bool) -> AffineStream (Of a) m r %1 -> Stream (Of a) m r+ loop test (AffineStream s step end) = Effect $ Control.do+ next <- step s+ next & \case+ Right r -> Control.return (Return r)+ Left (a :> next) -> case test a of+ True -> Control.fmap Control.return $ end next+ False ->+ Control.return $+ Step $+ a :> loop test (AffineStream next step end)+{-# INLINEABLE until #-}++-- | Zip a finite stream with an affine stream.+zip ::+ forall a x m r1 r2.+ Control.Monad m =>+ Stream (Of x) m r1 %1 ->+ AffineStream (Of a) m r2 %1 ->+ Stream (Of (x, a)) m (r1, r2)+zip = loop+ where+ loop ::+ Stream (Of x) m r1 %1 ->+ AffineStream (Of a) m r2 %1 ->+ Stream (Of (x, a)) m (r1, r2)+ loop stream (AffineStream s step end) =+ stream & \case+ Return r1 ->+ Effect $+ Control.fmap (\r2 -> Control.return $ (r1, r2)) $ end s+ Effect m ->+ Effect $+ Control.fmap (\str -> loop str (AffineStream s step end)) m+ Step (x :> rest) -> Effect $ Control.do+ next <- step s+ next & \case+ Right r2 -> Control.do+ r1 <- effects rest+ Control.return (Return (r1, r2))+ Left (a :> rest') ->+ Control.return $+ Step $+ (x, a) :> loop rest (AffineStream rest' step end)+{-# INLINEABLE zip #-}++-- | An affine stream of standard input lines.+stdinLn :: AffineStream (Of Text) IO ()+stdinLn = AffineStream () getALine Control.pure+ where+ getALine :: () %1 -> IO (Either (Of Text ()) ())+ getALine () = Control.do+ Ur line <- fromSystemIOU System.getLine+ Control.return $ Left (Text.pack line :> ())++-- | An affine stream of reading lines, crashing on failed parse.+readLn :: Read a => AffineStream (Of a) IO ()+readLn = AffineStream () readALine Control.pure+ where+ readALine :: Read a => () %1 -> IO (Either (Of a ()) ())+ readALine () = Control.do+ Ur line <- fromSystemIOU System.getLine+ Control.return $ Left (Prelude.read line :> ())++-- | An affine stream iterating an initial state forever.+iterate ::+ forall a m.+ Control.Monad m =>+ a ->+ (a -> a) ->+ AffineStream (Of a) m ()+iterate a step =+ AffineStream (Ur a) stepper (\x -> Control.return $ consume x)+ where+ stepper :: Ur a %1 -> m (Either (Of a (Ur a)) ())+ stepper (Ur a) =+ Control.return $+ Left $ a :> Ur (step a)++-- | An affine stream monadically iterating an initial state forever.+iterateM ::+ forall a m.+ Control.Monad m =>+ m (Ur a) ->+ (a -> m (Ur a)) ->+ AffineStream (Of a) m ()+iterateM ma step =+ AffineStream ma stepper (Control.fmap consume)+ where+ stepper :: m (Ur a) %1 -> m (Either (Of a (m (Ur a))) ())+ stepper ma = Control.do+ Ur a <- ma+ Control.return $ Left $ a :> (step a)++-- Remark. In order to implement the affine break function, which is the third+-- argument of the constructor, we need to specify the functor as @Of@.+-- Approaches to keeping it functor general seem messy.++-- | An affine stream cycling through a given finite stream forever.+cycle ::+ forall a m r.+ (Control.Monad m, Consumable r) =>+ Stream (Of a) m r ->+ AffineStream (Of a) m r+cycle stream =+ -- Note. The state is (original stream, stream_in_current_cycle)+ AffineStream (Ur stream, stream) stepStream leftoverEffects+ where+ leftoverEffects ::+ (Ur (Stream (Of a) m r), Stream (Of a) m r) %1 -> m r+ leftoverEffects (Ur _, str) = effects str++ stepStream ::+ Control.Functor f =>+ (Ur (Stream f m r), Stream f m r) %1 ->+ m (Either (f (Ur (Stream f m r), Stream f m r)) r)+ stepStream (Ur s, str) =+ str & \case+ Return r -> lseq r $ stepStream (Ur s, s)+ Effect m ->+ m Control.>>= (\stream -> stepStream (Ur s, stream))+ Step f ->+ Control.return $+ Left $ Control.fmap ((,) (Ur s)) f++-- | An affine stream iterating an enumerated stream forever.+enumFrom :: (Control.Monad m, Enum e) => e -> AffineStream (Of e) m ()+enumFrom e = iterate e Prelude.succ++-- | An affine stream iterating an enumerated stream forever, using the+-- first two elements to determine the gap to skip by.+-- E.g., @enumFromThen 3 5@ is like @[3,5..]@.+enumFromThen ::+ forall e m.+ (Control.Monad m, Enum e) =>+ e ->+ e ->+ AffineStream (Of e) m ()+enumFromThen e e' = iterate e enumStep+ where+ enumStep :: e -> e+ enumStep enum =+ toEnum $+ (fromEnum enum) + ((fromEnum e') - (fromEnum e))++-- Think: \enum -> enum + stepSize where stepSize = (e1 - e0)++-- # Working with infinite 'Stream's+-------------------------------------------------------------------------------++-- | @stdinLnN n@ is a stream of @n@ lines from standard input+stdinLnN :: Int -> Stream (Of Text) IO ()+stdinLnN n = take n stdinLn+{-# INLINE stdinLnN #-}++-- | Provides a stream of standard input and omits the first line+-- that satisfies the predicate, possibly requiring IO+stdinLnUntilM :: (Text -> IO Bool) -> Stream (Of Text) IO ()+stdinLnUntilM test = untilM test stdinLn+{-# INLINE stdinLnUntilM #-}++-- | Provides a stream of standard input and omits the first line+-- that satisfies the predicate+stdinLnUntil :: (Text -> Bool) -> Stream (Of Text) IO ()+stdinLnUntil test = until test stdinLn+{-# INLINE stdinLnUntil #-}++-- | Given a finite stream, provide a stream of lines of standard input+-- zipped with that finite stream+stdinLnZip :: Stream (Of x) IO r %1 -> Stream (Of (x, Text)) IO r+stdinLnZip stream = Control.fmap (\(r, ()) -> r) $ zip stream stdinLn+{-# INLINE stdinLnZip #-}++readLnN :: Read a => Int -> Stream (Of a) IO ()+readLnN n = take n readLn+{-# INLINE readLnN #-}++readLnUntilM :: Read a => (a -> IO Bool) -> Stream (Of a) IO ()+readLnUntilM test = untilM test readLn+{-# INLINE readLnUntilM #-}++readLnUntil :: Read a => (a -> Bool) -> Stream (Of a) IO ()+readLnUntil test = until test readLn+{-# INLINE readLnUntil #-}++readLnZip :: Read a => Stream (Of x) IO r %1 -> Stream (Of (x, a)) IO r+readLnZip stream = Control.fmap (\(r, ()) -> r) $ zip stream readLn+{-# INLINE readLnZip #-}++-- | Iterate a pure function from a seed value,+-- streaming the results forever.+iterateN :: Control.Monad m => Int -> (a -> a) -> a -> Stream (Of a) m ()+iterateN n step a = take n $ iterate a step+{-# INLINE iterateN #-}++iterateZip ::+ Control.Monad m =>+ Stream (Of x) m r ->+ (a -> a) ->+ a ->+ Stream (Of (x, a)) m r+iterateZip stream step a =+ Control.fmap (\(r, ()) -> r) $ zip stream $ iterate a step+{-# INLINE iterateZip #-}++-- | Iterate a monadic function from a seed value,+-- streaming the results forever.+iterateMN ::+ Control.Monad m =>+ Int ->+ (a -> m (Ur a)) ->+ m (Ur a) ->+ Stream (Of a) m ()+iterateMN n step ma = take n $ iterateM ma step+{-# INLINE iterateMN #-}++iterateMZip ::+ Control.Monad m =>+ Stream (Of x) m r %1 ->+ (a -> m (Ur a)) ->+ m (Ur a) ->+ Stream (Of (x, a)) m r+iterateMZip stream step ma =+ Control.fmap (\(r, ()) -> r) $ zip stream $ iterateM ma step+{-# INLINE iterateMZip #-}++-- | Cycle a stream a finite number of times+cycleN ::+ (Control.Monad m, Consumable r) =>+ Int ->+ Stream (Of a) m r ->+ Stream (Of a) m r+cycleN n stream = take n $ cycle stream+{-# INLINE cycleN #-}++-- | @cycleZip s1 s2@ will cycle @s2@ just enough to zip with the given finite+-- stream @s1@. Note that we consume all the effects of the remainder of the+-- cycled stream @s2@. That is, we consume @s2@ the smallest natural number of+-- times we need to zip.+cycleZip ::+ (Control.Monad m, Consumable s) =>+ Stream (Of a) m r %1 ->+ Stream (Of b) m s ->+ Stream (Of (a, b)) m (r, s)+cycleZip str stream = zip str $ cycle stream+{-# INLINE cycleZip #-}++-- | An finite sequence of enumerable values at a fixed distance, determined+-- by the first and second values.+--+-- @+-- \>\>\> S.print $ S.enumFromThenN 3 100 200+-- 100+-- 200+-- 300+-- @+enumFromThenN :: (Control.Monad m, Enum e) => Int -> e -> e -> Stream (Of e) m ()+enumFromThenN n e e' = take n $ enumFromThen e e'+{-# INLINE enumFromThenN #-}++-- | A finite sequence of enumerable values at a fixed distance determined+-- by the first and second values. The length is limited by zipping+-- with a given finite stream, i.e., the first argument.+enumFromThenZip ::+ (Control.Monad m, Enum e) =>+ Stream (Of a) m r %1 ->+ e ->+ e ->+ Stream (Of (a, e)) m r+enumFromThenZip stream e e' =+ Control.fmap (\(r, ()) -> r) $ zip stream $ enumFromThen e e'+{-# INLINE enumFromThenZip #-}++-- | Like 'enumFromThenN' but where the next element in the enumeration is just+-- the successor @succ n@ for a given enum @n@.+enumFromN :: (Control.Monad m, Enum e) => Int -> e -> Stream (Of e) m ()+enumFromN n e = take n $ enumFrom e+{-# INLINE enumFromN #-}++-- | Like 'enumFromThenZip' but where the next element in the enumeration is just+-- the successor @succ n@ for a given enum @n@.+enumFromZip ::+ (Control.Monad m, Enum e) =>+ Stream (Of a) m r %1 ->+ e ->+ Stream (Of (a, e)) m r+enumFromZip str e =+ Control.fmap (\(r, ()) -> r) $ zip str $ enumFrom e+{-# INLINE enumFromZip #-}
+ src/Streaming/Linear/Internal/Type.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++module Streaming.Linear.Internal.Type+ ( -- * The 'Stream' and 'Of' types+ -- $stream+ Stream (..),+ Of (..),+ )+where++import qualified Control.Functor.Linear as Control+import qualified Data.Functor.Linear as Data+import Prelude.Linear (($), (.))+import qualified Prelude.Linear as Linear++-- # Data Definitions+-------------------------------------------------------------------------------++-- $stream+--+-- The 'Stream' data type is equivalent to @FreeT@ and can represent any effectful+-- succession of steps, where the form of the steps or 'commands' is+-- specified by the first (functor) parameter. The effects are performed+-- exactly once since the monad is a @Control.Monad@ from+-- <https://github.com/tweag/linear-base linear-base>.+--+-- > data Stream f m r = Step !(f (Stream f m r)) | Effect (m (Stream f m r)) | Return r+--+-- The /producer/ concept uses the simple functor @ (a,_) @ \- or the stricter+-- @ Of a _ @. Then the news at each step or layer is just: an individual item of type @a@.+-- Since @Stream (Of a) m r@ is equivalent to @Pipe.Producer a m r@, much of+-- the @pipes@ @Prelude@ can easily be mirrored in a @streaming@ @Prelude@. Similarly,+-- a simple @Consumer a m r@ or @Parser a m r@ concept arises when the base functor is+-- @ (a -> _) @ . @Stream ((->) input) m result@ consumes @input@ until it returns a+-- @result@.+--+-- To avoid breaking reasoning principles, the constructors+-- should not be used directly. A pattern-match should go by way of 'inspect' \+-- \- or, in the producer case, 'Streaming.Prelude.next'++data Stream f m r where+ Step :: !(f (Stream f m r)) %1 -> Stream f m r+ Effect :: m (Stream f m r) %1 -> Stream f m r+ Return :: r %1 -> Stream f m r++-- | A left-strict pair; the base functor for streams of individual elements.+data Of a b where+ (:>) :: !a -> b %1 -> Of a b++infixr 5 :> -- same fixity as streaming.:>++-- # Control.Monad instance for (Stream f m)+-------------------------------------------------------------------------------++-- Note: we have maintained the weakest prerequisite constraints possible.++-- Note: to consume the 'Stream f m a' in the 'Cons' case, you+-- need 'fmap' to consume the stream. This implies at minimum+-- Data.Functor m and Data.Functor m.+instance (Data.Functor m, Data.Functor f) => Data.Functor (Stream f m) where+ fmap ::+ (Data.Functor m, Data.Functor f) =>+ (a %1 -> b) ->+ Stream f m a %1 ->+ Stream f m b+ fmap f s = fmap' f s+ {-# INLINEABLE fmap #-}++fmap' ::+ (Data.Functor m, Data.Functor f) =>+ (a %1 -> b) ->+ Stream f m a %1 ->+ Stream f m b+fmap' f (Return r) = Return (f r)+fmap' f (Step fs) = Step $ Data.fmap (Data.fmap f) fs+fmap' f (Effect ms) = Effect $ Data.fmap (Data.fmap f) ms++-- Note: the 'Control.Functor f' instance is needed.+-- Weaker constraints won't do.+instance+ (Control.Functor m, Control.Functor f) =>+ Data.Applicative (Stream f m)+ where+ pure :: a -> Stream f m a+ pure = Return+ {-# INLINE pure #-}++ (<*>) ::+ (Control.Functor m, Control.Functor f) =>+ Stream f m (a %1 -> b) %1 ->+ Stream f m a %1 ->+ Stream f m b+ (<*>) s1 s2 = app s1 s2+ {-# INLINEABLE (<*>) #-}++app ::+ (Control.Functor m, Control.Functor f) =>+ Stream f m (a %1 -> b) %1 ->+ Stream f m a %1 ->+ Stream f m b+app (Return f) stream = Control.fmap f stream+app (Step fs) stream = Step $ Control.fmap (Data.<*> stream) fs+app (Effect ms) stream = Effect $ Control.fmap (Data.<*> stream) ms++instance+ (Control.Functor m, Control.Functor f) =>+ Control.Functor (Stream f m)+ where+ fmap ::+ (Data.Functor m, Data.Functor f) =>+ (a %1 -> b) %1 ->+ Stream f m a %1 ->+ Stream f m b+ fmap f s = fmap'' f s+ {-# INLINEABLE fmap #-}++fmap'' ::+ (Control.Functor m, Control.Functor f) =>+ (a %1 -> b) %1 ->+ Stream f m a %1 ->+ Stream f m b+fmap'' f (Return r) = Return (f r)+fmap'' f (Step fs) = Step $ Control.fmap (Control.fmap f) fs+fmap'' f (Effect ms) = Effect $ Control.fmap (Control.fmap f) ms++instance+ (Control.Functor m, Control.Functor f) =>+ Control.Applicative (Stream f m)+ where+ pure :: a %1 -> Stream f m a+ pure = Return+ {-# INLINE pure #-}++ (<*>) ::+ (Control.Functor m, Control.Functor f) =>+ Stream f m (a %1 -> b) %1 ->+ Stream f m a %1 ->+ Stream f m b+ (<*>) = (Data.<*>)+ {-# INLINE (<*>) #-}++instance+ (Control.Functor m, Control.Functor f) =>+ Control.Monad (Stream f m)+ where+ (>>=) :: Stream f m a %1 -> (a %1 -> Stream f m b) %1 -> Stream f m b+ (>>=) = bind+ {-# INLINEABLE (>>=) #-}++bind ::+ (Control.Functor m, Control.Functor f) =>+ Stream f m a %1 ->+ (a %1 -> Stream f m b) %1 ->+ Stream f m b+bind (Return a) f = f a+bind (Step fs) f = Step $ Control.fmap (Control.>>= f) fs+bind (Effect ms) f = Effect $ Control.fmap (Control.>>= f) ms++-- # MonadTrans for (Stream f m)+-------------------------------------------------------------------------------++instance Control.Functor f => Control.MonadTrans (Stream f) where+ lift :: (Control.Functor m, Control.Functor f) => m a %1 -> Stream f m a+ lift = Effect . Control.fmap Control.return+ {-# INLINE lift #-}++-- # Control.Functor for (Of)+-------------------------------------------------------------------------------++ofFmap :: (a %1 -> b) %1 -> (Of x a) %1 -> (Of x b)+ofFmap f (a :> b) = a :> f b+{-# INLINE ofFmap #-}++instance Data.Functor (Of a) where+ fmap = Linear.forget ofFmap+ {-# INLINE fmap #-}++instance Control.Functor (Of a) where+ fmap = ofFmap+ {-# INLINE fmap #-}
src/Streaming/Prelude/Linear.hs view
@@ -1,66 +1,64 @@-{-| The names exported by this module are closely modeled on those in @Prelude@ and @Data.List@,- but also on- <http://hackage.haskell.org/package/pipes-4.1.9/docs/Pipes-Prelude.html Pipes.Prelude>,- <http://hackage.haskell.org/package/pipes-group-1.0.3/docs/Pipes-Group.html Pipes.Group>- and <http://hackage.haskell.org/package/pipes-parse-3.0.6/docs/Pipes-Parse.html Pipes.Parse>.- The module may be said to give independent expression to the conception of- Producer \/ Source \/ Generator manipulation- articulated in the latter two modules. Because we dispense with piping and- conduiting, the distinction between all of these modules collapses. Some things are- lost but much is gained: on the one hand, everything comes much closer to ordinary- beginning Haskell programming and, on the other, acquires the plasticity of programming- directly with a general free monad type. The leading type, @Stream (Of a) m r@ is chosen to permit an api- that is as close as possible to that of @Data.List@ and the @Prelude@.-- Import qualified thus:--> import Streaming-> import qualified Streaming.Prelude as S-- For the examples below, one sometimes needs--> import Streaming.Prelude (each, yield, next, mapped, stdoutLn, stdinLn)-> import Data.Function ((&))-- Other libraries that come up in passing are--> import qualified Control.Foldl as L -- cabal install foldl-> import qualified Pipes as P-> import qualified Pipes.Prelude as P-> import qualified System.IO as IO-- Here are some correspondences between the types employed here and elsewhere:--> streaming | pipes | conduit | io-streams-> --------------------------------------------------------------------------------------------------------------------> Stream (Of a) m () | Producer a m () | Source m a | InputStream a-> | ListT m a | ConduitM () o m () | Generator r ()-> --------------------------------------------------------------------------------------------------------------------> Stream (Of a) m r | Producer a m r | ConduitM () o m r | Generator a r-> --------------------------------------------------------------------------------------------------------------------> Stream (Of a) m (Stream (Of a) m r) | Producer a m (Producer a m r) |-> ---------------------------------------------------------------------------------------------------------------------> Stream (Stream (Of a) m) r | FreeT (Producer a m) m r |-> ---------------------------------------------------------------------------------------------------------------------> ---------------------------------------------------------------------------------------------------------------------> ByteString m () | Producer ByteString m () | Source m ByteString | InputStream ByteString-> --------------------------------------------------------------------------------------------------------------------->--}+-- | The names exported by this module are closely modeled on those in @Prelude@ and @Data.List@,+-- but also on+-- <http://hackage.haskell.org/package/pipes-4.1.9/docs/Pipes-Prelude.html Pipes.Prelude>,+-- <http://hackage.haskell.org/package/pipes-group-1.0.3/docs/Pipes-Group.html Pipes.Group>+-- and <http://hackage.haskell.org/package/pipes-parse-3.0.6/docs/Pipes-Parse.html Pipes.Parse>.+-- The module may be said to give independent expression to the conception of+-- Producer \/ Source \/ Generator manipulation+-- articulated in the latter two modules. Because we dispense with piping and+-- conduiting, the distinction between all of these modules collapses. Some things are+-- lost but much is gained: on the one hand, everything comes much closer to ordinary+-- beginning Haskell programming and, on the other, acquires the plasticity of programming+-- directly with a general free monad type. The leading type, @Stream (Of a) m r@ is chosen to permit an api+-- that is as close as possible to that of @Data.List@ and the @Prelude@.+--+-- Import qualified thus:+--+-- > import Streaming+-- > import qualified Streaming.Prelude as S+--+-- For the examples below, one sometimes needs+--+-- > import Streaming.Prelude (each, yield, next, mapped, stdoutLn, stdinLn)+-- > import Data.Function ((&))+--+-- Other libraries that come up in passing are+--+-- > import qualified Control.Foldl as L -- cabal install foldl+-- > import qualified Pipes as P+-- > import qualified Pipes.Prelude as P+-- > import qualified System.IO as IO+--+-- Here are some correspondences between the types employed here and elsewhere:+--+-- > streaming | pipes | conduit | io-streams+-- > -------------------------------------------------------------------------------------------------------------------+-- > Stream (Of a) m () | Producer a m () | Source m a | InputStream a+-- > | ListT m a | ConduitM () o m () | Generator r ()+-- > -------------------------------------------------------------------------------------------------------------------+-- > Stream (Of a) m r | Producer a m r | ConduitM () o m r | Generator a r+-- > -------------------------------------------------------------------------------------------------------------------+-- > Stream (Of a) m (Stream (Of a) m r) | Producer a m (Producer a m r) |+-- > --------------------------------------------------------------------------------------------------------------------+-- > Stream (Stream (Of a) m) r | FreeT (Producer a m) m r |+-- > --------------------------------------------------------------------------------------------------------------------+-- > --------------------------------------------------------------------------------------------------------------------+-- > ByteString m () | Producer ByteString m () | Source m ByteString | InputStream ByteString+-- > --------------------------------------------------------------------------------------------------------------------+-- > module Streaming.Prelude.Linear- ( module Streaming.Internal.Type- , module Streaming.Internal.Consume- , module Streaming.Internal.Interop- , module Streaming.Internal.Many- , module Streaming.Internal.Process- , module Streaming.Internal.Produce- ) where--import Streaming.Internal.Type-import Streaming.Internal.Consume-import Streaming.Internal.Interop-import Streaming.Internal.Many-import Streaming.Internal.Process-import Streaming.Internal.Produce-+ ( module Streaming.Linear.Internal.Type,+ module Streaming.Linear.Internal.Consume,+ module Streaming.Linear.Internal.Interop,+ module Streaming.Linear.Internal.Many,+ module Streaming.Linear.Internal.Process,+ module Streaming.Linear.Internal.Produce,+ )+where +import Streaming.Linear.Internal.Consume+import Streaming.Linear.Internal.Interop+import Streaming.Linear.Internal.Many+import Streaming.Linear.Internal.Process+import Streaming.Linear.Internal.Produce+import Streaming.Linear.Internal.Type
src/System/IO/Linear.hs view
@@ -2,11 +2,10 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | This module redefines 'IO' with linear types. --@@ -33,38 +32,40 @@ -- upstreamed in "System.IO". When multiplicity-polymorphism is implemented, -- this module will supercede IO by providing a seamless replacement for -- "System.IO" that won't break non-linear code.- module System.IO.Linear- ( IO(..)- -- * Interfacing with "System.IO"- , fromSystemIO- , fromSystemIOU- , withLinearIO- -- * Using Mutable References- -- $ioref- , newIORef- , readIORef- , writeIORef- -- * Catching and Throwing Exceptions- -- $exceptions- , throwIO- , catch- , mask_- ) where+ ( IO (..), -import Data.IORef (IORef)-import qualified Data.IORef as System+ -- * Interfacing with "System.IO"+ fromSystemIO,+ fromSystemIOU,+ withLinearIO,++ -- * Using Mutable References+ -- $ioref+ newIORef,+ readIORef,+ writeIORef,++ -- * Catching and Throwing Exceptions+ -- $exceptions+ throwIO,+ catch,+ mask_,+ )+where+ import Control.Exception (Exception)-import qualified Control.Exception as System (throwIO, catch, mask_)+import qualified Control.Exception as System (catch, mask_, throwIO) import qualified Control.Functor.Linear as Control import qualified Data.Functor.Linear as Data-import GHC.Exts (State#, RealWorld)+import Data.IORef (IORef)+import qualified Data.IORef as System+import GHC.Exts (RealWorld, State#) import Prelude.Linear hiding (IO)+import qualified System.IO as System import qualified Unsafe.Linear as Unsafe import qualified Prelude-import qualified System.IO as System - -- | This is the linear IO monad. -- It is a newtype around a function that transitions from one -- @State# RealWorld@ to another, producing a value of type @a@ along with it.@@ -77,18 +78,19 @@ -- linear arrow enforcing the implicit invariant that IO actions linearly -- thread the state of the real world. Hence, we can safely release the -- constructor to this newtype.-newtype IO a = IO (State# RealWorld %1-> (# State# RealWorld, a #))+newtype IO a = IO (State# RealWorld %1 -> (# State# RealWorld, a #)) deriving (Data.Functor, Data.Applicative) via (Control.Data IO)+ type role IO representational -- Defined separately because projections from newtypes are considered like -- general projections of data types, which take an unrestricted argument.-unIO :: IO a %1-> State# RealWorld %1-> (# State# RealWorld, a #)+unIO :: IO a %1 -> State# RealWorld %1 -> (# State# RealWorld, a #) unIO (IO action) = action -- | Coerces a standard IO action into a linear IO action. -- Note that the value @a@ must be used linearly in the linear IO monad.-fromSystemIO :: System.IO a %1-> IO a+fromSystemIO :: System.IO a %1 -> IO a -- The implementation relies on the fact that the monad abstraction for IO -- actually enforces linear use of the @RealWorld@ token. --@@ -107,7 +109,7 @@ fromSystemIO (Ur Prelude.<$> action) -- | Convert a linear IO action to a "System.IO" action.-toSystemIO :: IO a %1-> System.IO a+toSystemIO :: IO a %1 -> System.IO a toSystemIO = Unsafe.coerce -- basically just subtyping -- | Use at the top of @main@ function in your program to switch to the@@ -123,37 +125,43 @@ -- * Monadic interface instance Control.Functor IO where- fmap :: forall a b. (a %1-> b) %1-> IO a %1-> IO b+ fmap :: forall a b. (a %1 -> b) %1 -> IO a %1 -> IO b fmap f x = IO $ \s ->- cont (unIO x s) f+ cont (unIO x s) f where -- XXX: long line- cont :: (# State# RealWorld, a #) %1-> (a %1-> b) %1-> (# State# RealWorld, b #)+ cont :: (# State# RealWorld, a #) %1 -> (a %1 -> b) %1 -> (# State# RealWorld, b #) cont (# s', a #) f' = (# s', f' a #) instance Control.Applicative IO where- pure :: forall a. a %1-> IO a+ pure :: forall a. a %1 -> IO a pure a = IO $ \s -> (# s, a #) - (<*>) :: forall a b. IO (a %1-> b) %1-> IO a %1-> IO b+ (<*>) :: forall a b. IO (a %1 -> b) %1 -> IO a %1 -> IO b (<*>) = Control.ap instance Control.Monad IO where- (>>=) :: forall a b. IO a %1-> (a %1-> IO b) %1-> IO b+ (>>=) :: forall a b. IO a %1 -> (a %1 -> IO b) %1 -> IO b x >>= f = IO $ \s ->- cont (unIO x s) f+ cont (unIO x s) f where -- XXX: long line- cont :: (# State# RealWorld, a #) %1-> (a %1-> IO b) %1-> (# State# RealWorld, b #)+ cont :: (# State# RealWorld, a #) %1 -> (a %1 -> IO b) %1 -> (# State# RealWorld, b #) cont (# s', a #) f' = unIO (f' a) s' - (>>) :: forall b. IO () %1-> IO b %1-> IO b+ (>>) :: forall b. IO () %1 -> IO b %1 -> IO b x >> y = IO $ \s ->- cont (unIO x s) y+ cont (unIO x s) y where- cont :: (# State# RealWorld, () #) %1-> IO b %1-> (# State# RealWorld, b #)+ cont :: (# State# RealWorld, () #) %1 -> IO b %1 -> (# State# RealWorld, b #) cont (# s', () #) y' = unIO y' s' +instance Semigroup a => Semigroup (IO a) where+ (<>) = Control.liftA2 (<>)++instance Monoid a => Monoid (IO a) where+ mempty = Control.pure mempty+ -- $ioref -- @IORef@s are mutable references to values, or pointers to values. -- You can create, mutate and read them from running IO actions.@@ -181,9 +189,11 @@ throwIO :: Exception e => e -> IO a throwIO e = fromSystemIO $ System.throwIO e -catch- :: Exception e- => IO (Ur a) -> (e -> IO (Ur a)) -> IO (Ur a)+catch ::+ Exception e =>+ IO (Ur a) ->+ (e -> IO (Ur a)) ->+ IO (Ur a) catch body handler = fromSystemIO $ System.catch (toSystemIO body) (\e -> toSystemIO (handler e))
− src/System/IO/Resource.hs
@@ -1,259 +0,0 @@-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}--- Deactivate warning because it is painful to refactor functions with two--- rebinded-do with different bind functions. Such as in the 'run'--- function. Which is a good argument for having support for F#-style builders.-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE RecordWildCards #-}---- | This module defines an IO monad for linearly working with system resources--- like files. It provides tools to take resources that are currently--- unsafely accessible from "System.IO" and use them in this monad.------ Import this module qualified to avoid name clashes.------ To use this RIO monad, create some @RIO@ computation,--- run it to get a "System.IO" computation.------ = A simple example--- >>> :set -XLinearTypes--- >>> :set -XQualifiedDo--- >>> :set -XNoImplicitPrelude--- >>> import qualified System.IO.Resource as Linear--- >>> import qualified Control.Functor.Linear as Control--- >>> import qualified Data.Text as Text--- >>> import Prelude.Linear--- >>> import qualified Prelude--- >>> :{--- linearWriteToFile :: IO ()--- linearWriteToFile = Linear.run Prelude.$ Control.do--- handle1 <- Linear.openFile "/home/user/test.txt" Linear.WriteMode--- handle2 <- Linear.hPutStrLn handle1 (Text.pack "hello there")--- () <- Linear.hClose handle2--- Control.return (Ur ())--- :}------ To enable do notation, `QualifiedDo` extension is used. But since QualifiedDo--- only modifies the desugaring of binds, we still need to qualify `Control.return`.-module System.IO.Resource- ( -- * The Resource I/O Monad- RIO- , run- -- * Using Resource Handles- -- $monad- -- $files- , Handle- -- ** File I/O- , openFile- , System.IOMode (..)- -- ** Working with Handles- , hClose- , hIsEOF- , hGetChar- , hPutChar- , hGetLine- , hPutStr- , hPutStrLn- -- * Creating new types of resources- -- $new-resources- , UnsafeResource- , unsafeRelease- , unsafeAcquire- , unsafeFromSystemIOResource- , unsafeFromSystemIOResource_- ) where--import Control.Exception (onException, mask, finally)-import qualified Control.Monad as Ur (fmap)-import qualified Data.Functor.Linear as Data-import qualified Control.Functor.Linear as Control-import Data.Coerce-import qualified Data.IORef as System-import Data.IORef (IORef)-import qualified Data.IntMap.Strict as IntMap-import Data.IntMap.Strict (IntMap)-import Data.Text (Text)-import qualified Data.Text.IO as Text-import Prelude.Linear hiding (IO)-import qualified Prelude-import qualified System.IO.Linear as Linear-import qualified System.IO as System---- XXX: This would be better as a multiplicity-parametric relative monad, but--- until we have multiplicity polymorphism, we use a linear monad.---newtype ReleaseMap = ReleaseMap (IntMap (Linear.IO ()))---- | The resource-aware I/O monad. This monad guarantees that acquired resources--- are always released.-newtype RIO a = RIO (IORef ReleaseMap -> Linear.IO a)- deriving (Data.Functor, Data.Applicative) via (Control.Data RIO)-unRIO :: RIO a %1-> IORef ReleaseMap -> Linear.IO a-unRIO (RIO action) = action---- | Take a @RIO@ computation with a value @a@ that is not linearly bound and--- make it a "System.IO" computation.-run :: RIO (Ur a) -> System.IO a-run (RIO action) = do- rrm <- System.newIORef (ReleaseMap IntMap.empty)- mask (\restore ->- onException- (restore (Linear.withLinearIO (action rrm)))- (do -- release stray resources- ReleaseMap releaseMap <- System.readIORef rrm- safeRelease Prelude.$ Ur.fmap snd Prelude.$ IntMap.toList releaseMap))- -- Remarks: resources are guaranteed to be released on non-exceptional- -- return. So, contrary to a standard bracket/ResourceT implementation, we- -- only release exceptions in the release map upon exception.- where- safeRelease :: [Linear.IO ()] -> System.IO ()- safeRelease [] = Prelude.return ()- safeRelease (finalizer:fs) = Linear.withLinearIO (moveLinearIO finalizer)- `finally` safeRelease fs- -- Should be just an application of a linear `(<$>)`.- moveLinearIO :: Movable a => Linear.IO a %1-> Linear.IO (Ur a)- moveLinearIO action' = Control.do- result <- action'- Control.return $ move result---- | Should not be applied to a function that acquires or releases resources.-unsafeFromSystemIO :: System.IO a %1-> RIO a-unsafeFromSystemIO action = RIO (\ _ -> Linear.fromSystemIO action)---- $monad--instance Control.Functor RIO where- fmap f (RIO action) = RIO $ \releaseMap ->- Control.fmap f (action releaseMap)--instance Control.Applicative RIO where- pure a = RIO $ \_releaseMap -> Control.pure a- (<*>) = Control.ap--instance Control.Monad RIO where- x >>= f = RIO $ \releaseMap -> Control.do- a <- unRIO x releaseMap- unRIO (f a) releaseMap-- x >> y = RIO $ \releaseMap -> Control.do- unRIO x releaseMap- unRIO y releaseMap---- $files---- Remark: Handle needs to be private otherwise `Data.Coerce.coerce` could wreak--- Havoc on the abstraction. But we could provide a smart constructor/view to--- unsafely convert to file handles in order for the Handle API to be--- extensible.--newtype Handle = Handle (UnsafeResource System.Handle)---- | See 'System.IO.openFile'-openFile :: FilePath -> System.IOMode -> RIO Handle-openFile path mode = Control.do- h <- unsafeAcquire- (Linear.fromSystemIOU Prelude.$ System.openFile path mode)- (\h -> Linear.fromSystemIO $ System.hClose h)- Control.return $ Handle h--hClose :: Handle %1-> RIO ()-hClose (Handle h) = unsafeRelease h--hIsEOF :: Handle %1-> RIO (Ur Bool, Handle)-hIsEOF = coerce (unsafeFromSystemIOResource System.hIsEOF)--hGetChar :: Handle %1-> RIO (Ur Char, Handle)-hGetChar = coerce (unsafeFromSystemIOResource System.hGetChar)--hPutChar :: Handle %1-> Char -> RIO Handle-hPutChar h c = flipHPutChar c h -- needs a multiplicity polymorphic flip- where- flipHPutChar :: Char -> Handle %1-> RIO Handle- flipHPutChar c =- coerce (unsafeFromSystemIOResource_ (\h' -> System.hPutChar h' c))--hGetLine :: Handle %1-> RIO (Ur Text, Handle)-hGetLine = coerce (unsafeFromSystemIOResource Text.hGetLine)--hPutStr :: Handle %1-> Text -> RIO Handle-hPutStr h s = flipHPutStr s h -- needs a multiplicity polymorphic flip- where- flipHPutStr :: Text -> Handle %1-> RIO Handle- flipHPutStr s =- coerce (unsafeFromSystemIOResource_ (\h' -> Text.hPutStr h' s))--hPutStrLn :: Handle %1-> Text -> RIO Handle-hPutStrLn h s = flipHPutStrLn s h -- needs a multiplicity polymorphic flip- where- flipHPutStrLn :: Text -> Handle %1-> RIO Handle- flipHPutStrLn s =- coerce (unsafeFromSystemIOResource_ (\h' -> Text.hPutStrLn h' s))---- $new-resources---- | The type of system resources. To create and use resources, you need to--- use the API since the constructor is not released.-data UnsafeResource a where- UnsafeResource :: Int -> a -> UnsafeResource a- -- Note that both components are unrestricted.---- | Given an unsafe resource, release it with the linear IO action provided--- when the resrouce was acquired.-unsafeRelease :: UnsafeResource a %1-> RIO ()-unsafeRelease (UnsafeResource key _) = RIO (\st -> Linear.mask_ (releaseWith key st))- where- releaseWith key rrm = Control.do- Ur (ReleaseMap releaseMap) <- Linear.readIORef rrm- () <- releaseMap IntMap.! key- Linear.writeIORef rrm (ReleaseMap (IntMap.delete key releaseMap))---- | Given a resource in the "System.IO.Linear.IO" monad, and--- given a function to release that resource, provides that resource in--- the @RIO@ monad. For example, releasing a @Handle@ from "System.IO"--- would be done with @fromSystemIO hClose@. Because this release function--- is an input, and could be wrong, this function is unsafe.-unsafeAcquire- :: Linear.IO (Ur a)- -> (a -> Linear.IO ())- -> RIO (UnsafeResource a)-unsafeAcquire acquire release = RIO $ \rrm -> Linear.mask_ (Control.do- Ur resource <- acquire- Ur (ReleaseMap releaseMap) <- Linear.readIORef rrm- () <-- Linear.writeIORef- rrm- (ReleaseMap- (IntMap.insert (releaseKey releaseMap) (release resource) releaseMap))- Control.return $ UnsafeResource (releaseKey releaseMap) resource)- where- releaseKey releaseMap =- case IntMap.null releaseMap of- True -> 0- False -> fst (IntMap.findMax releaseMap) + 1---- | Given a "System.IO" computation on an unsafe resource,--- lift it to @RIO@ computaton on the acquired resource.--- That is function of type @a -> IO b@ turns into a function of type--- @UnsafeResource a %1-> RIO (Ur b)@ --- along with threading the @UnsafeResource a@.------ Note that the result @b@ can be used non-linearly.-unsafeFromSystemIOResource- :: (a -> System.IO b)- -> (UnsafeResource a %1-> RIO (Ur b, UnsafeResource a))-unsafeFromSystemIOResource action (UnsafeResource key resource) =- unsafeFromSystemIO (do- c <- action resource- Prelude.return (Ur c, UnsafeResource key resource))--unsafeFromSystemIOResource_- :: (a -> System.IO ())- -> (UnsafeResource a %1-> RIO (UnsafeResource a))-unsafeFromSystemIOResource_ action resource = Control.do- (Ur _, resource) <- unsafeFromSystemIOResource action resource- Control.return resource
+ src/System/IO/Resource/Linear.hs view
@@ -0,0 +1,64 @@+-- | This module defines an IO monad for linearly working with system resources+-- like files. It provides tools to take resources that are currently+-- unsafely accessible from "System.IO" and use them in this monad.+--+-- Import this module qualified to avoid name clashes.+--+-- To use this RIO monad, create some @RIO@ computation,+-- run it to get a "System.IO" computation.+--+-- = A simple example+-- >>> :set -XLinearTypes+-- >>> :set -XQualifiedDo+-- >>> :set -XNoImplicitPrelude+-- >>> import qualified System.IO.Resource.Linear as Linear+-- >>> import qualified Control.Functor.Linear as Control+-- >>> import qualified Data.Text as Text+-- >>> import Prelude.Linear+-- >>> import qualified Prelude+-- >>> :{+-- linearWriteToFile :: IO ()+-- linearWriteToFile = Linear.run $ Control.do+-- handle1 <- Linear.openFile "/home/user/test.txt" Linear.WriteMode+-- handle2 <- Linear.hPutStrLn handle1 (Text.pack "hello there")+-- () <- Linear.hClose handle2+-- Control.return (Ur ())+-- :}+--+-- To enable do notation, `QualifiedDo` extension is used. But since QualifiedDo+-- only modifies the desugaring of binds, we still need to qualify `Control.return`.+module System.IO.Resource.Linear+ ( -- * The Resource I/O Monad+ RIO,+ run,++ -- * Using Resource Handles+ -- $monad+ -- $files+ Handle,++ -- ** File I/O+ openFile,+ System.IOMode (..),++ -- ** Working with Handles+ hClose,+ hIsEOF,+ hGetChar,+ hPutChar,+ hGetLine,+ hPutStr,+ hPutStrLn,++ -- * Creating new types of resources+ -- $new-resources+ UnsafeResource,+ unsafeRelease,+ unsafeAcquire,+ unsafeFromSystemIOResource,+ unsafeFromSystemIOResource_,+ )+where++import qualified System.IO as System+import System.IO.Resource.Linear.Internal
+ src/System/IO/Resource/Linear/Internal.hs view
@@ -0,0 +1,219 @@+-- Deactivate warning because it is painful to refactor functions with two+-- rebinded-do with different bind functions. Such as in the 'run'+-- function. Which is a good argument for having support for F#-style builders.+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}++module System.IO.Resource.Linear.Internal where++import Control.Exception (finally, mask, onException)+import qualified Control.Functor.Linear as Control+import qualified Control.Monad as Ur (fmap)+import Data.Coerce+import qualified Data.Functor.Linear as Data+import Data.IORef (IORef)+import qualified Data.IORef as System+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Monoid (Ap (..))+import Data.Text (Text)+import qualified Data.Text.IO as Text+import Prelude.Linear hiding (IO)+import qualified System.IO as System+import qualified System.IO.Linear as Linear+import qualified Prelude++-- XXX: This would be better as a multiplicity-parametric relative monad, but+-- until we have multiplicity polymorphism, we use a linear monad.++newtype ReleaseMap = ReleaseMap (IntMap (Linear.IO ()))++-- | The resource-aware I/O monad. This monad guarantees that acquired resources+-- are always released.+newtype RIO a = RIO (IORef ReleaseMap -> Linear.IO a)+ deriving (Data.Functor, Data.Applicative) via (Control.Data RIO)+ deriving (Semigroup, Monoid) via (Ap RIO a)++unRIO :: RIO a %1 -> IORef ReleaseMap -> Linear.IO a+unRIO (RIO action) = action++-- | Take a @RIO@ computation with a value @a@ that is not linearly bound and+-- make it a "System.IO" computation.+run :: RIO (Ur a) -> System.IO a+run (RIO action) = do+ rrm <- System.newIORef (ReleaseMap IntMap.empty)+ mask+ ( \restore ->+ onException+ (restore (Linear.withLinearIO (action rrm)))+ ( do+ -- release stray resources+ ReleaseMap releaseMap <- System.readIORef rrm+ safeRelease $ Ur.fmap snd $ IntMap.toList releaseMap+ )+ )+ where+ -- Remarks: resources are guaranteed to be released on non-exceptional+ -- return. So, contrary to a standard bracket/ResourceT implementation, we+ -- only release exceptions in the release map upon exception.++ safeRelease :: [Linear.IO ()] -> System.IO ()+ safeRelease [] = Prelude.return ()+ safeRelease (finalizer : fs) =+ Linear.withLinearIO (moveLinearIO finalizer)+ `finally` safeRelease fs+ -- Should be just an application of a linear `(<$>)`.+ moveLinearIO :: Movable a => Linear.IO a %1 -> Linear.IO (Ur a)+ moveLinearIO action' = Control.do+ result <- action'+ Control.return $ move result++-- | Should not be applied to a function that acquires or releases resources.+unsafeFromSystemIO :: System.IO a %1 -> RIO a+unsafeFromSystemIO action = RIO (\_ -> Linear.fromSystemIO action)++-- monad++instance Control.Functor RIO where+ fmap f (RIO action) = RIO $ \releaseMap ->+ Control.fmap f (action releaseMap)++instance Control.Applicative RIO where+ pure a = RIO $ \_releaseMap -> Control.pure a+ (<*>) = Control.ap++instance Control.Monad RIO where+ x >>= f = RIO $ \releaseMap -> Control.do+ a <- unRIO x releaseMap+ unRIO (f a) releaseMap++ x >> y = RIO $ \releaseMap -> Control.do+ unRIO x releaseMap+ unRIO y releaseMap++-- files++-- Remark: Handle needs to be private otherwise `Data.Coerce.coerce` could wreak+-- Havoc on the abstraction. But we could provide a smart constructor/view to+-- unsafely convert to file handles in order for the Handle API to be+-- extensible.++newtype Handle = Handle (UnsafeResource System.Handle)++-- | See 'System.IO.openFile'+openFile :: FilePath -> System.IOMode -> RIO Handle+openFile path mode = Control.do+ h <-+ unsafeAcquire+ (Linear.fromSystemIOU $ System.openFile path mode)+ (\h -> Linear.fromSystemIO $ System.hClose h)+ Control.return $ Handle h++hClose :: Handle %1 -> RIO ()+hClose (Handle h) = unsafeRelease h++hIsEOF :: Handle %1 -> RIO (Ur Bool, Handle)+hIsEOF = coerce (unsafeFromSystemIOResource System.hIsEOF)++hGetChar :: Handle %1 -> RIO (Ur Char, Handle)+hGetChar = coerce (unsafeFromSystemIOResource System.hGetChar)++hPutChar :: Handle %1 -> Char -> RIO Handle+hPutChar h c = flipHPutChar c h -- needs a multiplicity polymorphic flip+ where+ flipHPutChar :: Char -> Handle %1 -> RIO Handle+ flipHPutChar c =+ coerce (unsafeFromSystemIOResource_ (\h' -> System.hPutChar h' c))++hGetLine :: Handle %1 -> RIO (Ur Text, Handle)+hGetLine = coerce (unsafeFromSystemIOResource Text.hGetLine)++hPutStr :: Handle %1 -> Text -> RIO Handle+hPutStr h s = flipHPutStr s h -- needs a multiplicity polymorphic flip+ where+ flipHPutStr :: Text -> Handle %1 -> RIO Handle+ flipHPutStr s =+ coerce (unsafeFromSystemIOResource_ (\h' -> Text.hPutStr h' s))++hPutStrLn :: Handle %1 -> Text -> RIO Handle+hPutStrLn h s = flipHPutStrLn s h -- needs a multiplicity polymorphic flip+ where+ flipHPutStrLn :: Text -> Handle %1 -> RIO Handle+ flipHPutStrLn s =+ coerce (unsafeFromSystemIOResource_ (\h' -> Text.hPutStrLn h' s))++-- new-resources++-- | The type of system resources. To create and use resources, you need to+-- use the API since the constructor is not released.+data UnsafeResource a where+ UnsafeResource :: Int -> a -> UnsafeResource a++-- Note that both components are unrestricted.++-- | Given an unsafe resource, release it with the linear IO action provided+-- when the resrouce was acquired.+unsafeRelease :: UnsafeResource a %1 -> RIO ()+unsafeRelease (UnsafeResource key _) = RIO (\st -> Linear.mask_ (releaseWith key st))+ where+ releaseWith key rrm = Control.do+ Ur (ReleaseMap releaseMap) <- Linear.readIORef rrm+ () <- releaseMap IntMap.! key+ Linear.writeIORef rrm (ReleaseMap (IntMap.delete key releaseMap))++-- | Given a resource in the "System.IO.Linear.IO" monad, and+-- given a function to release that resource, provides that resource in+-- the @RIO@ monad. For example, releasing a @Handle@ from "System.IO"+-- would be done with @fromSystemIO hClose@. Because this release function+-- is an input, and could be wrong, this function is unsafe.+unsafeAcquire ::+ Linear.IO (Ur a) ->+ (a -> Linear.IO ()) ->+ RIO (UnsafeResource a)+unsafeAcquire acquire release = RIO $ \rrm ->+ Linear.mask_+ ( Control.do+ Ur resource <- acquire+ Ur (ReleaseMap releaseMap) <- Linear.readIORef rrm+ () <-+ Linear.writeIORef+ rrm+ ( ReleaseMap+ (IntMap.insert (releaseKey releaseMap) (release resource) releaseMap)+ )+ Control.return $ UnsafeResource (releaseKey releaseMap) resource+ )+ where+ releaseKey releaseMap =+ case IntMap.null releaseMap of+ True -> 0+ False -> fst (IntMap.findMax releaseMap) + 1++-- | Given a "System.IO" computation on an unsafe resource,+-- lift it to @RIO@ computaton on the acquired resource.+-- That is function of type @a -> IO b@ turns into a function of type+-- @UnsafeResource a %1-> RIO (Ur b)@+-- along with threading the @UnsafeResource a@.+--+-- Note that the result @b@ can be used non-linearly.+unsafeFromSystemIOResource ::+ (a -> System.IO b) ->+ (UnsafeResource a %1 -> RIO (Ur b, UnsafeResource a))+unsafeFromSystemIOResource action (UnsafeResource key resource) =+ unsafeFromSystemIO+ ( do+ c <- action resource+ Prelude.return (Ur c, UnsafeResource key resource)+ )++unsafeFromSystemIOResource_ ::+ (a -> System.IO ()) ->+ (UnsafeResource a %1 -> RIO (UnsafeResource a))+unsafeFromSystemIOResource_ action resource = Control.do+ (Ur _, resource) <- unsafeFromSystemIOResource action resource+ Control.return resource
src/Unsafe/Linear.hs view
@@ -1,7 +1,16 @@-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeInType #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -- | Unsafe coercions for linearly typed code. --@@ -15,41 +24,173 @@ -- * Do not use this unless you have to. Specifically, if you can write a -- linear function @f :: A %1-> B@, do not write a non-linear version and coerce -- it.- module Unsafe.Linear- ( -- * Unsafe Coersions+ ( -- * Unsafe Coercions coerce, toLinear, toLinear2, toLinear3,+ toLinearN,+ ToLinearN (..), )- where+where -import qualified Unsafe.Coerce as NonLinear-import GHC.Exts (TYPE, RuntimeRep)+import Data.Kind (Constraint)+import Data.Type.Equality (type (~~))+import GHC.Exts (RuntimeRep (..), TYPE)+import GHC.TypeNats+import Unsafe.Coerce (UnsafeEquality (..), unsafeEqualityProof) -- | Linearly typed @unsafeCoerce@-coerce :: a %1-> b-coerce = NonLinear.unsafeCoerce NonLinear.unsafeCoerce+coerce :: forall a b. a %1 -> b+coerce a =+ case unsafeEqualityProof @a @b of+ UnsafeRefl -> a+{-# INLINE coerce #-} -- | Converts an unrestricted function into a linear function-toLinear- :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)- (a :: TYPE r1) (b :: TYPE r2) p.- (a %p-> b) %1-> (a %1-> b)-toLinear = coerce+toLinear ::+ forall+ (r1 :: RuntimeRep)+ (r2 :: RuntimeRep)+ (a :: TYPE r1)+ (b :: TYPE r2)+ p+ x.+ (a %p -> b) %1 ->+ (a %x -> b)+toLinear f = case unsafeEqualityProof @p @x of+ UnsafeRefl -> f -- | Like 'toLinear' but for two-argument functions-toLinear2- :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (r3 :: RuntimeRep)- (a :: TYPE r1) (b :: TYPE r2) (c :: TYPE r3) p q.- (a %p-> b %q-> c) %1-> (a %1-> b %1-> c)-toLinear2 = coerce+toLinear2 ::+ forall+ (r1 :: RuntimeRep)+ (r2 :: RuntimeRep)+ (r3 :: RuntimeRep)+ (a :: TYPE r1)+ (b :: TYPE r2)+ (c :: TYPE r3)+ p+ q+ x+ y.+ (a %p -> b %q -> c) %1 ->+ (a %x -> b %y -> c)+toLinear2 f = case unsafeEqualityProof @'(p, q) @'(x, y) of+ UnsafeRefl -> f -- | Like 'toLinear' but for three-argument functions-toLinear3- :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)- (r3 :: RuntimeRep) (r4 :: RuntimeRep)- (a :: TYPE r1) (b :: TYPE r2) (c :: TYPE r3) (d :: TYPE r4) p q r.- (a %p-> b %q-> c %r-> d) %1-> (a %1-> b %1-> c %1-> d)-toLinear3 = coerce+toLinear3 ::+ forall+ (r1 :: RuntimeRep)+ (r2 :: RuntimeRep)+ (r3 :: RuntimeRep)+ (r4 :: RuntimeRep)+ (a :: TYPE r1)+ (b :: TYPE r2)+ (c :: TYPE r3)+ (d :: TYPE r4)+ p+ q+ r+ x+ y+ z.+ (a %p -> b %q -> c %r -> d) %1 ->+ (a %x -> b %y -> c %z -> d)+toLinear3 f = case unsafeEqualityProof @'(p, q, r) @'(x, y, z) of+ UnsafeRefl -> f++-- | @toLinearN@ subsumes the functionality of 'toLinear1', 'toLinear2', and+-- 'toLinear3'. In particular, @toLinearN \@n@ unsafely changes the+-- multiplicities of the first @n@ arrows from any multiplicity to any+-- other multiplicity. To be explicit about how each multiplicity is+-- being changed, you can use additional type arguments.+--+-- === Examples+--+-- @+-- toLinearN \@2 :: (a %m-> b %n-> Int) %1-> a %x-> b %y-> Int+-- toLinearN \@3 \@(_ %m-> _ -> _ %1-> _) \@(_ %1-> _ %1-> _ %x-> _)+-- :: (a %m-> b -> c %1-> d) %1-> (a %1-> b %1-> c %x-> d)+-- 'toLinear3' = toLinearN \@3+-- @+toLinearN :: forall n f g. ToLinearN n f g => f %1 -> g+-- See Note: Core size+toLinearN f = case unsafeLinearityProofN @n @f @g of+ UnsafeRefl -> f++-- | @ToLinearN n f g@ means that @f@ and @g@ are the same with the+-- possible exception of the multiplicities of the first @n@ arrows.+type ToLinearN :: forall {rep :: RuntimeRep}. Nat -> TYPE rep -> TYPE rep -> Constraint+class ToLinearN n f g where+ -- | Given that @f@ and @g@ are the same, with the possible exception of the+ -- multiplicities of the first @n@ arrows, @unsafeLinearityProofN \@n \@f \@g@+ -- is a fake proof that @f@ and @g@ are identical. This is used primarily in the+ -- definition of 'toLinearN', but it can also be used, for example, to coerce+ -- a container of functions:+ --+ -- @+ -- linearMany :: forall a b c. [a -> b -> c] %1-> [a %1-> b %1-> c]+ -- linearMany = castWithUnsafe (applyUnsafe (UnsafeRefl @[]) $+ -- unsafeLinearityProofN @2 @(a -> b -> c) @(a %1-> b %1-> c))+ --+ -- applyUnsafe :: UnsafeEquality f g -> UnsafeEquality x y -> UnsafeEquality (f x) (g y)+ -- applyUnsafe UnsafeRefl UnsafeRefl = UnsafeRefl+ --+ -- castWithUnsafe :: UnsafeEquality x y -> x %1-> y+ -- castWithUnsafe UnsafeRefl x = x+ -- @+ --+ -- The rather explicit handling of coercions seems to be necessary,+ -- unfortunately, presumably due to the way GHC eagerly rejects equality+ -- constraints it sees as definitely unsatisfiable.+ unsafeLinearityProofN :: UnsafeEquality f g++instance (ToLinearN' ni f g, ni ~ ToINat n) => ToLinearN n f g where+ unsafeLinearityProofN = prf @ni++-- | Plain old inductive natural numbers.+data INat = Z | S INat++-- | Convert a GHC 'Nat' to a real inductive natural number.+-- We use this because GHC 'Nat' offers a friendly API but+-- it's a terrible pain for implementation.+type ToINat :: Nat -> INat+type family ToINat n where+ ToINat 0 = 'Z+ ToINat n = 'S (ToINat (n - 1))++-- | The actual implementation of 'ToLinearN', using the inductive natural+-- number it's handed.+type ToLinearN' :: forall {rep :: RuntimeRep}. INat -> TYPE rep -> TYPE rep -> Constraint+class ToLinearN' arrs f g where+ prf :: UnsafeEquality f g++instance a ~ b => ToLinearN' 'Z (a :: TYPE rep) (b :: TYPE rep) where+ prf = UnsafeRefl++-- We use heterogeneous equality here to shift @rep ~ 'LiftedRep@ to the left+-- side of the fat arrow, so that seeing @'S k@ lets GHC /infer/ that @x@ and+-- @y@ are lifted types, rather than needing that information to come from+-- elsewhere.+instance+ ( ToLinearN' k fb gb,+ x ~~ ((a :: TYPE repa) %p -> (fb :: TYPE repb)),+ y ~~ (a %q -> (gb :: TYPE repb))+ ) =>+ ToLinearN' ('S k) (x :: TYPE rep) (y :: TYPE rep)+ where+ prf = case prf @k @fb @gb of+ UnsafeRefl -> case unsafeEqualityProof @p @q of+ UnsafeRefl -> UnsafeRefl++-- Note: Core size+--+-- In GHC 9.0, at least, using toLinearN to implement toLinear2 and toLinear3+-- produces more Core terms, though fewer types and coercions. Does this hamper+-- inlining? If not, we could actually use it so. Alternatively, we *might* be+-- able to reduce unsafeLinearityProofN to one case expression by using some+-- (quantified constraint?) tricks. But that will be complicated, if possible,+-- and probably not worth the trouble.
test/Main.hs view
@@ -3,24 +3,35 @@ module Main where -import Test.Tasty+import Test.Data.Destination (destArrayTests) import Test.Data.Mutable.Array (mutArrTests)-import Test.Data.Mutable.Vector (mutVecTests) import Test.Data.Mutable.HashMap (mutHMTests) import Test.Data.Mutable.Set (mutSetTests)-import Test.Data.Destination (destArrayTests)+import Test.Data.Mutable.Vector (mutVecTests) import Test.Data.Polarized (polarizedArrayTests)+import Test.Data.Replicator (replicatorInspectionTests)+import Test.Data.V (vInspectionTests)+import Test.Tasty main :: IO () main = defaultMain allTests allTests :: TestTree-allTests = testGroup "All tests"- [ mutArrTests- , mutVecTests- , mutHMTests- , mutSetTests- , destArrayTests- , polarizedArrayTests- ]-+allTests =+ testGroup+ "All tests"+ [ testGroup+ "Functional tests"+ [ mutArrTests,+ mutVecTests,+ mutHMTests,+ mutSetTests,+ destArrayTests,+ polarizedArrayTests+ ],+ testGroup+ "Inspection tests"+ [ vInspectionTests,+ replicatorInspectionTests+ ]+ ]
test/Test/Data/Destination.hs view
@@ -2,27 +2,28 @@ module Test.Data.Destination (destArrayTests) where -import Test.Tasty-import Test.Tasty.Hedgehog (testProperty) import qualified Data.Array.Destination as DArray+import qualified Data.Vector as Vector import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range-import qualified Data.Vector as Vector import Prelude.Linear+import Test.Tasty+import Test.Tasty.Hedgehog (testProperty) import qualified Prelude - -- # Tests and Utlities ------------------------------------------------------------------------------- destArrayTests :: TestTree-destArrayTests = testGroup "Destination array tests"- [ testProperty "alloc . mirror = id" roundTrip- , testProperty "alloc . replicate = V.replicate" replicateTest- , testProperty "alloc . fill = V.singleton" fillTest- , testProperty "alloc n . fromFunction (+s) = V.fromEnum n s" fromFuncEnum- ]+destArrayTests =+ testGroup+ "Destination array tests"+ [ testProperty "alloc . mirror = id" roundTrip,+ testProperty "alloc . replicate = V.replicate" replicateTest,+ testProperty "alloc . fill = V.singleton" fillTest,+ testProperty "alloc n . fromFunction (+s) = V.fromEnum n s" fromFuncEnum+ ] list :: Gen [Int] list = Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 100))@@ -33,7 +34,6 @@ randNonnegInt :: Gen Int randNonnegInt = Gen.int (Range.linear 0 500) - -- # Properties ------------------------------------------------------------------------------- @@ -51,7 +51,6 @@ let v = Vector.replicate n x v === DArray.alloc n (DArray.replicate x) - fillTest :: Property fillTest = property Prelude.$ do x <- forAll randInt@@ -64,4 +63,3 @@ start <- forAll randInt let v = Vector.enumFromN start n v === DArray.alloc n (DArray.fromFunction (Prelude.+ start))-
test/Test/Data/Mutable/Array.hs view
@@ -20,15 +20,15 @@ where import qualified Data.Array.Mutable.Linear as Array-import Data.Unrestricted.Linear import qualified Data.Functor.Linear as Data+import qualified Data.List as List import qualified Data.Ord.Linear as Linear+import Data.Unrestricted.Linear+import qualified Data.Vector as Vector import Hedgehog-import qualified Data.List as List import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Prelude.Linear as Linear hiding ((>))-import qualified Data.Vector as Vector import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -41,36 +41,36 @@ group :: [TestTree] group = -- All tests for exprs of the form (read (const ...) i)- [ testProperty "∀ s,i,x. read (alloc s x) i = x" readAlloc- , testProperty "∀ a,s,x,i. read (snd (allocBeside s x a)) i = x" allocBeside- , testProperty "∀ s,a,i. i < length a, read (resize s 42 a) i = read a i" readResize- , testProperty "∀ a,i,x. read (write a i x) i = x " readWrite1- , testProperty "∀ a,i,j/=i,x. read (write a j x) i = read a i" readWrite2- -- All tests for exprs of the form (length (const ...))- , testProperty "∀ s,x. len (alloc s x) = s" lenAlloc- , testProperty "∀ a,i,x. len (write a i x) = len a" lenWrite- , testProperty "∀ a,s,x. len (resize s x a) = s" lenResizeSeed- -- Tests against a reference implementation- , testProperty+ [ testProperty "∀ s,i,x. read (alloc s x) i = x" readAlloc,+ testProperty "∀ a,s,x,i. read (snd (allocBeside s x a)) i = x" allocBeside,+ testProperty "∀ s,a,i. i < length a, read (resize s 42 a) i = read a i" readResize,+ testProperty "∀ a,i,x. read (write a i x) i = x " readWrite1,+ testProperty "∀ a,i,j/=i,x. read (write a j x) i = read a i" readWrite2,+ -- All tests for exprs of the form (length (const ...))+ testProperty "∀ s,x. len (alloc s x) = s" lenAlloc,+ testProperty "∀ a,i,x. len (write a i x) = len a" lenWrite,+ testProperty "∀ a,s,x. len (resize s x a) = s" lenResizeSeed,+ -- Tests against a reference implementation+ testProperty "∀ a,ix. toList . write a ix = (\\l -> take ix l ++ [a] ++ drop (ix+1) l) . toList"- writeRef- , testProperty "∀ ix. read ix a = (toList a) !! i" readRef- , testProperty "size = length . toList" sizeRef- , testProperty "∀ a,s,x. resize s x a = take s (toList a ++ repeat x)" resizeRef- , testProperty "∀ s,n. slice s n = take s . drop n" sliceRef- , testProperty "f <$> fromList xs == fromList (f <$> xs)" refFmap- , testProperty "toList . fromList = id" refToListFromList- , testProperty "toList . freeze . fromList = id" refFreeze- , testProperty "dup2 produces identical arrays" refDupable- -- Regression tests- , testProperty "do not reorder reads and writes" readAndWriteTest- , testProperty "do not evaluate values unnecesesarily" strictnessTest+ writeRef,+ testProperty "∀ ix. read ix a = (toList a) !! i" readRef,+ testProperty "size = length . toList" sizeRef,+ testProperty "∀ a,s,x. resize s x a = take s (toList a ++ repeat x)" resizeRef,+ testProperty "∀ s,n. slice s n = take s . drop n" sliceRef,+ testProperty "f <$> fromList xs == fromList (f <$> xs)" refFmap,+ testProperty "toList . fromList = id" refToListFromList,+ testProperty "toList . freeze . fromList = id" refFreeze,+ testProperty "dup2 produces identical arrays" refDupable,+ -- Regression tests+ testProperty "do not reorder reads and writes" readAndWriteTest,+ testProperty "do not evaluate values unnecesesarily" strictnessTest ] -- # Internal Library -------------------------------------------------------------------------------- -type ArrayTester = Array.Array Int %1-> Ur (TestT IO ())+type ArrayTester = Array.Array Int %1 -> Ur (TestT IO ()) nonEmptyList :: Gen [Int] nonEmptyList = Gen.list (Range.linear 1 1000) value@@ -83,16 +83,15 @@ value = Gen.int (Range.linear (-1000) 1000) compInts ::- Ur Int %1->- Ur Int %1->+ Ur Int %1 ->+ Ur Int %1 -> Ur (TestT IO ()) compInts (Ur x) (Ur y) = Ur (x === y) -- XXX: This is a terrible name-getFst :: Consumable b => (a, b) %1-> a+getFst :: Consumable b => (a, b) %1 -> a getFst (a, b) = lseq b a - -- # Tests -------------------------------------------------------------------------------- @@ -100,7 +99,7 @@ readAlloc = property $ do size <- forAll $ Gen.int $ Range.linear 1 1000 val <- forAll value- ix <- forAll $ Gen.element [0..size-1]+ ix <- forAll $ Gen.element [0 .. size - 1] test $ unur Linear.$ Array.alloc size val (readAllocTest ix val) readAllocTest :: Int -> Int -> ArrayTester@@ -110,24 +109,26 @@ readResize = property $ do l <- forAll nonEmptyList let size = length l- newSize <- forAll $ Gen.element [1..(size*4)]- ix <- forAll $ Gen.element [0..(min size newSize)-1]+ newSize <- forAll $ Gen.element [1 .. (size * 4)]+ ix <- forAll $ Gen.element [0 .. (min size newSize) - 1] let tester = readResizeTest newSize ix test $ unur Linear.$ Array.fromList l tester readResizeTest :: Int -> Int -> ArrayTester readResizeTest size ix arr = Array.read arr ix- Linear.& \(Ur old, arr) -> Array.resize size 42 arr- Linear.& \arr -> Array.read arr ix- Linear.& getFst- Linear.& \(Ur new) -> Ur (old === new)+ Linear.& \(Ur old, arr) ->+ Array.resize size 42 arr+ Linear.& \arr ->+ Array.read arr ix+ Linear.& getFst+ Linear.& \(Ur new) -> Ur (old === new) readWrite1 :: Property readWrite1 = property $ do l <- forAll nonEmptyList let size = length l- ix <- forAll $ Gen.element [0..size-1]+ ix <- forAll $ Gen.element [0 .. size - 1] val <- forAll value let tester = readWrite1Test ix val test $ unur Linear.$ Array.fromList l tester@@ -141,8 +142,8 @@ let list = Gen.list (Range.linearFrom 2 2 1000) value l <- forAll list let size = length l- ix <- forAll $ Gen.element [0..size-1]- jx <- forAll $ Gen.element [ z | z <- [0..size-1], z /= ix ]+ ix <- forAll $ Gen.element [0 .. size - 1]+ jx <- forAll $ Gen.element [z | z <- [0 .. size - 1], z /= ix] val <- forAll value let tester = readWrite2Test ix jx val test $ unur Linear.$ Array.fromList l tester@@ -151,7 +152,7 @@ readWrite2Test ix jx val arr = fromRead (Array.read arr ix) where fromRead ::- (Ur Int, Array.Array Int) %1-> Ur (TestT IO ())+ (Ur Int, Array.Array Int) %1 -> Ur (TestT IO ()) fromRead (val1, arr) = compInts val1@@ -161,9 +162,9 @@ allocBeside = property $ do l <- forAll nonEmptyList let size = length l- newSize <- forAll $ Gen.element [size..(size*4)]+ newSize <- forAll $ Gen.element [size .. (size * 4)] val <- forAll value- ix <- forAll $ Gen.element [0..newSize-1]+ ix <- forAll $ Gen.element [0 .. newSize - 1] let tester = allocBesideTest newSize val ix test $ unur Linear.$ Array.fromList l tester @@ -171,9 +172,10 @@ allocBesideTest newSize val ix arr = Array.allocBeside newSize val arr Linear.& getFst- Linear.& \arr -> Array.read arr ix- Linear.& getFst- Linear.& compInts (move val)+ Linear.& \arr ->+ Array.read arr ix+ Linear.& getFst+ Linear.& compInts (move val) lenAlloc :: Property lenAlloc = property $ do@@ -190,13 +192,14 @@ l <- forAll nonEmptyList let size = length l val <- forAll value- ix <- forAll $ Gen.element [0..size-1]+ ix <- forAll $ Gen.element [0 .. size - 1] let tester = lenWriteTest size val ix test $ unur Linear.$ Array.fromList l tester lenWriteTest :: Int -> Int -> Int -> ArrayTester lenWriteTest size val ix arr =- compInts (move size)+ compInts+ (move size) (getFst Linear.$ Array.size (Array.write arr ix val)) lenResizeSeed :: Property@@ -204,7 +207,7 @@ l <- forAll list let size = length l val <- forAll value- newSize <- forAll $ Gen.element [size..(size*4)]+ newSize <- forAll $ Gen.element [size .. (size * 4)] let tester = lenResizeSeedTest newSize val test $ unur Linear.$ Array.fromList l tester @@ -219,7 +222,7 @@ l <- forAll nonEmptyList v <- forAll value ix <- forAll $ Gen.int $ Range.linear 0 (List.length l - 1)- let l' = List.take ix l ++ [v] ++ List.drop (ix+1) l+ let l' = List.take ix l ++ [v] ++ List.drop (ix + 1) l l' === unur (Array.fromList l (Array.toList Linear.. Array.set ix v)) readRef :: Property@@ -261,14 +264,14 @@ Array.fromList xs Linear.$ \arr -> Array.slice s n arr Linear.& \(old, new) ->- old `lseq` Array.toList new+ old `lseq` Array.toList new expected === actual refFmap :: Property refFmap = property $ do xs <- forAll list let -- An arbitrary function- f :: Int %1-> Bool+ f :: Int %1 -> Bool f = (Linear.> 0) expected = map (Linear.forget f) xs Ur actual =@@ -296,10 +299,11 @@ -- https://github.com/tweag/linear-base/pull/135 readAndWriteTest :: Property-readAndWriteTest = withTests 1 . property $- unur (Array.fromList "a" test) === 'a'+readAndWriteTest =+ withTests 1 . property $+ unur (Array.fromList "a" test) === 'a' where- test :: Array.Array Char %1-> Ur Char+ test :: Array.Array Char %1 -> Ur Char test arr = Array.read arr 0 Linear.& \(before, arr') -> Array.write arr' 0 'b' Linear.& \arr'' ->@@ -307,11 +311,12 @@ -- https://github.com/tweag/linear-base/issues/142 strictnessTest :: Property-strictnessTest = withTests 1 . property $- unur (Array.fromList [()] test) === ()+strictnessTest =+ withTests 1 . property $+ unur (Array.fromList [()] test) === () where- test :: Array.Array () %1-> Ur ()+ test :: Array.Array () %1 -> Ur () test arr = Array.write arr 0 (error "this should not be evaluated") Linear.& \arr ->- Array.read arr 0 Linear.& \(Ur _, arr) ->- arr `Linear.lseq` Ur ()+ Array.read arr 0 Linear.& \(Ur _, arr) ->+ arr `Linear.lseq` Ur ()
test/Test/Data/Mutable/HashMap.hs view
@@ -23,19 +23,19 @@ ) where +import Data.Containers.ListUtils (nubOrdOn)+import Data.Function ((&)) import qualified Data.Functor.Linear as Linear import qualified Data.HashMap.Mutable.Linear as HashMap+import Data.List (sort)+import qualified Data.List as List+import qualified Data.Map.Lazy as Map+import Data.Maybe (mapMaybe) import Data.Unrestricted.Linear-import Data.Function ((&)) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Prelude.Linear as Linear-import qualified Data.Map.Lazy as Map-import Data.Containers.ListUtils (nubOrdOn)-import Data.List (sort)-import qualified Data.List as List-import Data.Maybe (mapMaybe) import Test.Tasty import Test.Tasty.Hedgehog (testProperty) @@ -48,31 +48,31 @@ group :: [TestTree] group = [ -- Axiomatic tests- testProperty "∀ k,v,m. lookup k (insert m k v) = Just v" lookupInsert1- , testProperty+ testProperty "∀ k,v,m. lookup k (insert m k v) = Just v" lookupInsert1,+ testProperty "∀ k,v,m,k'/=k. lookup k'(insert m k v) = lookup k' m"- lookupInsert2- , testProperty "∀ k,m. lookup k (delete m k) = Nothing" lookupDelete1- , testProperty+ lookupInsert2,+ testProperty "∀ k,m. lookup k (delete m k) = Nothing" lookupDelete1,+ testProperty "∀ k,m,k'/=k. lookup k' (delete m k) = lookup k' m"- lookupDelete2- , testProperty "∀ k,v,m. member k (insert m k v) = True" memberInsert- , testProperty "∀ k,m. member k (delete m k) = False" memberDelete- , testProperty "∀ k,v,m. size (insert (m-k) k v) = 1+ size (m-k)" sizeInsert- , testProperty "∀ k,m with k. size (delete m k) + 1 = size m" deleteSize- -- Homorphism tests against a reference implementation- , testProperty "insert k v h = fromList (toList h ++ [(k,v)])" refInsert- , testProperty "delete k h = fromList (filter (!= k . fst) (toList h))" refDelete- , testProperty "fst . lookup k h = lookup k (toList h)" refLookup- , testProperty "mapMaybe f h = fromList . mapMaybe (uncurry f) . toList" refMap- , testProperty "size = length . toList" refSize- , testProperty "toList . fromList = id" refToListFromList- , testProperty "filter f (fromList xs) = fromList (filter f xs)" refFilter- , testProperty "fromList xs <> fromList ys = fromList (xs <> ys)" refMappend- , testProperty "unionWith reference" refUnionWith- , testProperty "intersectionWith reference" refIntersectionWith- -- Misc- , testProperty "toList . shrinkToFit = toList" shrinkToFitTest+ lookupDelete2,+ testProperty "∀ k,v,m. member k (insert m k v) = True" memberInsert,+ testProperty "∀ k,m. member k (delete m k) = False" memberDelete,+ testProperty "∀ k,v,m. size (insert (m-k) k v) = 1+ size (m-k)" sizeInsert,+ testProperty "∀ k,m with k. size (delete m k) + 1 = size m" deleteSize,+ -- Homorphism tests against a reference implementation+ testProperty "insert k v h = fromList (toList h ++ [(k,v)])" refInsert,+ testProperty "delete k h = fromList (filter (!= k . fst) (toList h))" refDelete,+ testProperty "fst . lookup k h = lookup k (toList h)" refLookup,+ testProperty "mapMaybe f h = fromList . mapMaybe (uncurry f) . toList" refMap,+ testProperty "size = length . toList" refSize,+ testProperty "toList . fromList = id" refToListFromList,+ testProperty "filter f (fromList xs) = fromList (filter f xs)" refFilter,+ testProperty "fromList xs <> fromList ys = fromList (xs <> ys)" refMappend,+ testProperty "unionWith reference" refUnionWith,+ testProperty "intersectionWith reference" refIntersectionWith,+ -- Misc+ testProperty "toList . shrinkToFit = toList" shrinkToFitTest ] -- # Internal Library@@ -85,8 +85,7 @@ type HMap = HashMap.HashMap Int String -- | A test checks a boolean property on a hashmap and consumes it-type HMTest = HMap %1-> Ur Bool-+type HMTest = HMap %1 -> Ur Bool maxSize :: Int maxSize = 800@@ -106,7 +105,7 @@ testKVPairExists (k, v) hmap = fromLookup Linear.$ getFst Linear.$ HashMap.lookup k hmap where- fromLookup :: Ur (Maybe String) %1-> Ur Bool+ fromLookup :: Ur (Maybe String) %1 -> Ur Bool fromLookup (Ur Nothing) = Ur False fromLookup (Ur (Just v')) = Ur (v' == v) @@ -121,27 +120,28 @@ testKeyMissing key hmap = fromLookup Linear.$ getFst Linear.$ HashMap.lookup key hmap where- fromLookup :: Ur (Maybe String) %1-> Ur Bool+ fromLookup :: Ur (Maybe String) %1 -> Ur Bool fromLookup (Ur Nothing) = Ur True fromLookup (Ur _) = Ur False -testLookupUnchanged :: (HMap %1-> HMap) -> Int -> HMTest+testLookupUnchanged :: (HMap %1 -> HMap) -> Int -> HMTest testLookupUnchanged f k hmap = fromLookup (HashMap.lookup k hmap) where- fromLookup :: (Ur (Maybe String), HMap) %1-> Ur Bool+ fromLookup :: (Ur (Maybe String), HMap) %1 -> Ur Bool fromLookup (look1, hmap') = compareMaybes look1 (getFst Linear.$ HashMap.lookup k (f hmap')) -insertPair :: (Int, String) -> HMap %1-> HMap+insertPair :: (Int, String) -> HMap %1 -> HMap insertPair (k, v) hmap = HashMap.insert k v hmap -- XXX: This is a terrible name-getFst :: (Consumable b) => (a, b) %1-> a+getFst :: (Consumable b) => (a, b) %1 -> a getFst (a, b) = lseq b a -compareMaybes :: Eq a =>- Ur (Maybe a) %1->- Ur (Maybe a) %1->+compareMaybes ::+ Eq a =>+ Ur (Maybe a) %1 ->+ Ur (Maybe a) %1 -> Ur Bool compareMaybes (Ur a) (Ur b) = Ur (a == b) @@ -226,13 +226,13 @@ checkSizeAfterInsert :: (Int, String) -> HMTest checkSizeAfterInsert (k, v) hmap = withSize Linear.$ HashMap.size hmap where- withSize :: (Ur Int, HMap) %1-> Ur Bool+ withSize :: (Ur Int, HMap) %1 -> Ur Bool withSize (oldSize, hmap) =- checkSize oldSize- Linear.$ getFst- Linear.$ HashMap.size- Linear.$ HashMap.insert k v hmap- checkSize :: Ur Int %1-> Ur Int %1-> Ur Bool+ checkSize oldSize Linear.$+ getFst Linear.$+ HashMap.size Linear.$+ HashMap.insert k v hmap+ checkSize :: Ur Int %1 -> Ur Int %1 -> Ur Bool checkSize (Ur old) (Ur new) = Ur ((old + 1) == new) @@ -247,12 +247,12 @@ checkSizeAfterDelete :: Int -> HMTest checkSizeAfterDelete key hmap = fromSize (HashMap.size hmap) where- fromSize :: (Ur Int, HMap) %1-> Ur Bool+ fromSize :: (Ur Int, HMap) %1 -> Ur Bool fromSize (orgSize, hmap) =- compSizes orgSize- Linear.$ getFst- Linear.$ HashMap.size (HashMap.delete key hmap)- compSizes :: Ur Int %1-> Ur Int %1-> Ur Bool+ compSizes orgSize Linear.$+ getFst Linear.$+ HashMap.size (HashMap.delete key hmap)+ compSizes :: Ur Int %1 -> Ur Int %1 -> Ur Bool compSizes (Ur orgSize) (Ur newSize) = Ur ((newSize + 1) == orgSize) @@ -261,7 +261,7 @@ k <- forAll key v <- forAll val kvs <- forAll keyVals- let listInsert = HashMap.fromList (kvs ++ [(k,v)]) HashMap.toList+ let listInsert = HashMap.fromList (kvs ++ [(k, v)]) HashMap.toList let hmInsert = HashMap.fromList kvs (HashMap.toList Linear.. HashMap.insert k v) sort (unur listInsert) === sort (unur hmInsert) @@ -279,32 +279,30 @@ kvs <- forAll keyVals k <- forAll key let listLookup = List.lookup k (List.reverse kvs)- let (#.) = (Linear..)- let hmLookup = HashMap.fromList kvs (getFst #. HashMap.lookup k)+ let hmLookup = HashMap.fromList kvs (getFst Linear.. HashMap.lookup k) listLookup === unur hmLookup refMap :: Property refMap = defProperty $ do let f k v = if mod k 5 < 3 then Just (show k ++ v) else Nothing- let f' (k,v) = fmap ((,) k) (f k v)+ let f' (k, v) = fmap ((,) k) (f k v) kvs <- forAll keyVals- let (#.) = (Linear..) let mappedList = mapMaybe f' (nubOrdOn fst (List.reverse kvs))- let mappedHm = HashMap.fromList kvs (HashMap.toList #. HashMap.mapMaybeWithKey f)+ let mappedHm = HashMap.fromList kvs (HashMap.toList Linear.. HashMap.mapMaybeWithKey f) sort mappedList === sort (unur mappedHm) refSize :: Property refSize = defProperty $ do kvs <- forAll keyVals- let (#.) = (Linear..)- length (nubOrdOn fst kvs) === unur (HashMap.fromList kvs (getFst #. HashMap.size))+ length (nubOrdOn fst kvs) === unur (HashMap.fromList kvs (getFst Linear.. HashMap.size)) refToListFromList :: Property refToListFromList = defProperty $ do xs <- forAll keyVals - let expected = Map.fromList xs- & Map.toList+ let expected =+ Map.fromList xs+ & Map.toList Ur actual = HashMap.fromList xs HashMap.toList @@ -315,14 +313,16 @@ xs <- forAll keyVals let predicate "" = False- predicate (i:_) = i < 'h'+ predicate (i : _) = i < 'h' - expected = Map.fromList xs- & Map.filter predicate- & Map.toList+ expected =+ Map.fromList xs+ & Map.filter predicate+ & Map.toList - Ur actual = HashMap.fromList xs Linear.$- HashMap.toList Linear.. HashMap.filter predicate+ Ur actual =+ HashMap.fromList xs Linear.$+ HashMap.toList Linear.. HashMap.filter predicate sort expected === sort actual @@ -348,10 +348,12 @@ let combine a b = a ++ "," ++ b - expected = Map.unionWith combine- (Map.fromList xs)- (Map.fromList ys)- & Map.toList+ expected =+ Map.unionWith+ combine+ (Map.fromList xs)+ (Map.fromList ys)+ & Map.toList Ur actual = HashMap.fromList xs Linear.$ \hx ->@@ -366,10 +368,12 @@ xs <- forAll keyVals ys <- forAll keyVals - let expected = Map.intersectionWith (,)- (Map.fromList xs)- (Map.fromList ys)- & Map.toList+ let expected =+ Map.intersectionWith+ (,)+ (Map.fromList xs)+ (Map.fromList ys)+ & Map.toList Ur actual = HashMap.fromList xs Linear.$ \hx ->@@ -382,7 +386,5 @@ shrinkToFitTest :: Property shrinkToFitTest = defProperty $ do kvs <- forAll keyVals- let (#.) = (Linear..)- let shrunk = (HashMap.fromList kvs (HashMap.toList #. HashMap.shrinkToFit))+ let shrunk = (HashMap.fromList kvs (HashMap.toList Linear.. HashMap.shrinkToFit)) sort (nubOrdOn fst (List.reverse kvs)) === sort (unur shrunk)-
test/Test/Data/Mutable/Set.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE LinearTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | -- Tests for mutable sets. --@@ -58,13 +59,13 @@ ) where -import qualified Data.Set.Mutable.Linear as Set+import Data.Containers.ListUtils (nubOrd)+import qualified Data.Functor.Linear as Data+import qualified Data.List as List import Data.Set.Mutable.Linear (Set)+import qualified Data.Set.Mutable.Linear as Set import Data.Unrestricted.Linear import Hedgehog-import Data.Containers.ListUtils (nubOrd)-import qualified Data.List as List-import qualified Data.Functor.Linear as Data import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Prelude.Linear as Linear@@ -80,22 +81,22 @@ group :: [TestTree] group = -- Tests of the form [accessor (mutator)]- [ testProperty "∀ x. member (insert s x) x = True" memberInsert1- , testProperty "∀ x,y/=x. member (insert s x) y = member s y" memberInsert2- , testProperty "∀ x. member (delete s x) x = False" memberDelete1- , testProperty "∀ x,y/=x. member (delete s x) y = member s y" memberDelete2- , testProperty "∀ s, x \\in s. size (insert s x) = size s" sizeInsert1- , testProperty "∀ s, x \\notin s. size (insert s x) = size s + 1" sizeInsert2- , testProperty "∀ s, x \\in s. size (delete s x) = size s - 1" sizeDelete1- , testProperty "∀ s, x \\notin s. size (delete s x) = size s" sizeDelete2- -- Homomorphism tests- , testProperty "sort . nub = sort . toList" toListFromList- , testProperty "member x s = elem x (toList s)" memberHomomorphism- , testProperty "size = length . toList" sizeHomomorphism- , testProperty+ [ testProperty "∀ x. member (insert s x) x = True" memberInsert1,+ testProperty "∀ x,y/=x. member (insert s x) y = member s y" memberInsert2,+ testProperty "∀ x. member (delete s x) x = False" memberDelete1,+ testProperty "∀ x,y/=x. member (delete s x) y = member s y" memberDelete2,+ testProperty "∀ s, x \\in s. size (insert s x) = size s" sizeInsert1,+ testProperty "∀ s, x \\notin s. size (insert s x) = size s + 1" sizeInsert2,+ testProperty "∀ s, x \\in s. size (delete s x) = size s - 1" sizeDelete1,+ testProperty "∀ s, x \\notin s. size (delete s x) = size s" sizeDelete2,+ -- Homomorphism tests+ testProperty "sort . nub = sort . toList" toListFromList,+ testProperty "member x s = elem x (toList s)" memberHomomorphism,+ testProperty "size = length . toList" sizeHomomorphism,+ testProperty "sort . nub ((toList s) ∪ (toList s')) = sort . toList (s ∪ s')"- unionHomomorphism- , testProperty+ unionHomomorphism,+ testProperty "sort . nub ((toList s) ∩ (toList s')) = sort . toList (s ∩ s')" intersectHomomorphism ]@@ -103,7 +104,7 @@ -- # Internal Library -------------------------------------------------------------------------------- -type SetTester = Set.Set Int %1-> Ur (TestT IO ())+type SetTester = Set.Set Int %1 -> Ur (TestT IO ()) -- | A random list list :: Gen [Int]@@ -116,14 +117,15 @@ value :: Gen Int value = Gen.int (Range.linear (-100) 100) -testEqual :: (Show a, Eq a) =>- Ur a %1->- Ur a %1->+testEqual ::+ (Show a, Eq a) =>+ Ur a %1 ->+ Ur a %1 -> Ur (TestT IO ()) testEqual (Ur x) (Ur y) = Ur (x === y) -- XXX: This is a terrible name-getFst :: Consumable b => (a, b) %1-> a+getFst :: Consumable b => (a, b) %1 -> a getFst (a, b) = lseq b a -- # Tests@@ -153,7 +155,7 @@ memberInsert2Test :: Int -> Int -> SetTester memberInsert2Test val1 val2 set = fromRead (Set.member val2 set) where- fromRead :: (Ur Bool, Set.Set Int) %1-> Ur (TestT IO ())+ fromRead :: (Ur Bool, Set.Set Int) %1 -> Ur (TestT IO ()) fromRead (memberVal2, set) = testEqual memberVal2@@ -183,7 +185,7 @@ memberDelete2Test :: Int -> Int -> SetTester memberDelete2Test val1 val2 set = fromRead (Set.member val2 set) where- fromRead :: (Ur Bool, Set.Set Int) %1-> Ur (TestT IO ())+ fromRead :: (Ur Bool, Set.Set Int) %1 -> Ur (TestT IO ()) fromRead (memberVal2, set) = testEqual memberVal2@@ -199,7 +201,7 @@ sizeInsert1Test :: Int -> SetTester sizeInsert1Test val set = fromRead (Set.size set) where- fromRead :: (Ur Int, Set.Set Int) %1-> Ur (TestT IO ())+ fromRead :: (Ur Int, Set.Set Int) %1 -> Ur (TestT IO ()) fromRead (sizeOriginal, set) = testEqual sizeOriginal@@ -215,7 +217,7 @@ sizeInsert2Test :: Int -> SetTester sizeInsert2Test val set = fromRead (Set.size set) where- fromRead :: (Ur Int, Set.Set Int) %1-> Ur (TestT IO ())+ fromRead :: (Ur Int, Set.Set Int) %1 -> Ur (TestT IO ()) fromRead (sizeOriginal, set) = testEqual ((Linear.+ 1) Data.<$> sizeOriginal)@@ -231,7 +233,7 @@ sizeDelete1Test :: Int -> SetTester sizeDelete1Test val set = fromRead (Set.size set) where- fromRead :: (Ur Int, Set.Set Int) %1-> Ur (TestT IO ())+ fromRead :: (Ur Int, Set.Set Int) %1 -> Ur (TestT IO ()) fromRead (sizeOriginal, set) = testEqual ((Linear.- 1) Data.<$> sizeOriginal)@@ -247,7 +249,7 @@ sizeDelete2Test :: Int -> SetTester sizeDelete2Test val set = fromRead (Set.size set) where- fromRead :: (Ur Int, Set.Set Int) %1-> Ur (TestT IO ())+ fromRead :: (Ur Int, Set.Set Int) %1 -> Ur (TestT IO ()) fromRead (sizeOriginal, set) = testEqual sizeOriginal@@ -267,10 +269,10 @@ let setUnion = List.sort $ unur (fromLists l l' doUnion) setUnion === listUnion where- fromLists :: [Int] -> [Int] -> (Set Int %1-> Set Int %1-> Ur b) %1-> Ur b+ fromLists :: [Int] -> [Int] -> (Set Int %1 -> Set Int %1 -> Ur b) %1 -> Ur b fromLists l l' f = Set.fromList l (\s -> Set.fromList l' (\s' -> f s s')) - doUnion :: Set Int %1-> Set Int %1-> Ur [Int]+ doUnion :: Set Int %1 -> Set Int %1 -> Ur [Int] doUnion s s' = Set.toList (Set.union s s') intersectHomomorphism :: Property@@ -281,10 +283,10 @@ let setIntersect = List.sort $ unur (fromLists l l' doIntersect) setIntersect === listIntersect where- fromLists :: [Int] -> [Int] -> (Set Int %1-> Set Int %1-> Ur b) %1-> Ur b+ fromLists :: [Int] -> [Int] -> (Set Int %1 -> Set Int %1 -> Ur b) %1 -> Ur b fromLists l l' f = Set.fromList l (\s -> Set.fromList l' (\s' -> f s s')) - doIntersect :: Set Int %1-> Set Int %1-> Ur [Int]+ doIntersect :: Set Int %1 -> Set Int %1 -> Ur [Int] doIntersect s s' = Set.toList (Set.intersection s s') memberHomomorphism :: Property@@ -297,4 +299,3 @@ sizeHomomorphism = property $ do l <- forAll list length (nubOrd l) === (unur (Set.fromList l (getFst Linear.. Set.size)))-
test/Test/Data/Mutable/Vector.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-name-shadowing -Wno-incomplete-uni-patterns #-} -- | -- Tests for mutable vectors.@@ -20,17 +20,17 @@ ) where -import qualified Data.Vector.Mutable.Linear as Vector-import Data.Unrestricted.Linear import qualified Data.Functor.Linear as Data-import Hedgehog-import Data.Ord.Linear as Linear hiding (Eq(..))-import Data.Maybe (mapMaybe) import qualified Data.List as List+import Data.Maybe (mapMaybe)+import Data.Ord.Linear as Linear hiding (Eq (..))+import Data.Unrestricted.Linear+import qualified Data.Vector as ImmutableVector+import qualified Data.Vector.Mutable.Linear as Vector+import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Prelude.Linear as Linear hiding ((>))-import qualified Data.Vector as ImmutableVector import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -43,49 +43,49 @@ group :: [TestTree] group = -- All tests for exprs of the form (read (const ...) i)- [ testProperty "∀ s,i,x. read (constant s x) i = x" readConst- , testProperty "∀ a,i,x. read (write a i x) i = x " readWrite1- , testProperty "∀ a,i,j/=i,x. read (write a j x) i = read a i" readWrite2- , testProperty "∀ a,x,(i < len a). read (push a x) i = read a i" readPush1- , testProperty "∀ a,x. read (push a x) (len a) = x" readPush2- -- All tests for exprs of the form (length (const ...))- , testProperty "∀ s,x. len (constant s x) = s" lenConst- , testProperty "∀ a,i,x. len (write a i x) = len a" lenWrite- , testProperty "∀ a,x. len (push a x) = 1 + len a" lenPush- -- Tests against a reference implementation- , testProperty+ [ testProperty "∀ s,i,x. read (constant s x) i = x" readConst,+ testProperty "∀ a,i,x. read (write a i x) i = x " readWrite1,+ testProperty "∀ a,i,j/=i,x. read (write a j x) i = read a i" readWrite2,+ testProperty "∀ a,x,(i < len a). read (push a x) i = read a i" readPush1,+ testProperty "∀ a,x. read (push a x) (len a) = x" readPush2,+ -- All tests for exprs of the form (length (const ...))+ testProperty "∀ s,x. len (constant s x) = s" lenConst,+ testProperty "∀ a,i,x. len (write a i x) = len a" lenWrite,+ testProperty "∀ a,x. len (push a x) = 1 + len a" lenPush,+ -- Tests against a reference implementation+ testProperty "write ix a v = (\\l -> take ix l ++ [a] ++ drop (ix+1) l) . toList"- refWrite- , testProperty "fst $ modify f ix v = snd $ f ((toList v) !! ix)" refModify1- , testProperty+ refWrite,+ testProperty "fst $ modify f ix v = snd $ f ((toList v) !! ix)" refModify1,+ testProperty "snd (modify f i v) = write (toList v) i (fst (f ((toList v) !! i))))"- refModify2- , testProperty "toList . push x = snoc x . toList" refPush- , testProperty "toList . pop = init . toList" refPop- , testProperty "read ix v = (toList v) !! ix" refRead- , testProperty "size = length . toList" refSize- , testProperty "toList . shrinkToFit = toList" refShrinkToFit- , testProperty "pop . push _ = id" refPopPush- , testProperty "push . pop = id" refPushPop- , testProperty "slice s n = take s . drop n" refSlice- , testProperty "toList . fromList = id" refToListFromList- , testProperty "toList can be implemented with repeated pops" refToListViaPop- , testProperty "fromList can be implemented with repeated pushes" refFromListViaPush- , testProperty "toList works with extra capacity" refToListWithExtraCapacity- , testProperty "fromList xs <> fromList ys = fromList (xs <> ys)" refMappend- , testProperty "mapMaybe f (fromList xs) = fromList (mapMaybe f xs)" refMapMaybe- , testProperty "filter f (fromList xs) = fromList (filter f xs)" refFilter- , testProperty "f <$> fromList xs == fromList (f <$> xs)" refFmap- , testProperty "toList . freeze . fromList = id" refFreeze- -- Regression tests- , testProperty "push on an empty vector should succeed" snocOnEmptyVector- , testProperty "do not reorder reads and writes" readAndWriteTest+ refModify2,+ testProperty "toList . push x = snoc x . toList" refPush,+ testProperty "toList . pop = init . toList" refPop,+ testProperty "read ix v = (toList v) !! ix" refRead,+ testProperty "size = length . toList" refSize,+ testProperty "toList . shrinkToFit = toList" refShrinkToFit,+ testProperty "pop . push _ = id" refPopPush,+ testProperty "push . pop = id" refPushPop,+ testProperty "slice s n = take s . drop n" refSlice,+ testProperty "toList . fromList = id" refToListFromList,+ testProperty "toList can be implemented with repeated pops" refToListViaPop,+ testProperty "fromList can be implemented with repeated pushes" refFromListViaPush,+ testProperty "toList works with extra capacity" refToListWithExtraCapacity,+ testProperty "fromList xs <> fromList ys = fromList (xs <> ys)" refMappend,+ testProperty "mapMaybe f (fromList xs) = fromList (mapMaybe f xs)" refMapMaybe,+ testProperty "filter f (fromList xs) = fromList (filter f xs)" refFilter,+ testProperty "f <$> fromList xs == fromList (f <$> xs)" refFmap,+ testProperty "toList . freeze . fromList = id" refFreeze,+ -- Regression tests+ testProperty "push on an empty vector should succeed" snocOnEmptyVector,+ testProperty "do not reorder reads and writes" readAndWriteTest ] -- # Internal Library -------------------------------------------------------------------------------- -type VectorTester = Vector.Vector Int %1-> Ur (TestT IO ())+type VectorTester = Vector.Vector Int %1 -> Ur (TestT IO ()) nonEmptyList :: Gen [Int] nonEmptyList = Gen.list (Range.linear 1 1000) val@@ -97,29 +97,29 @@ val = Gen.int (Range.linear (-1000) 1000) compInts ::- Ur Int %1->- Ur Int %1->+ Ur Int %1 ->+ Ur Int %1 -> Ur (TestT IO ()) compInts (Ur x) (Ur y) = Ur (x === y) -- XXX: This is a terrible name-getFst :: Consumable b => (a, b) %1-> a+getFst :: Consumable b => (a, b) %1 -> a getFst (a, b) = lseq b a -getSnd :: Consumable a => (a, b) %1-> b+getSnd :: Consumable a => (a, b) %1 -> b getSnd (a, b) = lseq a b - -- # Tests -------------------------------------------------------------------------------- snocOnEmptyVector :: Property snocOnEmptyVector = withTests 1 . property $ do let Ur actual =- Vector.empty- Linear.$ \vec -> Vector.push (42 :: Int) vec- Linear.& Vector.get 0- Linear.& getFst+ Vector.empty Linear.$+ \vec ->+ Vector.push (42 :: Int) vec+ Linear.& Vector.get 0+ Linear.& getFst actual === 42 -- | Constant should give us a constant vector.@@ -127,7 +127,7 @@ readConst = property $ do size <- forAll $ Gen.int $ Range.linear 1 1000 v <- forAll val- ix <- forAll $ Gen.element [0..size-1]+ ix <- forAll $ Gen.element [0 .. size - 1] test $ unur Linear.$ Vector.constant size v (readConstTest ix v) readConstTest :: Int -> Int -> VectorTester@@ -137,7 +137,7 @@ readWrite1 = property $ do l <- forAll nonEmptyList let size = length l- ix <- forAll $ Gen.element [0..size-1]+ ix <- forAll $ Gen.element [0 .. size - 1] v <- forAll val let tester = readWrite1Test ix v test $ unur Linear.$ Vector.fromList l tester@@ -151,8 +151,8 @@ let list = Gen.list (Range.linearFrom 2 2 1000) val l <- forAll list let size = length l- ix <- forAll $ Gen.element [0..size-1]- jx <- forAll $ Gen.element [ z | z <- [0..size-1], z /= ix ]+ ix <- forAll $ Gen.element [0 .. size - 1]+ jx <- forAll $ Gen.element [z | z <- [0 .. size - 1], z /= ix] v <- forAll val let tester = readWrite2Test ix jx v test $ unur Linear.$ Vector.fromList l tester@@ -160,7 +160,7 @@ readWrite2Test :: Int -> Int -> Int -> VectorTester readWrite2Test ix jx val vec = fromRead (Vector.read vec ix) where- fromRead :: (Ur Int, Vector.Vector Int) %1-> Ur (TestT IO ())+ fromRead :: (Ur Int, Vector.Vector Int) %1 -> Ur (TestT IO ()) fromRead (val1, vec) = compInts val1@@ -171,18 +171,17 @@ l <- forAll nonEmptyList let size = length l v <- forAll val- ix <- forAll $ Gen.element [0..size-1]+ ix <- forAll $ Gen.element [0 .. size - 1] let tester = readPush1Test v ix test $ unur Linear.$ Vector.fromList l tester readPush1Test :: Int -> Int -> VectorTester readPush1Test val ix vec = fromRead (Vector.read vec ix) where- fromRead :: (Ur Int, Vector.Vector Int) %1-> Ur (TestT IO ())+ fromRead :: (Ur Int, Vector.Vector Int) %1 -> Ur (TestT IO ()) fromRead (val', vec) = compInts (getFst (Vector.get ix (Vector.push val vec))) val' - readPush2 :: Property readPush2 = property $ do l <- forAll list@@ -194,7 +193,7 @@ readPush2Test val vec = fromLen (Vector.size vec) where fromLen ::- (Ur Int, Vector.Vector Int) %1->+ (Ur Int, Vector.Vector Int) %1 -> Ur (TestT IO ()) fromLen (Ur len, vec) = compInts (getFst (Vector.get len (Vector.push val vec))) (move val)@@ -214,7 +213,7 @@ l <- forAll nonEmptyList let size = length l v <- forAll val- ix <- forAll $ Gen.element [0..size-1]+ ix <- forAll $ Gen.element [0 .. size - 1] let tester = lenWriteTest size v ix test $ unur Linear.$ Vector.fromList l tester @@ -226,55 +225,54 @@ lenPush :: Property lenPush = property $ do- l <- forAll list- v <- forAll val- let tester = lenPushTest v- test $ unur Linear.$ Vector.fromList l tester+ l <- forAll list+ v <- forAll val+ let tester = lenPushTest v+ test $ unur Linear.$ Vector.fromList l tester lenPushTest :: Int -> VectorTester lenPushTest val vec = fromLen Linear.$ Vector.size vec where fromLen ::- (Ur Int, Vector.Vector Int) %1->+ (Ur Int, Vector.Vector Int) %1 -> Ur (TestT IO ()) fromLen (Ur len, vec) =- compInts (move (len+1)) (getFst (Vector.size (Vector.push val vec)))+ compInts (move (len + 1)) (getFst (Vector.size (Vector.push val vec))) refWrite :: Property refWrite = property $ do l <- forAll nonEmptyList- ix <- forAll $ Gen.element [0..(length l - 1)]+ ix <- forAll $ Gen.element [0 .. (length l - 1)] v <- forAll val let l' = listWrite ix v l l' === unur (Vector.fromList l (Vector.toList Linear.. Vector.set ix v)) where- listWrite :: Int -> a -> [a] -> [a] listWrite n _ _ | n Prelude.< 0 = error "Index negative" listWrite _ _ [] = error "Index too big"- listWrite 0 a (_:xs) = a:xs- listWrite n a (x:xs) = x : listWrite (n-1) a xs+ listWrite 0 a (_ : xs) = a : xs+ listWrite n a (x : xs) = x : listWrite (n - 1) a xs refModify1 :: Property refModify1 = property $ do l <- forAll nonEmptyList let f x = (mod x 5, (mod x 5) Prelude.< 3)- ix <- forAll $ Gen.element [0..(length l - 1)]+ ix <- forAll $ Gen.element [0 .. (length l - 1)] snd (f (l !! ix)) === unur (Vector.fromList l (getFst Linear.. Vector.modify f ix)) refModify2 :: Property refModify2 = property $ do l <- forAll nonEmptyList- let f x = 3*x*x - 2*x + 4- ix <- forAll $ Gen.element [0..(length l - 1)]+ let f x = 3 * x * x - 2 * x + 4+ ix <- forAll $ Gen.element [0 .. (length l - 1)] let l' = listMod ix f l l' === unur (Vector.fromList l (Vector.toList Linear.. Vector.modify_ f ix)) where listMod :: Int -> (a -> a) -> [a] -> [a] listMod n _ _ | n Prelude.< 0 = error "Index negative" listMod _ _ [] = error "Index too big"- listMod 0 f (x:xs) = f x : xs- listMod n f (x:xs) = x : listMod (n-1) f xs+ listMod 0 f (x : xs) = f x : xs+ listMod n f (x : xs) = x : listMod (n - 1) f xs refPush :: Property refPush = property $ do@@ -292,7 +290,7 @@ refRead :: Property refRead = property $ do l <- forAll nonEmptyList- ix <- forAll $ Gen.element [0..(length l - 1)]+ ix <- forAll $ Gen.element [0 .. (length l - 1)] let value = l List.!! ix value === unur (Vector.fromList l (getFst Linear.. Vector.get ix)) @@ -331,7 +329,7 @@ Vector.push (error "not used") vec Linear.& Vector.pop Linear.& \(Ur _, vec) ->- Vector.toList vec+ Vector.toList vec xs === actual refPushPop :: Property@@ -341,8 +339,8 @@ Vector.fromList xs Linear.$ \vec -> Vector.pop vec Linear.& \(Ur (Just a), vec) ->- Vector.push a vec- Linear.& Vector.toList+ Vector.push a vec+ Linear.& Vector.toList xs === actual refToListViaPop :: Property@@ -351,12 +349,12 @@ let Ur actual = Vector.fromList xs (popAll []) xs === actual- where- popAll :: [a] -> Vector.Vector a %1-> Ur [a]- popAll acc vec =- Vector.pop vec Linear.& \case- (Ur Nothing, vec') -> vec' `lseq` Ur acc- (Ur (Just x), vec') -> popAll (x:acc) vec'+ where+ popAll :: [a] -> Vector.Vector a %1 -> Ur [a]+ popAll acc vec =+ Vector.pop vec Linear.& \case+ (Ur Nothing, vec') -> vec' `lseq` Ur acc+ (Ur (Just x), vec') -> popAll (x : acc) vec' refFromListViaPush :: Property refFromListViaPush = property $ do@@ -365,10 +363,10 @@ Vector.empty Linear.$ Vector.toList Linear.. pushAll xs xs === actual- where- pushAll :: [a] -> Vector.Vector a %1-> Vector.Vector a- pushAll [] vec = vec- pushAll (x:xs) vec = Vector.push x vec Linear.& pushAll xs+ where+ pushAll :: [a] -> Vector.Vector a %1 -> Vector.Vector a+ pushAll [] vec = vec+ pushAll (x : xs) vec = Vector.push x vec Linear.& pushAll xs refSlice :: Property refSlice = property $ do@@ -397,7 +395,7 @@ refFmap = property $ do xs <- forAll list let -- An arbitrary function- f :: Int %1-> Bool+ f :: Int %1 -> Bool f = (Linear.> 0) expected = map (Linear.forget f) xs Ur actual =@@ -442,22 +440,24 @@ let expected = if shouldAppend- then xs ++ [12]- else xs+ then xs ++ [12]+ else xs Ur actual = Vector.fromList xs Linear.$ \vec ->- (if shouldAppend+ ( if shouldAppend then Vector.push 12 vec else vec- ) Linear.& Vector.freeze+ )+ Linear.& Vector.freeze expected === ImmutableVector.toList actual -- https://github.com/tweag/linear-base/pull/135 readAndWriteTest :: Property-readAndWriteTest = withTests 1 . property $- unur (Vector.fromList "a" test) === 'a'+readAndWriteTest =+ withTests 1 . property $+ unur (Vector.fromList "a" test) === 'a' where- test :: Vector.Vector Char %1-> Ur Char+ test :: Vector.Vector Char %1 -> Ur Char test vec = Vector.read vec 0 Linear.& \(before, vec') -> Vector.write vec' 0 'b' Linear.& \vec'' ->
test/Test/Data/Polarized.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE NoImplicitPrelude #-}+ module Test.Data.Polarized (polarizedArrayTests) where -import Test.Tasty-import Test.Tasty.Hedgehog (testProperty)-import Hedgehog-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range+import qualified Data.Array.Polarized as Polar import qualified Data.Array.Polarized.Pull as Pull import qualified Data.Array.Polarized.Push as Push-import qualified Data.Array.Polarized as Polar import qualified Data.Vector as Vector+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range import Prelude.Linear+import Test.Tasty+import Test.Tasty.Hedgehog (testProperty) import qualified Prelude {- TODO:@@ -20,22 +21,23 @@ -} - -- # Tests and Utlities ------------------------------------------------------------------------------- polarizedArrayTests :: TestTree-polarizedArrayTests = testGroup "Polarized arrays"- [ testProperty "Push.alloc . transfer . Pull.fromVector = id" polarRoundTrip- , testProperty "Push.append ~ Vec.append" pushAppend- , testProperty "Push.make ~ Vec.replicate" pushMake- , testProperty "Pull.append ~ Vec.append" pullAppend- , testProperty "Pull.asList . Pull.fromVector ~ id" pullAsList- , testProperty "Pull.singleton x = [x]" pullSingleton- , testProperty "Pull.splitAt ~ splitAt" pullSplitAt- , testProperty "Pull.make ~ Vec.replicate" pullMake- , testProperty "Pull.zip ~ zip" pullZip- ]+polarizedArrayTests =+ testGroup+ "Polarized arrays"+ [ testProperty "Push.alloc . transfer . Pull.fromVector = id" polarRoundTrip,+ testProperty "Push.append ~ Vec.append" pushAppend,+ testProperty "Push.make ~ Vec.replicate" pushMake,+ testProperty "Pull.append ~ Vec.append" pullAppend,+ testProperty "Pull.asList . Pull.fromVector ~ id" pullAsList,+ testProperty "Pull.singleton x = [x]" pullSingleton,+ testProperty "Pull.splitAt ~ splitAt" pullSplitAt,+ testProperty "Pull.make ~ Vec.replicate" pullMake,+ testProperty "Pull.zip ~ zip" pullZip+ ] list :: Gen [Int] list = Gen.list (Range.linear 0 1000) randInt@@ -46,7 +48,6 @@ randNonnegInt :: Gen Int randNonnegInt = Gen.int (Range.linear 0 500) - -- # Properties ------------------------------------------------------------------------------- @@ -96,7 +97,7 @@ xs <- forAll list n <- forAll randNonnegInt let v = Vector.fromList xs- let (l,r) = Pull.split n (Pull.fromVector v)+ let (l, r) = Pull.split n (Pull.fromVector v) (Pull.asList l, Pull.asList r) === splitAt n xs pullMake :: Property@@ -109,8 +110,7 @@ pullZip = property Prelude.$ do let genPairs = (,) Prelude.<$> randInt Prelude.<*> randInt as <- forAll (Gen.list (Range.linear 0 1000) genPairs)- let (xs,ys) = unzip as+ let (xs, ys) = unzip as let xs' = Pull.fromVector (Vector.fromList xs) let ys' = Pull.fromVector (Vector.fromList ys) zip xs ys === Pull.asList (Pull.zip xs' ys')-
+ test/Test/Data/Replicator.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -O -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}++module Test.Data.Replicator (replicatorInspectionTests) where++import Data.Replicator.Linear (Replicator)+import qualified Data.Replicator.Linear as Replicator+import Prelude.Linear+import Test.Tasty+import Test.Tasty.Inspection++replicatorInspectionTests :: TestTree+replicatorInspectionTests =+ testGroup+ "Inspection testing of elim for Replicator"+ [$(inspectTest $ 'elim3 === 'manualElim3)]++elim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> Replicator a %1 -> [a]+elim3 = Replicator.elim++manualElim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> Replicator a %1 -> [a]+manualElim3 f r =+ Replicator.next r & \case+ (x, r') ->+ Replicator.next r' & \case+ (y, r'') ->+ Replicator.extract r'' & \case+ z -> f x y z
+ test/Test/Data/V.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -O -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}++module Test.Data.V (vInspectionTests) where++import Data.V.Linear (V)+import qualified Data.V.Linear as V+import Prelude.Linear+import Test.Tasty+import Test.Tasty.Inspection++vInspectionTests :: TestTree+vInspectionTests =+ testGroup+ "Inspection testing of elim and make for V"+ [ $(inspectTest $ 'make3 ==- 'manualMake3),+ $(inspectTest $ 'elim3 ==- 'manualElim3)+ ]++make3 :: a %1 -> a %1 -> a %1 -> V 3 a+make3 = V.make++manualMake3 :: a %1 -> a %1 -> a %1 -> V 3 a+manualMake3 x y z = V.cons x . V.cons y . V.cons z $ V.empty++elim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> V 3 a %1 -> [a]+elim3 = V.elim++manualElim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> V 3 a %1 -> [a]+manualElim3 f v =+ V.uncons v & \case+ (x, v') ->+ V.uncons v' & \case+ (y, v'') ->+ V.uncons v'' & \case+ (z, v''') ->+ V.consume v''' & \case+ () -> f x y z