diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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):
`infixr 0 $`, `infixl 1 &`, `infixr 2 ||`, `infixr 3 &&`,
`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`:**
+ `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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,8 @@ [![License MIT](https://img.shields.io/badge/license-MIT-brightgreen.svg)](https://github.com/tweag/linear-base/blob/master/LICENSE) [![Build status](https://badge.buildkite.com/5b60ab93dadba234a95e04e6568985918552dcc9e7685ede0d.svg?branch=master)](https://buildkite.com/tweag-1/linear-base) - +[![Hackage](https://img.shields.io/hackage/v/linear-base.svg?style=flat&color=brightgreen)][hackage-pkg] +[![Stackage](https://stackage.org/package/linear-base/badge/nightly)][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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,3 @@ -module Main where - -import Distribution.Extra.Doctest (defaultMainWithDoctests) +import Distribution.Simple -main :: IO () -main = defaultMainWithDoctests "doctests" +main = defaultMain diff --git a/bench/Data/Mutable/Array.hs b/bench/Data/Mutable/Array.hs new file mode 100644 --- /dev/null +++ b/bench/Data/Mutable/Array.hs @@ -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 #-} diff --git a/bench/Data/Mutable/HashMap.hs b/bench/Data/Mutable/HashMap.hs --- a/bench/Data/Mutable/HashMap.hs +++ b/bench/Data/Mutable/HashMap.hs @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 ] - diff --git a/docs/DESIGN.md b/docs/DESIGN.md --- a/docs/DESIGN.md +++ b/docs/DESIGN.md @@ -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 diff --git a/docs/USER_GUIDE.md b/docs/USER_GUIDE.md --- a/docs/USER_GUIDE.md +++ b/docs/USER_GUIDE.md @@ -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 diff --git a/examples/Foreign/Heap.hs b/examples/Foreign/Heap.hs --- a/examples/Foreign/Heap.hs +++ b/examples/Foreign/Heap.hs @@ -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 diff --git a/examples/Foreign/List.hs b/examples/Foreign/List.hs --- a/examples/Foreign/List.hs +++ b/examples/Foreign/List.hs @@ -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 diff --git a/examples/Generic/Traverse.hs b/examples/Generic/Traverse.hs new file mode 100644 --- /dev/null +++ b/examples/Generic/Traverse.hs @@ -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] diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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 + ] diff --git a/examples/Simple/FileIO.hs b/examples/Simple/FileIO.hs --- a/examples/Simple/FileIO.hs +++ b/examples/Simple/FileIO.hs @@ -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) diff --git a/examples/Simple/Pure.hs b/examples/Simple/Pure.hs --- a/examples/Simple/Pure.hs +++ b/examples/Simple/Pure.hs @@ -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 diff --git a/examples/Simple/Quicksort.hs b/examples/Simple/Quicksort.hs --- a/examples/Simple/Quicksort.hs +++ b/examples/Simple/Quicksort.hs @@ -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 diff --git a/examples/Simple/TopSort.hs b/examples/Simple/TopSort.hs --- a/examples/Simple/TopSort.hs +++ b/examples/Simple/TopSort.hs @@ -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) diff --git a/examples/Test/Foreign.hs b/examples/Test/Foreign.hs --- a/examples/Test/Foreign.hs +++ b/examples/Test/Foreign.hs @@ -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) - diff --git a/examples/Test/Generic.hs b/examples/Test/Generic.hs new file mode 100644 --- /dev/null +++ b/examples/Test/Generic.hs @@ -0,0 +1,11 @@ +module Test.Generic (genericTests) where + +import Generic.Traverse (genericTraverseTests) +import Test.Tasty + +genericTests :: TestTree +genericTests = + testGroup + "Generic tests" + [ genericTraverseTests + ] diff --git a/examples/Test/Quicksort.hs b/examples/Test/Quicksort.hs --- a/examples/Test/Quicksort.hs +++ b/examples/Test/Quicksort.hs @@ -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 - diff --git a/linear-base.cabal b/linear-base.cabal --- a/linear-base.cabal +++ b/linear-base.cabal @@ -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 diff --git a/src/Control/Functor/Linear.hs b/src/Control/Functor/Linear.hs --- a/src/Control/Functor/Linear.hs +++ b/src/Control/Functor/Linear.hs @@ -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). - diff --git a/src/Control/Functor/Linear/Internal/Class.hs b/src/Control/Functor/Linear/Internal/Class.hs --- a/src/Control/Functor/Linear/Internal/Class.hs +++ b/src/Control/Functor/Linear/Internal/Class.hs @@ -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 diff --git a/src/Control/Functor/Linear/Internal/Instances.hs b/src/Control/Functor/Linear/Internal/Instances.hs --- a/src/Control/Functor/Linear/Internal/Instances.hs +++ b/src/Control/Functor/Linear/Internal/Instances.hs @@ -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 - diff --git a/src/Control/Functor/Linear/Internal/Kan.hs b/src/Control/Functor/Linear/Internal/Kan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Linear/Internal/Kan.hs @@ -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 #-} diff --git a/src/Control/Functor/Linear/Internal/MonadTrans.hs b/src/Control/Functor/Linear/Internal/MonadTrans.hs --- a/src/Control/Functor/Linear/Internal/MonadTrans.hs +++ b/src/Control/Functor/Linear/Internal/MonadTrans.hs @@ -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 diff --git a/src/Control/Functor/Linear/Internal/Reader.hs b/src/Control/Functor/Linear/Internal/Reader.hs --- a/src/Control/Functor/Linear/Internal/Reader.hs +++ b/src/Control/Functor/Linear/Internal/Reader.hs @@ -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) - diff --git a/src/Control/Functor/Linear/Internal/State.hs b/src/Control/Functor/Linear/Internal/State.hs --- a/src/Control/Functor/Linear/Internal/State.hs +++ b/src/Control/Functor/Linear/Internal/State.hs @@ -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) - diff --git a/src/Control/Monad/IO/Class/Linear.hs b/src/Control/Monad/IO/Class/Linear.hs --- a/src/Control/Monad/IO/Class/Linear.hs +++ b/src/Control/Monad/IO/Class/Linear.hs @@ -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) diff --git a/src/Control/Optics/Linear.hs b/src/Control/Optics/Linear.hs --- a/src/Control/Optics/Linear.hs +++ b/src/Control/Optics/Linear.hs @@ -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 diff --git a/src/Control/Optics/Linear/Internal.hs b/src/Control/Optics/Linear/Internal.hs --- a/src/Control/Optics/Linear/Internal.hs +++ b/src/Control/Optics/Linear/Internal.hs @@ -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 diff --git a/src/Control/Optics/Linear/Iso.hs b/src/Control/Optics/Linear/Iso.hs --- a/src/Control/Optics/Linear/Iso.hs +++ b/src/Control/Optics/Linear/Iso.hs @@ -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 diff --git a/src/Control/Optics/Linear/Lens.hs b/src/Control/Optics/Linear/Lens.hs --- a/src/Control/Optics/Linear/Lens.hs +++ b/src/Control/Optics/Linear/Lens.hs @@ -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 diff --git a/src/Control/Optics/Linear/Prism.hs b/src/Control/Optics/Linear/Prism.hs --- a/src/Control/Optics/Linear/Prism.hs +++ b/src/Control/Optics/Linear/Prism.hs @@ -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 diff --git a/src/Control/Optics/Linear/Traversal.hs b/src/Control/Optics/Linear/Traversal.hs --- a/src/Control/Optics/Linear/Traversal.hs +++ b/src/Control/Optics/Linear/Traversal.hs @@ -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 diff --git a/src/Data/Arity/Linear.hs b/src/Data/Arity/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Arity/Linear.hs @@ -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 diff --git a/src/Data/Arity/Linear/Internal.hs b/src/Data/Arity/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Arity/Linear/Internal.hs @@ -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) diff --git a/src/Data/Array/Destination.hs b/src/Data/Array/Destination.hs --- a/src/Data/Array/Destination.hs +++ b/src/Data/Array/Destination.hs @@ -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 diff --git a/src/Data/Array/Destination/Internal.hs b/src/Data/Array/Destination/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Destination/Internal.hs @@ -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. diff --git a/src/Data/Array/Mutable/Linear.hs b/src/Data/Array/Mutable/Linear.hs --- a/src/Data/Array/Mutable/Linear.hs +++ b/src/Data/Array/Mutable/Linear.hs @@ -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) diff --git a/src/Data/Array/Mutable/Linear/Internal.hs b/src/Data/Array/Mutable/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Mutable/Linear/Internal.hs @@ -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" diff --git a/src/Data/Array/Mutable/Unlifted/Linear.hs b/src/Data/Array/Mutable/Unlifted/Linear.hs --- a/src/Data/Array/Mutable/Unlifted/Linear.hs +++ b/src/Data/Array/Mutable/Unlifted/Linear.hs @@ -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` diff --git a/src/Data/Array/Polarized.hs b/src/Data/Array/Polarized.hs --- a/src/Data/Array/Polarized.hs +++ b/src/Data/Array/Polarized.hs @@ -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 diff --git a/src/Data/Array/Polarized/Pull.hs b/src/Data/Array/Polarized/Pull.hs --- a/src/Data/Array/Polarized/Pull.hs +++ b/src/Data/Array/Polarized/Pull.hs @@ -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) diff --git a/src/Data/Array/Polarized/Pull/Internal.hs b/src/Data/Array/Polarized/Pull/Internal.hs --- a/src/Data/Array/Polarized/Pull/Internal.hs +++ b/src/Data/Array/Polarized/Pull/Internal.hs @@ -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) diff --git a/src/Data/Array/Polarized/Push.hs b/src/Data/Array/Polarized/Push.hs --- a/src/Data/Array/Polarized/Push.hs +++ b/src/Data/Array/Polarized/Push.hs @@ -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. diff --git a/src/Data/Bifunctor/Linear.hs b/src/Data/Bifunctor/Linear.hs --- a/src/Data/Bifunctor/Linear.hs +++ b/src/Data/Bifunctor/Linear.hs @@ -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 - diff --git a/src/Data/Bifunctor/Linear/Internal/Bifunctor.hs b/src/Data/Bifunctor/Linear/Internal/Bifunctor.hs --- a/src/Data/Bifunctor/Linear/Internal/Bifunctor.hs +++ b/src/Data/Bifunctor/Linear/Internal/Bifunctor.hs @@ -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) - diff --git a/src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs b/src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs --- a/src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs +++ b/src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs @@ -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 - diff --git a/src/Data/Bool/Linear.hs b/src/Data/Bool/Linear.hs --- a/src/Data/Bool/Linear.hs +++ b/src/Data/Bool/Linear.hs @@ -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 diff --git a/src/Data/Either/Linear.hs b/src/Data/Either/Linear.hs --- a/src/Data/Either/Linear.hs +++ b/src/Data/Either/Linear.hs @@ -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) diff --git a/src/Data/Functor/Linear.hs b/src/Data/Functor/Linear.hs --- a/src/Data/Functor/Linear.hs +++ b/src/Data/Functor/Linear.hs @@ -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 diff --git a/src/Data/Functor/Linear/Internal/Applicative.hs b/src/Data/Functor/Linear/Internal/Applicative.hs --- a/src/Data/Functor/Linear/Internal/Applicative.hs +++ b/src/Data/Functor/Linear/Internal/Applicative.hs @@ -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 diff --git a/src/Data/Functor/Linear/Internal/Functor.hs b/src/Data/Functor/Linear/Internal/Functor.hs --- a/src/Data/Functor/Linear/Internal/Functor.hs +++ b/src/Data/Functor/Linear/Internal/Functor.hs @@ -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 diff --git a/src/Data/Functor/Linear/Internal/Traversable.hs b/src/Data/Functor/Linear/Internal/Traversable.hs --- a/src/Data/Functor/Linear/Internal/Traversable.hs +++ b/src/Data/Functor/Linear/Internal/Traversable.hs @@ -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 -- . --- 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 #-} diff --git a/src/Data/HashMap/Mutable/Linear.hs b/src/Data/HashMap/Mutable/Linear.hs --- a/src/Data/HashMap/Mutable/Linear.hs +++ b/src/Data/HashMap/Mutable/Linear.hs @@ -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 diff --git a/src/Data/HashMap/Mutable/Linear/Internal.hs b/src/Data/HashMap/Mutable/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Linear/Internal.hs @@ -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 diff --git a/src/Data/List/Linear.hs b/src/Data/List/Linear.hs --- a/src/Data/List/Linear.hs +++ b/src/Data/List/Linear.hs @@ -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 = [] diff --git a/src/Data/Maybe/Linear.hs b/src/Data/Maybe/Linear.hs --- a/src/Data/Maybe/Linear.hs +++ b/src/Data/Maybe/Linear.hs @@ -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) diff --git a/src/Data/Monoid/Linear.hs b/src/Data/Monoid/Linear.hs --- a/src/Data/Monoid/Linear.hs +++ b/src/Data/Monoid/Linear.hs @@ -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 - diff --git a/src/Data/Monoid/Linear/Internal/Monoid.hs b/src/Data/Monoid/Linear/Internal/Monoid.hs --- a/src/Data/Monoid/Linear/Internal/Monoid.hs +++ b/src/Data/Monoid/Linear/Internal/Monoid.hs @@ -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) diff --git a/src/Data/Monoid/Linear/Internal/Semigroup.hs b/src/Data/Monoid/Linear/Internal/Semigroup.hs --- a/src/Data/Monoid/Linear/Internal/Semigroup.hs +++ b/src/Data/Monoid/Linear/Internal/Semigroup.hs @@ -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) diff --git a/src/Data/Num/Linear.hs b/src/Data/Num/Linear.hs --- a/src/Data/Num/Linear.hs +++ b/src/Data/Num/Linear.hs @@ -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 diff --git a/src/Data/Ord/Linear.hs b/src/Data/Ord/Linear.hs --- a/src/Data/Ord/Linear.hs +++ b/src/Data/Ord/Linear.hs @@ -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 diff --git a/src/Data/Ord/Linear/Internal/Eq.hs b/src/Data/Ord/Linear/Internal/Eq.hs --- a/src/Data/Ord/Linear/Internal/Eq.hs +++ b/src/Data/Ord/Linear/Internal/Eq.hs @@ -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 diff --git a/src/Data/Ord/Linear/Internal/Ord.hs b/src/Data/Ord/Linear/Internal/Ord.hs --- a/src/Data/Ord/Linear/Internal/Ord.hs +++ b/src/Data/Ord/Linear/Internal/Ord.hs @@ -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 diff --git a/src/Data/Profunctor/Kleisli/Linear.hs b/src/Data/Profunctor/Kleisli/Linear.hs --- a/src/Data/Profunctor/Kleisli/Linear.hs +++ b/src/Data/Profunctor/Kleisli/Linear.hs @@ -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) diff --git a/src/Data/Profunctor/Linear.hs b/src/Data/Profunctor/Linear.hs --- a/src/Data/Profunctor/Linear.hs +++ b/src/Data/Profunctor/Linear.hs @@ -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 diff --git a/src/Data/Replicator/Linear.hs b/src/Data/Replicator/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Replicator/Linear.hs @@ -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 () diff --git a/src/Data/Replicator/Linear/Internal.hs b/src/Data/Replicator/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Replicator/Linear/Internal.hs @@ -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' #-} diff --git a/src/Data/Replicator/Linear/Internal/Instances.hs b/src/Data/Replicator/Linear/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Replicator/Linear/Internal/Instances.hs @@ -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 diff --git a/src/Data/Replicator/Linear/Internal/ReplicationStream.hs b/src/Data/Replicator/Linear/Internal/ReplicationStream.hs new file mode 100644 --- /dev/null +++ b/src/Data/Replicator/Linear/Internal/ReplicationStream.hs @@ -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.<*> diff --git a/src/Data/Set/Mutable/Linear.hs b/src/Data/Set/Mutable/Linear.hs --- a/src/Data/Set/Mutable/Linear.hs +++ b/src/Data/Set/Mutable/Linear.hs @@ -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 diff --git a/src/Data/Set/Mutable/Linear/Internal.hs b/src/Data/Set/Mutable/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Mutable/Linear/Internal.hs @@ -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) diff --git a/src/Data/Tuple/Linear.hs b/src/Data/Tuple/Linear.hs --- a/src/Data/Tuple/Linear.hs +++ b/src/Data/Tuple/Linear.hs @@ -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) diff --git a/src/Data/Unrestricted/Internal/Consumable.hs b/src/Data/Unrestricted/Internal/Consumable.hs deleted file mode 100644 --- a/src/Data/Unrestricted/Internal/Consumable.hs +++ /dev/null @@ -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 - diff --git a/src/Data/Unrestricted/Internal/Dupable.hs b/src/Data/Unrestricted/Internal/Dupable.hs deleted file mode 100644 --- a/src/Data/Unrestricted/Internal/Dupable.hs +++ /dev/null @@ -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 - diff --git a/src/Data/Unrestricted/Internal/Instances.hs b/src/Data/Unrestricted/Internal/Instances.hs deleted file mode 100644 --- a/src/Data/Unrestricted/Internal/Instances.hs +++ /dev/null @@ -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) - diff --git a/src/Data/Unrestricted/Internal/Movable.hs b/src/Data/Unrestricted/Internal/Movable.hs deleted file mode 100644 --- a/src/Data/Unrestricted/Internal/Movable.hs +++ /dev/null @@ -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 - diff --git a/src/Data/Unrestricted/Internal/Ur.hs b/src/Data/Unrestricted/Internal/Ur.hs deleted file mode 100644 --- a/src/Data/Unrestricted/Internal/Ur.hs +++ /dev/null @@ -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) - diff --git a/src/Data/Unrestricted/Linear.hs b/src/Data/Unrestricted/Linear.hs --- a/src/Data/Unrestricted/Linear.hs +++ b/src/Data/Unrestricted/Linear.hs @@ -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 diff --git a/src/Data/Unrestricted/Linear/Internal/Consumable.hs b/src/Data/Unrestricted/Linear/Internal/Consumable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Linear/Internal/Consumable.hs @@ -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 diff --git a/src/Data/Unrestricted/Linear/Internal/Dupable.hs b/src/Data/Unrestricted/Linear/Internal/Dupable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Linear/Internal/Dupable.hs @@ -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 diff --git a/src/Data/Unrestricted/Linear/Internal/Instances.hs b/src/Data/Unrestricted/Linear/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Linear/Internal/Instances.hs @@ -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 diff --git a/src/Data/Unrestricted/Linear/Internal/Movable.hs b/src/Data/Unrestricted/Linear/Internal/Movable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Linear/Internal/Movable.hs @@ -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 diff --git a/src/Data/Unrestricted/Linear/Internal/Ur.hs b/src/Data/Unrestricted/Linear/Internal/Ur.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Linear/Internal/Ur.hs @@ -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 diff --git a/src/Data/Unrestricted/Linear/Internal/UrT.hs b/src/Data/Unrestricted/Linear/Internal/UrT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Linear/Internal/UrT.hs @@ -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) diff --git a/src/Data/V/Linear.hs b/src/Data/V/Linear.hs --- a/src/Data/V/Linear.hs +++ b/src/Data/V/Linear.hs @@ -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. -} - diff --git a/src/Data/V/Linear/Internal.hs b/src/Data/V/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/V/Linear/Internal.hs @@ -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 diff --git a/src/Data/V/Linear/Internal/Instances.hs b/src/Data/V/Linear/Internal/Instances.hs --- a/src/Data/V/Linear/Internal/Instances.hs +++ b/src/Data/V/Linear/Internal/Instances.hs @@ -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) diff --git a/src/Data/V/Linear/Internal/V.hs b/src/Data/V/Linear/Internal/V.hs deleted file mode 100644 --- a/src/Data/V/Linear/Internal/V.hs +++ /dev/null @@ -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 - diff --git a/src/Data/Vector/Mutable/Linear.hs b/src/Data/Vector/Mutable/Linear.hs --- a/src/Data/Vector/Mutable/Linear.hs +++ b/src/Data/Vector/Mutable/Linear.hs @@ -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 diff --git a/src/Data/Vector/Mutable/Linear/Internal.hs b/src/Data/Vector/Mutable/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Mutable/Linear/Internal.hs @@ -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" diff --git a/src/Debug/Trace/Linear.hs b/src/Debug/Trace/Linear.hs --- a/src/Debug/Trace/Linear.hs +++ b/src/Debug/Trace/Linear.hs @@ -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) diff --git a/src/Foreign/Marshal/Pure.hs b/src/Foreign/Marshal/Pure.hs --- a/src/Foreign/Marshal/Pure.hs +++ b/src/Foreign/Marshal/Pure.hs @@ -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 @ --- then declare the following instance: --- --- @instance Representable where {type AsKnown = AsKnown }@ --- --- 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 diff --git a/src/Foreign/Marshal/Pure/Internal.hs b/src/Foreign/Marshal/Pure/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Pure/Internal.hs @@ -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 @ +-- then declare the following instance: +-- +-- @instance Representable where {type AsKnown = AsKnown }@ +-- +-- 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 diff --git a/src/Prelude/Linear.hs b/src/Prelude/Linear.hs --- a/src/Prelude/Linear.hs +++ b/src/Prelude/Linear.hs @@ -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.<* diff --git a/src/Prelude/Linear/GenericUtil.hs b/src/Prelude/Linear/GenericUtil.hs new file mode 100644 --- /dev/null +++ b/src/Prelude/Linear/GenericUtil.hs @@ -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 diff --git a/src/Prelude/Linear/Generically.hs b/src/Prelude/Linear/Generically.hs new file mode 100644 --- /dev/null +++ b/src/Prelude/Linear/Generically.hs @@ -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 diff --git a/src/Prelude/Linear/Internal.hs b/src/Prelude/Linear/Internal.hs --- a/src/Prelude/Linear/Internal.hs +++ b/src/Prelude/Linear/Internal.hs @@ -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 #-} diff --git a/src/Prelude/Linear/Unsatisfiable.hs b/src/Prelude/Linear/Unsatisfiable.hs new file mode 100644 --- /dev/null +++ b/src/Prelude/Linear/Unsatisfiable.hs @@ -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 +-- +-- 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 {} diff --git a/src/Streaming/Internal/Consume.hs b/src/Streaming/Internal/Consume.hs deleted file mode 100644 --- a/src/Streaming/Internal/Consume.hs +++ /dev/null @@ -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 -t -["s","t"] -u -v -["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 #-} - diff --git a/src/Streaming/Internal/Interop.hs b/src/Streaming/Internal/Interop.hs deleted file mode 100644 --- a/src/Streaming/Internal/Interop.hs +++ /dev/null @@ -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 #-} - diff --git a/src/Streaming/Internal/Many.hs b/src/Streaming/Internal/Many.hs deleted file mode 100644 --- a/src/Streaming/Internal/Many.hs +++ /dev/null @@ -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 #-} - diff --git a/src/Streaming/Internal/Process.hs b/src/Streaming/Internal/Process.hs deleted file mode 100644 --- a/src/Streaming/Internal/Process.hs +++ /dev/null @@ -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 -b -c -d -e -["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 -two -three -"three" -four -"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 -2000 -total -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 - . - -@ -\>\>\> 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 #-} - diff --git a/src/Streaming/Internal/Produce.hs b/src/Streaming/Internal/Produce.hs deleted file mode 100644 --- a/src/Streaming/Internal/Produce.hs +++ /dev/null @@ -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 #-} - diff --git a/src/Streaming/Internal/Type.hs b/src/Streaming/Internal/Type.hs deleted file mode 100644 --- a/src/Streaming/Internal/Type.hs +++ /dev/null @@ -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 - . - -> 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 #-} - diff --git a/src/Streaming/Linear.hs b/src/Streaming/Linear.hs --- a/src/Streaming/Linear.hs +++ b/src/Streaming/Linear.hs @@ -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 - 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 - - 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 +-- 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 +-- +-- 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 #-} diff --git a/src/Streaming/Linear/Internal/Consume.hs b/src/Streaming/Linear/Internal/Consume.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Linear/Internal/Consume.hs @@ -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 +-- t +-- ["s","t"] +-- u +-- v +-- ["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 #-} diff --git a/src/Streaming/Linear/Internal/Interop.hs b/src/Streaming/Linear/Internal/Interop.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Linear/Internal/Interop.hs @@ -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 #-} diff --git a/src/Streaming/Linear/Internal/Many.hs b/src/Streaming/Linear/Internal/Many.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Linear/Internal/Many.hs @@ -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 #-} diff --git a/src/Streaming/Linear/Internal/Process.hs b/src/Streaming/Linear/Internal/Process.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Linear/Internal/Process.hs @@ -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 +-- b +-- c +-- d +-- e +-- ["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 +-- two +-- three +-- "three" +-- four +-- "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 +-- 2000 +-- total +-- 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 +-- . +-- +-- @ +-- \>\>\> 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 #-} diff --git a/src/Streaming/Linear/Internal/Produce.hs b/src/Streaming/Linear/Internal/Produce.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Linear/Internal/Produce.hs @@ -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 #-} diff --git a/src/Streaming/Linear/Internal/Type.hs b/src/Streaming/Linear/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Linear/Internal/Type.hs @@ -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 +-- . +-- +-- > 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 #-} diff --git a/src/Streaming/Prelude/Linear.hs b/src/Streaming/Prelude/Linear.hs --- a/src/Streaming/Prelude/Linear.hs +++ b/src/Streaming/Prelude/Linear.hs @@ -1,66 +1,64 @@ -{-| The names exported by this module are closely modeled on those in @Prelude@ and @Data.List@, - but also on - , - - and . - 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 +-- , +-- +-- and . +-- 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 diff --git a/src/System/IO/Linear.hs b/src/System/IO/Linear.hs --- a/src/System/IO/Linear.hs +++ b/src/System/IO/Linear.hs @@ -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)) diff --git a/src/System/IO/Resource.hs b/src/System/IO/Resource.hs deleted file mode 100644 --- a/src/System/IO/Resource.hs +++ /dev/null @@ -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 diff --git a/src/System/IO/Resource/Linear.hs b/src/System/IO/Resource/Linear.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Resource/Linear.hs @@ -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 diff --git a/src/System/IO/Resource/Linear/Internal.hs b/src/System/IO/Resource/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Resource/Linear/Internal.hs @@ -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 diff --git a/src/Unsafe/Linear.hs b/src/Unsafe/Linear.hs --- a/src/Unsafe/Linear.hs +++ b/src/Unsafe/Linear.hs @@ -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. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 + ] + ] diff --git a/test/Test/Data/Destination.hs b/test/Test/Data/Destination.hs --- a/test/Test/Data/Destination.hs +++ b/test/Test/Data/Destination.hs @@ -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)) - diff --git a/test/Test/Data/Mutable/Array.hs b/test/Test/Data/Mutable/Array.hs --- a/test/Test/Data/Mutable/Array.hs +++ b/test/Test/Data/Mutable/Array.hs @@ -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 () diff --git a/test/Test/Data/Mutable/HashMap.hs b/test/Test/Data/Mutable/HashMap.hs --- a/test/Test/Data/Mutable/HashMap.hs +++ b/test/Test/Data/Mutable/HashMap.hs @@ -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) - diff --git a/test/Test/Data/Mutable/Set.hs b/test/Test/Data/Mutable/Set.hs --- a/test/Test/Data/Mutable/Set.hs +++ b/test/Test/Data/Mutable/Set.hs @@ -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))) - diff --git a/test/Test/Data/Mutable/Vector.hs b/test/Test/Data/Mutable/Vector.hs --- a/test/Test/Data/Mutable/Vector.hs +++ b/test/Test/Data/Mutable/Vector.hs @@ -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'' -> diff --git a/test/Test/Data/Polarized.hs b/test/Test/Data/Polarized.hs --- a/test/Test/Data/Polarized.hs +++ b/test/Test/Data/Polarized.hs @@ -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') - diff --git a/test/Test/Data/Replicator.hs b/test/Test/Data/Replicator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Replicator.hs @@ -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 diff --git a/test/Test/Data/V.hs b/test/Test/Data/V.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/V.hs @@ -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