packages feed

linear-base (empty) → 0.1.0

raw patch · 93 files changed

+14903/−0 lines, 93 filesdep +basedep +containersdep +deepseqsetup-changed

Dependencies added: base, containers, deepseq, gauge, ghc-prim, hashable, hashtables, hedgehog, linear-base, mmorph, primitive, random, random-shuffle, storable-tuple, tasty, tasty-hedgehog, text, transformers, unordered-containers, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Change Log++## [0.1.0] - 2021-02-09++* Initial release
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) Tweag Holding and its affiliates.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,91 @@+# Linear base++[![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)+++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`]+package that ships with GHC.++The purpose of `linear-base` is to provide the minimal facilities you need to+write _practical_ Linear Haskell code, i.e., Haskell code that uses the+`-XLinearTypes` language extension.++## Motivation++_Why do you need `linear-base` to write linear projects?_++1. Data types, functions and classes in `base` are not linear types+  aware. For instance, if `n` is a linearly-bound `Int`, the RHS of+  a definition cannot write `n + 1` — this will not type check. We+  need linear variants of `Num`, `Functor`s, `Monad`s, `($)`, etc.++2. This library exports new abstractions that leverage linear types+  for resource safety or performance. For example, there are new APIs+  for file and socket I/O as well as for safe in-place mutation of+  arrays.++## Getting started++`-XLinearTypes` is released with GHC 9, and `linear-base` is released+on [Hackage](https://hackage.haskell.org/package/linear-base).++All source files with linear types need a language extension pragma at+the top:++```+{-# LANGUAGE LinearTypes #-}+```++## User Guide++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`.++## Learning about `-XLinearTypes`++If you're a Haskeller who hasn't written any Linear Haskell code, don't fear!+There are plenty of excellent resources and examples to help you.++### Tutorials and examples++ * See the [`examples/`](./examples) folder.+ * [Linear examples on watertight 3D models](https://github.com/gelisam/linear-examples)++### Reading material++  * There is a [wiki page](https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types).+  * Key Blog posts+    * [Predictable performance](https://www.tweag.io/posts/2017-03-13-linear-types.html) (the first blog post from Tweag on this)+    * [IO State Transitions](https://www.tweag.io/posts/2017-08-03-linear-typestates.html)+    * [Streaming](https://www.tweag.io/posts/2018-06-21-linear-streams.html)+    * See [here](https://www.tweag.io/blog/tags/linear-types/) for all of Tweag's blog posts on linear types.+  * [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)+ * [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)++## Contributing++Linear base is maintained by [Tweag].++To contribute please see the [Design Document] for instructions and advice on+making pull requests.++## Licence++See the [Licence file](./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
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctests"
+ bench/Data/Mutable/HashMap.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+module Data.Mutable.HashMap (hmbench, getHMInput) where++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)++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+++-- # Exported benchmarks+-------------------------------------------------------------------------------++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++data BenchInput where+  BenchInput ::+    { pairs :: ![(Key, Int)] -- Keys paired with values+    , shuffle1 :: ![Key]+    , shuffle2 :: ![Key]+    , shuffle3 :: ![Key]+    } -> BenchInput++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+  ]++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"+  ]+++-- # 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+++-- # Linear Hashmaps+-------------------------------------------------------------------------------++linear_hashmap :: BenchInput -> [Benchmark]+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) ->+      Benchmark+    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 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 = b+    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++    insertDelete ::+      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_ xs = foldlx insertDelete xs++    bench2 :: Benchmark+    bench2 = mkBench 1 bench2_++    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++    bench3 :: Benchmark+    bench3 = mkBench 2 bench3_++    bench3_ :: [(Key,Int)] -> LMap.HashMap Key Int %1-> LMap.HashMap Key Int+    bench3_ 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_ 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_ 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}) =+  [bench1, bench2, bench3, bench4, bench5]+  where+    mkBench ::+      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++    foldlx :: (b -> a -> b) -> [a] -> b -> b+    foldlx f xs b = foldl' f b xs++    look :: Map.HashMap Key Int -> Key -> Map.HashMap Key Int+    look m k = case m Map.!? k of+      Nothing -> m+      Just v -> deepseq v m++    bench1 :: Benchmark+    bench1 = mkBench 0 $+      \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++    bench3 :: Benchmark+    bench3 = mkBench 2 $+      \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++    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+++-- # ST Basic+-------------------------------------------------------------------------------++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 ()) ->+      Benchmark+    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+      maybeV <- fmap force $ BasicST.lookup m k+      case maybeV of+        Nothing -> return ()+        Just v -> deepseq v (return ())++    bench1 :: Benchmark+    bench1 = mkBench 0 $ \xs hm ->+      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 -> 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_ (look hm) (shuffle1 inp)++    bench4 :: Benchmark+    bench4 = mkBench 3 $ \xs hm -> do+      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 -> 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}) =+  [bench1, bench2, bench3, bench4, bench5]+  where+    mkBench ::+      Int ->+      (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++    look :: CuckooST.HashTable s Key Int -> Key -> ST s ()+    look m k = do+      maybeV <- fmap force $ CuckooST.lookup m k+      case maybeV of+        Nothing -> return ()+        Just v -> deepseq v (return ())++    bench1 :: Benchmark+    bench1 = mkBench 0 $ \xs hm ->+      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 -> 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_ (look hm) (shuffle1 inp)++    bench4 :: Benchmark+    bench4 = mkBench 3 $ \xs hm -> do+      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 -> CuckooST.mutate hm k ((,()) . modVal)) (shuffle1 inp)+      mapM_ (\k -> CuckooST.mutate hm k ((,()) . modVal)) (shuffle2 inp)+      mapM_ (look hm) (shuffle3 inp)+
+ bench/Main.hs view
@@ -0,0 +1,12 @@+module Main where++import Gauge+import Data.Mutable.HashMap (hmbench, getHMInput)++main :: IO ()+main = do+  hmInput <- getHMInput+  defaultMain+    [ hmbench hmInput+    ]+
+ docs/DESIGN.md view
@@ -0,0 +1,95 @@+# Design++## Overall architecture++Linear base is more than a copy of things from [`base`] with some function+arrows being replaced by linear arrows. Moreover, the goal is __not__ exact+compliance with `base`.++Linear base consists of the following:++* fundamental data structures, functions and classes that arise+  naturally from wanting to do any linear development (e.g.,+  `Ur` and `Consumable`),+* 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`],+* new abstractions made possible by linear types, like monad-free+  mutable arrays in ([`Data.Array.Mutable.Linear`]).++There is a top-level `Prelude.Linear` that is meant to be imported _unqualified_.+It does not include functors, monads, applicatives and so on because there are+multiple sensible ways to give linear arrows to these things. See this [blog+post] for details. This prelude includes:++* linear variants of definitions in `Prelude`,+* a few pervasive utility definitions when programming with linear+  types.++## Module structure++* `Prelude.Linear` is public facing and meant for users of linear-base+  whereas `Prelude.Linear.Internal` is meant as an internal prelude for+  development in linear-base itself. It is down deep in the module+  hierarchy, used throughout linear-base while `Prelude.Linear` is at the top+  and no other modules import it.+* Modules that have `Internal` in the name are not meant to be+  public and have their functionality used and/or re-exported in+  public-facing modules.++## General implementation strategy++This is the strategy that we've followed so far for developing+`linear-base`:++1. If the definition is simple enough that there's only one sensible+   place to replace a function arrow by a linear arrow, do that.+   Example:++   ```haskell+   foldr :: (a #-> b #-> b) -> b #-> [a] #-> b+   foldr f z = \case+     [] -> z+     x:xs -> f x (foldr f z xs)+   ```++	Otherwise, implement each sensible variant of the definition in+    dedicated modules. For instance, this is the case with+    `Data.Functor`s and `Control.Functor`s (see this [blog post]).++2. The ideas behind new definitions that are just now possible with+   linear types vary and each have unique concepts that are not+   addressed by a general strategy. These should be documented below+   if one of the following is true:++   * there is an overarching concept that extends beyond a handful of+     modules. Or,+   * There is an explicit departure away from the direction of `base`.+     (E.g., we decide there should be different laws for some type+     class already in `base`.)++## Conventions++We have established the following conventions in this project:++* use full words for Qualified imports, not abbreviations. For+  instance, import `Data.Functor.Linear` as `Linear` and not as `F`+  for functor.+* All public modules have an export list.+* Pure functions which modify a container take the+container as the last parameter (similar to functions in `Data.Map`). Monadic functions on containers+take the containers as the first parameter+(similar to functions in `Control.Concurrent.MVar`). See [issue #147][issue-147] for some+more details.++[functors]: https://www.tweag.io/posts/2020-01-16-data-vs-control.html+[examples/Simple/FileIO.hs]: https://github.com/tweag/linear-base/tree/master/examples/Simple/FileIO.hs+[`Data.Unrestricted.Linear`]: https://github.com/tweag/linear-base/tree/master/src/Data/Unrestricted/Linear.hs+[`Num`]: https://github.com/tweag/linear-base/tree/master/src/Data/Num/Linear.hs+[`base`]: https://hackage.haskell.org/package/base+[`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+[issue-147]: https://github.com/tweag/linear-base/issues/147
+ docs/USER_GUIDE.md view
@@ -0,0 +1,169 @@+# User Guide++This short guide assumes+familiarity with linear types (see the [`README`] for resources about linear types+if you are unfamiliar).++#### Table of contents++  1. [How to navigate the library](#navigating-the-library)+  2. [Core concepts you need to know](#core-concepts)+  3. [Current limitations](#temporary-limitations)++## Navigating the library++ * 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`.+ * 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`.+ * Streams in the style of the [`streaming`+   library](https://hackage.haskell.org/package/streaming) is in+   `Streaming.Linear` and `Streaming.Prelude.Linear`.++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`.++### Naming conventions & layout++Typically, variants of common Haskell tools and facilities+share the same name with a `Linear` postfix. For instance,+`Data.Bool.Linear` provides the linear versions of `not`+and `&&`.++The module names follow the typical hierarchical module+naming scheme with top-level names like `Control`, `Data`, `System`+and so on.+++## Core concepts++### Using values multiple times++Frequently enough, you will want to consume a linear value, or maybe+use it multiple time. The basic tools you need to do this are in+[`Data.Unrestricted`] and are typically re-exported by+[`Prelude.Linear`].++Interfacing linear code with regular Haskell is done, for instance, through the type `Ur`.+The data type `Ur`, short for _unrestricted_ lets you store an+unrestricted value inside a linear value.++### Import Conventions++We've designed `linear-base` to work nicely with the following import conventions:++- `import qualified Data.Functor.Linear as Data`+- `import qualified Control.Functor.Linear as Control`++### Importing linear and non-linear code++Most modules with `{-# LANGUAGE LinearHaskell #-}` will want to have a mix of+linear and non-linear code and, for example, import linear modules like+`Data.Functor.Linear` and unrestricted modules from `base` like `Data.List`.+The pattern we've followed internally is to import the non-linear module+qualified. For instance:++```haskell+import Prelude.Linear+import Data.Functor.Linear+import qualified Prelude as NonLinear+import Data.List as List+```++Sometimes it's easier to use `forget :: (a %1-> b) -> (a -> b)` from+`Prelude.Linear` than to import the non-linear version of some function.+This is useful in passing linear functions to higher order functions.+For non HOF uses, we can use linear functions directly; given a linear function+`f`, we can always write `g x = f x` for `g :: A -> B`.+++### `f :: X -> (SomeType %1-> Ur b) %1-> Ur b` functions++This style function is used throughout `linear-base`, particularly+with mutable data structures.++It serves to limit the **scope** of using `SomeType` by taking+a function of type `(SomeType %1-> Ur b)`+as its second argument and using it with a value of type `SomeType` to+produce an `Ur b`. We call this function of type `(SomeType %1-> Ur b)`,+a **scope function** or just **scope** for short.++The `SomeType` cannot escape the scope function by being inside the type `b`+in some way. This is because the `SomeType` is bound linearly in the scope+function and `Ur` can only contain unrestricted (in particular not linear)+values. At any nested level, the `SomeType` would have to be used in an+unrestricted way.++Now, if `f` is the only function that can make a `SomeType`,+then we have an API that completely controls the creation-to-deletion+lifetime (i.e, the scope) of `SomeType`.+++## Temporary limitations++### Case statements are not linear++The following definition will **fail** to type check:++```haskell+maybeFlip :: Int %1-> Int %1-> (a,a) -> a+maybeFlip i j (x,y) = case i < j of+  True -> x+  False -> y+```++The scrutinee on (i.e., `x` in `case x of ...`) is considered to be+consumed many times. It's a limitation of the current implementation+of the type checker.++For now, we can mimic a linear case statement using the+`-XLambdaCase` language extension and the `(&)` from `Prelude.Linear`:++```haskell+{-# LANGUAGE LambdaCase #-}+import Prelude.Linear ((&))++maybeFlip :: Int %1-> Int %1-> (a,a) -> a+maybeFlip i j (x,y) =  i < j & \case+  True -> x+  False -> y+```++The `(&)` operator is like `($)` with the argument order flipped.++### `let` and `where` bindings are not linear++The following will **fail** to type check:++```haskell+idBad1 :: a %1-> a+idBad1 x = y+  where+    y = x++idBad2 :: a %1-> a+idBad2 x = let y = x in y+```++This is because GHC assumes that anything used in a `where`-binding or+`let`-binding is consumed with multiplicity `Many`. Workaround: inline+these bindings or use sub-functions.++```haskell+inlined1 :: a %1-> a+inlined1 x = x++useSubfunction :: Array a %1-> Array a+useSubfunction arr = fromRead (read arr 0)+  where+    fromRead :: (Array a, Ur a) %1-> Array a+    fromRead = undefined+```++[`Data.Unrestricted`]: ../src/Data/Unrestricted/Linear.hs+[`Prelude.Linear`]: ../src/Prelude/Linear.hs+[`README`]: ../README.md
+ examples/Foreign/Heap.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | 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.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++  toRepr (Heap k a l) = (k, a, l)+  ofRepr (k, a, l) = Heap k a l++instance (Manual.Representable k, Manual.Representable a) => Manual.Representable (NEHeap k a) where+  type AsKnown (NEHeap k a) = Manual.AsKnown (k, a, (Box (List (NEHeap k a))))++-- * Non-empty heap primitives++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 (Heap k1 a1 h1) (Heap 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 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.++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 (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 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 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' h1 List.Nil pools =+      pools `lseq` h1+    pairOne' h1 (List.Cons h2 r') (pool1, pool2, pool3) =+      mergeN' (mergeN h1 h2 pool1) (pairUp (Manual.deconstruct r') pool2) pool3++-- * Heap primitives++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 k a pool = NonEmpty $ singletonAlloc k a (dup pool)+  where+    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 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 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 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 f acc h pool = go acc h (dup pool)+  where+    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 acc' Nothing pool' = pool' `lseq` acc'+    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 step seed pool = dispatch (step seed) pool+  where+    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 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 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++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)]+    sort' l' (pool1, pool2) = toList (ofList l' pool1) pool2
+ examples/Foreign/List.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Foreign.List where++import qualified Data.List as List+import Foreign.Marshal.Pure (Pool, Box)+import qualified Foreign.Marshal.Pure as Manual+import Prelude.Linear hiding (map, foldl, foldr)++-- XXX: we keep the last Cons in Memory here. A better approach would be to+-- always keep a Box instead.+data List a+  = Nil+  | Cons !a !(Box (List a))++-- TODO: generating appropriate instances using the Generic framework+instance+  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++instance Manual.Representable a => Manual.Representable (List a) where+  type AsKnown (List a) = Manual.AsKnown (Maybe (a, Box (List a)))++-- Remark: this is a bit wasteful, we could implement an allocation-free map by+-- reusing the old pointer with realloc.+--+-- 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 _f Nil pool = pool `lseq` Nil+map f (Cons a l) pool =+    withPools (dup pool) a (Manual.deconstruct l)+  where+    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 _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 _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 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+    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 step state pool = dispatch (step state) (dup pool)+  where+    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 l pool = unfold List.uncons l pool++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 step state pool = loop state Nil pool+  where+    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 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 l pool = runfold List.uncons l pool
+ examples/Main.hs view
@@ -0,0 +1,15 @@+module Main where++import Test.Tasty+import Test.Foreign (foreignGCTests)+import Test.Quicksort (quickSortTests)++main :: IO ()+main = defaultMain allTests++allTests :: TestTree+allTests = testGroup "All tests"+  [ foreignGCTests+  , quickSortTests+  ]+
+ examples/Simple/FileIO.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- |+-- Module      : FileIO+-- Description : The Linear File IO example from the Linear Haskell paper.+--+-- We implement a function that prints the first line of a file.+--+-- We do this with the normal file IO interface in base and the linear file IO+-- interface in linear-base. With the latter, the protocol for using files is+-- enforced by the linear type system. For instance, forgetting to close the file+-- will induce a type error at compile time. That is, typechecking proves that all+-- opened files are closed at some later point in execution. With the former+-- interface, we have code that type checks but will error or cause errors at+-- runtime.+module Simple.FileIO where++import Control.Monad ()+-- Linear Base Imports+import qualified Control.Functor.Linear as Control+import Data.Text+import Data.Unrestricted.Linear+import qualified System.IO as System+import qualified System.IO.Resource as Linear+import Prelude++-- *  Non-linear first line printing+--------------------------------------------++-- openFile :: FilePath -> IOMode -> IO Handle+-- IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode+-- hGetLine :: Handle -> IO String+-- hPutStr :: Handle -> String -> IO ()+-- hClose :: Handle -> IO ()++printFirstLine :: FilePath -> System.IO ()+printFirstLine fpath = do+  fileHandle <- System.openFile fpath System.ReadMode+  firstLine <- System.hGetLine fileHandle+  System.putStrLn firstLine+  System.hClose fileHandle++-- This compiles but can cause issues!+-- The number of file handles you can have active is finite and after that+-- openFile errors. This is especially critical on mobile devices or systems+-- with limited resources.+printFirstLineNoClose :: FilePath -> System.IO ()+printFirstLineNoClose fpath = do+  fileHandle <- System.openFile fpath System.ReadMode+  firstLine <- System.hGetLine fileHandle+  System.putStrLn firstLine++-- This compiles, but will throw an error!+printFirstLineAfterClose :: FilePath -> System.IO ()+printFirstLineAfterClose fpath = do+  fileHandle <- System.openFile fpath System.ReadMode+  System.hClose fileHandle+  firstLine <- System.hGetLine fileHandle+  System.putStrLn firstLine++-- * Linear first line printing+--------------------------------------------++linearGetFirstLine :: FilePath -> RIO (Ur Text)+linearGetFirstLine fp = Control.do+  handle <- Linear.openFile fp System.ReadMode+  (t, handle') <- Linear.hGetLine handle+  Linear.hClose handle'+  Control.return t++linearPrintFirstLine :: FilePath -> System.IO ()+linearPrintFirstLine fp = do+  text <- Linear.run (linearGetFirstLine fp)+  System.putStrLn (unpack text)++{-+    For clarity, we show this function without do notation.++    Note that the current approach is limited.+    We have to make the continuation use the unit type.++    Enabling a more generic approach with a type index+    for the multiplicity, as descibed in the paper is a work in progress.+    This will hopefully result in using++    `(>>==) RIO 'Many a %1-> (a -> RIO p b) %1-> RIO p b`++    as the non-linear bind operation.+    See https://github.com/tweag/linear-base/issues/83.+-}++-- * Linear and non-linear combinators+-------------------------------------------------++-- Some type synonyms+type RIO = Linear.RIO++type LinHandle = Linear.Handle++-- | 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+(>>#=) = (Control.>>=)++-- | 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+(>>==) ma f = ma Control.>>= (\() -> f ())++-- | Inject+-- provided just to make the type explicit+inject :: a %1-> RIO a+inject = Control.return++-- * The explicit example+-------------------------------------------------++getFirstLineExplicit :: FilePath -> RIO (Ur Text)+getFirstLineExplicit path =+  (openFileForReading path)+    >>#= readOneLine+    >>#= closeAndReturnLine -- Internally uses (>>==)+  where+    openFileForReading :: FilePath -> RIO LinHandle+    openFileForReading fp = Linear.openFile fp System.ReadMode+    readOneLine :: LinHandle %1-> RIO (Ur Text, LinHandle)+    readOneLine = Linear.hGetLine+    closeAndReturnLine ::+      (Ur Text, LinHandle) %1-> RIO (Ur Text)+    closeAndReturnLine (unrText, handle) =+      Linear.hClose handle >>#= (\() -> inject unrText)++printFirstLineExplicit :: FilePath -> System.IO ()+printFirstLineExplicit fp = do+  firstLine <- Linear.run $ getFirstLineExplicit fp+  putStrLn $ unpack firstLine
+ examples/Simple/Pure.hs view
@@ -0,0 +1,304 @@+{-# 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 Simple.Pure where+++-- * Simple linear functions+------------------------------------------------------------++{-+   A linear function simply "consumes/uses" its argument exactly once.++   Giving a more precise idea of this is tricky, so first we present a+   bunch of examples. You should try to get a sense of the arithmatic of how+   many times an argument in a function is used. In other words, you should+   have some idea of a counting function in your head, that can take some+   haskell function f :: A -> B and give a natural number as to the number of+   times the argument of f is used in the body.+-}++linearIdentity :: a %1-> a+linearIdentity x = x++{-+   DEFINITION.+   ==========+   We say the argument of a function is linear if the arrow+   that follows it is linear.++   Here, the argument is present exactly once in the body and is+   consumed exactly once.+-}+++linearSwap :: (a,a) %1-> (a,a)+linearSwap (x,y) = (y,x)++{-+   Here, the argument is decomposed by the tuple data constructor into two+   pieces. Since the whole first argument is linear, the tuple constructor+   in linear haskell is linear -- i.e., notice the type of the+   constructor:++   (,) :: a %1-> b %1-> (a,b)++   Now, this does not mean that if we have some non-linear function with+   an argument (a,b) that `a` and `b` have to be consumed exactly once.++   DEFINITION.+   ==========+   A linear arrow in a data constructor merely signifies that the argument to+   the constructor that preceedes that arrow must be used linearly if the input+   to a linear function is this data type with this constructor.++   Here, since `(,) x y` was the first input to linearSwap, which is a+   linear function (meaning the first input is linear), the components `x`+   and `y` must be used linearly. Indeed, we see the `x` and `y` are each+   used exactly once.++   With a non-linear function, this is not the case; a non-linear function+   `f :: (x,y) -> B` does not have to use the `x` and `y` linearly.+   Consider the next function as an example.+-}++nonLinearSubsume :: (a,a) -> (a,a)+nonLinearSubsume (x,_) = (x,x)++{-+   This function is not linear on its argument and in fact could not have a+   linear arrow. If it did, this file would not compile. Why is this?  Well,+   the first argument would be linear, and the constructor is linear in both+   components.++   (,) :: a %1-> b %1-> (a,b)++   Again, in a linear function, this means the `a` and `b` must be used+   linearly.++   Yet, in the body of the function, `a` is used twice and `b` is used+   zero times.+-}++linearPairIdentity :: (a,a) %1-> (a,a)+linearPairIdentity (x,y) = (x,y)++{-+   Here, notice that `(a,a)` is linear, and since `(,)` is linear+   on both arguments, both `a`s must be used linearly, and indeed+   they are. Each is consumed exactly once in a linear input+   to the constructor `(,) :: a %1-> b %1-> (a,b)`.++   Notice the general pattern: we consumed `(a,b)` linearly by pattern matching+   into `Constructor arg1 ... argn` and consumed the linearly bound arguments+   of the constructor linearly by giving them as arguments to some other+   constructor that is linear on the appropreate arguments.+-}+++linearIdentity2 :: a %1-> a+linearIdentity2 x = linearIdentity x++{-+   Of course, another way to use an input linearly (or a component of an input)+   is to pass it to a linear function.  Here, since linearIdentity is linear,+   we can be sure the term (linearIdentity x) consumes x exactly once.  Hence,+   all of linearIdentity2 consumes the input x exactly once.++   If we replaced it with the original `id`, this would fail to type check+   because `id` has the non-linear type `a -> a`.  Thus, GHC isn't sure+   that `id` uses its input exactly once.  If `id` doesn't use its input+   exactly once, then linearIdentity2 won't use its input exactly once,+   violating it's type signature.++   Now, this does not mean that merely using a linear function makes the+   use of a variable linear. For instance, both of the two functions below+   use their input exactly twice.+-}++nonLinearPair :: a -> (a,a)+nonLinearPair x = (linearIdentity x, linearIdentity x)++nonLinearPair2 :: a -> (a,a)+nonLinearPair2 x = (x, linearIdentity x)+++{-+   The function below uses its input exactly thrice.+-}++nonLinearTriple :: a -> (a,(a,a))+nonLinearTriple x = (linearIdentity x, linearIdentity (nonLinearPair2 x))++{-++   With several examples in hand, we can now give a more precise way of+   constructively checking that an argument is "consumed exactly once".+   Here's a rough (good enough most of the time) definition:++   DEFINITION.+   ==========+   Let f :: A %1-> B.  Suppose that we don't have the identity, "f x = x"+   which is trivially linear. Then, the thunk (f x) is basically a tree+   composed of function applications, data constructors and case+   statements.++   We say f is linear if for any thunk (f x) ...++   I.+     If x is not a function and is not deconstructed in a case statement:++     case (a): (f x) is some function application (func t1 ... tn) or+               a constructor (Constr t1 ... tn)++       Either (i) exactly one of the t_i is x and the function func or+       constructor Constr is linear on its ith argument, or (ii) x is used+       exactly once in exactly one t_i.++     case (b): (f x) is a case statement (case s of [a_i -> t_i]),++        x is used exactly once in **each** t_i (and not at all in s)++   II.++     If x is a function, then for some argument u, (f u) is used+     exactly once.++   III.++     If x is deconstructed into (Constructor t1 ... tn) in a case statement+     then whatever pieces t_i that are bound linearly by the constuctor,+     must be consumed exactly once.++-}+++regularIdentity :: a -> a+regularIdentity x = linearIdentity x++{-+   Of course, the fact that a function is linear makes no difference in+   non-linear functions. So, non-linear functions can call linear+   functions willy-nilly and they will work as expected. (Obviously,+   the converse is false, which is kind of the point of linear types.)+   To state the obvious, linear functions are regular functions but not all+   functions are linear functions.+-}+++(#.) :: (b %1-> c) -> (a %1-> b) -> (a %1-> c)+g #. f = \a -> g (f a)++linearCompose :: (a,a) %1-> (a,a)+linearCompose = linearIdentity #. linearSwap++{-+   Above, we compose two linear functions and write a linear version of+   `(.)`.  Here, as before, it is critical that we are composing linear+   functions.  Notice that we cannot write a function of the following+   type:++   (##.) :: (b -> c) -> (a %1-> b) -> (a %1-> c)+-}++++-- * Linear functions with user data types+------------------------------------------------------------++{-+  As we've seen, we can consume linearly bound inputs into data types if+  the constructor has a linear arrow before the input.+-}++data LinearHolder a where+  LinearHolder :: a %1-> LinearHolder a++linearHold :: a %1-> LinearHolder a+linearHold x = LinearHolder x++{-+   Note that if the constructor LinearHolder did not have the %1-> then+   linearHold would not compile, because then you could use the value+   non-linearly.+-}+++linearHoldExtract :: LinearHolder a %1-> a+linearHoldExtract (LinearHolder x) = x++linearIdentity3 :: a %1-> a+linearIdentity3 = linearHoldExtract #. linearHold++{-+   For clarity, we include an example of using such linear constructors.+   Here, linearHoldExtract must use the inner component linearly.+   Therefore, it's impossible to implement the following function:++   linearHoldPair :: LinearHolder a %1-> (a,a)+   linearHoldPair (LinearHolder x) = (x,x)++   In fact, we have the following equivalence:++   (LinearHolder a  %1-> b) ≅ (a %1-> b)+-}+++data LinearHolder2 where+  LinearHolder2 :: a %1-> b -> LinearHolder2++linearHold' :: a %1-> LinearHolder2+linearHold' x = LinearHolder2 x "hello"+--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)++{-+   Above we define a data type ForcedUnlinear which does not use the+   linear arrow to hold it's argument. This means that even if an input of+   type `ForcedUnlinear a` is linear, the component does not have to be.+   Hence, we can write the function above but could not write something+   the following type:++   linearPair :: a %1-> (a,a)+-}+++demote :: (ForcedUnlinear a %1-> b) -> (a -> b)+demote f x = f (ForcedUnlinear x)++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+   two functions above:++   (ForcedUnlinear a  %1-> b) ≅ (a -> b)++   In the Linear Haskell POPL '18 paper, this datatype is called+   Unrestricted.+-}
+ examples/Simple/Quicksort.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | 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 Data.Unrestricted.Linear+import Prelude.Linear hiding (partition)++-- # Quicksort+-------------------------------------------------------------------------------++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++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++-- | @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 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)++-- | @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
+ examples/Simple/TopSort.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+++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++-- # 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))  )+  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)+++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)++      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++-- pluckSources sources postOrdSoFar dag+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'+  where+    -- decrement degree of children, save newly made sources+    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+        (Ur Nothing, dag') -> (dag', Ur Nothing)+        (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 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)+++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)+
+ examples/Test/Foreign.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Test.Foreign (foreignGCTests) where++import Data.Typeable+import Control.Monad (void)+import Control.Exception hiding (assert)+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+++-- # Organizing tests+-------------------------------------------------------------------------------++foreignGCTests :: TestTree+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+  ]++heapExampleTests :: TestTree+heapExampleTests = testGroup "heap tests"+  [ testProperty "sort = heapsort" nonGCHeapSort ]+++-- # Internal library+-------------------------------------------------------------------------------++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 l1 l2 = move $ (List.toList l1) == (List.toList l2)++data InjectedError = InjectedError+  deriving (Typeable, Show)++instance Exception InjectedError+++-- # Properties+-------------------------------------------------------------------------------++invertNonGCList :: Property+invertNonGCList = property Prelude.$ do+  xs <- forAll list+  let xs' = unur $+        Manual.withPool (\p -> move $ List.toList $ List.ofList xs p)+  xs === xs'++mapIdNonGCList :: Property+mapIdNonGCList = property Prelude.$ 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)+  assert boolTest++testExecptionOnMem :: Property+testExecptionOnMem = property Prelude.$ do+  xs <- forAll list+  let bs = xs ++ (throw InjectedError)+  let writeBadList = Manual.withPool (move . List.toList . List.ofRList bs)+  let ignoreCatch = \_ -> Prelude.return ()+  evalIO (catch @InjectedError (void (evaluate writeBadList)) ignoreCatch)++nonGCHeapSort :: Property+nonGCHeapSort = property Prelude.$ do+  xs <- forAll list+  let ys :: [(Int,())] = zip xs $ Prelude.replicate (Prelude.length xs) ()+  (Heap.sort ys) === (reverse $ sort ys)+
+ examples/Test/Quicksort.hs view
@@ -0,0 +1,18 @@+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++quickSortTests :: TestTree+quickSortTests = testProperty "quicksort sorts" testQuicksort++testQuicksort :: Property+testQuicksort = property $ do+  xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int $ Range.linear 0 100)+  sort xs === quickSort xs+
+ linear-base.cabal view
@@ -0,0 +1,206 @@+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.++extra-source-files:+  README.md+  CHANGELOG.md+  docs/DESIGN.md+  docs/USER_GUIDE.md++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++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++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++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++-- 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++-- 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++source-repository head+  type: git+  location: https://github.com/tweag/linear-base
+ src/Control/Functor/Linear.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | = The control functor hierarchy+--+-- The functors in this module are called control functors, which+-- are different from the data functors in @Data.Functor.Linear@.+--+-- 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++import Control.Functor.Linear.Internal.Class+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+-- the basics of reader monads. To know about the standard reader monad+-- functions, see the documentation of the standard reader monad+-- [here](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader.html).++-- $stateT+-- This is a linear version of the standard state monad.+-- The linear arrows ensure that the state is threaded linearly through+-- functions of the form @a %1-> StateT s m a@. That is, when sequencing+-- @f :: a %1-> StateT s m b@ and @g :: b %1-> StateT s m c@,+-- the type system enforces that state produced by $f$ is fed into @g@.+--+-- For this reason, there is only one way to define '(>>=)':+--+-- > instance Monad m => Applicative (StateT s m) where+-- > StateT mx >>= f = StateT $ \s -> do+-- >   (x, s') <- mx s+-- >   runStateT (f x) s'+--+-- To see examples and learn about all the standard state monad functions, see+-- [here](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-State-Lazy.html).+-- To learn the basics of the state monad, see+-- [here](https://mmhaskell.com/monads/state).+
+ src/Control/Functor/Linear/Internal/Class.hs view
@@ -0,0 +1,149 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-- | 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++import Prelude (String)+import Prelude.Linear.Internal+import qualified Control.Monad as NonLinear ()+import qualified Data.Functor.Linear.Internal.Functor as Data+import qualified Data.Functor.Linear.Internal.Applicative as Data+import Data.Unrestricted.Internal.Consumable+++-- # Control Functors+-------------------------------------------------------------------------------++-- TODO: explain that the category of linear function is self-enriched, and that+-- this is a hierarchy of enriched monads. In order to have some common+-- vocabulary.++-- There is also room for another type of functor where map has type `(a %1->b)+-- -> f a %1-> f b`. `[]` and `Maybe` are such functors (they are regular+-- (endo)functors of the category of linear functions whereas `LFunctor` are+-- control functors). A Traversable hierarchy would start with non-control+-- functors.++-- TODO: make the laws explicit++-- | Control linear functors. The functor of type+-- @f a@ holds only one value of type @a@ and represents a computation+-- producing an @a@ with an effect. All control functors are data functors,+-- but not all data functors are control functors.+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++-- | Apply the control @fmap@ over a data functor.+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+(<$>) = fmap+{-# INLINE (<$>) #-}++-- |  @+--    ('<&>') = 'flip' 'fmap'+--    @+(<&>) :: Functor f => f a %1-> (a %1-> b) %1-> f b+(<&>) a f = f <$> a+{-# INLINE (<&>) #-}++-- | Linearly typed replacement for the standard '(Prelude.<$)' function.+(<$) :: (Functor f, Consumable b) => a %1-> f b %1-> f a+a <$ fb = fmap (`lseq` a) fb+++-- # Control Applicatives+-------------------------------------------------------------------------------++-- | Control linear applicative functors. These represent effectful+-- computations that could produce continuations that can be applied with+-- '<*>'.+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+  -- | 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+  (<*>) = liftA2 id+  -- | @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 f x y = f <$> x <*> y++-- | Apply the control @pure@ over a data applicative.+dataPureDefault :: Applicative f => a -> f a+dataPureDefault x = pure x+++-- # Control Monads+-------------------------------------------------------------------------------++-- | Control linear monads.+-- A linear monad is one in which you sequence linear functions in a context,+-- 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 >> k = m >>= (\() -> k)++-- | 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 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 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 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 _ i [] = return i+foldM f i (x:xs) = f i x >>= \i' -> foldM f i' xs+
+ src/Control/Functor/Linear/Internal/Instances.hs view
@@ -0,0 +1,71 @@+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Control.Functor.Linear.Internal.Instances+  ( 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+++-- # Deriving Data.XXX in terms of Control.XXX+-------------------------------------------------------------------------------++-- | This is a newtype for deriving Data.XXX classes from+-- Control.XXX classes.+newtype Data f a = Data (f a)+++-- # Basic instances+-------------------------------------------------------------------------------++instance Functor f => Data.Functor (Data f) where+  fmap f (Data x) = Data (fmap f x)++instance Applicative f => Data.Applicative (Data f) where+  pure x = Data (pure x)+  Data f <*> Data x = Data (f <*> x)++instance Functor ((,) a) where+  fmap f (a, x) = (a, f x)++instance Monoid a => Applicative ((,) a) where+  pure x = (mempty, x)+  (a, f) <*> (b, x) = (a <> b, f x)++instance Monoid a => Monad ((,) a) where+  (a, x) >>= f = go a (f x)+    where go :: a %1-> (a,b) %1-> (a,b)+          go b1 (b2, y) = (b1 <> b2, y)++instance Functor Identity where+  fmap f (Identity x) = Identity (f x)++instance Applicative Identity where+  pure = Identity+  Identity f <*> Identity x = Identity (f x)++instance Monad Identity where+  Identity x >>= f = f x++instance (Functor f, Functor g) => Functor (Sum f g) where+  fmap f (InL fa) = InL (fmap f fa)+  fmap f (InR ga) = InR (fmap f ga)++instance (Functor f, Functor g) => Functor (Compose f g) where+  fmap f (Compose fga) = Compose $ fmap (fmap f) fga+
+ src/Control/Functor/Linear/Internal/MonadTrans.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+module Control.Functor.Linear.Internal.MonadTrans+  ( 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+
+ src/Control/Functor/Linear/Internal/Reader.hs view
@@ -0,0 +1,112 @@+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Control.Functor.Linear.Internal.Reader+  (+  --  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 qualified Control.Monad as NonLinear ()+import qualified Control.Monad.Trans.Reader as NonLinear+++-- # Linear ReaderT+-------------------------------------------------------------------------------++-- | A linear reader monad transformer.+-- This reader monad requires that use of the read-only state is explict.+--+-- The monad instance requires that @r@ be 'Dupable'.  This means that you+-- 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)++-- 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 +-- a reader monad transformer+runReaderT :: ReaderT r m a %1-> r %1-> m a+runReaderT (ReaderT f) = f++instance Data.Functor m => Data.Functor (ReaderT r m) where+  fmap f = mapReaderT (Data.fmap f)++instance Functor m => Functor (ReaderT r m) where+  fmap f = mapReaderT (fmap f)++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)++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)++instance (Monad m, Dupable r) => Monad (ReaderT r m) where+  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 f m = ReaderT $ runReaderT m . f++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 f = ReaderT (return . f)++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 f = mapReaderT (Identity . f . runIdentity')++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 = withReaderT++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 f) = f++instance MonadTrans (NonLinear.ReaderT r) where+  lift x = NonLinear.ReaderT (\_ -> x)+
+ src/Control/Functor/Linear/Internal/State.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Control.Functor.Linear.Internal.State+  ( 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 qualified Control.Monad as NonLinear ()+import Data.Functor.Identity+++-- # 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.++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 = 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)++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 f = StateT (pure . f)++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 r (StateT f) = StateT (r . f)++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 f = fmap (\((), s) -> s) . (runStateT f)++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 = withStateT++execState :: State s () %1-> s %1-> s+execState f = runIdentity' . execStateT f++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 s = state $ (\s' -> (s', s))+++-- # Instances of StateT+-------------------------------------------------------------------------------++instance Functor m => Functor (NonLinear.StateT s m) where+  fmap f (NonLinear.StateT x) = NonLinear.StateT $ \s -> fmap (\(a, s') -> (f a, s')) $ x s++instance Data.Functor m => Data.Functor (StateT s m) where+  fmap f (StateT x) = StateT (\s -> Data.fmap (\(a, s') -> (f a, s')) (x s))++instance Functor m => Functor (StateT s m) where+  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))+  StateT mf <*> StateT mx = StateT $ \s -> do+    (f, s') <- mf s+    (x, s'') <- mx s'+    return (f x, s'')++instance Monad m => Monad (StateT s m) where+  StateT mx >>= f = StateT $ \s -> do+    (x, s') <- mx s+    runStateT (f x) s'++instance MonadTrans (StateT s) where+  lift x = StateT (\s -> fmap (,s) x)+
+ src/Control/Monad/IO/Class/Linear.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Control.Monad.IO.Class.Linear where++import qualified Control.Functor.Linear as Linear+import Prelude.Linear+import qualified System.IO as System+import qualified System.IO.Linear as Linear++-- | 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+  liftSystemIO :: System.IO a -> m a+  liftSystemIO io = liftIO (Linear.fromSystemIO io)+  liftSystemIOU :: System.IO a -> m (Ur a)+  liftSystemIOU io = liftIO (Linear.fromSystemIOU io)++instance MonadIO Linear.IO where+  liftIO = id
+ src/Control/Optics/Linear.hs view
@@ -0,0 +1,148 @@+-- | This module provides linear optics.+--+-- Documentation for specific optics (lenses, prisms, traversals and+-- isomorphisms) are provided in their respective modules.+--+-- Here we just provide an overview.+--+-- Some familiarity with optics is needed to understand linear optics.+-- Please go through the (hopefully friendly!) background material section+-- if you are unfamiliar with lenses, prisms, traversals or isomorphisms.+--+-- == Background Material+--+-- If you don't know anything about optics, we suggest looking at the+-- resources below and playing with the @lens@ package.+--+--  * [A great intro-to-lenses talk by Simon Peyton Jones](https://skillsmatter.com/skillscasts/4251-lenses-compositional-data-access-and-manipulation)+--  * [A nice introductory blog post](https://tech.fpcomplete.com/haskell/tutorial/lens)+--  * [A friendly introduction to prisms and isos](https://www.schoolofhaskell.com/school/to-infinity-and-beyond/pick-of-the-week/a-little-lens-starter-tutorial)+--  * [The wiki of the @lens@ package](https://github.com/ekmett/lens/wiki)+--  that contains some nice examples+--+-- == Conceptualizing and using optics+--+-- === What are /linear/ optics?+--+-- Optics can be conceptualized as a first class object with which you can+-- view and map functions over sub-structure(s) within a larger structure.+--+-- __ /Linear/ optics are optics where the \"viewing\" and \"mapping\" are__+-- __done with linear functions (and any corresponding structures hold values__+-- __linearly, i.e., with constructors that use linear arrows).__+--+-- In types: a (linear) optic of type @Optic s t a b@ is a way of viewing the+-- sub-structure(s) of type @a@ in the structure of type @s@ and mapping a+-- function from an @a@ to a @b@ on those sub-structures in @s@ which change an+-- @s@ to a @t@. The non-polymorphic version of the optic is specialized+-- to the types @Optic s s a a@ and is usually defined with a tick mark,+-- e.g., the non-polymorphic @Lens@ is @Lens'@.+--+-- There are four basic optics: traversals, lenses, prisms and isomorphisms.+--+-- === Sub-typing diagram of optics+--+-- \[ \texttt{Traversal} \]+-- \[ \Huge \nearrow ~~~~~ \nwarrow \]+-- \[ \texttt{Lens}\hspace{6em}\texttt{Prism} \]+-- \[ \Huge \nwarrow ~~~~~ \nearrow \]+-- \[ \texttt{Iso} \]+--+-- In the diagram above, the arrows @X --> Y@ mean any of the following+-- equivalent things:+--+--  * X is a specialization of Y+--  * X is a strict subset of Y+--  * You can (basically) implement @f :: X -> Y@ with @f = id@+--  but you can't implement @f :: Y -> X@.+--+-- === A bird's eye view of the types+--+-- The types of linear optics are generalizations of the standard optic+-- types from the @lens@ package.+--+-- These are the standard optic types:+--+-- > type Traversal s t a b =+-- >   forall f. Applicative f => (a -> f b) -> s -> f t+-- > type Lens s t a b =+-- >   forall f. Functor f => (a -> f b) -> (s -> f t)+-- > type Prism s t a b =+-- >   forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)+-- > type Iso s t a b =+-- >   forall p f. (Profunctor p, Functor f) => a `p` (f b) -> s `p` (f t)+--+-- These are (basically) the linear optic types:+--+-- > type Traversal a b s t =+-- >   forall arr.  Wandering arr => (a `arr` b) -> (s `arr` t)+-- > type Lens a b s t =+-- >   forall arr. Strong (,) () arr => (a `arr` b) -> (s `arr` t)+-- > type Prism a b s t =+-- >   forall arr. Strong Either Void arr => (a `arr` b) -> (s `arr` t)+-- > type Iso a b s t =+-- >   forall arr. Profunctor arr => (a `arr` b) -> (s `arr` t)+--+-- Below is a table that lists the instances of the typeclasses which+-- generalize the standard optics.+--+-- Note that Kleisli arrows basically defined like so:+--+-- > type Kleisli f a b = a #-> f b+--+-- /Note: We abbreviate Control for Control.Functor.Linear./+--+-- +-----------------+------------+---------------+--------------------+-----------++-- |                 | Profunctor | Strong (,) () | Strong Either Void | Wandering |+-- +=================+============+===============+====================+===========++-- |     @(->)@      |     X      |       X       |         X          |           |+-- +-----------------+------------+---------------+--------------------+-----------++-- |    @(\#->)@     |     X      |       X       |         X          |           |+-- +-----------------+------------+---------------+--------------------+-----------++-- |    (Prelude)    |            |               |                    |           |+-- |  @Functor f@    |            |               |                    |           |+-- | @=> Kleisli f@  |     X (4)  |       X       |                    |           |+-- +-----------------+------------+---------------+--------------------+-----------++-- | (Data.Functor)  |            |               |                    |           |+-- |  @Functor f@    |            |               |                    |           |+-- | @=> Kleisli f@  |     X      |               |                    |           |+-- +-----------------+------------+---------------+--------------------+-----------++-- |    (Prelude)    |            |               |                    |           |+-- | @Applicative f@ |            |               |                    |           |+-- | @=> Kleisli f@  |     X      |       X       |         X   (3)    |           |+-- +-----------------+------------+---------------+--------------------+-----------++-- |    (Control)    |            |               |                    |           |+-- |   @Functor f@   |            |               |                    |           |+-- | @=> Kleisli f@  |     X      |       X (2)   |                    |           |+-- +-----------------+------------+---------------+--------------------+-----------++-- |    (Control)    |            |               |                    |           |+-- | @Applicative f@ |            |               |                    |           |+-- | @=> Kleisli f@  |     X      |       X       |         X          |     X (1) |+-- +-----------------+------------+---------------+--------------------+-----------++--+-- Essentially:+--+--  * The instance marked (1) implies that the linear traversal definition+--    includes the standard one+--  * The instance marked by (2) implies that the linear lens definition+--    includes the standard one+--  * The instance marked by (3) implies that the linear prism definition+--    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+  )+where++import Control.Optics.Linear.Internal (Optic_(..), Optic)+import Control.Optics.Linear.Iso+import Control.Optics.Linear.Lens+import Control.Optics.Linear.Prism+import Control.Optics.Linear.Traversal
+ src/Control/Optics/Linear/Internal.hs view
@@ -0,0 +1,174 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module Control.Optics.Linear.Internal+  ( -- * Types+    Optic_(..)+  , Optic+  , Iso, Iso'+  , Lens, Lens'+  , Prism, Prism'+  , Traversal, Traversal'+    -- * Composing optics+  , (.>)+    -- * Common optics+  , 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+    -- * Constructing optics+  , iso, lens, prism, traversal+  )+  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 Data.Functor.Compose hiding (getCompose)+import Data.Functor.Linear+import qualified Data.Profunctor.Kleisli.Linear as Linear+import Data.Void+import GHC.Exts (FUN)+import GHC.Types+import Prelude.Linear+import qualified Prelude++newtype Optic_ arr s t a b = Optical (a `arr` b -> s `arr` t)++type Optic c s t a b =+  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)+swap = iso Bifunctor.swap Bifunctor.swap++assoc :: SymmetricMonoidal m u => Iso (a `m` (b `m` c)) (d `m` (e `m` f)) ((a `m` b) `m` c) ((d `m` e) `m` f)+assoc = iso Bifunctor.lassoc Bifunctor.rassoc++(.>) :: 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)+++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 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 trav = Optical $ wander trav++_1 :: Lens (a,c) (b,c) a b+_1 = Optical first++_2 :: Lens (c,a) (c,b) a b+_2 = Optical second++_Left :: Prism (Either a c) (Either b c) a b+_Left = Optical first++_Right :: Prism (Either c a) (Either c b) a b+_Right = Optical second++_Just :: Prism (Maybe a) (Maybe b) a b+_Just = prism Just (maybe (Left Nothing) Right)++_Nothing :: Prism' (Maybe a) ()+_Nothing = prism (\() -> Nothing) Left++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))++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]+toListOf l = gets l (\a -> [a])++get :: Optic_ (NonLinear.Kleisli (Const a)) s t a b -> s -> a+get l = gets l Prelude.id++gets :: Optic_ (NonLinear.Kleisli (Const r)) s t a b -> (a -> r) -> s -> r+gets (Optical l) f s = getConst' (NonLinear.runKleisli (l (NonLinear.Kleisli (Const Prelude.. f))) s)++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))++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 (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 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)++-- XXX: the below two functions will be made redundant with multiplicity+-- polymorphism on over and traverseOfU+overU :: Optic_ (->) s t a b -> (a -> b) -> s -> t+overU (Optical l) f = l f++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 f g = Optical (dimap f g)++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)++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)++-- 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 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 (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 x) = x
+ src/Control/Optics/Linear/Iso.hs view
@@ -0,0 +1,55 @@+-- | This module provides linear isomorphisms.+--+-- An @Iso a b s t@ is equivalent to a @(s \#-> a, b \#-> 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+-- you can form isomorphisms between @s@, @t@, @a@ and @b@.+--+-- = Example+--+-- @+-- {-# LANGUAGE LinearTypes #-}+-- {-# LANGUAGE NoImplicitPrelude #-}+-- {-# LANGUAGE GADTs #-}+--+-- import Control.Optics.Linear.Internal+-- import Prelude.Linear+-- import qualified Data.Functor.Linear as Data+--+-- -- A toy example of operating over two isomorphic linear types+-- closureFmap :: (a %1-> b) -> ClosureEither x a %1-> ClosureEither x b+-- closureFmap f = over isoEithers (Data.fmap f)+--+-- data ClosureEither a b where+--   CLeft :: x %1-> (x %1-> a) %1-> ClosureEither a b+--   CRight :: x %1-> (x %1-> b) %1-> ClosureEither a b+--+-- isoEithers ::+--   Iso (ClosureEither a b) (ClosureEither a b') (Either a b) (Either a b')+-- isoEithers = iso fromClosure fromEither+--   where+--     fromEither :: Either a b %1-> ClosureEither a b+--     fromEither (Left a) = CLeft () (\() -> a)+--     fromEither (Right b) = CRight () (\() -> b)+--+--     fromClosure :: ClosureEither a b %1-> Either a b+--     fromClosure (CLeft x f) = Left (f x)+--     fromClosure (CRight x f) = Right (f x)+-- @+--+module Control.Optics.Linear.Iso+  ( -- * Types+    Iso, Iso'+    -- * Composing optics+  , (.>)+    -- * Common optics+  , swap, assoc+    -- * Using optics+  , withIso+    -- * Constructing optics+  , iso+  )+  where++import Control.Optics.Linear.Internal
+ src/Control/Optics/Linear/Lens.hs view
@@ -0,0 +1,58 @@+{-# 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+-- 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+-- traversal on exactly one @a@ in a @s@.+--+-- = Example+--+-- @+-- {-# LANGUAGE LinearTypes #-}+-- {-# LANGUAGE FlexibleContexts #-}+-- {-# LANGUAGE NoImplicitPrelude #-}+--+-- import Control.Optics.Linear.Internal+-- import Prelude.Linear+--+-- import Control.Optics.Linear.Internal+-- import Prelude.Linear+-- -- We can use a lens to, for instance, linearly modify a sub-piece in+-- -- a nested record+-- modPersonZip :: Person %1-> Person+-- modPersonZip = over (personLocL .> locZipL)  (\x -> x + 1)+--+-- -- A person has a name and location+-- data Person = Person String Location+--+-- -- A location is a zip code and address+-- data Location = Location Int String+--+-- personLocL :: Lens' Person Location+-- personLocL = lens (\(Person s l) -> (l, \l' -> Person s l'))+--+-- locZipL :: Lens' Location Int+-- locZipL = lens (\(Location i s) -> (i, \i' -> Location i' s))+-- @+--+module Control.Optics.Linear.Lens+  ( -- * Types+    Lens, Lens'+    -- * Composing lens+  , (.>)+    -- * Common optics+  , _1, _2+    -- * Using optics+  , get, set, gets, setSwap+  , over, overU+  , reifyLens, withLens+    -- * Constructing optics+  , lens+  )+where++import Control.Optics.Linear.Internal
+ src/Control/Optics/Linear/Prism.hs view
@@ -0,0 +1,65 @@+-- | 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+-- 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.+--+-- = Example+--+-- @+-- {-# LANGUAGE LinearTypes #-}+-- {-# LANGUAGE LambdaCase #-}+-- {-# LANGUAGE FlexibleContexts #-}+-- {-# LANGUAGE NoImplicitPrelude #-}+-- {-# LANGUAGE GADTs #-}+--+-- import Control.Optics.Linear.Internal+-- import Prelude.Linear+-- import qualified Data.Functor.Linear as Data+--+-- -- We can use a prism to do operations on one branch of a sum-type+-- -- (This is a bit of a toy example since we could use @over@ for this.)+-- formatLicenceName :: PersonId %1-> PersonId+-- formatLicenceName personId =+--   Data.fmap modLisc (match pIdLiscPrism personId) & \case+--     Left personId' -> personId'+--     Right lisc -> build pIdLiscPrism lisc+--   where+--     modLisc :: Licence %1-> Licence+--     modLisc (Licence nm x) = Licence (nm ++ "\n") x+--+-- data PersonId where+--   IdLicence :: Licence %1-> PersonId+--   SSN :: Int %1-> PersonId+--   BirthCertif :: String %1-> PersonId+--   -- And there could be many more constructors ...+--+-- -- A Licence is a name and number+-- data Licence = Licence String Int+--+-- pIdLiscPrism :: Prism' PersonId Licence+-- pIdLiscPrism = prism IdLicence decompose where+--   decompose :: PersonId %1-> Either PersonId Licence+--   decompose (IdLicence l) = Right l+--   decompose x = Left x+-- @+--+module Control.Optics.Linear.Prism+  ( -- * Types+    Prism, Prism'+    -- * Composing optics+  , (.>)+    -- * Common optics+  , _Left, _Right+  , _Just, _Nothing+    -- * Using optics+  , match, build+  , withPrism+    -- * Constructing optics+  , prism+  )+  where++import Control.Optics.Linear.Internal
+ src/Control/Optics/Linear/Traversal.hs view
@@ -0,0 +1,69 @@+-- | This module provides linear traversals.+--+--  Traversals provides a means of accessing several @a@s organized in some+--  structural way in an @s@, and a means of changing them to @b@s to create a+--  @t@. In very ordinary language, it's like walking or traversing the data+--  structure, going across cases and inside definitions. In more imaginative+--  language, it's like selecting some specific @a@s by looking at each+--  constructor of a data definition and recursing on each non-basic type+--  (where basic types are things like @Int@, @Bool@ or @Char@).+--+-- = Example+--+-- @+-- {-# LANGUAGE LinearTypes #-}+-- {-# LANGUAGE NoImplicitPrelude #-}+-- {-# LANGUAGE RankNTypes #-}+-- {-# LANGUAGE GADTs #-}+--+-- import Control.Optics.Linear.Internal+-- import qualified Control.Functor.Linear as Control+-- import Control.Functor.Linear ((<$>), (<*>), pure)+-- import Prelude.Linear+--+-- -- We can use a traversal to append a string only to the+-- -- human names in a classroom struct+-- appendToNames :: String -> Classroom %1-> Classroom+-- appendToNames s = over classroomNamesTrav (\name -> name ++ s)+--+-- data Classroom where+--   Classroom ::+--     { className :: String+--     , teacherName :: String+--     , classNum :: Int+--     , students :: [Student]+--     , textbooks :: [String]+--     } %1-> Classroom+--+-- -- A Student is a name and a student id number+-- data Student = Student String Int+--+-- classroomNamesTrav :: Traversal' Classroom String+-- classroomNamesTrav = traversal traverseClassStr where+--   traverseClassStr :: forall f. Control.Applicative f =>+--     (String %1-> f String) -> Classroom %1-> f Classroom+--   traverseClassStr onName (Classroom cname teachname x students texts) =+--     Classroom <$>+--     pure cname <*>+--     onName teachname <*>+--     pure x <*>+--     traverse' (\(Student s i) -> Student <$> onName s <*> pure i) students <*>+--     pure texts+-- @+--+module Control.Optics.Linear.Traversal+  ( -- * Types+    Traversal, Traversal'+    -- * Composing optics+  , (.>)+    -- * Common optics+  , traversed+    -- * Using optics+  , over, overU+  , traverseOf, traverseOfU+    -- * Constructing optics+  , traversal+  )+  where++import Control.Optics.Linear.Internal
+ src/Data/Array/Destination.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module provides destination arrays+--+-- == What are destination arrays? What are they good for?+--+-- Destination arrays are write-only arrays that are only allocated once,+-- thereby avoiding your reliance on GHC's fusion mechanisms to remove+-- unneccessary allocations.+--+-- The current status-quo for computations that have a write-only array+-- threaded along is to rely on fusion. While the optimizations in say,+-- `Data.Vector` are quite good at ensuring GHC fuses, they aren't+-- foolproof and can sometimes break by simple refactorings.+--+-- Avoiding extra allocations of a write-only array is easy in C, with+-- something the functional programming world calls destination passing style,+-- or DPS for short.+--+-- Here is a C function that manipulates an array written in DPS style; it+-- takes in the destiniation array @res@ and writes to it:+--+-- @+-- // ((a + b) * c) for vectors a,b and scalar c+-- void apbxc(int size, int *a, int *b, int c, int *res){+--   for (int i=0; i<size;++i){res[i]=a[i]+b[i];}+--   mult(size, c, res);+-- }+--+-- void mult(int size, int scalar, int* vec){+--   for (int i=0; i<size; ++i){vec[i] *= scalar;}+-- }+-- @+--+-- == Example: Stencil computation+--+-- One possible use of destination arrays could be the stencil computation+-- typically called+-- [jacobi](https://en.wikipedia.org/wiki/Iterative_Stencil_Loops#Example:_2D_Jacobi_iteration).+-- Here we show one time step of this computation in a single dimension:+--+-- @+-- jacobi1d :: Int -> Vector Double -> Vector Double+-- jacobi1d n oldA = case stepArr n oldA of +--   newB -> stepArr n newB+--+-- -- @jacobi1d N A[N] B[N] = (new_A[N], new_B[N])@.+-- stepArr :: Int -> Vector Double -> Vector Double+-- stepArr n oldArr = alloc n $ \newArr -> fillArr newArr oldArr 1+--   where+--     fillArr :: DArray Double %1-> Vector Double -> Int -> ()+--     fillArr newA oldA ix+--       | ix == (n-1) = newA &+--           fill (0.33 * ((oldA ! (ix-1)) + (oldA ! ix) + (oldA ! (ix+1))))+--       | True = split 1 newA & \(fst, rest) ->+--           fill (0.33 * ((oldA ! (ix-1)) + (oldA ! ix) + (oldA ! (ix+1)))) fst &+--             \() -> fillArr rest oldA (ix+1)+-- @+--+-- We can be sure that @stepArr@ only allocates one array. In certain+-- variations and implementations of the jacobi kernel or similar dense array+-- computations, ensuring one allocation with @Data.Vector@'s fusion oriented+-- implementation may not be trivial.+--+-- For reference, the C equivalent of this code is the following:+--+-- @+-- static void jacobi_1d_time_step(int n, int *A, int *B){+--   int t, i;+--   for (i = 1; i < _PB_N - 1; i++)+--     B[i] = 0.33333 * (A[i-1] + A[i] + A[i + 1]);+--   for (i = 1; i < _PB_N - 1; i++)+--     A[i] = 0.33333 * (B[i-1] + B[i] + B[i + 1]);+-- }+-- @+--+-- This example is taken from the+-- [polybench test-suite](https://web.cse.ohio-state.edu/~pouchet.2/software/polybench/)+-- of dense array codes.+--+-- == Aside: Why do we need linear types?+--+-- Linear types avoids ambiguous writes to the destination array.+-- For example, this function could never be linear and hence we avoid+-- ambiguity:+--+-- @+--  nonLinearUse :: DArray Int -> ()+--  nonLinearUse arr = case (replicate 3 arr, replicate 4 arr) of+--    ((),()) -> ()+-- @+--+-- Furthermore, this API is safely implemented by mutating an underlying array+-- which is good for performance. The API is safe because linear types+-- enforce the fact that each reference to an underlying mutable array+-- (and there can be more than one by using @split@) is+-- linearly threaded through functions and at the end consumed by one of our+-- write functions.+--+-- Lastly, linear types are used to ensure that each cell in the destination+-- array is written to exactly once. This is because the only way to create and+-- use a destination array is via+--+-- @+-- alloc :: Int -> (DArray a %1-> ()) %1-> Vector a+-- @+--+-- 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)++-- | 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 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.+
+ src/Data/Array/Mutable/Linear.hs view
@@ -0,0 +1,286 @@+{-# 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+-- mutation.+--+-- To use these mutable arrays, create a linear computation of type+-- @Array a %1-> Ur b@ and feed it to 'alloc' or 'fromList'.+--+-- == A Tiny Example+--+-- >>> :set -XLinearTypes+-- >>> :set -XNoImplicitPrelude+-- >>> import Prelude.Linear+-- >>> import qualified Data.Array.Mutable.Linear as Array+-- >>> :{+--  isFirstZero :: Array.Array Int %1-> Ur Bool+--  isFirstZero arr =+--    Array.get 0 arr+--      & \(Ur val, arr') -> arr' `lseq` Ur (val == 0)+-- :}+--+-- >>> unur $ Array.fromList [0..10] isFirstZero+-- True+-- >>> unur $ Array.fromList [1,2,3] isFirstZero+-- False+module Data.Array.Mutable.Linear+  ( -- * 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.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"
+ src/Data/Array/Mutable/Unlifted/Linear.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedNewtypes #-}++-- |+-- This module provides an unlifted mutable array with a pure+-- interface. Though the array itself is unlifted, it's elements are+-- lifted types. This is made possible by using linear types to make+-- sure array references are single threaded through reads and writes.+--+-- Accessing out-of-bounds indices causes undefined behaviour.+--+-- 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++import Data.Unrestricted.Linear hiding (lseq, dup2)+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# 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 = Unsafe.toLinear2 (\_ b -> b)++-- | 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 (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++-- For the reasoning behind these NOINLINE pragmas, see the discussion at:+-- https://github.com/tweag/linear-base/pull/187#pullrequestreview-489183531++-- | Allocate a mutable array of given size using a default value,+-- using another 'Array#' as a uniqueness proof.+--+-- The size should be non-negative.+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++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  #)++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++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++-- | Copy the first mutable array into the second mutable array, starting+-- from the given index of the source array.+--+-- It copies fewer elements if the second array is smaller than the+-- first. 'n' should be within [0..size src).+--+-- @+--  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 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+            _ -> (# Array# src, Array# dst #)+{-# 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'''+{-# NOINLINE map #-}++-- | Return the array elements as a lazy list.+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++-- | /O(1)/ Convert an 'Array#' to an immutable 'GHC.Array#'.+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++-- | Clone an array.+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 #)+{-# NOINLINE dup2 #-}++-- * Internal library++-- Below two are variants of (&) specialized for taking commonly used+-- unlifted values and returning a levity-polymorphic result.+--+-- They are not polymorphic on their first parameter since levity-polymorphism+-- disallows binding to levity-polymorphic values.++chain :: forall (r :: GHC.RuntimeRep) a (b :: GHC.TYPE r).+        Array# a %1-> (Array# a %1-> b) %1-> b+chain a f = f a++chain2 :: forall (r :: GHC.RuntimeRep) a b (c :: GHC.TYPE r).+        (# b, Array# a #) %1-> ((# b, Array# a #) %1-> c) %1-> c+chain2 a f = f a+infixl 1 `chain`, `chain2`
+ src/Data/Array/Polarized.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module documents polarized arrays and top-level conversions+--+-- == What are polarized arrays and what are they good for?+--+-- Polarized arrays aim to offer an API to replace that of @Data.Vector@+-- with mechanisms to explicitly control when memory is allocated for+-- an array. The current status quo is to use some array or vector type+-- and rely on a good implementation and GHC's fusion capabilities+-- to avoid unnecessary allocations (and thus save memory and improve+-- the performance).+--+-- Polarized arrays are arrays with one of two polarities or directions: push+-- or pull. Push and pull arrays are two array types that do not allocate+-- memory with conversions to and from @Data.Vector@. The only API function+-- that allocates space for an array is @Push.alloc@. Nothing else allocates+-- memory and hence we are not relying on GHC to fuse according to a+-- particular implementation of our vector API and program.+--+-- === What is a pull array?+--+-- A pull array is one that it's easy to "pull" from and read. These arrays+-- work nicely as arguments to functions and we can fold, map, zip, and split+-- these easily.+--+-- A typical use of polarized arrays would construct a pull array to begin+-- a computation using arrays.+--+-- === What is a push array?+--+-- A push array is a finished result that we do not want to allocate just yet.+-- We can concatenate two push arrays, convert a pull array into a push array+-- (without any memory allocation), create constant push arrays and when+-- we desire allocate a push array to a @Data.Vector@:+--+-- > Push.alloc :: Push.Array a %1-> Vector a+--+-- A push array is typically created towards the end of a computation that uses+-- arrays and passed along until we are ready to allocate.+--+-- === What does using polarized arrays look like?+--+-- A typical computation would start by constructing a pull array,+-- computing over it, converting it to a push array while other computations+-- occur and then finally finishing the computation by allocating the push+-- array (or arrays).+--+-- A simple example is a one-time allocating filter on vectors:+--+-- @+-- vecfilter :: Vector a -> (a -> Bool) -> Vector a+-- vecfilter vec f = Push.alloc (transfer (loop (Pull.fromVector vec) f))+--   where+--     loop :: Pull.Array a -> (a -> Bool) -> Pull.Array a+--     loop arr f = case Pull.findLength arr of+--       (0,_) -> Pull.fromFunction (error "empty") 0+--       (n,_) -> case Pull.split 1 arr of+--         (head, tail) -> case Pull.index head 0 of+--           (a,_) ->+--             if f a+--             then Pull.append (Pull.singleton a) (loop tail f)+--             else loop tail f+-- @+--+--+-- == Aside: why do we need linear types?+--+-- To correctly represent a push array, we need a way of specifying a+-- computation that writes to and fills an array.+--+-- @+-- data Array a where+--   Array :: (forall b. (a %1-> b) -> DArray b %1-> ()) %1-> Int -> Array a+-- @+--+-- As documented with destination arrays in @Data.Array.Destination@,+-- any computation of type @DArray b %1-> ()@ must fill the array. Now,+-- 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 +-- evaluated until we are sure we want to allocate.+--+-- == Background for the interested+--+-- To understand how polarized arrays work in greater depth, these links+-- may be of some help:+--+-- * 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+  )+  where++import qualified Data.Array.Polarized.Pull.Internal as Pull+import qualified Data.Array.Polarized.Pull as Pull+import qualified Data.Array.Polarized.Push as Push+import qualified Data.Foldable as NonLinear+import Prelude.Linear+import Data.Vector (Vector)++-- DEVELOPER NOTE:+--+-- The general spirit is: `Push.Array` are those arrays which are friendly in+-- returned-value position. And `Pull.Array` are those arrays which are friendly+-- in argument position. If you have more than one array in an unfriendly+-- position, you need to allocate (allocated arrays are friendly in all+-- positions).+--+-- There are three types of array which are involved, with conversion+-- functions available between them, the third being an allocated Vector.+-- The primary conversion functions are:+-- > Polarized.transfer :: Pull.Array a %1-> Push.Array a+-- > Push.alloc :: Push.Array a %1-> Vector a+-- > Pull.fromVector :: Vector a %1-> Pull.Array a+--+-- In this way, we gain further control over exactly when allocation may occur+-- in a fusion pipeline.+-- In such a pipeline converting one allocated array to another, it would be+-- common to begin with Pull.fromVector, and end with Push.alloc.++-- | 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 f n) =+  Push.Array (\k -> NonLinear.foldMap' (\x -> k (f x)) [0..(n-1)])++-- | This is a shortcut convenience function+-- for @transfer . Pull.fromVector@.+walk :: Vector a %1-> Push.Array a+walk = transfer . Pull.fromVector
+ src/Data/Array/Polarized/Pull.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | This module provides pull arrays.+--+-- 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+    -- * Construction+  , fromFunction+  , fromVector+  , make+  , singleton+    -- * Consumption+  , toVector+  , asList+    -- * Operations+  , zip+  , zipWith+  , append+  , foldr+  , foldMap+  , findLength+  , split+  , reverse+  , index+  )+  where++import Data.Array.Polarized.Pull.Internal+-- XXX: the data constructor Pull.Array could be used unsafely, so we don't+-- export it, instead exporting a collection of functions to manipulate+-- PullArrays+-- (eg one could use an element multiple times, if the constructor was+-- available)+-- TODO: the current collection is almost certainly not complete: it would be+-- nice if there was one (or a small number) of functions which characterise+-- PullArrays, but I'm not sure what they are+-- 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 qualified Unsafe.Linear as Unsafe++-- | Convert a pull array into a list.+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 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 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 = Unsafe.toLinear $ \v -> fromFunction (v Vector.!) (Vector.length v)
+ src/Data/Array/Polarized/Pull/Internal.hs view
@@ -0,0 +1,110 @@+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PartialTypeSignatures #-}++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 qualified Unsafe.Linear as Unsafe++-- | 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+-- each element is consumed exactly once, but the length can be accessed+-- 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.++instance Data.Functor Array where+  fmap f (Array g n) = fromFunction (\x -> f (g x)) n++-- XXX: This should be well-typed without the unsafe, but it isn't accepted:+-- the pull array type probably isn't the ideal choice (making Array linear in+-- (Int -> a) would mean only one value could be taken out of the Array (which+-- 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 = 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 g n) (Array h m)+  | 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 f m) (Array g n) = Array h (m + n)+  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+make x n = fromFunction (const x) n++instance Semigroup (Array a) where+  (<>) = append++-- | A right-fold of a pull array.+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++-- | Extract the length of an array, and give back the original array.+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+-- @arrIndexer@ that goes from an array index to array values and a specified+-- 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++-- 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 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))++-- | Reverse a pull array.+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 f n) ix = (f ix, Array f n)
+ src/Data/Array/Polarized/Push.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}++-- | This module provides push arrays.+--+-- These are part of a larger framework for controlling when memory is+-- allocated for an array. See @Data.Array.Polarized@.+--+-- 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+  )+where++import qualified Data.Functor.Linear as Data+import qualified Data.Array.Destination as DArray+import Data.Array.Destination (DArray)+import Data.Vector (Vector)+import qualified Prelude+import Prelude.Linear hiding (unzip, foldMap)+import GHC.Stack+++-- The Types+-------------------------------------------------------------------------------++-- | 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.++data ArrayWriter a where+  ArrayWriter :: (DArray a %1-> ()) %1-> !Int -> ArrayWriter a+  -- The second parameter is the length of the @DArray@+++-- 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++  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@.+make :: HasCallStack => a -> Int -> Array a+make x n+  | n < 0 = error "Making a negative length push array"+  | otherwise = Array (\makeA -> mconcat $ Prelude.replicate n (makeA x))++singleton :: a -> Array a+singleton x = Array (\writeA -> writeA x)++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 x (Array k) = Array (\writeA -> (writeA x) <> (k writeA))++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))+++-- # Instances+-------------------------------------------------------------------------------++instance Data.Functor Array where+  fmap f (Array k) = Array (\g -> k (\x -> (g (f x))))++instance Prelude.Semigroup (Array a) where+  (<>) x y = append x y++instance Semigroup (Array a) where+  (<>) = append++instance Prelude.Monoid (Array a) where+  mempty = empty++instance Monoid (Array a) where+  mempty = empty++empty :: Array a+empty = Array (\_ -> mempty)++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+  (<>) x y = addWriters x y++instance Prelude.Monoid (ArrayWriter a) where+  mempty = emptyWriter++instance Semigroup (ArrayWriter a) where+  (<>) = addWriters++instance Monoid (ArrayWriter a) where+  mempty = emptyWriter++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)++emptyWriter :: ArrayWriter a+emptyWriter = ArrayWriter DArray.dropEmpty 0+-- Remark. @emptyWriter@ assumes we can split a destination array at 0.+
+ src/Data/Bifunctor/Linear.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeOperators #-}++-- | This module provides Bifunctor and related classes.+--+-- == 'Bifunctor'+--+-- Use a bifunctor instance to map functions over data structures+-- that have two type paramaters @a@ and @b@ and could be have a+-- functor instance for either the @a@s or @b@s.+-- For instance, you might want to map a function on either the left+-- or right element of a @(Int, Bool)@:+--+-- > import Prelude.Linear+-- > import Data.Bifunctor.Linear+-- >+-- > -- Map over the second element+-- > negateRight :: (Int, Bool) %1-> (Int, Bool)+-- > negateRight x = second not x+module Data.Bifunctor.Linear+  ( Bifunctor(..),+    SymmetricMonoidal(..),+  )+  where++import Data.Bifunctor.Linear.Internal.Bifunctor+import Data.Bifunctor.Linear.Internal.SymmetricMonoidal+
+ src/Data/Bifunctor/Linear/Internal/Bifunctor.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE TypeOperators #-}++module Data.Bifunctor.Linear.Internal.Bifunctor+  ( Bifunctor(..)+  ) where++import Prelude.Linear+++-- | The Bifunctor class+--+-- == Laws+--+-- If 'bimap' is supplied, then+-- @'bimap' 'id' 'id' = 'id'@+--+-- * If 'first' and 'second' are supplied, then+-- @+-- 'first' 'id' ≡ 'id'+-- 'second' 'id' ≡ 'id'+-- @+--+-- * 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+  bimap f g x = first f (second g x)+  {-# INLINE bimap #-}++  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 = 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)++instance Bifunctor Either where+  bimap f g = either (Left . f) (Right . g)+
+ src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeOperators #-}++module Data.Bifunctor.Linear.Internal.SymmetricMonoidal+  ( SymmetricMonoidal(..)+  ) where++import Data.Bifunctor.Linear.Internal.Bifunctor+import Prelude.Linear+import Data.Kind (Type)+import Data.Void+++-- | A SymmetricMonoidal class+--+-- This allows you to shuffle around a bifunctor nested in itself and swap the+-- places of the two types held in the bifunctor. For instance, for tuples:+--+--  * You can use @lassoc :: (a,(b,c)) %1-> ((a,b),c)@ and then use 'first' to access the @a@+--  * You can use the dual, i.e., @ rassoc :: ((a,b),c) %1-> (a,(b,c))@ and then 'second'+--  * You can swap the first and second values with @swap :: (a,b) %1-> (b,a)@+--+--  == Laws+--+--  * @swap . swap = id@+--  * @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+  {-# MINIMAL swap, (rassoc | lassoc) #-}+  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 = swap . rassoc . swap . rassoc . swap+  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))++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)+-- XXX: the above type signatures are necessary for certain older versions of+-- the compiler, and as such are temporary+
+ src/Data/Bool/Linear.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | This module provides linear functions on the standard 'Bool' type.+module Data.Bool.Linear+  ( -- * The Boolean type+    Bool(..)+    -- * Operators+  , (&&)+  , (||)+  , not+  , otherwise+  )+  where++import Prelude (Bool(..), otherwise)++-- | @True@ iff both are @True@.+-- __NOTE:__ this is strict and not lazy!+(&&) :: Bool %1-> Bool %1-> Bool+False && False = False+False && True = False+True && x = x++infixr 3 &&++-- | @True@ iff either is @True@+-- __NOTE:__ this is strict and not lazy!+(||) :: Bool %1-> Bool %1-> Bool+True || False = True+True || True = True+False || x = x++infixr 2 ||++-- | @not b@ is @True@ iff b is @False@+-- __NOTE:__ this is strict and not lazy!+not :: Bool %1-> Bool+not False = True+not True = False
+ src/Data/Either/Linear.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | This module contains useful functions for working with 'Either's.+module Data.Either.Linear+  ( Either (..)+  , either+  , lefts+  , rights+  , fromLeft+  , fromRight+  , partitionEithers+  )+  where++import Data.Unrestricted.Linear+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 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 [] = []+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 [] = []+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 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 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 [] = ([], [])+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)
+ src/Data/Functor/Linear.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | = The data functor hierarchy+--+-- This module defines the data functor library. Unlike in the case of+-- non-linear, unrestricted, functors, there is a split between data functors,+-- which represent containers, and control functors which represent effects.+-- Please read this+-- [blog post](https://www.tweag.io/posts/2020-01-16-data-vs-control.html).+-- For more details, see "Control.Functor.Linear".+--+-- * 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+-- containers which store a finite number of values.+--+module Data.Functor.Linear+  ( -- * Data Functor Hierarchy+    Functor(..)+  , (<$>)+  , (<$)+  , void+  , Applicative(..)+  , Const(..)+  -- * Linear traversable hierarchy+  , Traversable(..)+  , mapM, sequenceA, for, forM+  , mapAccumL, mapAccumR+  )+  where++import Data.Functor.Linear.Internal.Functor+import Data.Functor.Linear.Internal.Applicative+import Data.Functor.Linear.Internal.Traversable+import Data.Functor.Const
+ src/Data/Functor/Linear/Internal/Applicative.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Functor.Linear.Internal.Applicative+  (+    Applicative(..)+  ) 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++-- # Applicative definition+-------------------------------------------------------------------------------++-- | Data 'Applicative'-s can be seen as containers which can be zipped+-- together. A prime example of data 'Applicative' are vectors of known length+-- ('ZipList's would be, if it were not for the fact that zipping them together+-- drops values, which we are not allowed to do in a linear container).+--+-- In fact, an applicative functor is precisely a functor equipped with (pure+-- and) @liftA2 :: (a %1-> b %1-> c) -> f a %1-> f b %1-> f c@. In the case where+-- @f = []@, the signature of 'liftA2' would specialise to that of 'zipWith'.+--+-- Intuitively, the type of 'liftA2' means that 'Applicative's can be seen as+-- containers whose "number" of elements is known at compile-time. This+-- includes vectors of known length but excludes 'Maybe', since this may+-- contain either zero or one value.  Similarly, @((->) r)@ forms a Data+-- 'Applicative', since this is a (possibly infinitary) container indexed by+-- @r@, while lists do not, since they may contain any number of elements.+--+-- == Remarks for the mathematically inclined+--+-- An 'Applicative' is, as in the restricted case, a lax monoidal endofunctor of+-- the category of linear types. That is, it is equipped with+--+-- * a (linear) function @() %1-> f ()@+-- * a (linear) natural transformation @(f a, f b) %1-> f (a, b)@+--+-- It is a simple exercise to verify that these are equivalent to the definition+-- of 'Applicative'. Hence that the choice of linearity of the various arrow is+-- indeed natural.+class Functor f => Applicative f where+  {-# MINIMAL pure, (liftA2 | (<*>)) #-}+  pure :: a -> f a+  (<*>) :: f (a %1-> b) %1-> f a %1-> f b+  f <*> x = liftA2 ($) f x+  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)++instance Monoid a => Applicative ((,) a) where+  pure x = (mempty, x)+  (u,f) <*> (v,x) = (u <> v, f x)++instance Applicative Identity where+  pure = Identity+  Identity f <*> Identity x = Identity (f x)++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)++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)+
+ src/Data/Functor/Linear/Internal/Functor.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Data.Functor.Linear.Internal.Functor+  (+    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.State.Strict as Strict+import Data.Unrestricted.Internal.Consumable++-- # Functor definition+-------------------------------------------------------------------------------++-- | Linear Data Functors should be thought of as containers holding values of+-- type @a@ over which you are able to apply a linear function of type @a %1->+-- 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++(<$>) :: Functor f => (a %1-> b) -> f a %1-> f b+(<$>) = fmap++-- | 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+a <$ fb = fmap (`lseq` a) fb++-- | Discard a consumable value stored in a data functor.+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++instance Functor (Const x) where+  fmap _ (Const x) = Const x++instance Functor Maybe where+  fmap _ Nothing = Nothing+  fmap f (Just x) = Just (f x)++instance Functor (Either e) where+  fmap _ (Left x) = Left x+  fmap f (Right x) = Right (f x)++instance Functor ((,) a) where+  fmap f (x,y) = (x, f y)++instance Functor Identity where+  fmap f (Identity x) = Identity (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 x) = Compose (fmap (fmap f) x)++---------------------------------+-- Monad transformer instances --+---------------------------------++instance Functor m => Functor (NonLinear.ReaderT r m) where+  fmap f (NonLinear.ReaderT g) = NonLinear.ReaderT (\r -> fmap f (g r))++-- The below transformers are all Data.Functors and all fail to be+-- Data.Applicatives without further restriction. In every case however,+-- @pure :: a -> f a@ can be defined in the standard way.+-- For @MaybeT@ and @ExceptT e@, the failure to be applicative is as detailed+-- above: @Maybe@ and @Either e@ can contain 0 or 1 elements, and so fail+-- to be applicative.+-- To give applicative instances for ContT (resp. StateT), we require the+-- parameter r (resp. s) to be Movable.++instance Functor m => Functor (NonLinear.MaybeT m) where+  fmap f (NonLinear.MaybeT x) = NonLinear.MaybeT $ fmap (fmap f) x++instance Functor m => Functor (NonLinear.ExceptT e m) where+  fmap f (NonLinear.ExceptT x) = NonLinear.ExceptT $ fmap (fmap f) x++instance Functor (NonLinear.ContT r m) where+  fmap f (NonLinear.ContT x) = NonLinear.ContT $ \k -> x (\a -> k (f a))++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))+
+ src/Data/Functor/Linear/Internal/Traversable.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}++module Data.Functor.Linear.Internal.Traversable+  ( -- * Linear traversable hierarchy+    -- $ traversable+    Traversable(..)+  , 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 Data.Functor.Const+import Prelude.Linear.Internal+import Prelude (Maybe(..), Either(..))++-- $traversable++-- TODO: write the laws+-- TODO: maybe add a Foldable class between Functor and Traversable as well++-- | A linear data traversible is a functor of type @t a@ where you can apply a+-- linear effectful action of type @a %1-> f b@ on each value of type @a@ and+-- compose this to perform an action on the whole functor, resulting in a value+-- of type @f (t b)@.+--+-- To learn more about 'Traversable', see here:+--+--  * \"Applicative Programming with Effects\",+--    by Conor McBride and Ross Paterson,+--    /Journal of Functional Programming/ 18:1 (2008) 1-13, online at+--    <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+--  * \"The Essence of the Iterator Pattern\",+--    by Jeremy Gibbons and Bruno Oliveira,+--    in /Mathematically-Structured Functional Programming/, 2006, online at+--    <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>.+--+--  * \"An Investigation of the Laws of Traversals\",+--    by Mauro Jaskelioff and Ondrej Rypacek,+--    in /Mathematically-Structured Functional Programming/, 2012, online at+--    <http://arxiv.org/pdf/1202.2919>.+--+class Data.Functor t => Traversable t where+  {-# MINIMAL traverse | sequence #-}++  traverse :: Control.Applicative f => (a %1-> f b) -> t a %1-> f (t b)+  {-# INLINE traverse #-}+  traverse f x = sequence (Data.fmap f x)++  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 = traverse+{-# INLINE mapM #-}++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 t f = traverse f t+{-# INLINE for #-}++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 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 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)++-- | A right-to-left state transformer+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 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)+  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'')++------------------------+-- Standard instances --+------------------------++instance Traversable [] where+  traverse _f [] = Control.pure []+  traverse f (a : as) = (:) Control.<$> f a Control.<*> traverse f as++instance Traversable ((,) a) where+  sequence (a, fb) = (a,) Control.<$> fb++instance Traversable Maybe where+  sequence Nothing = Control.pure Nothing+  sequence (Just x) = Control.fmap Just x++instance Traversable (Const a) where+  sequence (Const x) = Control.pure (Const x)++instance Traversable (Either a) where+  sequence (Left x) = Control.pure (Left x)+  sequence (Right x) = Right Control.<$> x
+ src/Data/HashMap/Mutable/Linear.hs view
@@ -0,0 +1,571 @@+{-# 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 #-}++-- |+-- This module provides mutable hashmaps with a linear interface.+--+-- It is implemented with Robin Hood hashing which has amortized+-- constant time lookups and updates.+module Data.HashMap.Mutable.Linear+  ( -- * A mutable hashmap+    HashMap,+    Keyed,+    -- * Constructors+    empty,+    fromList,+    -- * Modifiers+    insert,+    insertAll,+    delete,+    filter,+    filterWithKey,+    mapMaybe,+    mapMaybeWithKey,+    shrinkToFit,+    alter,+    alterF,+    -- * Accessors+    size,+    capacity,+    lookup,+    member,+    toList,+    -- * Combining maps+    union,+    unionWith,+    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.
+ src/Data/List/Linear.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Linear versions of 'Data.List' functions.+--+-- This module only contains minimal amount of documentation; consult the+-- 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'+    -- * 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++import qualified Unsafe.Linear as Unsafe+import qualified Prelude as Prelude+import Prelude (Maybe(..), Either(..), Int)+import Prelude.Linear.Internal+import Data.Bool.Linear+import Data.Unrestricted.Linear+import Data.Functor.Linear+import Data.Monoid.Linear+import Data.Num.Linear+import Data.List.NonEmpty (NonEmpty ((:|)))+import GHC.Stack+import qualified Data.List as NonLinear+import qualified Data.Functor.Linear as Data++-- # Basic functions+--------------------------------------------------++(++) :: [a] %1-> [a] %1-> [a]+(++) = Unsafe.toLinear2 (NonLinear.++)++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 _ [] = []+filter p (x:xs) =+  dup x & \case+    (x', x'') ->+      if p x'+      then x'' : filter p xs+      else x'' `lseq` filter p xs++uncons :: [a] %1-> Maybe (a, [a])+uncons [] = Nothing+uncons (x:xs) = Just (x, xs)++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 = 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 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 _ [] = ([], [])+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 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)++-- | __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 _ [] = []+takeWhile p (x:xs) =+  dup2 x & \(x', x'') ->+    if p x'+    then x'' : takeWhile p xs+    else (x'', xs) `lseq` []++dropWhile :: Dupable a => (a %1-> Bool) -> [a] %1-> [a]+dropWhile _ [] = []+dropWhile p (x:xs) =+  dup2 x & \(x', x'') ->+    if p x'+    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 _ [] = []+take i (x:xs)+  | i Prelude.< 0 = (x, xs) `lseq` []+  | otherwise = x : take (i-1) xs++drop :: Consumable a => Int -> [a] %1-> [a]+drop _ [] = []+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 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 sep = Unsafe.toLinear (NonLinear.intercalate sep)++-- | The transpose function transposes the rows and columns of its argument.+transpose :: [[a]] %1-> [[a]]+transpose = Unsafe.toLinear NonLinear.transpose++traverse' :: Data.Applicative f => (a %1-> f b) -> [a] %1-> f [b]+traverse' _ [] = Data.pure []+traverse' f (a:as) = (:) <$> f a <*> traverse' f as++-- # Folds+--------------------------------------------------++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 f = Unsafe.toLinear (NonLinear.foldr1 (\a b -> f a 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' f = Unsafe.toLinear2 (NonLinear.foldl' (\b a -> f b 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' 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 f = foldr ((<>) . f) mempty++-- | A variant of 'foldMap' that is strict in the accumulator.+foldMap' :: Monoid m => (a %1-> m) ->  [a] %1-> m+foldMap' f = foldl' (\acc a -> acc <> f a) mempty++concat :: [[a]] %1-> [a]+concat = Unsafe.toLinear NonLinear.concat++concatMap :: (a %1-> [b]) -> [a] %1-> [b]+concatMap f = Unsafe.toLinear (NonLinear.concatMap (forget f))++sum :: AddIdentity a => [a] %1-> a+sum = foldl' (+) zero++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 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 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 = foldl' (&&) True++-- | __NOTE:__ This does not short-circuit, and always consumes the+-- entire container.+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'')++repeat :: Dupable a => a %1-> [a]+repeat = iterate id++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 _ b [] = [b]+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 _ [] = []+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'++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'++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''++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 = 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' = zipWith' (,)++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 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' _ [] [] = ([], 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)++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++unzip :: [(a, b)] %1-> ([a], [b])+unzip = Unsafe.toLinear NonLinear.unzip++unzip3 :: [(a, b, c)] %1-> ([a], [b], [c])+unzip3 = Unsafe.toLinear NonLinear.unzip3
+ src/Data/Maybe/Linear.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | This module provides linear functions on the standard 'Maybe' type.+module Data.Maybe.Linear+  ( Maybe (..)+  , maybe+  , fromMaybe+  , maybeToList+  , catMaybes+  , mapMaybe+  )+  where++import qualified Data.Functor.Linear as Linear+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 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 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 Nothing = []+maybeToList (Just a) = [a]++-- | @catMaybes xs@ discards the @Nothing@s in @xs@+-- and extracts the @a@s+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 f xs = catMaybes (Linear.fmap f xs)
+ src/Data/Monoid/Linear.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | 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+  )+  where++import Data.Monoid.Linear.Internal.Monoid+import Data.Monoid.Linear.Internal.Semigroup+
+ src/Data/Monoid/Linear/Internal/Monoid.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | This module provides linear versions of 'Monoid'.+--+-- To learn about how these classic monoids work, go to this school of haskell+-- [post](https://www.schoolofhaskell.com/user/mgsloan/monoids-tour).+module Data.Monoid.Linear.Internal.Monoid+  ( -- * Monoid operations+    Monoid(..)+  , mconcat+  )+  where++import Prelude.Linear.Internal+import Data.Monoid.Linear.Internal.Semigroup+import GHC.Types hiding (Any)+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 #-}+  mempty :: a+  mempty = Prelude.mempty+  -- convenience redefine++mconcat :: Monoid a => [a] %1-> a+mconcat (xs' :: [a]) = go mempty xs'+  where+    go :: a %1-> [a] %1-> a+    go acc [] = acc+    go acc (x:xs) = go (acc <> x) xs++---------------+-- Instances --+---------------++instance Prelude.Monoid (Endo a) where+  mempty = Endo id+instance Monoid (Endo a)++instance (Monoid a, Monoid b) => Monoid (a,b)++instance Monoid a => Monoid (Dual a)++instance Monoid Ordering where+    mempty = EQ+
+ src/Data/Monoid/Linear/Internal/Semigroup.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | This module provides a linear version of 'Semigroup'.+module Data.Monoid.Linear.Internal.Semigroup+  ( -- * Semigroup+    Semigroup(..)+    -- * Endo+  , Endo(..), appEndo+  , NonLinear(..)+  , module Data.Semigroup+  )+  where++import Prelude.Linear.Internal+import Data.Semigroup hiding (Semigroup(..), Endo(..))+import qualified Data.Semigroup as Prelude+import GHC.Types hiding (Any)++-- | 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+  () <> () = ()++-- | 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)+  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 f) = f++instance Semigroup (Endo a) where+  Endo f <> Endo g = Endo (f . g)++instance (Semigroup a, Semigroup b) => Semigroup (a,b) where+  (a,x) <> (b,y) = (a <> b, x <> y)++instance Semigroup a => Semigroup (Dual a) where+  Dual x <> Dual y = Dual (y <> x)++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+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++instance Semigroup a => Prelude.Semigroup (NonLinear a) where+  NonLinear a <> NonLinear b = NonLinear (a <> b)++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.+
+ src/Data/Num/Linear.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StandaloneDeriving #-}+++-- | This module provides a linear 'Num' class with instances.+-- Import this module to use linear versions of @(+)@, @(-)@, etc, on numeric+-- types like 'Int' and 'Double'.+--+-- == The Typeclass Hierarchy+--+-- The 'Num' class is broken up into several instances. Here is the basic+-- hierarchy:+--+-- * Additive ⊆ AddIdentity ⊆ AdditiveGroup+-- * MultIdentity ⊆ MultIdentity+-- * (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+  )+  where++-- TODO: flesh out laws+import qualified Prelude+import Data.Unrestricted.Linear+import qualified Unsafe.Linear as Unsafe+import Data.Monoid.Linear++-- | A type that can be added linearly.  The operation @(+)@ is associative and+-- commutative, i.e., for all @a@, @b@, @c@+--+-- > (a + b) + c = a + (b + c)+-- > a + b = b + c+class Additive a where+  (+) :: a %1-> a %1-> a++-- | An 'Additive' type with an identity on @(+)@.+class Additive a => AddIdentity a where+  zero :: a++-- | An 'AddIdentity' with inverses that satisfies+-- 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 x = zero - x+  (-) :: a %1-> a %1-> a+  x - y = x + negate y++-- | A numeric type with an associative @(*)@ operation+class Multiplicative a where+  (*) :: a %1-> a %1-> a++-- | A 'Multipcative' type with an identity for @(*)@+class Multiplicative a => MultIdentity a where+  one :: a++-- | A [semiring](https://en.wikipedia.org/wiki/Semiring) class. This is+-- basically a numeric type with mutliplication, addition and with identities+-- for each. The laws:+--+-- > zero * x = zero+-- > a * (b + c) = (a * b) + (a * c)+class (AddIdentity a, MultIdentity a) => Semiring a where++-- Note:+-- Having a linear (*) means we can't short-circuit multiplication by zero++-- | 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+++-- | 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+-- like commutivity of integers @x + y == y + x@, then we must have:+--+-- > fromInteger x + fromInteger y == fromInteger y + fromInteger x+--+-- For mathy folk: @fromInteger@ should be a homomorphism over @(+)@ and @(*)@.+class FromInteger a where+  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++newtype MovableNum a = MovableNum a+  deriving (Consumable, Dupable, Movable, Prelude.Num)++instance (Movable a, Prelude.Num a) => Additive (MovableNum a) where+  (+) = liftU2 (Prelude.+)++instance (Movable a, Prelude.Num a) => AddIdentity (MovableNum a) where+  zero = MovableNum 0++instance (Movable a, Prelude.Num a) => AdditiveGroup (MovableNum a) where+  (-) = liftU2 (Prelude.-)++instance (Movable a, Prelude.Num a) => Multiplicative (MovableNum a) where+  (*) = liftU2 (Prelude.*)++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) => FromInteger (MovableNum a) where+  fromInteger = Unsafe.toLinear Prelude.fromInteger++instance (Movable a, Prelude.Num a) => Num (MovableNum a) where+  abs = liftU Prelude.abs+  signum = liftU Prelude.signum++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++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++-- A newtype wrapper to give the underlying monoid for an additive structure.+newtype Adding a = Adding a+  deriving Prelude.Semigroup via NonLinear (Adding a)++getAdded :: Adding a %1-> a+getAdded (Adding x) = x++instance Additive a => Semigroup (Adding a) where+  Adding a <> Adding b = Adding (a + b)+instance AddIdentity a => Prelude.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.+newtype Multiplying a = Multiplying a+  deriving Prelude.Semigroup via NonLinear (Multiplying a)++getMultiplied :: Multiplying a %1-> a+getMultiplied (Multiplying x) = x++instance Multiplicative a => Semigroup (Multiplying a) where+  Multiplying a <> Multiplying b = Multiplying (a * b)+instance MultIdentity a => Prelude.Monoid (Multiplying a) where+  mempty = Multiplying one+instance MultIdentity a => Monoid (Multiplying a)++deriving via MovableNum Prelude.Int instance Additive Prelude.Int+deriving via MovableNum Prelude.Double instance Additive Prelude.Double+deriving via MovableNum Prelude.Int instance AddIdentity Prelude.Int+deriving via MovableNum Prelude.Double instance AddIdentity Prelude.Double+deriving via MovableNum Prelude.Int instance AdditiveGroup Prelude.Int+deriving via MovableNum Prelude.Double instance AdditiveGroup Prelude.Double+deriving via MovableNum Prelude.Int instance Multiplicative Prelude.Int+deriving via MovableNum Prelude.Double instance Multiplicative Prelude.Double+deriving via MovableNum Prelude.Int instance MultIdentity Prelude.Int+deriving via MovableNum Prelude.Double instance MultIdentity Prelude.Double+deriving via MovableNum Prelude.Int instance Semiring Prelude.Int+deriving via MovableNum Prelude.Double instance Semiring Prelude.Double+deriving via MovableNum Prelude.Int instance Ring Prelude.Int+deriving via MovableNum Prelude.Double instance Ring Prelude.Double+deriving via MovableNum Prelude.Int instance FromInteger Prelude.Int+deriving via MovableNum Prelude.Double instance FromInteger Prelude.Double+deriving via MovableNum Prelude.Int instance Num Prelude.Int+deriving via MovableNum Prelude.Double instance Num Prelude.Double
+ src/Data/Ord/Linear.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Ord.Linear+  ( 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+
+ src/Data/Ord/Linear/Internal/Eq.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | This module provides a linear 'Eq' class for testing equality between+-- values, along with standard instances.+module Data.Ord.Linear.Internal.Eq+  ( Eq(..)+  )+  where++import Data.Bool.Linear+import qualified Prelude+import Prelude.Linear.Internal+import Data.Unrestricted.Linear++-- | Testing equality on values.+--+-- The laws are that (==) and (/=) are compatible+-- and (==) is an equivalence relation. So, for all @x@, @y@, @z@,+--+-- * @x == x@ always+-- * @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+  x == y = not (x /= y)+  (/=) :: a %1-> a %1-> Bool+  x /= y = not (x == y)+  infix 4 ==, /=++-- * Instances++instance Prelude.Eq a => Eq (Ur a) where+  Ur x == Ur y = x Prelude.== y+  Ur x /= Ur y = x Prelude./= y++instance (Consumable a, Eq a) => Eq [a] where+  [] == [] = True+  (x:xs) == (y:ys) = x == y && xs == ys+  xs == ys = (xs, ys) `lseq` False++instance (Consumable a, Eq a) => Eq (Prelude.Maybe a) where+  Prelude.Nothing == Prelude.Nothing = True+  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+  Prelude.Left x == Prelude.Left y = x == y+  Prelude.Right x == Prelude.Right y = x == y+  x == y = (x, y) `lseq` False++instance (Eq a, Eq b) => Eq (a, b) where+  (a, b) == (a', b') =+    a == a' && b == b'++instance (Eq a, Eq b, Eq c) => Eq (a, b, c) where+  (a, b, c) == (a', b', c') =+    a == a' && b == b' && c == c'++instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) where+  (a, b, c, d) == (a', b', c', d') =+    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+
+ src/Data/Ord/Linear/Internal/Ord.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}++module Data.Ord.Linear.Internal.Ord+  ( Ord(..)+  , Ordering(..)+  , min+  , max+  )+  where++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++-- | Linear Orderings+--+-- Linear orderings provide a strict order. The laws for @(<=)@ for+-- all \(a,b,c\):+--+-- * reflexivity: \(a \leq a \)+-- * antisymmetry: \((a \leq b) \land (b \leq a) \rightarrow (a = b) \)+-- * transitivity: \((a \leq b) \land (b \leq c) \rightarrow (a \leq c) \)+--+-- and these \"agree\" with @<@:+--+-- * @x <= y@ = @not (y > x)@+-- * @x >= y@ = @not (y < x)@+--+-- Unlike in the non-linear setting, a linear @compare@ doesn't follow from+-- @<=@ since it requires calls: one to @<=@ and one to @==@. However,+-- from a linear @compare@ it is easy to implement the others. Hence, the+-- minimal complete definition only contains @compare@.+class Eq a => Ord a where+  {-# MINIMAL compare #-}++  -- | @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++  (<=) :: a %1-> a %1-> Bool+  x <= y = not (x > y)++  (<) :: a %1-> a %1-> Bool+  x < y = compare x y == LT++  (>) :: a %1-> a %1-> Bool+  x > y = compare x y == GT++  (>=) :: a %1-> a %1-> Bool+  x >= y = not (x < y)++  infix 4 <=, <, >, >=+++-- | @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 x y =+  dup2 x & \(x', x'') ->+    dup2 y & \(y', y'') ->+      if x' <= y'+      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 x y =+  dup2 x & \(x', x'') ->+    dup2 y & \(y', y'') ->+      if x' <= y'+      then y'' `lseq` x''+      else x'' `lseq` y''++-- * Instances++instance Prelude.Ord a => Ord (Ur a) where+  Ur x `compare` Ur y = x `Prelude.compare` y++instance (Consumable a, Ord a) => Ord (Prelude.Maybe a) where+  Prelude.Nothing `compare` Prelude.Nothing = EQ+  Prelude.Nothing `compare` Prelude.Just y = y `lseq` LT+  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+  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] #-}+  compare [] [] = EQ+  compare xs [] = xs `lseq` GT+  compare [] ys = ys `lseq` LT+  compare (x:xs) (y:ys) =+    compare x y & \case+      EQ -> compare xs ys+      res -> (xs, ys) `lseq` res++instance (Ord a, Ord b) => Ord (a, b) where+  (a, b) `compare` (a', b') =+    compare a a' <> compare b b'++instance (Ord a, Ord b, Ord c) => Ord (a, b, c) where+  (a, b, c) `compare` (a', b', c') =+    compare a a' <> compare b b' <> compare c c'++instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) where+  (a, b, c, d) `compare` (a', b', c', d') =+    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++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+
+ src/Data/Profunctor/Kleisli/Linear.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections #-}++-- | This module provides (linear) Kleisli and CoKleisli arrows+--+-- This module is meant to be imported qualified, perhaps as below.+--+-- > import qualified Data.Profunctor.Kleisli as Linear+--+-- == What are Kleisli arrows?+--+-- 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+--+-- == Why make this definition?+--+-- It let's us view @Kleisli m@ for a certain @m@ as a certain kind of+-- function arrow, give it instances, abstract over it an so on.+--+-- For instance, if @m@ is any functor, @Kleisli m@ is a @Profunctor@.+--+-- == CoKleisli+--+-- 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(..)+  )+  where++import Data.Profunctor.Linear+import Data.Void+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:+-- newtype Kleisli p m a b = Kleisli { runKleisli :: a # p -> m b }+--+-- Some instances would also still work, eg+-- instance Functor p f => Profunctor (Kleisli p f)++-- | 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 }++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)++instance Control.Applicative f => Strong Either Void (Kleisli f) where+  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+  unit = Kleisli $ \() -> Data.pure ()++instance Data.Functor f => Monoidal Either Void (Kleisli f) where+  Kleisli f *** Kleisli g = Kleisli $ \case+    Left a -> Left Data.<$> f a+    Right b -> Right Data.<$> g b+  unit = Kleisli $ \case {}++instance Control.Applicative f => Wandering (Kleisli f) where+  wander traverse (Kleisli f) = Kleisli (traverse f)++-- | Linear co-Kleisli arrows for the comonad `w`. These arrows are still+-- useful in the case where `w` is not a comonad however, and some+-- 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 }++instance Data.Functor f => Profunctor (CoKleisli f) where+  dimap f g (CoKleisli h) = CoKleisli (g . h . Data.fmap f)++instance Strong Either Void (CoKleisli (Data.Const x)) where+  first (CoKleisli f) = CoKleisli (\(Data.Const x) -> Left (f (Data.Const x)))
+ src/Data/Profunctor/Linear.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}++-- | This module provides profunctor classes and instances.+--+-- Please import this module qualified.+--+-- Some of the definitions in this module are heavily connected to and+-- motivated by linear optics. Please see @Control.Optics.Linear@ and other+-- optics modules for motivations for the definitions provided here.+--+-- == Connections to Linear Optics+--+-- * @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++import qualified Control.Functor.Linear as Control+import Data.Bifunctor.Linear hiding (first, second)+import qualified Data.Bifunctor as Prelude+import Data.Functor.Identity+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 @->@.+--+-- Hence, think of a value of type @x `arr` y@ for profunctor @arr@ to be+-- something like a function from @x@ to @y@.+--+-- Laws:+--+-- > lmap id = id+-- > 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 f g x = lmap f (rmap g x)+  {-# INLINE dimap #-}++  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 = dimap id+  {-# INLINE rmap #-}++-- | A @(Monoidal m u arr)@ is a profunctor @arr@ that can be sequenced+-- with the bifunctor @m@. In rough terms, you can combine two function-like+-- things to one function-like thing that holds both input and output types+-- 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)+  unit :: u `arr` u++-- | A @(Strong m u arr)@ instance means that the function-like thing+-- of type @a `arr` b@ can be extended to pass along a value of type @c@+-- as a constant via the bifunctor of type @m@.+--+-- This typeclass is used primarily to generalize common patterns+-- and instances that are defined when defining optics. The two uses+-- below are used in defining lenses and prisms respectively in+-- "Control.Optics.Linear.Internal":+--+-- If @m@ is the tuple+-- type constructor @(,)@ then we can create a function-like thing+-- of type @(a,c) `arr` (b,c)@ passing along @c@ as a constant.+--+-- If @m@ is @Either@ then we can create a function-like thing of type+-- @Either a c `arr` Either b c@ that either does the original function+-- or behaves like the constant function.+class (SymmetricMonoidal m u, Profunctor arr) => Strong m u arr where+  {-# MINIMAL first | second #-}++  first :: a `arr` b -> (a `m` c) `arr` (b `m` c)+  first arr = dimap swap swap (second arr)+  {-# INLINE first #-}++  second :: b `arr` c -> (a `m` b) `arr` (a `m` c)+  second arr = dimap swap swap (first arr)+  {-# INLINE second #-}++-- | A @Wandering arr@ instance means that there is a @wander@ function+-- which is the traversable generalization of the classic lens function:+--+-- > forall f. Functor f => (a -> f b) -> (s -> f t)+--+-- in our notation:+--+-- > forall arr. (HasKleisliFunctor arr) => (a `arr` b) -> (s `arr` t)+--+-- @wander@ specializes the @Functor@ constraint to a control applicative:+--+-- > forall f. Applicative f => (a -> f b) -> (s -> f t)+-- > forall arr. (HasKleisliApplicative arr) => (a `arr` b) -> (s `arr` t)+--+-- 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++---------------+-- 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 Strong (,) () LinearArrow where+  first  (LA f) = LA $ \(a,b) -> (f a, b)+  second (LA g) = LA $ \(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 Wandering LinearArrow where+  wander f (LA a_to_b) = LA $ \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 Either Void LinearArrow where+  LA f *** LA g = LA $ bimap f g+  unit = LA $ \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)+  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)+instance Profunctor (Exchange a b) where+  dimap f g (Exchange p q) = Exchange (p . f) (g . q)++instance Prelude.Functor f => Profunctor (Kleisli f) where+  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)++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)++instance Prelude.Applicative f => Monoidal (,) () (Kleisli f) where+  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+  Kleisli f *** Kleisli g = Kleisli $ \case+    Left a -> Left Prelude.<$> f a+    Right b -> Right Prelude.<$> g b+  unit = Kleisli $ \case {}++-- | 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)+runMarket (Market f g) = (f, g)++instance Profunctor (Market a b) where+  dimap f g (Market h k) = Market (g . h) (either (Left . g) Right . k . f)++instance Strong Either Void (Market a b) where+  first (Market f g) = Market (Left . f) (either (either (Left . Left) Right . g) (Left . Right))
+ src/Data/Set/Mutable/Linear.hs view
@@ -0,0 +1,106 @@+{-# 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.+--+-- The underlying implementation uses 'Data.HashMap.Linear', so it inherits+-- the time and memory characteristics of it.+--+-- Please import this module qualified to avoid name clashes.+module Data.Set.Mutable.Linear+  ( -- * Mutable Sets+    Set,+    empty,+    insert,+    delete,+    union,+    intersection,+    size,+    member,+    fromList,+    toList,+    Keyed,+  )+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)
+ src/Data/Tuple/Linear.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | This module provides linear functions commonly used on tuples++module Data.Tuple.Linear+  (+    fst+  , snd+  , swap+  , curry+  , uncurry+  )+  where++import Prelude.Linear.Internal+import Data.Unrestricted.Linear++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++swap :: (a,b) %1-> (b,a)+swap (a,b) = (b,a)
+ src/Data/Unrestricted/Internal/Consumable.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE LinearTypes #-}++module Data.Unrestricted.Internal.Consumable+  (+  -- * Consumable+    Consumable(..)+  , lseq+  , seqUnit+  )+  where++class Consumable a where+  consume :: a %1-> ()++-- | Consume the unit and return the second argument.+-- This is like 'seq' but since the first argument is restricted to be of type+-- @()@ it is consumed, hence @seqUnit@ is linear in its first argument.+seqUnit :: () %1-> b %1-> b+seqUnit () b = b++-- | Consume the first argument and return the second argument.+-- This is like 'seq' but the first argument is restricted to be 'Consumable'.+lseq :: Consumable a => a %1-> b %1-> b+lseq a b = seqUnit (consume a) b+
+ src/Data/Unrestricted/Internal/Dupable.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE GADTs #-}+module Data.Unrestricted.Internal.Dupable+  (+  -- * Dupable+    Dupable(..)+  , dup+  , dup3+  ) where++import Data.Unrestricted.Internal.Consumable+import GHC.TypeLits+import Data.Type.Equality+import Data.V.Linear.Internal.V (V)+import qualified Data.V.Linear.Internal.V as V++-- | The laws of @Dupable@ are dual to those of 'Monoid':+--+-- * @first consume (dup2 a) ≃ a ≃ second consume (dup2 a)@ (neutrality)+-- * @first dup2 (dup2 a) ≃ (second dup2 (dup2 a))@ (associativity)+--+-- Where the @(≃)@ sign represents equality up to type isomorphism.+--+-- When implementing 'Dupable' instances for composite types, using 'dupV'+-- should be more convenient since 'V' has a zipping 'Applicative' instance.+class Consumable a => Dupable a where+  {-# MINIMAL dupV | dup2 #-}++  dupV :: forall n. KnownNat n => a %1-> V n a+  dupV a =+    case V.caseNat @n of+      Prelude.Left Refl -> a `lseq` V.make @0 @a+      Prelude.Right Refl -> V.iterate dup2 a++  dup2 :: a %1-> (a, a)+  dup2 a = V.elim (dupV @a @2 a) (,)++dup3 :: Dupable a => a %1-> (a, a, a)+dup3 x = V.elim (dupV @_ @3 x) (,,)++dup :: Dupable a => a %1-> (a, a)+dup = dup2+
+ src/Data/Unrestricted/Internal/Instances.hs view
@@ -0,0 +1,241 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++-- | This module exports instances of Consumable, Dupable and Movable+--+-- We export instances in this module to avoid a circular dependence+-- and keep things clean. Movable depends on the defintion of Ur yet+-- many instances of Movable which we might have put in the module with+-- Movable depend on Ur. So, we just put the instances of Movable and the+-- other classes (for cleanness) in this module to avoid this dependence.+module Data.Unrestricted.Internal.Instances where++import Data.Unrestricted.Internal.Consumable+import Data.Unrestricted.Internal.Dupable+import Data.Unrestricted.Internal.Movable+import Data.Unrestricted.Internal.Ur+import qualified Data.Functor.Linear.Internal.Functor as Data+import qualified Data.Functor.Linear.Internal.Applicative as Data+import GHC.Types hiding (Any)+import Data.Monoid.Linear+import Data.List.NonEmpty+import qualified Prelude+import qualified Unsafe.Linear as Unsafe+import Data.V.Linear ()++instance Consumable () where+  consume () = ()++instance Dupable () where+  dupV () = Data.pure ()++instance Movable () where+  move () = Ur ()++instance Consumable Bool where+  consume True = ()+  consume False = ()++instance Dupable Bool where+  dupV True = Data.pure True+  dupV False = Data.pure False++instance Movable Bool where+  move True = Ur True+  move False = Ur False++instance Consumable Int where+  -- /!\ 'Int#' is an unboxed unlifted data-types, therefore it cannot have any+  -- linear values hidden in a closure anywhere. Therefore it is safe to call+  -- non-linear functions linearly on this type: there is no difference between+  -- copying an 'Int#' and using it several times. /!\+  consume (I# i) = Unsafe.toLinear (\_ -> ()) i++instance Dupable Int where+  -- /!\ 'Int#' is an unboxed unlifted data-types, therefore it cannot have any+  -- linear values hidden in a closure anywhere. Therefore it is safe to call+  -- non-linear functions linearly on this type: there is no difference between+  -- copying an 'Int#' and using it several times. /!\+  dupV (I# i) = Unsafe.toLinear (\j -> Data.pure (I# j)) i++instance Movable Int where+  -- /!\ 'Int#' is an unboxed unlifted data-types, therefore it cannot have any+  -- linear values hidden in a closure anywhere. Therefore it is safe to call+  -- non-linear functions linearly on this type: there is no difference between+  -- copying an 'Int#' and using it several times. /!\+  move (I# i) = Unsafe.toLinear (\j -> Ur (I# j)) i++instance Consumable Double where+  -- /!\ 'Double#' is an unboxed unlifted data-types, therefore it cannot have any+  -- linear values hidden in a closure anywhere. Therefore it is safe to call+  -- non-linear functions linearly on this type: there is no difference between+  -- copying an 'Double#' and using it several times. /!\+  consume (D# i) = Unsafe.toLinear (\_ -> ()) i++instance Dupable Double where+  -- /!\ 'Double#' is an unboxed unlifted data-types, therefore it cannot have any+  -- linear values hidden in a closure anywhere. Therefore it is safe to call+  -- non-linear functions linearly on this type: there is no difference between+  -- copying an 'Double#' and using it several times. /!\+  dupV (D# i) = Unsafe.toLinear (\j -> Data.pure (D# j)) i++instance Movable Double where+  -- /!\ 'Double#' is an unboxed unlifted data-types, therefore it cannot have any+  -- linear values hidden in a closure anywhere. Therefore it is safe to call+  -- non-linear functions linearly on this type: there is no difference between+  -- copying an 'Double#' and using it several times. /!\+  move (D# i) = Unsafe.toLinear (\j -> Ur (D# j)) i++instance Consumable Char where+  consume (C# c) = Unsafe.toLinear (\_ -> ()) c++instance Dupable Char where+  dupV (C# c) = Unsafe.toLinear (\x -> Data.pure (C# x)) c++instance Movable Char where+  move (C# c) = Unsafe.toLinear (\x -> Ur (C# x)) c++instance Consumable Ordering where+  consume LT = ()+  consume GT = ()+  consume EQ = ()++instance Dupable Ordering where+  dup2 LT = (LT, LT)+  dup2 GT = (GT, GT)+  dup2 EQ = (EQ, EQ)++instance Movable Ordering where+  move LT = Ur LT+  move GT = Ur GT+  move EQ = Ur EQ++-- TODO: instances for longer primitive tuples+-- TODO: default instances based on the Generic framework++instance (Consumable a, Consumable b) => Consumable (a, b) where+  consume (a, b) = consume a `lseq` consume b++instance (Dupable a, Dupable b) => Dupable (a, b) where+  dupV (a, b) = (,) Data.<$> dupV a Data.<*> dupV b++instance (Movable a, Movable b) => Movable (a, b) where+  move (a, b) = (,) Data.<$> move a Data.<*> move b++instance (Consumable a, Consumable b, Consumable c) => Consumable (a, b, c) where+  consume (a, b, c) = consume a `lseq` consume b `lseq` consume c++instance (Dupable a, Dupable b, Dupable c) => Dupable (a, b, c) where+  dupV (a, b, c) = (,,) Data.<$> dupV a Data.<*> dupV b Data.<*> dupV c++instance (Movable a, Movable b, Movable c) => Movable (a, b, c) where+  move (a, b, c) = (,,) Data.<$> move a Data.<*> move b Data.<*> move c++instance Consumable a => Consumable (Prelude.Maybe a) where+  consume Prelude.Nothing = ()+  consume (Prelude.Just x) = consume x++instance Dupable a => Dupable (Prelude.Maybe a) where+  dupV Prelude.Nothing = Data.pure Prelude.Nothing+  dupV (Prelude.Just x) = Data.fmap Prelude.Just (dupV x)++instance Movable a => Movable (Prelude.Maybe a) where+  move (Prelude.Nothing) = Ur Prelude.Nothing+  move (Prelude.Just x) = Data.fmap Prelude.Just (move x)++instance (Consumable a, Consumable b) => Consumable (Prelude.Either a b) where+  consume (Prelude.Left a) = consume a+  consume (Prelude.Right b) = consume b++instance (Dupable a, Dupable b) => Dupable (Prelude.Either a b) where+  dupV (Prelude.Left a) = Data.fmap Prelude.Left (dupV a)+  dupV (Prelude.Right b) = Data.fmap Prelude.Right (dupV b)++instance (Movable a, Movable b) => Movable (Prelude.Either a b) where+  move (Prelude.Left a) = Data.fmap Prelude.Left (move a)+  move (Prelude.Right b) = Data.fmap Prelude.Right (move b)++instance Consumable a => Consumable [a] where+  consume [] = ()+  consume (a:l) = consume a `lseq` consume l++instance Dupable a => Dupable [a] where+  dupV [] = Data.pure []+  dupV (a:l) = (:) Data.<$> dupV a Data.<*> dupV l++instance Movable a => Movable [a] where+  move [] = Ur []+  move (a:l) = (:) Data.<$> move a Data.<*> move l++instance Consumable a => Consumable (NonEmpty a) where+  consume (x :| xs) = consume x `lseq` consume xs++instance Dupable a => Dupable (NonEmpty a) where+  dupV (x :| xs) = (:|) Data.<$> dupV x Data.<*> dupV xs++instance Movable a => Movable (NonEmpty a) where+  move (x :| xs) = (:|) Data.<$> move x Data.<*> move xs++instance Consumable (Ur a) where+  consume (Ur _) = ()++instance Dupable (Ur a) where+  dupV (Ur a) = Data.pure (Ur a)++instance Movable (Ur a) where+  move (Ur a) = Ur (Ur a)++instance Prelude.Functor Ur where+  fmap f (Ur a) = Ur (f a)++instance Prelude.Applicative Ur where+  pure = Ur+  Ur f <*> Ur x = Ur (f x)++instance Data.Functor Ur where+  fmap f (Ur a) = Ur (f a)++instance Data.Applicative Ur where+  pure = Ur+  Ur f <*> Ur x = Ur (f x)++instance Prelude.Foldable Ur where+  foldMap f (Ur x) = f x++instance Prelude.Traversable Ur where+  sequenceA (Ur x) = Prelude.fmap Ur x++-- Some stock instances+deriving instance Consumable a => Consumable (Sum a)+deriving instance Dupable a => Dupable (Sum a)+deriving instance Movable a => Movable (Sum a)+deriving instance Consumable a => Consumable (Product a)+deriving instance Dupable a => Dupable (Product a)+deriving instance Movable a => Movable (Product a)+deriving instance Consumable All+deriving instance Dupable All+deriving instance Movable All+deriving instance Consumable Any+deriving instance Dupable Any+deriving instance Movable Any++newtype MovableMonoid a = MovableMonoid a+  deriving (Prelude.Semigroup, Prelude.Monoid)++instance (Movable a, Prelude.Semigroup a) => Semigroup (MovableMonoid a) where+  MovableMonoid a <> MovableMonoid b = MovableMonoid (combine (move a) (move b))+    where combine :: Prelude.Semigroup a => Ur a %1-> Ur a %1-> a+          combine (Ur x) (Ur y) = x Prelude.<> y+instance (Movable a, Prelude.Monoid a) => Monoid (MovableMonoid a)+
+ src/Data/Unrestricted/Internal/Movable.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE LinearTypes #-}+module Data.Unrestricted.Internal.Movable+  (+  -- * Movable+    Movable(..)+  ) where++import Data.Unrestricted.Internal.Ur+import Data.Unrestricted.Internal.Dupable++-- | Use @'Movable' a@ to represent a type which can be used many times even+-- when given linearly. Simple data types such as 'Bool' or @[]@ are 'Movable'.+-- Though, bear in mind that this typically induces a deep copy of the value.+--+-- Formally, @'Movable' a@ is the class of+-- [coalgebras](https://ncatlab.org/nlab/show/coalgebra+over+a+comonad) of the+-- 'Ur' comonad. That is+--+-- * @unur (move x) = x@+-- * @move \@(Ur a) (move \@a x) = fmap (move \@a) $ move \@a x  +--+-- Additionally, a 'Movable' instance must be compatible with its 'Dupable' parent instance. That is:+--+-- * @case move x of {Ur _ -> ()} = consume x@+-- * @case move x of {Ur x -> (x, x)} = dup2 x@+class Dupable a => Movable a where+  move :: a %1-> Ur a+
+ src/Data/Unrestricted/Internal/Ur.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE GADTs #-}++module Data.Unrestricted.Internal.Ur+  (+    Ur(..)+  , unur+  , lift+  , lift2+  ) where++-- | @Ur a@ represents unrestricted values of type @a@ in a linear+-- context. The key idea is that because the contructor holds @a@ with a+-- regular arrow, a function that uses @Ur a@ linearly can use @a@+-- however it likes.+-- > someLinear :: Ur a %1-> (a,a)+-- > someLinear (Ur a) = (a,a)+data Ur a where+  Ur :: a -> Ur a++-- | Get an @a@ out of an @Ur a@. If you call this function on a+-- linearly bound @Ur a@, then the @a@ you get out has to be used+-- linearly, for example:+--+-- > restricted :: Ur a %1-> b+-- > restricted x = f (unur x)+-- >   where+-- >     -- f __must__ be linear+-- >     f :: a %1-> b+-- >     f x = ...+unur :: Ur a %1-> a+unur (Ur a) = a++-- | Lifts a function on a linear @Ur a@.+lift :: (a -> b) -> Ur a %1-> Ur b+lift f (Ur a) = Ur (f a)++-- | Lifts a function to work on two linear @Ur a@.+lift2 :: (a -> b -> c) -> Ur a %1-> Ur b %1-> Ur c+lift2 f (Ur a) (Ur b) = Ur (f a b)+
+ src/Data/Unrestricted/Linear.hs view
@@ -0,0 +1,80 @@+-- | This module provides essential tools for doing non-linear things+-- in linear code.+--+-- = /Critical/ Definition: Restricted+--+-- In a linear function @f :: a %1-> b@, the argument @a@ must+-- be used in a linear way. Its use is __restricted__ while+-- an argument in a non-linear function is __unrestricted__.+--+-- Hence, a linear function with an argument of @Ur a@ (@Ur@ is short for+-- /unrestricted/) can use the @a@ in an unrestricted way. That is, we have+-- the following equivalence:+--+-- @+-- (Ur a %1-> b) ≌ (a -> b)+-- @+--+-- = Consumable, Dupable, Moveable classes+--+-- Use these classes to perform some non-linear action on linearly bound values.+--+-- If a type is 'Consumable', you can __consume__ it in a linear function that+-- doesn't need that value to produce it's result:+--+-- > first :: Consumable b => (a,b) %1-> a+-- > first (a,b) = withConsume (consume b) a+-- >   where+-- >     withConsume :: () %1-> a %1-> a+-- >     withConsume () x = x+--+-- If a type is 'Dupable', you can __duplicate__ it as much as you like.+--+-- > -- checkIndex ix size_of_array+-- > checkIndex :: Int %1-> Int %1-> Bool+-- > checkIndex ix size = withDuplicate (dup2 ix) size+-- >   where+-- >     withDuplicate :: (Int, Int) %1-> Int %1-> Bool+-- >     withDuplicate (ix,ix') size = (0 <= ix) && (ix < size)+-- >     (<) :: Int %1-> Int %1-> Bool+-- >     (<) = ...+-- >+-- >     (<=) :: Int %1-> Int %1-> Bool+-- >     (<=) = ...+-- >+-- >     (&&) :: Bool %1-> Bool %1-> Bool+-- >     (&&) = ...+--+-- If a type is 'Moveable', you can __move__ it inside 'Ur'+-- and use it in any non-linear way you would like.+--+-- > diverge :: Int %1-> Bool+-- > diverge ix = fromMove (move ix)+-- >   where+-- >     fromMove :: Ur Int %1-> Bool+-- >     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++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+
+ src/Data/V/Linear.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -Wno-dodgy-exports #-}+{-# 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+-- operations (like zip) are not total with linear types.+--+-- Make these vectors by giving any finite number of arguments to 'make'+-- and use them with 'elim':+--+-- >>> :set -XLinearTypes+-- >>> :set -XTypeApplications+-- >>> :set -XTypeInType+-- >>> :set -XTypeFamilies+-- >>> import Prelude.Linear+-- >>> import qualified Data.V.Linear as V+-- >>> :{+--  doSomething :: Int %1-> Int %1-> Bool+--  doSomething x y = x + y > 0+-- :}+--+-- >>> :{+--  isTrue :: Bool+--  isTrue = V.elim (build 4 9) doSomething+--    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+-- :}+--+-- A much more expensive library of vectors of known size (including matrices+-- and tensors of all dimensions) is the [@linear@ library on+-- Hackage](https://hackage.haskell.org/package/linear) (that's /linear/ in the+-- 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++import Data.V.Linear.Internal.V+import Data.V.Linear.Internal.Instances ()++{- Developers Note++To avoid a common circular dependence, we moved the data type to+Data.V.Internal.Linear.V and moved the instances here. The common import issue+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+type defintion in Data.V.Linear.V and does not require any of the dependencies+of the instances.++Remark: ideally the instances below would be in an internal `Instances`+module. But we haven't got around to it yet.+-}+
+ src/Data/V/Linear/Internal/Instances.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | 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.Traversable as Data+import GHC.TypeLits+import qualified Data.Vector as Vector+++-- # Instances of V+-------------------------------------------------------------------------------++instance Data.Functor (V n) where+  fmap f (V xs) = V $ Unsafe.toLinear (Vector.map (\x -> f x)) xs++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++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)+
+ src/Data/V/Linear/Internal/V.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+module Data.V.Linear.Internal.V+  ( V(..)+  , FunN+  , theLength+  , elim+  , make+  , iterate+  -- * Type-level utilities+  , caseNat+  ) where++import Data.Kind (Type)+import Data.Proxy+import Data.Type.Equality+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import GHC.Exts (Constraint, proxy#)+import GHC.TypeLits+import Prelude+  ( Eq+  , Ord+  , Int+  , Bool(..)+  , Either(..)+  , Maybe(..)+  , fromIntegral+  , error+  , (-))+import qualified Prelude as Prelude+import Prelude.Linear.Internal+import qualified Unsafe.Linear as Unsafe++{- Developers Note++See the "Developers Note" in Data.V.Linear for an explanation of this module+structure.++-}++-- # Type Definitions+-------------------------------------------------------------------------------++newtype V (n :: Nat) (a :: Type) = V (Vector a)+  deriving (Eq, Ord, Prelude.Functor)+  -- Using vector rather than, say, 'Array' (or directly 'Array#') because it+  -- offers many convenience function. Since all these unsafeCoerces probably+  -- kill the fusion rules, it may be worth it going lower level since I+  -- probably have to write my own fusion anyway. Therefore, starting from+  -- Vectors at the moment.++type family FunN (n :: Nat) (a :: Type) (b :: Type) :: Type where+  FunN 0 a b = b+  FunN n a b = a %1-> FunN (n-1) a b++-- # API+-------------------------------------------------------------------------------++theLength :: forall n. KnownNat n => Int+theLength = fromIntegral (natVal' @n (proxy# @_))++split :: 1 <= n => V n a %1-> (# a, V (n-1) a #)+split = Unsafe.toLinear split'+  where+    split' :: 1 <= n => V n a -> (# a, V (n-1) a #)+    split' (V xs) = (# Vector.head xs, V (Vector.tail xs) #)++consumeV :: V 0 a %1-> b %1-> b+consumeV = Unsafe.toLinear (\_ -> id)++unsafeZero :: n :~: 0+unsafeZero = Unsafe.coerce Refl++unsafeNonZero :: (1 <=? n) :~: 'True+unsafeNonZero = Unsafe.coerce Refl++-- Same as in the constraints library, but it's just as easy to avoid a+-- dependency here.+data Dict (c :: Constraint) where+  Dict :: c => Dict c++predNat :: forall n. (1 <= n, KnownNat n) => Dict (KnownNat (n-1))+predNat = case someNatVal (natVal' @n (proxy# @_) - 1) of+  Just (SomeNat (_ :: Proxy p)) -> Unsafe.coerce (Dict @(KnownNat p))+  Nothing -> error "Vector.pred: n-1 is necessarily a Nat, if 1<=n"++caseNat :: forall n. KnownNat n => Either (n :~: 0) ((1 <=? n) :~: 'True)+caseNat =+  case theLength @n of+    0 -> Left $ unsafeZero @n+    _ -> Right $ unsafeNonZero @n+{-# INLINE caseNat #-}++-- By definition.+expandFunN :: forall n a b. (1 <= n) => FunN n a b %1-> a %1-> FunN (n-1) a b+expandFunN k = Unsafe.coerce k++-- By definition.+contractFunN :: (1 <= n) => (a %1-> FunN (n-1) a b) %1-> FunN n a b+contractFunN k = Unsafe.coerce k++-- TODO: consider using template haskell to make this expression more efficient.+-- | This is like pattern-matching on a n-tuple. It will eventually be+-- polymorphic the same way as a case expression.+elim :: forall n a b. KnownNat n => V n a %1-> FunN n a b %1-> b+elim xs f =+  case caseNat @n of+    Left Refl -> consumeV xs f+    Right Refl -> elimS (split xs) f+  where+    elimS :: 1 <= n => (# a, V (n-1) a #) %1-> FunN n a b %1-> b+    elimS (# x, xs' #) g = case predNat @n of+      Dict -> elim xs' (expandFunN @n @a @b g x)++-- XXX: This can probably be improved a lot.+make :: forall n a. KnownNat n => FunN n a (V n a)+make = case caseNat @n of+          Left Refl -> V Vector.empty+          Right Refl -> contractFunN @n @a @(V n a) prepend+            where prepend :: a %1-> FunN (n-1) a (V n a)+                  prepend t = case predNat @n of+                                Dict -> continue @(n-1) @a @(V (n-1) a) (cons t) (make @(n-1) @a)++cons :: forall n a. a %1-> V (n-1) a %1-> V n a+cons = Unsafe.toLinear2 $ \x (V v) -> V (Vector.cons x v)++continue :: forall n a b c. KnownNat n => (b %1-> c) %1-> FunN n a b %1-> FunN n a c+continue = case caseNat @n of+             Left Refl -> id+             Right Refl -> \f t -> contractFunN @n @a @c (continueS f (expandFunN @n @a @b t))+               where continueS :: (KnownNat n, 1 <= n) => (b %1-> c) %1-> (a %1-> FunN (n-1) a b) %1-> (a %1-> FunN (n-1) a c)+                     continueS f' x a = case predNat @n of Dict -> continue @(n-1) @a @b f' (x a)++iterate :: forall n a. (KnownNat n, 1 <= n) => (a %1-> (a, a)) -> a %1-> V n a+iterate dup init =+  go @n init+ where+  go :: forall m. (KnownNat m, 1 <= m) => a %1-> V m a+  go a =+    case predNat @m of+      Dict -> case caseNat @(m-1) of+        Prelude.Left Refl ->+          case pr1 @m Refl of+            Refl ->+              (make @m @a :: a %1-> V m a) a+        Prelude.Right Refl ->+          dup a & \(a', a'') ->+            a' `cons` go @(m-1) a''++  -- An unsafe cast to prove the simple equality.+  pr1 :: forall k. 0 :~: (k - 1) -> k :~: 1+  pr1 Refl = Unsafe.coerce Refl+
+ src/Data/Vector/Mutable/Linear.hs view
@@ -0,0 +1,375 @@+{-# 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.+--+-- Vectors are arrays that grow automatically, that you can append to with+-- 'push'. They never shrink automatically to reduce unnecessary copying,+-- use 'shrinkToFit' to get rid of the wasted space.+--+-- To use mutable vectors, create a linear computation of type+-- @Vector a %1-> Ur b@ and feed it to 'constant' or 'fromList'.+--+-- == Example+--+-- >>> :set -XLinearTypes+-- >>> import Prelude.Linear+-- >>> import qualified Data.Vector.Mutable.Linear as Vector+-- >>> :{+--  isFirstZero :: Vector.Vector Int %1-> Ur Bool+--  isFirstZero vec =+--    Vector.get 0 vec+--      & \(Ur ret, vec) -> vec `lseq` Ur (ret == 0)+-- :}+--+-- >>> unur $ Vector.fromList [0..10] isFirstZero+-- True+-- >>> unur $ Vector.fromList [1,2,3] isFirstZero+-- False+module Data.Vector.Mutable.Linear+  ( -- * A mutable vector+    Vector,+    -- * Run a computation with a vector+    empty,+    constant,+    fromList,+    -- * Mutators+    set,+    unsafeSet,+    modify,+    modify_,+    push,+    pop,+    filter,+    mapMaybe,+    slice,+    shrinkToFit,+    -- * Accessors+    get,+    unsafeGet,+    size,+    capacity,+    toList,+    freeze,+    -- * Mutable-style interface+    read,+    unsafeRead,+    write,+    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"
+ src/Debug/Trace/Linear.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- |+-- A thin wrapper on top of "Debug.Trace", providing linear versions of+-- tracing functions.+--+-- It only contains minimal amount of documentation; you should consult+-- the original "Debug.Trace" module for more detailed information.+module Debug.Trace.Linear+  ( -- * Tracing+    trace+  , traceShow+  , traceId+  , traceStack+  , traceIO+  , traceM+  , traceShowM+    -- * Eventlog tracing+  , traceEvent+  , traceEventIO+    -- * Execution phase markers+  , 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 Prelude.Linear.Internal++-- | 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 = 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 a = Unsafe.toLinear (NonLinear.traceShow a)++-- | Like 'trace' but returns the message instead of a third value.+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 = 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 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 s = trace s $ pure ()++-- | Like 'traceM', but uses 'show' on the argument to convert it to a+-- 'String'.+traceShowM :: (Show a, Applicative f) => a -> f ()+traceShowM a = traceM (show a)++-- | 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 = 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 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 = 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 s = fromSystemIO (Unsafe.toLinear NonLinear.traceMarkerIO s)
+ src/Foreign/Marshal/Pure.hs view
@@ -0,0 +1,438 @@+{-# 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/.+-- (Basically, a haskell program has a GC that at runtime, manages its own heap+-- by freeing and allocating space from the system heap.) Values discarded+-- explicitly don't need to be managed by the garbage collector (GC), which+-- therefore has less work to do. Less work for the GC can sometimes mean more+-- predictable request latencies in multi-threaded and distributed+-- applications.+--+-- This module is meant to be imported qualified.+--+-- == The Interface+--+-- Run a computation that uses heap memory by passing a continuation to+-- 'withPool' of type @Pool %1-> Ur b@. Allocate and free with+-- 'alloc' and 'deconstruct'. Make as many or as few pools you need, by+-- using the 'Dupable' and 'Consumable' instances of  'Pool'.+--+-- A toy example:+--+-- >>> :set -XLinearTypes+-- >>> import Data.Unrestricted.Linear+-- >>> import qualified Foreign.Marshal.Pure as Manual+-- >>> :{+--   nothingWith3 :: Pool %1-> Ur Int+--   nothingWith3 pool = move (Manual.deconstruct (Manual.alloc 3 pool))+-- :}+--+-- >>> unur (Manual.withPool nothingWith3)+-- 3+--+--+-- === What are 'Pool's?+--+-- 'Pool's are memory pools from which a user can safely allocate and use+-- heap memory manually by passing 'withPool' a continuation.+-- An alternative design would have allowed passing continuations to+-- allocation functions but this could break tail-recursion in certain cases.+--+-- Pools play another role: resilience to exceptions. If an exception is raised,+-- all the data in the pool is deallocated.+--+-- Note that data from one pool can refer to data in another pool and vice+-- versa.+--+-- == Large Examples+--+-- You can find example data structure implementations in @Foreign.List@ and+-- @Foreign.Heap@ [here](https://github.com/tweag/linear-base/tree/master/examples/Foreign).++module Foreign.Marshal.Pure+  (+  -- * Allocating and using values on the heap+    Pool+  , withPool+  , Box+  , alloc+  , deconstruct+  -- * Typeclasses for values that can be allocated+  , KnownRepresentable+  , Representable(..)+  , MkRepresentable(..)+  ) where++import Control.Exception+import qualified Data.Functor.Linear as Data+import Data.Kind (Constraint, Type)+import Data.Word (Word8)+import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import Foreign.Storable.Tuple ()+import Prelude (($), return, (<*>), Eq(..), (<$>), (=<<))+import Prelude.Linear hiding (($), Eq(..))+import System.IO.Unsafe+import qualified Unsafe.Linear as Unsafe++-- XXX: [2018-02-09] I'm having trouble with the `constraints` package (it seems+-- that the version of Type.Reflection.Unsafe in the linear ghc compiler is not+-- the one that was released with 8.2, and that `mtl` fails to compile against+-- it), therefore, I'm redefining `Dict` here, as it's cheap.+data Dict :: Constraint -> Type where+  Dict :: c => Dict c++-- TODO: organise into sections++-- | This abstract type class represents values natively known to have a GC-less+-- implementation. Basically, these are sequences (represented as tuples) of+-- base types.+class KnownRepresentable a where+  storable :: Dict (Storable a)++  default storable :: Storable a => Dict (Storable a)+  storable = Dict+  -- This ought to be read a `newtype` around `Storable`. This type is abstract,+  -- because using Storable this way is highly unsafe: Storable uses IO so we+  -- will call unsafePerformIO, and Storable doesn't guarantee linearity. But+  -- Storable comes with a lot of machinery, in particular for+  -- architecture-independent alignment. So we can depend on it.+  --+  -- So, we restrict ourselves to known instances that we trust. For base types+  -- there is no reason to expect problems. Tuples are a bit more subtle in that+  -- they use non-linear operations. But the way they are used should be ok. At+  -- any rate: in case a bug is found, the tuple instances are a good place to+  -- look.++instance KnownRepresentable Word -- TODO: more word types+instance KnownRepresentable Int+instance KnownRepresentable (Ptr a)+instance KnownRepresentable ()+instance+  (KnownRepresentable a, KnownRepresentable b)+  => KnownRepresentable (a, b) where+  storable =+    case (storable @a, storable @b) of+      (Dict, Dict) -> Dict+instance+  (KnownRepresentable a, KnownRepresentable b, KnownRepresentable c)+  => KnownRepresentable (a, b, c) where+  storable =+    case (storable @a, storable @b, storable @c) of+      (Dict, Dict, Dict) -> Dict++-- TODO: move to the definition of Ur+instance Storable a => Storable (Ur a) where+  sizeOf _ = sizeOf (undefined :: a)+  alignment _ = alignment (undefined :: a)+  peek ptr = Ur <$> peek (castPtr ptr :: Ptr a)+  poke ptr (Ur a) = poke (castPtr ptr :: Ptr a) a++instance KnownRepresentable a => KnownRepresentable (Ur a) where+  storable | Dict <- storable @a = Dict++-- Below is a KnownRepresentable instance for Maybe. The Storable instance is+-- taken from+-- https://www.schoolofhaskell.com/user/snoyberg/random-code-snippets/storable-instance-of-maybe+--+-- aspiwack: This does not yield very good data representation for the general+-- case. But I believe that to improve on it we need to rethink the abstraction+-- in more depths.++instance Storable a => Storable (Maybe a) where+  sizeOf x = sizeOf (stripMaybe x) + 1+  alignment x = alignment (stripMaybe x)+  peek ptr = do+      filled <- peekByteOff ptr $ sizeOf $ stripMaybe $ stripPtr ptr+      case filled == (1 :: Word8) of+        True -> do+          x <- peek (stripMaybePtr ptr)+          return (Just x)+        False ->+          return Nothing+  poke ptr Nothing = pokeByteOff ptr (sizeOf $ stripMaybe $ stripPtr ptr) (0 :: Word8)+  poke ptr (Just a) = do+      poke (stripMaybePtr ptr) a+      pokeByteOff ptr (sizeOf a) (1 :: Word8)++stripMaybe :: Maybe a -> a+stripMaybe _ = error "stripMaybe"++stripMaybePtr :: Ptr (Maybe a) -> Ptr a+stripMaybePtr = castPtr++stripPtr :: Ptr a -> a+stripPtr _ = error "stripPtr"++instance KnownRepresentable a => KnownRepresentable (Maybe a) where+  storable | Dict <- storable @a = Dict++-- | Laws of 'Representable':+--+-- * 'toKnown' must be total+-- * 'ofKnown' may be partial, but must be total on the image of 'toKnown'+-- * @ofKnown . toKnown == id@+class (KnownRepresentable (AsKnown a)) => Representable a where+  type AsKnown a :: Type++  toKnown :: a %1-> AsKnown a+  ofKnown :: AsKnown a %1-> a++  default toKnown+    :: (MkRepresentable a b, AsKnown a ~ AsKnown b) => a %1-> AsKnown a+  default ofKnown+    :: (MkRepresentable a b, AsKnown a ~ AsKnown b) => AsKnown a %1-> a++  toKnown a = toKnown (toRepr a)+  ofKnown b = ofRepr (ofKnown b)++-- Some boilerplate: all the KnownRepresentable are Representable, by virtue of+-- the identity being a retraction. We generalise a bit for the types of tuples:+-- tuples of Representable (not only KnownRepresentable) are Representable.+instance Representable Word where+  type AsKnown Word = Word+  toKnown = id+  ofKnown = id+instance Representable Int where+  type AsKnown Int = Int+  toKnown = id+  ofKnown = id+instance Representable (Ptr a) where+  type AsKnown (Ptr a) = Ptr a+  toKnown = id+  ofKnown = id+instance Representable () where+  type AsKnown () = ()+  toKnown = id+  ofKnown = id+instance+  (Representable a, Representable b)+  => Representable (a, b) where+  type AsKnown (a, b) = (AsKnown a, AsKnown b)+  toKnown (a, b) = (toKnown a, toKnown b)+  ofKnown (x, y) = (ofKnown x, ofKnown y)++instance+  (Representable a, Representable b, Representable c)+  => Representable (a, b, c) where+  type AsKnown (a, b, c) = (AsKnown a, AsKnown b, AsKnown c)+  toKnown (a, b, c) = (toKnown a, toKnown b, toKnown c)+  ofKnown (x, y, z) = (ofKnown x, ofKnown y, ofKnown z)++instance Representable a => Representable (Maybe a) where+  type AsKnown (Maybe a) = Maybe (AsKnown a)+  toKnown (Just x) = Just (toKnown x)+  toKnown Nothing  = Nothing+  ofKnown (Just x) = Just (ofKnown x)+  ofKnown Nothing  = Nothing++-- | This is an easier way to create an instance of 'Representable'. It is a bit+-- abusive to use a type class for this (after all, it almost never makes sense+-- to use this as a constraint). But it works in practice.+--+-- To use, define an instance of @MkRepresentable <myType> <intermediateType>@+-- then declare the following instance:+--+-- @instance Representable <myType> where {type AsKnown = AsKnown <intermediateType>}@+--+-- And the default instance mechanism will create the appropriate+-- 'Representable' instance.+--+-- Laws of 'MkRepresentable':+--+-- * 'toRepr' must be total+-- * 'ofRepr' may be partial, but must be total on the image of 'toRepr'+-- * @ofRepr . toRepr = id@+class Representable b => MkRepresentable a b | a -> b where+  toRepr :: a %1-> b+  ofRepr :: b %1-> a+++-- TODO: Briefly explain the Dupable-reader style of API, below, and fix+-- details.++-- | Pools represent collections of values. A 'Pool' can be 'consume'-ed. This+-- is a no-op: it does not deallocate the data in that pool. It cannot do so,+-- because accessible values might still exist. Consuming a pool simply makes it+-- impossible to add new data to the pool.+data Pool where+  Pool :: DLL (Ptr ()) -> Pool+  -- /!\ Black magic: the pointers in the pool are only used to deallocate+  -- dangling pointers. Therefore their 'sizeOf' does not matter. It is simpler+  -- to cast all the pointers to some canonical type (here `Ptr ()`) so that we+  -- don't have to deal with heterogeneous types. /!\++-- Implementing a doubly-linked list with `Ptr`++data DLL a = DLL { prev :: Ptr (DLL a), elt :: Ptr a, next :: Ptr (DLL a) }+  deriving Eq++-- XXX: probably replaceable by storable-generic+instance Storable (DLL a) where+  sizeOf _ = sizeOf (undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))+  alignment _ = alignment (undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a)))++  peek ptr = do+    (p, e, n) <- peek (castPtr ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a)))+    return $ DLL p e n++  poke ptr (DLL p e n) =+    poke (castPtr ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))) (p, e, n)++-- Precondition: in `insertAfter start ptr`, `next start` must be initalised,+-- and so must be `prev =<< peek (next start)`+insertAfter :: Storable a => DLL a -> a -> IO (Ptr (DLL a))+insertAfter start ptr = do+  secondLink <- peek $ next start+  newLink <- DLL <$> new start <*> new ptr <*> new secondLink+  poke (next start) newLink+  poke (prev secondLink) newLink+  new newLink++delete :: DLL a -> IO ()+delete link = do+  prevLink <- peek $ prev link+  nextLink <- peek $ next link+  poke (next prevLink) nextLink+  poke (prev nextLink) prevLink++-- /Doubly-linked list++-- @freeAll start end@ frees all pointer in the linked list. Assumes that @end@+-- doesn't have a pointer, and indeed terminates the list.+--+freeAll :: DLL (Ptr ()) -> DLL (Ptr ()) -> IO ()+freeAll start end = do+  nextLink <- peek (next start)+  if nextLink == end then do+    free (next start)+    free (prev end)+  else do+    delete nextLink+    free (prev nextLink)+    free (elt nextLink)+    free (next nextLink)+    freeAll start end++-- TODO: document individual functions++-- | Given a linear computation that manages memory, run that computation.+withPool :: (Pool %1-> Ur b) %1-> Ur b+withPool scope = Unsafe.toLinear performScope scope+    -- XXX: do ^ without `toLinear` by using linear IO+  where+    performScope :: (Pool %1-> Ur b) -> Ur b+    performScope scope' = unsafeDupablePerformIO $ do+      -- Initialise the pool+      backPtr <- malloc+      let end = DLL backPtr nullPtr nullPtr -- always at the end of the list+      start <- DLL nullPtr nullPtr <$> new end -- always at the start of the list+      poke backPtr start+      -- Run the computation+      evaluate (scope' (Pool start)) `finally`+      -- Clean up remaining variables.+        (freeAll start end)++instance Consumable Pool where+  consume (Pool _) = ()++instance Dupable Pool where+  dupV (Pool l) = Data.pure (Pool l)++-- | 'Box a' is the abstract type of manually managed data. It can be used as+-- part of data type definitions in order to store linked data structure off+-- heap. See @Foreign.List@ and @Foreign.Pair@ in the @examples@ directory of+-- the source repository.+data Box a where+  Box :: Ptr (DLL (Ptr ())) -> Ptr a -> Box a++-- XXX: if Box is a newtype, can be derived+instance Storable (Box a) where+  sizeOf _ = sizeOf (undefined :: (Ptr (DLL (Ptr ())), Ptr a))+  alignment _ = alignment (undefined :: (Ptr (DLL (Ptr ())), Ptr a))+  peek ptr = do+    (pool, ptr') <- peek (castPtr ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a))+    return (Box pool ptr')+  poke ptr (Box pool ptr') =+    poke (castPtr ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a)) (pool, ptr')++instance KnownRepresentable (Box a) where+instance Representable (Box a) where+  type AsKnown (Box a) = Box a+  ofKnown = id+  toKnown = id++-- TODO: a way to store GC'd data using a StablePtr++-- TODO: reference counted pointer. Remarks: rc pointers are Dupable but not+-- Movable. In order to be useful, need some kind of borrowing on the values, I+-- guess. 'Box' can be realloced, but not RC pointers.++reprPoke :: forall a. Representable a => Ptr a -> a %1-> IO ()+reprPoke ptr a | Dict <- storable @(AsKnown a) =+  Unsafe.toLinear (poke (castPtr ptr :: Ptr (AsKnown a))) (toKnown a)++reprNew :: forall a. Representable a => a %1-> IO (Ptr a)+reprNew a =+    Unsafe.toLinear mkPtr a+  where+    -- XXX: should be improved by using linear IO+    mkPtr :: a -> IO (Ptr a)+    mkPtr a' | Dict <- storable @(AsKnown a) =+      do+        ptr0 <- malloc @(AsKnown a)+        let ptr = castPtr ptr0 :: Ptr a+        reprPoke ptr a'+        return ptr++-- TODO: Ideally, we would like to avoid having a boxed representation of the+-- data before a pointer is created. A better solution is to have a destination+-- passing-style API (but there is still some design to be done there). This+-- alloc primitive would then be derived (but most of the time we would rather+-- write bespoke constructors).+-- | Store a value @a@ on the system heap that is not managed by the GC.+alloc :: forall a. Representable a => a %1-> Pool %1-> Box a+alloc a (Pool pool) =+    Unsafe.toLinear mkPtr a+  where+    -- XXX: should be improved by using linear IO+    mkPtr :: a -> Box a+    mkPtr a' = unsafeDupablePerformIO $ do+      ptr <- reprNew a'+      poolPtr <- insertAfter pool (castPtr ptr :: Ptr ())+      return (Box poolPtr ptr)++-- TODO: would be better in linear IO, for we pretend that we are making an+-- unrestricted 'a', where really we are not.+reprPeek :: forall a. Representable a => Ptr a -> IO a+reprPeek ptr | Dict <- storable @(AsKnown a) = do+  knownRepr <- peek (castPtr ptr :: Ptr (AsKnown a))+  return (ofKnown knownRepr)++-- | Retrieve the value stored on system heap memory.+deconstruct :: Representable a => Box a %1-> a+deconstruct (Box poolPtr ptr) = unsafeDupablePerformIO $ mask_ $ do+  res <- reprPeek ptr+  delete =<< peek poolPtr+  free ptr+  free poolPtr+  return res
+ src/Prelude/Linear.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | This module provides a replacement for 'Prelude' with+-- support for linear programming via linear versions of+-- standard data types, functions and type classes.+--+-- A simple example:+--+-- >>> :set -XLinearTypes+-- >>> :set -XNoImplicitPrelude+-- >>> import Prelude.Linear+-- >>> :{+--   boolToInt :: Bool %1-> Int+--   boolToInt False = 0+--   boolToInt True = 1+-- :}+--+-- >>> :{+--   makeInt :: Either Int Bool %1-> Int+--   makeInt = either id boolToInt+-- :}+--+-- 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+    -- * Tuples+  , Prelude.fst+  , Prelude.snd+  , curry+  , uncurry+    -- ** Basic type classes+  , 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 (..)+    -- *** Numeric functions+  , 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+    -- ** Miscellaneous functions+  , id+  , const+  , (.)+  , flip+  , ($)+  , (&)+  , Prelude.until+  , asTypeOf+  , Prelude.error+  , Prelude.errorWithoutStackTrace+  , Prelude.undefined+  , seq+  , ($!)+    -- * List operations+  , module Data.List.Linear+    -- * Functions on strings+    -- TODO: Implement a linear counterpart of this+  , 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+    -- * Basic input and output+  , 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+    -- * Using 'Ur' values in linear code+    -- $ unrestricted+  , Ur(..)+  , unur+    -- * Doing non-linear operations inside linear functions+    -- $ comonoid+  , 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 Data.Maybe.Linear+import Data.Ord.Linear+import Data.Tuple.Linear+import Data.List.Linear+import qualified Prelude+import Prelude.Linear.Internal+import Data.String++-- | 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+fa <* fb = Data.fmap (flip lseq) fa Data.<*> fb
+ src/Prelude/Linear/Internal.hs view
@@ -0,0 +1,76 @@+-- | 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 LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Prelude.Linear.Internal where++import qualified Prelude as Prelude+import qualified Unsafe.Linear as Unsafe+import Data.Functor.Identity++-- 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.+($) f x = f x+infixr 0 $++(&) :: a %1-> (a %1-> b) %1-> b+x & f = f x+infixl 1 &++id :: a %1-> a+id x = x++const :: a %1-> 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)++($!) :: (a %1-> b) %1-> a %1-> 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+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++-- | 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+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+-- | 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 f a = f a++-- XXX: Temporary, until newtype record projections are linear.+runIdentity' :: Identity a %1-> a+runIdentity' (Identity x) = x+
+ src/Streaming/Internal/Consume.hs view
@@ -0,0 +1,637 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module provides all functions that take input streams+-- but do not return output streams.+module Streaming.Internal.Consume+  ( -- * Consuming 'Stream's of elements+  -- ** IO Consumers+    stdoutLn+  , stdoutLn'+  , print+  , toHandle+  , writeFile+  -- ** Basic Pure Consumers+  , effects+  , erase+  , drained+  , mapM_+  -- ** Folds+  , fold+  , fold_+  , foldM+  , foldM_+  , all+  , all_+  , any+  , any_+  , sum+  , sum_+  , product+  , product_+  , head+  , head_+  , last+  , last_+  , elem+  , elem_+  , notElem+  , notElem_+  , length+  , length_+  , toList+  , toList_+  , mconcat+  , mconcat_+  , minimum+  , minimum_+  , maximum+  , maximum_+  , foldrM+  , foldrT+  ) where++import Streaming.Internal.Type+import Streaming.Internal.Process+import System.IO.Linear+import System.IO.Resource+import qualified Data.Bool.Linear as Linear+import Prelude.Linear ((&), ($), (.))+import Prelude (Show(..), FilePath, (&&), Bool(..), id, (||),+               Num(..), Maybe(..), Eq(..), Int, Ord(..))+import qualified Prelude as Prelude+import Data.Unrestricted.Linear+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Functor.Identity+import qualified System.IO as System+import qualified Control.Functor.Linear as Control+++-- #  IO Consumers+-------------------------------------------------------------------------------++-- Note: crashes on a broken output pipe+--+{-| Write 'String's to 'System.stdout' using 'Text.putStrLn'; terminates on a broken output pipe+    (The name and implementation are modelled on the @Pipes.Prelude@ @stdoutLn@).++\>\>\> withLinearIO $ Control.fmap move $ S.stdoutLn $ S.each $ words "one two three"+one+two+three+-}+stdoutLn :: Stream (Of Text) IO () %1-> IO ()+stdoutLn stream = stdoutLn' stream+{-# INLINE stdoutLn #-}++-- | Like stdoutLn but with an arbitrary return value+stdoutLn' :: forall r. Stream (Of Text) IO r %1-> IO r+stdoutLn' stream = loop stream where+  loop :: Stream (Of Text) IO r %1-> IO r+  loop stream = stream & \case+    Return r -> Control.return r+    Effect ms -> ms Control.>>= stdoutLn'+    Step (str :> stream) -> Control.do+      fromSystemIO $ Text.putStrLn str+      stdoutLn' stream+{-# INLINABLE stdoutLn' #-}++{-| Print the elements of a stream as they arise.++-}+print :: Show a => Stream (Of a) IO r %1-> IO r+print = stdoutLn' . map (Text.pack Prelude.. Prelude.show)++-- | Write a stream to a handle and return the handle.+toHandle :: Handle %1-> Stream (Of Text) RIO r %1-> RIO (r, Handle)+toHandle handle stream = loop handle stream where+  loop :: Handle %1-> Stream (Of Text) RIO r %1-> RIO (r, Handle)+  loop handle stream = stream & \case+    Return r -> Control.return (r, handle)+    Effect ms -> ms Control.>>= toHandle handle+    Step (text :> stream') -> Control.do+      handle' <- hPutStrLn handle text+      toHandle handle' stream'+{-# INLINABLE toHandle #-}++-- | Write a stream of text as lines as lines to a file+writeFile :: FilePath -> Stream (Of Text) RIO r %1-> RIO r+writeFile filepath stream = Control.do+  handle <- openFile filepath System.WriteMode+  (r,handle') <- toHandle handle stream+  hClose handle'+  Control.return r+++-- #  Basic Pure Consumers+-------------------------------------------------------------------------------++{- | Reduce a stream, performing its actions but ignoring its elements.++@+\>\>\> rest <- S.effects $ S.splitAt 2 $ each' [1..5]+\>\>\> S.print rest+3+4+5+@++    'effects' should be understood together with 'copy' and is subject to the rules++> S.effects . S.copy       = id+> hoist S.effects . S.copy = id++    The similar @effects@ and @copy@ operations in @Data.ByteString.Streaming@ obey the same rules.++-}+effects :: forall a m r. Control.Monad m => Stream (Of a) m r %1-> m r+effects stream = loop stream where+  loop :: Stream (Of a) m r %1-> m r+  loop stream = stream & \case+    Return r -> Control.return r+    Effect ms -> ms Control.>>= effects+    Step (_ :> stream') -> effects stream'+{-# INLINABLE effects #-}++{- | Remove the elements from a stream of values, retaining the structure of layers.+-}+erase :: forall a m r. Control.Monad m => Stream (Of a) m r %1-> Stream Identity m r+erase stream = loop stream where+  loop :: Stream (Of a) m r %1-> Stream Identity m r+  loop stream = stream & \case+    Return r -> Return r+    Step (_ :> stream') -> Step $ Identity (erase stream')+    Effect ms -> Effect $ ms Control.>>= (Control.return . erase)+{-# INLINABLE erase #-}++{-| Where a transformer returns a stream, run the effects of the stream, keeping+   the return value. This is usually used at the type++> drained :: Control.Monad m => Stream (Of a) m (Stream (Of b) m r) -> Stream (Of a) m r+> drained = Control.join . Control.fmap (Control.lift . effects)++   Here, for example, we split a stream in two places and throw out the middle segment:++@+\>\>\> rest <- S.print $ S.drained $ S.splitAt 2 $ S.splitAt 5 $ each' [1..7]+1+2+\>\>\> S.print rest+6+7+@++-}+drained ::+  ( Control.Monad m+  , Control.Monad (t m)+  , Control.Functor (t m)+  , Control.MonadTrans t) =>+  t m (Stream (Of a) m r) %1-> t m r+drained = Control.join . Control.fmap (Control.lift . effects)+{-# INLINE drained #-}++{-| Reduce a stream to its return value with a monadic action.++@+\>\>\> S.mapM_ Prelude.print $ each' [1..3]+1+2+3+@++@+\>\>\> rest <- S.mapM_ Prelude.print $ S.splitAt 3 $ each' [1..10]+1+2+3+\>\>\> S.sum rest+49 :> ()+@++-}+mapM_ :: forall a m b r. (Consumable b, Control.Monad m) =>+  (a -> m b) -> Stream (Of a) m r %1-> m r+mapM_  f stream = loop stream where+  loop :: Stream (Of a) m r %1-> m r+  loop stream = stream & \case+    Return r -> Control.return r+    Effect ms -> ms Control.>>= mapM_ f+    Step (a :> stream') -> Control.do+      b <- f a+      Control.return $ consume b+      mapM_ f stream'+{-# INLINABLE mapM_ #-}+++-- #  Folds+-------------------------------------------------------------------------------+++{-| Strict fold of a 'Stream' of elements that preserves the return value.+   This does not short circuit and all effects are performed.+   The third parameter will often be 'id' where a fold is written by hand:++@+\>\>\> S.fold (+) 0 id $ each' [1..10]+55 :> ()+@++@+\>\>\> S.fold (*) 1 id $ S.fold (+) 0 id $ S.copy $ each' [1..10]+3628800 :> (55 :> ())+@++    It can be used to replace a standard Haskell type with one more suited to+    writing a strict accumulation function. It is also crucial to the+    Applicative instance for @Control.Foldl.Fold@  We can apply such a fold+    @purely@++> Control.Foldl.purely S.fold :: Control.Monad m => Fold a b -> Stream (Of a) m r %1-> m (Of b r)++    Thus, specializing a bit:++> L.purely S.fold L.sum :: Stream (Of Int) Int r %1-> m (Of Int r)+> mapped (L.purely S.fold L.sum) :: Stream (Stream (Of Int)) IO r %1-> Stream (Of Int) IO r++    Here we use the Applicative instance for @Control.Foldl.Fold@ to+    stream three-item segments of a stream together with their sums and products.++@+\>\>\> S.print $ mapped (L.purely S.fold (liftA3 (,,) L.list L.product L.sum)) $ chunksOf 3 $ each' [1..10]+([1,2,3],6,6)+([4,5,6],120,15)+([7,8,9],504,24)+([10],10,10)+@++-}+fold :: forall x a b m r. Control.Monad m =>+  (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> m (Of b r)+fold f x g stream = loop stream where+  loop :: Stream (Of a) m r %1-> m (Of b r)+  loop stream = stream & \case+    Return r -> Control.return $ g x :> r+    Effect ms -> ms Control.>>= fold f x g+    Step (a :> stream') -> fold f (f x a) g stream'+{-# INLINABLE fold #-}++{-| Strict fold of a 'Stream' of elements, preserving only the result of the fold, not+    the return value of the stream. This does not short circuit and all effects+    are performed. The third parameter will often be 'id' where a fold+    is written by hand:++@+\>\>\> S.fold_ (+) 0 id $ each [1..10]+55+@++    It can be used to replace a standard Haskell type with one more suited to+    writing a strict accumulation function. It is also crucial to the+    Applicative instance for @Control.Foldl.Fold@++> Control.Foldl.purely fold :: Control.Monad m => Fold a b -> Stream (Of a) m () %1-> m b++-}+fold_ :: forall x a b m r. (Control.Monad m, Consumable r) =>+  (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> m b+fold_ f x g stream = loop stream where+  loop :: Stream (Of a) m r %1-> m b+  loop stream = stream & \case+    Return r -> lseq r $ Control.return $ g x+    Effect ms -> ms Control.>>= fold_ f x g+    Step (a :> stream') -> fold_ f (f x a) g stream'+{-# INLINABLE fold_ #-}++-- Note: We can't use 'Of' since the left component is unrestricted.+-- Remark: to use the (`m x`) in the folding function that is the first+-- argument, we must bind to it. Since `m` is a `Control.Monad`, we need+-- the folding function to consume `x` linearly.+--+{-| Strict, monadic fold of the elements of a @Stream (Of a)@++> Control.Foldl.impurely foldM :: Control.Monad m => FoldM a b -> Stream (Of a) m r %1-> m (b, r)++   Thus to accumulate the elements of a stream as a vector, together with a random+   element we might write:++@+\>\>\> L.impurely S.foldM (liftA2 (,) L.vectorM L.random) $ each' [1..10::Int] :: IO (Of (Vector Int, Maybe Int) ())+([1,2,3,4,5,6,7,8,9,10],Just 9) :> ()+@+-}+foldM :: forall x a m b r. Control.Monad m =>+  (x %1-> a -> m x) -> m x -> (x %1-> m b) -> Stream (Of a) m r %1-> m (b,r)+foldM f mx g stream = loop stream where+  loop :: Stream (Of a) m r %1-> m (b,r)+  loop stream = stream & \case+    Return r -> mx Control.>>= g Control.>>= (\b -> Control.return (b,r))+    Effect ms -> ms Control.>>= foldM f mx g+    Step (a :> stream') -> foldM f (mx Control.>>= \x -> f x a) g stream'+{-# INLINABLE foldM #-}++{-| Strict, monadic fold of the elements of a @Stream (Of a)@++> Control.Foldl.impurely foldM_ :: Control.Monad m => FoldM a b -> Stream (Of a) m () %1-> m b+-}+foldM_ :: forall a m x b r. (Control.Monad m, Consumable r) =>+  (x %1-> a -> m x) -> m x -> (x %1-> m b) -> Stream (Of a) m r %1-> m b+foldM_ f mx g stream = loop stream where+  loop :: Stream (Of a) m r %1-> m b+  loop stream = stream & \case+    Return r  -> lseq r $ mx Control.>>= g+    Effect ms -> ms Control.>>= foldM_ f mx g+    Step (a :> stream') -> foldM_ f (mx Control.>>= \x -> f x a) g stream'+{-# INLINABLE foldM_ #-}++-- | Note: does not short circuit+all :: Control.Monad m => (a -> Bool) -> Stream (Of a) m r %1-> m (Of Bool r)+all f stream = fold (&&) True id (map f stream)+{-# INLINABLE all #-}++-- | Note: does not short circuit+all_ :: (Consumable r, Control.Monad m) => (a -> Bool) -> Stream (Of a) m r %1-> m Bool+all_ f stream = fold_ (&&) True id (map f stream)+{-# INLINABLE all_ #-}++-- | Note: does not short circuit+any :: Control.Monad m => (a -> Bool) -> Stream (Of a) m r %1-> m (Of Bool r)+any f stream = fold (||) False id (map f stream)+{-# INLINABLE any #-}++-- | Note: does not short circuit+any_ :: (Consumable r, Control.Monad m) => (a -> Bool) -> Stream (Of a) m r %1-> m Bool+any_ f stream = fold_ (||) False id (map f stream)+{-# INLINABLE any_ #-}++{-| Fold a 'Stream' of numbers into their sum with the return value++>  mapped S.sum :: Stream (Stream (Of Int)) m r %1-> Stream (Of Int) m r++@+\>\>\> S.sum $ each' [1..10]+55 :> ()+@++@+\>\>\> (n :> rest)  <- S.sum $ S.splitAt 3 $ each' [1..10]+\>\>\> System.IO.print n+6+\>\>\> (m :> rest') <- S.sum $ S.splitAt 3 rest+\>\>\> System.IO.print m+15+\>\>\> S.print rest'+7+8+9+10+@+-}+sum :: (Control.Monad m, Num a) => Stream (Of a) m r %1-> m (Of a r)+sum stream = fold (+) 0 id stream+{-# INLINE sum #-}++-- | Fold a 'Stream' of numbers into their sum+sum_ :: (Control.Monad m, Num a) => Stream (Of a) m () %1-> m a+sum_ stream = fold_ (+) 0 id stream+{-# INLINE sum_ #-}++{-| Fold a 'Stream' of numbers into their product with the return value++>  mapped product :: Stream (Stream (Of Int)) m r -> Stream (Of Int) m r+-}+product :: (Control.Monad m, Num a) => Stream (Of a) m r %1-> m (Of a r)+product stream = fold (*) 1 id stream+{-# INLINE product #-}++-- | Fold a 'Stream' of numbers into their product+product_ :: (Control.Monad m, Num a) => Stream (Of a) m () %1-> m a+product_ stream = fold_ (*) 1 id stream+{-# INLINE product_ #-}++-- | Note that 'head' exhausts the rest of the stream following the+-- first element, performing all monadic effects via 'effects'+head :: Control.Monad m => Stream (Of a) m r %1-> m (Of (Maybe a) r)+head str = str & \case+  Return r -> Control.return (Nothing :> r)+  Effect m -> m Control.>>= head+  Step (a :> rest) ->+    effects rest Control.>>= \r -> Control.return (Just a :> r)+{-# INLINABLE head #-}++-- | Note that 'head' exhausts the rest of the stream following the+-- first element, performing all monadic effects via 'effects'+head_ :: (Consumable r, Control.Monad m) => Stream (Of a) m r %1-> m (Maybe a)+head_ str = str & \case+  Return r -> lseq r $ Control.return Nothing+  Effect m -> m Control.>>= head_+  Step (a :> rest) ->+    effects rest Control.>>= \r -> lseq r $ Control.return  (Just a)+{-# INLINABLE head_ #-}++last :: Control.Monad m => Stream (Of a) m r %1-> m (Of (Maybe a) r)+last = loop Nothing where+  loop :: Control.Monad m =>+    Maybe a -> Stream (Of a) m r %1-> m (Of (Maybe a) r)+  loop m s = s & \case+    Return r  -> Control.return (m :> r)+    Effect m -> m Control.>>= last+    Step (a :> rest) -> loop (Just a) rest+{-# INLINABLE last #-}++last_ :: (Consumable r, Control.Monad m) => Stream (Of a) m r %1-> m (Maybe a)+last_ = loop Nothing where+  loop :: (Consumable r, Control.Monad m) =>+    Maybe a -> Stream (Of a) m r %1-> m (Maybe a)+  loop m s = s & \case+    Return r  -> lseq r $ Control.return m+    Effect m -> m Control.>>= last_+    Step (a :> rest) -> loop (Just a) rest+{-# INLINABLE last_ #-}++elem :: forall a m r. (Control.Monad m, Eq a) =>+  a -> Stream (Of a) m r %1-> m (Of Bool r)+elem a stream = loop stream where+  loop :: Stream (Of a) m r %1-> m (Of Bool r)+  loop stream = stream & \case+    Return r -> Control.return $ False :> r+    Effect ms -> ms Control.>>= elem a+    Step (a' :> stream') -> case a == a' of+      True -> effects stream' Control.>>= (\r -> Control.return $ True :> r)+      False -> elem a stream'+{-# INLINABLE elem #-}++elem_ :: forall a m r. (Consumable r, Control.Monad m, Eq a) =>+  a -> Stream (Of a) m r %1-> m Bool+elem_ a stream = loop stream where+  loop :: Stream (Of a) m r %1-> m Bool+  loop stream = stream & \case+    Return r -> lseq r $ Control.return False+    Effect ms -> ms Control.>>= elem_ a+    Step (a' :> stream') -> case a == a' of+      True -> effects stream' Control.>>= \r -> lseq r $ Control.return True+      False -> elem_ a stream'+{-# INLINABLE elem_ #-}++{-| Exhaust a stream deciding whether @a@ was an element.++-}+notElem :: (Control.Monad m, Eq a) => a -> Stream (Of a) m r %1-> m (Of Bool r)+notElem a stream = Control.fmap negate $ elem a stream+  where+    negate :: Of Bool r %1-> Of Bool r+    negate (b :> r) = Prelude.not b :> r+{-# INLINE notElem #-}++notElem_ :: (Consumable r, Control.Monad m, Eq a) => a -> Stream (Of a) m r %1-> m Bool+notElem_ a stream = Control.fmap Linear.not $ elem_ a stream+{-# INLINE notElem_ #-}++{-| Run a stream, keeping its length and its return value.++@+\>\>\> S.print $ mapped S.length $ chunksOf 3 $ S.each' [1..10]+3+3+3+1+@++-}+length :: Control.Monad m => Stream (Of a) m r %1-> m (Of Int r)+length = fold (\n _ -> n + 1) 0 id+{-# INLINE length #-}+++{-| Run a stream, remembering only its length:++@+\>\>\> runIdentity $ S.length_ (S.each [1..10] :: Stream (Of Int) Identity ())+10+@+-}+length_ :: (Consumable r, Control.Monad m) => Stream (Of a) m r %1-> m Int+length_ = fold_ (\n _ -> n + 1) 0 id+{-# INLINE length_ #-}++{-| Convert an effectful 'Stream' into a list alongside the return value++>  mapped toList :: Stream (Stream (Of a) m) m r %1-> Stream (Of [a]) m r++    Like 'toList_', 'toList' breaks streaming; unlike 'toList_' it /preserves the return value/+    and thus is frequently useful with e.g. 'mapped'++@+\>\>\> S.print $ mapped S.toList $ chunksOf 3 $ each' [1..9]+[1,2,3]+[4,5,6]+[7,8,9]+@++@+\>\>\> S.print $ mapped S.toList $ chunksOf 2 $ S.replicateM 4 getLine+s<Enter>+t<Enter>+["s","t"]+u<Enter>+v<Enter>+["u","v"]+@+-}+toList :: Control.Monad m => Stream (Of a) m r %1-> m (Of [a] r)+toList = fold (\diff a ls -> diff (a: ls)) id (\diff -> diff [])+{-# INLINE toList #-}++{-| Convert an effectful @Stream (Of a)@ into a list of @as@++    Note: Needless to say, this function does not stream properly.+    It is basically the same as Prelude 'mapM' which, like 'replicateM',+    'sequence' and similar operations on traversable containers+    is a leading cause of space leaks.++-}+toList_ :: Control.Monad m => Stream (Of a) m () %1-> m [a]+toList_ = fold_ (\diff a ls -> diff (a: ls)) id (\diff -> diff [])+{-# INLINE toList_ #-}++{-| Fold streamed items into their monoidal sum+ -}+mconcat :: (Control.Monad m, Prelude.Monoid w) => Stream (Of w) m r %1-> m (Of w r)+mconcat = fold (Prelude.<>) Prelude.mempty id+{-# INLINE mconcat #-}++mconcat_ :: (Consumable r, Control.Monad m, Prelude.Monoid w) =>+  Stream (Of w) m r %1-> m w+mconcat_ = fold_ (Prelude.<>) Prelude.mempty id+{-# INLINE mconcat_ #-}++minimum :: (Control.Monad m, Ord a) => Stream (Of a) m r %1-> m (Of (Maybe a) r)+minimum = fold getMin Nothing id . map Just+{-# INLINE minimum #-}++minimum_ :: (Consumable r, Control.Monad m, Ord a) =>+  Stream (Of a) m r %1-> m (Maybe a)+minimum_ = fold_ getMin Nothing id . map Just+{-# INLINE minimum_ #-}++maximum :: (Control.Monad m, Ord a) => Stream (Of a) m r %1-> m (Of (Maybe a) r)+maximum = fold getMax Nothing id . map Just+{-# INLINE maximum #-}++maximum_ :: (Consumable r, Control.Monad m, Ord a) =>+  Stream (Of a) m r %1-> m (Maybe a)+maximum_ = fold_ getMax Nothing id . map Just+{-# INLINE maximum_ #-}++getMin :: Ord a => Maybe a -> Maybe a -> Maybe a+getMin = mCompare Prelude.min++getMax :: Ord a => Maybe a -> Maybe a -> Maybe a+getMax = mCompare Prelude.max++mCompare :: Ord a => (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a+mCompare _ Nothing Nothing = Nothing+mCompare _ (Just a) Nothing = Just a+mCompare _ Nothing (Just a) = Just a+mCompare comp (Just x) (Just y) = Just $ comp x y++{-| A natural right fold for consuming a stream of elements.+    See also the more general 'iterT' in the 'Streaming' module and the+    still more general 'destroy'+-}+foldrM :: forall a m r. Control.Monad m+       => (a -> m r %1-> m r) -> Stream (Of a) m r %1-> m r+foldrM step stream = loop stream where+  loop :: Stream (Of a) m r %1-> m r+  loop stream = stream & \case+    Return r -> Control.return r+    Effect m -> m Control.>>= foldrM step+    Step (a :> as) -> step a (foldrM step as)+{-# INLINABLE foldrM #-}++{-| A natural right fold for consuming a stream of elements.+    See also the more general 'iterTM' in the 'Streaming' module+    and the still more general 'destroy'++> foldrT (\a p -> Streaming.yield a >> p) = id++-}+foldrT :: forall a t m r.+  (Control.Monad m, Control.MonadTrans t, Control.Monad (t m)) =>+  (a -> t m r %1-> t m r) -> Stream (Of a) m r %1-> t m r+foldrT step stream = loop stream where+  loop :: Stream (Of a) m r %1-> t m r+  loop stream = stream & \case+    Return r -> Control.return r+    Effect ms -> (Control.lift ms) Control.>>= foldrT step+    Step (a :> as) -> step a (foldrT step as)+{-# INLINABLE foldrT #-}+
+ src/Streaming/Internal/Interop.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}++-- | This module contains functions for interoperating with other+-- streaming libraries.+module Streaming.Internal.Interop+  ( -- * Interoperating with other streaming libraries+    reread+  ) where++import Streaming.Internal.Type+import Streaming.Internal.Produce+import Data.Unrestricted.Linear+import Prelude.Linear (($))+import Prelude (Maybe(..))+import qualified Control.Functor.Linear as Control++{-| Read an @IORef (Maybe a)@ or a similar device until it reads @Nothing@.+    @reread@ provides convenient exit from the @io-streams@ library++> reread readIORef    :: IORef (Maybe a) -> Stream (Of a) IO ()+> reread Streams.read :: System.IO.Streams.InputStream a -> Stream (Of a) IO ()+-}+reread :: Control.Monad m =>+  (s -> m (Ur (Maybe a))) -> s -> Stream (Of a) m ()+reread f s = reread' f s+  where+    reread' :: Control.Monad m =>+      (s -> m (Ur (Maybe a))) -> s -> Stream (Of a) m ()+    reread' f s = Effect $ Control.do+      Ur maybeA <- f s+      case maybeA of+        Nothing -> Control.return $ Return ()+        Just a -> Control.return $ (yield a Control.>> reread f s)+{-# INLINABLE reread #-}+
+ src/Streaming/Internal/Many.hs view
@@ -0,0 +1,371 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module contains all functions that do something with+-- multiple streams as input or output. This includes combining+-- streams, splitting a stream, etc.+module Streaming.Internal.Many+  (+  -- * Operations that use or return multiple 'Stream's+  -- ** Zips and Unzip+    unzip+  , ZipResidual+  , ZipResidual3+  , zip+  , zipR+  , zipWith+  , zipWithR+  , zip3+  , zip3R+  , zipWith3+  , zipWith3R+  , Either3 (..)+  -- ** Merging+  -- $ merging+  , merge+  , mergeOn+  , mergeBy+  ) where++import Streaming.Internal.Type+import Streaming.Internal.Consume+import Prelude (Either(..), Ord(..), Ordering(..))+import Prelude.Linear (($), (&))+import qualified Control.Functor.Linear as Control+++-- # Zips and Unzip+-------------------------------------------------------------------------------++{-| The type++> Data.List.unzip     :: [(a,b)] -> ([a],[b])++   might lead us to expect++> Streaming.unzip :: Stream (Of (a,b)) m r -> Stream (Of a) m (Stream (Of b) m r)++   which would not stream, since it would have to accumulate the second stream (of @b@s).+   Of course, @Data.List@ 'Data.List.unzip' doesn't stream either.++   This @unzip@ does+   stream, though of course you can spoil this by using e.g. 'toList':++@+\>\>\> let xs = Prelude.map (\x -> (x, Prelude.show x)) [1..5 :: Int]++\>\>\> S.toList $ S.toList $ S.unzip (S.each' xs)+["1","2","3","4","5"] :> ([1,2,3,4,5] :> ())++\>\>\> Prelude.unzip xs+([1,2,3,4,5],["1","2","3","4","5"])+@++    Note the difference of order in the results. It may be of some use to think why.+    The first application of 'toList' was applied to a stream of integers:++@+\>\>\> :t S.unzip $ S.each' xs+S.unzip $ S.each' xs :: Control.Monad m => Stream (Of Int) (Stream (Of String) m) ()+@++    Like any fold, 'toList' takes no notice of the monad of effects.++> toList :: Control.Monad m => Stream (Of a) m r %1-> m (Of [a] r)++    In the case at hand (since I am in @ghci@) @m = Stream (Of String) IO@.+    So when I apply 'toList', I exhaust that stream of integers, folding+    it into a list:++@+\>\>\> :t S.toList $ S.unzip $ S.each' xs+S.toList $ S.unzip $ S.each' xs+  :: Control.Monad m => Stream (Of String) m (Of [Int] ())+@++    When I apply 'toList' to /this/, I reduce everything to an ordinary action in @IO@,+    and return a list of strings:++@+\>\>\> S.toList $ S.toList $ S.unzip (S.each' xs)+["1","2","3","4","5"] :> ([1,2,3,4,5] :> ())+@++'unzip' can be considered a special case of either 'unzips' or 'expand':++@+  unzip = 'unzips' . 'maps' (\((a,b) :> x) -> Compose (a :> b :> x))+  unzip = 'expand' $ \p ((a,b) :> abs) -> b :> p (a :> abs)+@+-}+unzip :: Control.Monad m =>+  Stream (Of (a, b)) m r %1-> Stream (Of a) (Stream (Of b) m) r+unzip = loop+  where+  loop :: Control.Monad m =>+    Stream (Of (a, b)) m r %1-> Stream (Of a) (Stream (Of b) m) r+  loop stream = stream & \case+    Return r -> Return r+    Effect m -> Effect $ Control.fmap loop $ Control.lift m+    Step ((a,b):> rest) -> Step (a :> Effect (Step (b :> Return (loop rest))))+{-# INLINABLE unzip #-}+++{- Remarks on the design of zip functions++Zip functions have two design choices:+(1) What do we do with the end-of-stream values of both streams?+(2) If the streams are of different length, do we keep or throw out the+remainder of the longer stream?++* We are assuming not to take infinite streams as input and instead deal with+reasonably small finite streams.+* To avoid making choices for the user, we keep both end-of-stream payloads+* The default zips (ones without a prime in the name) use @effects@ to consume+the remainder stream after zipping. We include zip function variants that+return no remainder (for equal length streams), or the remainder of the+longer stream.++-}++data Either3 a b c where+  Left3 :: a %1-> Either3 a b c+  Middle3 :: b %1-> Either3 a b c+  Right3 :: c %1-> Either3 a b c++-- | The remainder of zipping two streams+type ZipResidual a b m r1 r2 =+  Either3+    (r1, r2)+    (r1, Stream (Of b) m r2)+    (Stream (Of a) m r1, r2)++-- | @zipWithR@ zips two streams applying a function along the way,+-- keeping the remainder of zipping if there is one.  Note. If two streams have+-- the same length, but one needs to perform some effects to obtain the+-- end-of-stream result, that stream is treated as a residual.+zipWithR :: Control.Monad m =>+  (a -> b -> c) ->+  Stream (Of a) m r1 %1->+  Stream (Of b) m r2 %1->+  Stream (Of c) m (ZipResidual a b m r1 r2)+zipWithR = loop+  where+  loop :: Control.Monad m =>+    (a -> b -> c) ->+    Stream (Of a) m r1 %1->+    Stream (Of b) m r2 %1->+    Stream (Of c) m (ZipResidual a b m r1 r2)+  loop f st1 st2 = st1 & \case+    Effect ms -> Effect $ Control.fmap (\s -> loop f s st2) ms+    Return r1 -> st2 & \case+      Return r2 -> Return $ Left3 (r1,r2)+      st2' -> Return $ Middle3 (r1,st2')+    Step (a :> as) -> st2 & \case+      Effect ms ->+        Effect $ Control.fmap (\s -> loop f (Step (a :> as)) s) ms+      Return r2 -> Return $ Right3 (Step (a :> as), r2)+      Step (b :> bs) -> Step $ (f a b) :> loop f as bs+{-# INLINABLE zipWithR #-}++zipWith :: Control.Monad m =>+  (a -> b -> c) ->+  Stream (Of a) m r1 %1->+  Stream (Of b) m r2 %1->+  Stream (Of c) m (r1,r2)+zipWith f s1 s2 = Control.do+  result <- zipWithR f s1 s2+  result & \case+    Left3 rets -> Control.return rets+    Middle3 (r1, s2') -> Control.do+      r2 <- Control.lift $ effects s2'+      Control.return (r1, r2)+    Right3 (s1', r2) -> Control.do+      r1 <- Control.lift $ effects s1'+      Control.return (r1, r2)+{-# INLINABLE zipWith #-}++-- | @zip@ zips two streams exhausing the remainder of the longer+-- stream and consuming its effects.+zip :: Control.Monad m =>+  Stream (Of a) m r1 %1->+  Stream (Of b) m r2 %1->+  Stream (Of (a,b)) m (r1, r2)+zip = zipWith (,)+{-# INLINE zip #-}++-- | @zipR@ zips two streams keeping the remainder if there is one.+zipR :: Control.Monad m =>+  Stream (Of a) m r1 %1->+  Stream (Of b) m r2 %1->+  Stream (Of (a,b)) m (ZipResidual a b m r1 r2)+zipR = zipWithR (,)+{-# INLINE zipR #-}++-- Remark. For simplicity, we do not create an @Either7@ which is the+-- proper remainder type for 'zip3R'. Our type simply has one impossible+-- case which is when all three streams have a remainder.++-- | The (liberal) remainder of zipping three streams.+-- This has the downside that the possibility of three remainders+-- is allowed, though it will never occur.+type ZipResidual3 a b c m r1 r2 r3 =+  ( Either r1 (Stream (Of a) m r1)+  , Either r2 (Stream (Of b) m r2)+  , Either r3 (Stream (Of c) m r3)+  )++-- | Like @zipWithR@ but with three streams.+zipWith3R :: Control.Monad m =>+  (a -> b -> c -> d) ->+  Stream (Of a) m r1 %1->+  Stream (Of b) m r2 %1->+  Stream (Of c) m r3 %1->+  Stream (Of d) m (ZipResidual3 a b c m r1 r2 r3)+zipWith3R = loop+  where+  loop :: Control.Monad m =>+    (a -> b -> c -> d) ->+    Stream (Of a) m r1 %1->+    Stream (Of b) m r2 %1->+    Stream (Of c) m r3 %1->+    Stream (Of d) m (ZipResidual3 a b c m r1 r2 r3)+  loop f s1 s2 s3 = s1 & \case+    Effect ms -> Effect $ Control.fmap (\s -> loop f s s2 s3) ms+    Return r1 -> (s2, s3) & \case+      (Return r2, Return r3) -> Return (Left r1, Left r2, Left r3)+      (s2', s3') -> Return (Left r1, Right s2', Right s3')+    Step (a :> as) -> s2 & \case+      Effect ms -> Effect $+        Control.fmap (\s -> loop f (Step $ a :> as) s s3) ms+      Return r2 -> Return (Right (Step $ a :> as), Left r2, Right s3)+      Step (b :> bs) -> s3 & \case+        Effect ms -> Effect $+          Control.fmap (\s -> loop f (Step $ a :> as) (Step $ b :> bs) s) ms+        Return r3 ->+          Return (Right (Step $ a :> as), Right (Step $ b :> bs), Left r3)+        Step (c :> cs) -> Step $ (f a b c) :> loop f as bs cs+{-# INLINABLE zipWith3R #-}++-- | Like @zipWith@ but with three streams+zipWith3 :: Control.Monad m =>+  (a -> b -> c -> d) ->+  Stream (Of a) m r1 %1->+  Stream (Of b) m r2 %1->+  Stream (Of c) m r3 %1->+  Stream (Of d) m (r1, r2, r3)+zipWith3 f s1 s2 s3 = Control.do+  result <- zipWith3R f s1 s2 s3+  result & \case+    (res1, res2, res3) -> Control.do+      r1 <- Control.lift $ extractResult res1+      r2 <- Control.lift $ extractResult res2+      r3 <- Control.lift $ extractResult res3+      Control.return (r1, r2, r3)+{-# INLINABLE zipWith3 #-}++-- | Like @zipR@ but with three streams.+zip3 :: Control.Monad m =>+  Stream (Of a) m r1 %1->+  Stream (Of b) m r2 %1->+  Stream (Of c) m r3 %1->+  Stream (Of (a,b,c)) m (r1, r2, r3)+zip3 = zipWith3 (,,)+{-# INLINABLE zip3 #-}++-- | Like @zipR@ but with three streams.+zip3R :: Control.Monad m =>+  Stream (Of a) m r1 %1->+  Stream (Of b) m r2 %1->+  Stream (Of c) m r3 %1->+  Stream (Of (a,b,c)) m (ZipResidual3 a b c m r1 r2 r3)+zip3R = zipWith3R (,,)+{-# INLINABLE zip3R #-}++-- | Internal function to consume a stream remainder to+-- get the payload+extractResult :: Control.Monad m => Either r (Stream (Of a) m r) %1-> m r+extractResult (Left r) = Control.return r+extractResult (Right s) = effects s+++-- # Merging+-------------------------------------------------------------------------------++{- $merging+   These functions combine two sorted streams of orderable elements+   into one sorted stream. The elements of the merged stream are+   guaranteed to be in a sorted order if the two input streams are+   also sorted.++   The merge operation is /left-biased/: when merging two elements+   that compare as equal, the left element is chosen first.+-}++{- | Merge two streams of elements ordered with their 'Ord' instance.++   The return values of both streams are returned.++@+\>\>\> S.print $ merge (each [1,3,5]) (each [2,4])+1+2+3+4+5+((), ())+@++-}+merge :: (Control.Monad m, Ord a) =>+  Stream (Of a) m r %1-> Stream (Of a) m s %1-> Stream (Of a) m (r,s)+merge = mergeBy compare+{-# INLINE merge #-}++{- | Merge two streams, ordering them by applying the given function to+   each element before comparing.++   The return values of both streams are returned.+-}+mergeOn :: (Control.Monad m, Ord b) =>+  (a -> b) ->+  Stream (Of a) m r %1->+  Stream (Of a) m s %1->+  Stream (Of a) m (r,s)+mergeOn f = mergeBy (\x y -> compare (f x) (f y))+{-# INLINE mergeOn #-}++{- | Merge two streams, ordering the elements using the given comparison function.++   The return values of both streams are returned.+-}+mergeBy :: forall m a r s . Control.Monad m =>+  (a -> a -> Ordering) ->+  Stream (Of a) m r %1->+  Stream (Of a) m s %1->+  Stream (Of a) m (r,s)+mergeBy comp s1 s2 = loop s1 s2+  where+    loop :: Stream (Of a) m r %1-> Stream (Of a) m s %1-> Stream (Of a) m (r,s)+    loop s1 s2 = s1 & \case+      Return r ->+        Effect $ effects s2 Control.>>= \s -> Control.return $ Return (r, s)+      Effect ms -> Effect $+        ms Control.>>= \s1' -> Control.return $ mergeBy comp s1' s2+      Step (a :> as) -> s2 & \case+        Return s ->+          Effect $ effects as Control.>>= \r -> Control.return $ Return (r, s)+        Effect ms -> Effect $+          ms Control.>>= \s2' ->+            Control.return $ mergeBy comp (Step (a :> as)) s2'+        Step (b :> bs) -> case comp a b of+          LT -> Step (a :> Step (b :> mergeBy comp as bs))+          _ -> Step (b :> Step (a :> mergeBy comp as bs))+{-# INLINABLE mergeBy #-}+
+ src/Streaming/Internal/Process.hs view
@@ -0,0 +1,1474 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module provides functions that take one input+-- stream and produce one output stream. These are functions that+-- process a single stream.+module Streaming.Internal.Process+  (+  -- * Stream processors+  -- ** Splitting and inspecting streams of elements+    next+  , uncons+  , splitAt+  , split+  , breaks+  , break+  , breakWhen+  , breakWhen'+  , span+  , group+  , groupBy+  -- ** Sum and compose manipulation+  , distinguish+  , switch+  , separate+  , unseparate+  , eitherToSum+  , sumToEither+  , sumToCompose+  , composeToSum+  -- ** Partitions+  , partitionEithers+  , partition+  -- ** Maybes+  , catMaybes+  , mapMaybe+  , mapMaybeM+  -- ** Direct Transformations+  , hoist+  , map+  , mapM+  , maps+  , mapped+  , mapsPost+  , mapsMPost+  , mappedPost+  , for+  , with+  , subst+  , copy+  , duplicate+  , store+  , chain+  , sequence+  , nubOrd+  , nubOrdOn+  , nubInt+  , nubIntOn+  , filter+  , filterM+  , intersperse+  , drop+  , dropWhile+  , scan+  , scanM+  , scanned+  , delay+  , read+  , show+  , cons+  , slidingWindow+  , wrapEffect+  -- ** Internal+  , destroyExposed+  ) where++import Streaming.Internal.Type+import Prelude.Linear ((&), ($), (.))+import Prelude (Maybe(..), Either(..), Bool(..), Int,+               Ordering(..), Num(..), Eq(..), id, Ord(..), Read(..),+               String, Double)+import qualified Prelude+import Data.Unrestricted.Linear+import qualified Control.Functor.Linear as Control+import System.IO.Linear+import Data.Functor.Sum+import Data.Functor.Compose+import qualified Data.Set as Set+import qualified Data.Sequence as Seq+import qualified Data.IntSet as IntSet+import Text.Read (readMaybe)+import Control.Concurrent (threadDelay)+import GHC.Stack+++-- # Internal Library+-------------------------------------------------------------------------------++-- | When chunking streams, it's useful to have a combinator+-- that can add an element to the functor that is itself a stream.+-- Basically `consFirstChunk 42 [[1,2,3],[4,5]] = [[42,1,2,3],[4,5]]`.+consFirstChunk :: Control.Monad m =>+  a -> Stream (Stream (Of a) m) m r %1-> Stream (Stream (Of a) m) m r+consFirstChunk a stream = stream & \case+    Return r -> Step (Step (a :> Return (Return r)))+    Effect m -> Effect $ Control.fmap (consFirstChunk a) m+    Step f -> Step (Step (a :> f))++-- This is an internal function used in 'seperate' from the original source.+-- It removes functoral and monadic steps and reduces to some type 'b'.+-- Here it's adapted to consume the stream linearly.+destroyExposed+  :: forall f m r b. (Control.Functor f, Control.Monad m) =>+     Stream f m r %1-> (f b %1-> b) -> (m b %1-> b) -> (r %1-> b) -> b+destroyExposed stream0 construct theEffect done = loop stream0+  where+    loop :: (Control.Functor f, Control.Monad m) =>+      Stream f m r %1-> b+    loop stream = stream & \case+      Return r -> done r+      Effect m -> theEffect (Control.fmap loop m)+      Step f  -> construct (Control.fmap loop f)+++-- # Splitting and inspecting streams of elements+-------------------------------------------------------------------------------++-- Remark. Since the 'a' is not held linearly in the 'Of' pair,+-- we return it inside an 'Ur'.+--+{-| The standard way of inspecting the first item in a stream of elements, if the+     stream is still \'running\'. The @Right@ case contains a+     Haskell pair, where the more general @inspect@ would return a left-strict pair.+     There is no reason to prefer @inspect@ since, if the @Right@ case is exposed,+     the first element in the pair will have been evaluated to whnf.++> next    :: Control.Monad m => Stream (Of a) m r %1-> m (Either r    (a, Stream (Of a) m r))+> inspect :: Control.Monad m => Stream (Of a) m r %1-> m (Either r (Of a (Stream (Of a) m r)))+-}+next :: forall a m r. Control.Monad m =>+  Stream (Of a) m r %1-> m (Either r (Ur a, Stream (Of a) m r))+next stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> m (Either r (Ur a, Stream (Of a) m r))+    loop stream = stream & \case+      Return r -> Control.return $ Left r+      Effect ms -> ms Control.>>= next+      Step (a :> as) -> Control.return $ Right (Ur a, as)+{-# INLINABLE next #-}++{-| Inspect the first item in a stream of elements, without a return value.++-}+uncons :: forall a m r. (Consumable r, Control.Monad m) =>+  Stream (Of a) m r %1-> m (Maybe (a, Stream (Of a) m r))+uncons  stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> m (Maybe (a, Stream (Of a) m r))+    loop stream = stream & \case+      Return r -> lseq r $ Control.return Nothing+      Effect ms -> ms Control.>>= uncons+      Step (a :> as) -> Control.return $ Just (a, as)+{-# INLINABLE uncons #-}++{-| Split a succession of layers after some number, returning a streaming or+    effectful pair. This function is the same as the 'splitsAt' exported by the+    @Streaming@ module, but since this module is imported qualified, it can+    usurp a Prelude name. It specializes to:++>  splitAt :: Control.Monad m => Int -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)++-}+splitAt :: forall f m r. (Control.Monad m, Control.Functor f) =>+  Int -> Stream f m r %1-> Stream f m (Stream f m r)+splitAt n stream = loop n stream where+  loop :: Int -> Stream f m r %1-> Stream f m (Stream f m r)+  loop n stream = case Prelude.compare n 0 of+    GT -> stream & \case+      Return r -> Return (Return r)+      Effect m -> Effect $ m Control.>>= (Control.return . splitAt n)+      Step f -> Step $ Control.fmap (splitAt (n-1)) f+    _ -> Return stream+{-# INLINABLE splitAt #-}++{-| Split a stream of elements wherever a given element arises.+    The action is like that of 'Prelude.words'.++@+\>\>\> S.stdoutLn $ mapped S.toList $ S.split ' ' $ each' "hello world  "+hello+world+@+-}+split :: forall a m r. (Eq a, Control.Monad m) =>+  a -> Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r+split x stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ m Control.>>= (Control.return . split x)+      Step (a :> as) -> case a == x of+        True -> split x as+        False -> consFirstChunk a (split x as)+{-# INLINABLE split #-}++{-| Break a sequence upon meeting an element that falls under a predicate,+    keeping it and the rest of the stream as the return value.++@+\>\>\> rest <- S.print $ S.break even $ each' [1,1,2,3]+1+1+\>\>\> S.print rest+2+3+@+-}+break :: forall a m r. Control.Monad m =>+  (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)+break f stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)+    loop stream = stream & \case+      Return r -> Return (Return r)+      Effect m -> Effect $ Control.fmap (break f) m+      Step (a :> as) -> case f a of+        True -> Return $ Step (a :> as)+        False -> Step (a :> (break f as))+{-# INLINABLE break #-}++{-| Break during periods where the predicate is not satisfied,+   grouping the periods when it is.++@+\>\>\> S.print $ mapped S.toList $ S.breaks not $ S.each' [False,True,True,False,True,True,False]+[True,True]+[True,True]+\>\>\> S.print $ mapped S.toList $ S.breaks id $ S.each' [False,True,True,False,True,True,False]+[False]+[False]+[False]+@+-}+breaks :: forall a m r. Control.Monad m =>+  (a -> Bool) -> Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r+breaks f stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap (breaks f) m+      Step (a :> as) -> case f a of+        True -> breaks f as+        False -> consFirstChunk a (breaks f as)+{-# INLINABLE breaks #-}++-- Remark. The funny type of this seems to be made to interoperate well with+-- `purely` from the `foldl` package.+--+{-| Yield elements, using a fold to maintain state, until the accumulated+   value satifies the supplied predicate. The fold will then be short-circuited+   and the element that breaks it will be put after the break.+   This function is easiest to use with 'Control.Foldl.purely'++@+\>\>\> rest <- each' [1..10] & L.purely S.breakWhen L.sum (>10) & S.print+1+2+3+4+\>\>\> S.print rest+5+6+7+8+9+10+@+-}+breakWhen :: forall m a x b r. Control.Monad m+          => (x -> a -> x) -> x -> (x -> b) -> (b -> Bool)+          -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)+breakWhen step x end pred stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)+    loop stream = stream & \case+      Return r -> Return (Return r)+      Effect m -> Effect $ Control.fmap (breakWhen step x end pred) m+      Step (a :> as) -> case pred (end (step x a)) of+        False -> Step $ a :> (breakWhen step (step x a) end pred as)+        True -> Return (Step (a :> as))+{-# INLINABLE breakWhen #-}++-- | Breaks on the first element to satisfy the predicate+breakWhen' :: Control.Monad m =>+  (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)+breakWhen' f stream = breakWhen (\_ a -> f a) True id id stream+{-# INLINE breakWhen' #-}++-- | Stream elements until one fails the condition, return the rest.+span :: Control.Monad m =>+  (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m (Stream (Of a) m r)+span f = break (Prelude.not Prelude.. f)+{-# INLINE span #-}++{-| Group elements of a stream in accordance with the supplied comparison.++@+\>\>\> S.print $ mapped S.toList $ S.groupBy (>=) $ each' [1,2,3,1,2,3,4,3,2,4,5,6,7,6,5]+[1]+[2]+[3,1,2,3]+[4,3,2,4]+[5]+[6]+[7,6,5]+@+-}+groupBy :: forall a m r. Control.Monad m =>+  (a -> a -> Bool) -> Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r+groupBy equals stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap (groupBy equals) m+      Step (a :> as) -> as & \case+        Return r -> Step (Step (a :> Return (Return r)))+        Effect m -> Effect $+          m Control.>>= (\s -> Control.return $ groupBy equals (Step (a :> s)))+        Step (a' :> as') -> case equals a a' of+          False ->+            Step $ Step $ a :> (Return $ groupBy equals (Step (a' :> as')))+          True ->+            Step $ Step $ a :> (Step $ a' :> (Return $ groupBy equals as'))+{-# INLINABLE groupBy #-}++{-| Group successive equal items together++@+\>\>\> S.toList $ mapped S.toList $ S.group $ each' "baaaaad"+["b","aaaaa","d"] :> ()+@++@+\>\>\> S.toList $ concats $ maps (S.drained . S.splitAt 1) $ S.group $ each' "baaaaaaad"+"bad" :> ()+@+-}+group :: (Control.Monad m, Eq a) =>+  Stream (Of a) m r %1-> Stream (Stream (Of a) m) m r+group = groupBy (==)+{-# INLINE group #-}++-- # Sum and compose manipulation+-------------------------------------------------------------------------------++-- Remark. Most of these functions are general and were merely cut and pasted+-- from the original library.++distinguish :: (a -> Bool) -> Of a r -> Sum (Of a) (Of a) r+distinguish predicate (a :> b) = case predicate a of+  True -> InR (a :> b)+  False -> InL (a :> b)+{-# INLINE distinguish #-}++{-| Swap the order of functors in a sum of functors.++@+\>\>\> S.toList $ S.print $ separate $ maps S.switch $ maps (S.distinguish (=='a')) $ S.each' "banana"+'a'+'a'+'a'+"bnn" :> ()+\>\>\> S.toList $ S.print $ separate $ maps (S.distinguish (=='a')) $ S.each' "banana"+'b'+'n'+'n'+"aaa" :> ()+@+-}+switch :: Sum f g r -> Sum g f r+switch s = case s of InL a -> InR a; InR a -> InL a+{-# INLINE switch #-}++sumToEither :: Sum (Of a) (Of b) r ->  Of (Either a b) r+sumToEither s = case s of+  InL (a :> r) -> Left a :> r+  InR (b :> r) -> Right b :> r+{-# INLINE sumToEither #-}++eitherToSum :: Of (Either a b) r -> Sum (Of a) (Of b) r+eitherToSum s = case s of+  Left a :> r  -> InL (a :> r)+  Right b :> r -> InR (b :> r)+{-# INLINE eitherToSum #-}++composeToSum ::  Compose (Of Bool) f r -> Sum f f r+composeToSum x = case x of+  Compose (True :> f) -> InR f+  Compose (False :> f) -> InL f+{-# INLINE composeToSum #-}++sumToCompose :: Sum f f r -> Compose (Of Bool) f r+sumToCompose x = case x of+  InR f -> Compose (True :> f)+  InL f -> Compose (False :> f)+{-# INLINE sumToCompose #-}++{-| Given a stream on a sum of functors, make it a stream on the left functor,+    with the streaming on the other functor as the governing monad. This is+    useful for acting on one or the other functor with a fold, leaving the+    other material for another treatment. It generalizes+    'Data.Either.partitionEithers', but actually streams properly.++@+\>\>\> let odd_even = S.maps (S.distinguish even) $ S.each' [1..10::Int]+\>\>\> :t separate odd_even+separate odd_even+  :: Monad m => Stream (Of Int) (Stream (Of Int) m) ()+@++    Now, for example, it is convenient to fold on the left and right values separately:++@+\>\>\> S.toList $ S.toList $ separate odd_even+[2,4,6,8,10] :> ([1,3,5,7,9] :> ())+@++   Or we can write them to separate files or whatever.++   Of course, in the special case of @Stream (Of a) m r@, we can achieve the above+   effects more simply by using 'Streaming.Prelude.copy'++@+\>\>\> S.toList . S.filter even $ S.toList . S.filter odd $ S.copy $ each' [1..10::Int]+[2,4,6,8,10] :> ([1,3,5,7,9] :> ())+@++    But 'separate' and 'unseparate' are functor-general.++-}+separate :: forall m f g r.+  (Control.Monad m, Control.Functor f, Control.Functor g) =>+  Stream (Sum f g) m r -> Stream f (Stream g m) r+separate stream = destroyExposed stream fromSum (Effect . Control.lift) Return+  where+    fromSum :: Sum f g (Stream f (Stream g m) r) %1-> (Stream f (Stream g m) r)+    fromSum x = x & \case+      InL fss -> Step fss+      InR gss -> Effect (Step $ Control.fmap Return gss)+{-# INLINABLE separate #-}++unseparate :: (Control.Monad m, Control.Functor f, Control.Functor g) =>+  Stream f (Stream g m) r -> Stream (Sum f g) m r+unseparate stream =+  destroyExposed stream (Step . InL) (Control.join . maps InR) Control.return+{-# INLINABLE unseparate #-}++-- # Partitions+-------------------------------------------------------------------------------++{-|+> filter p = hoist effects (partition p)++ -}+partition :: forall a m r. Control.Monad m =>+  (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r+partition pred = loop+  where+    loop :: Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect (Control.fmap loop (Control.lift m))+      Step (a :> as) -> case pred a of+        True -> Step (a :> loop as)+        False -> Effect $ Step $ a :> (Return (loop as))++{-| Separate left and right values in distinct streams. ('separate' is+    a more powerful, functor-general, equivalent using 'Sum' in place of 'Either').++> partitionEithers = separate . maps S.eitherToSum+> lefts  = hoist S.effects . partitionEithers+> rights = S.effects . partitionEithers+> rights = S.concat++-}+partitionEithers :: Control.Monad m =>+  Stream (Of (Either a b)) m r %1-> Stream (Of a) (Stream (Of b) m) r+partitionEithers = loop+  where+    loop :: Control.Monad m =>+      Stream (Of (Either a b)) m r %1-> Stream (Of a) (Stream (Of b) m) r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap loop (Control.lift m)+      Step (Left a :> as) -> Step (a :> loop as)+      Step (Right b :> as) -> Effect $ (Step $ b :> Return (loop as))+++-- # Maybes+-------------------------------------------------------------------------------++{-| The 'catMaybes' function takes a 'Stream' of 'Maybe's and returns+    a 'Stream' of all of the 'Just' values. 'concat' has the same behavior,+    but is more general; it works for any foldable container type.+-}+catMaybes :: Control.Monad m => Stream (Of (Maybe a)) m r %1-> Stream (Of a) m r+catMaybes stream = loop stream+  where+    loop :: Control.Monad m => Stream (Of (Maybe a)) m r %1-> Stream (Of a) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap catMaybes m+      Step (maybe :> as) -> case maybe of+        Nothing -> catMaybes as+        Just a -> Step $ a :> (catMaybes as)+{-# INLINABLE catMaybes #-}++{-| The 'mapMaybe' function is a version of 'map' which can throw out elements. In particular,+    the functional argument returns something of type @'Maybe' b@. If this is 'Nothing', no element+    is added on to the result 'Stream'. If it is @'Just' b@, then @b@ is included in the result 'Stream'.++-}+mapMaybe :: forall a b m r. Control.Monad m =>+  (a -> Maybe b) -> Stream (Of a) m r %1-> Stream (Of b) m r+mapMaybe f stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> Stream (Of b) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect ms -> Effect $ ms Control.>>= (Control.return . mapMaybe f)+      Step (a :> s) -> case f a of+        Just b -> Step $ b :> (mapMaybe f s)+        Nothing -> mapMaybe f s+{-# INLINABLE mapMaybe #-}++-- Note: the first function needs to wrap the 'b' in an 'Ur'+-- since the control monad is bound and the 'b' ends up in the first+-- unrestricted spot of 'Of'.+--+-- | Map monadically over a stream, producing a new stream+--   only containing the 'Just' values.+mapMaybeM :: forall a m b r. Control.Monad m =>+  (a -> m (Maybe (Ur b))) -> Stream (Of a) m r %1-> Stream (Of b) m r+mapMaybeM f stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> Stream (Of b) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap (mapMaybeM f) m+      Step (a :> as) -> Effect $ Control.do+        mb <- f a+        mb & \case+          Nothing -> Control.return $ mapMaybeM f as+          Just (Ur b) -> Control.return $ Step (b :> mapMaybeM f as)+{-# INLINABLE mapMaybeM #-}++-- # Direct Transformations+-------------------------------------------------------------------------------++{-| Change the effects of one monad to another with a transformation.+    This is one of the fundamental transformations on streams.+    Compare with 'maps':++> maps  :: (Control.Monad m, Control.Functor f) => (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r+> hoist :: (Control.Monad m, Control.Functor f) => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r++-}+hoist :: forall f m n r. (Control.Monad m, Control.Functor f) =>+  (forall a. m a %1-> n a) ->+  Stream f m r %1-> Stream f n r+hoist f stream = loop stream where+  loop :: Stream f m r %1-> Stream f n r+  loop stream = stream & \case+    Return r -> Return r+    Effect m -> Effect $ f $ Control.fmap loop m+    Step f -> Step $ Control.fmap loop f+{-# INLINABLE hoist #-}++{-| Standard map on the elements of a stream.++@+\>\>\> S.stdoutLn $ S.map reverse $ each' (words "alpha beta")+ahpla+ateb+@+-}+map :: Control.Monad m => (a -> b) -> Stream (Of a) m r %1-> Stream (Of b) m r+map f = maps (\(x :> rest) -> f x :> rest)+{-# INLINABLE map #-}++-- Remark.+--+-- The functor transformation in functions like maps, mapped, mapsPost,+-- and such must be linear since the 'Stream' data type holds each+-- functor step with a linear arrow.++{- | Map layers of one functor to another with a transformation. Compare+     hoist, which has a similar effect on the 'monadic' parameter.++> maps id = id+> maps f . maps g = maps (f . g)++-}+maps :: forall f g m r . (Control.Monad m, Control.Functor f) =>+  (forall x . f x %1-> g x) -> Stream f m r %1-> Stream g m r+maps phi = loop+  where+    loop :: Stream f m r %1-> Stream g m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap (maps phi) m+      Step f -> Step (phi (Control.fmap loop f))+{-# INLINABLE maps #-}++-- Remark: Since the mapping function puts its result in a control monad,+-- it must be used exactly once after the monadic value is bound.+-- As a result the mapping function needs to return an 'Ur b'+-- so that we can place the 'b' in the first argument of the+-- 'Of' constructor, which is unrestricted.+--+{-| Replace each element of a stream with the result of a monadic action++@+\>\>\> S.print $ S.mapM readIORef $ S.chain (\ior -> modifyIORef ior (*100)) $ S.mapM newIORef $ each' [1..6]+100+200+300+400+500+600+@++See also 'chain' for a variant of this which ignores the return value of the function and just uses the side effects.+-}+mapM :: Control.Monad m =>+  (a -> m (Ur b)) -> Stream (Of a) m r %1-> Stream (Of b) m r+mapM f s = loop f s+  where+    loop :: Control.Monad m =>+      (a -> m (Ur b)) -> Stream (Of a) m r %1-> Stream (Of b) m r+    loop f stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap (loop f) m+      Step (a :> as) -> Effect $ Control.do+        Ur b <- f a+        Control.return $ Step (b :> (loop f as))+{-# INLINABLE mapM #-}++{- | Map layers of one functor to another with a transformation. Compare+     hoist, which has a similar effect on the 'monadic' parameter.++> mapsPost id = id+> mapsPost f . mapsPost g = mapsPost (f . g)+> mapsPost f = maps f++     @mapsPost@ is essentially the same as 'maps', but it imposes a @Control.Functor@ constraint on+     its target functor rather than its source functor. It should be preferred if 'fmap'+     is cheaper for the target functor than for the source functor.+-}+mapsPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>+  (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r+mapsPost phi = loop+  where+    loop :: Stream f m r %1-> Stream g m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap loop m+      Step f -> Step $ Control.fmap loop $ phi f+{-# INLINABLE mapsPost #-}++{- | Map layers of one functor to another with a transformation involving the base monad.++     This function is completely functor-general. It is often useful with the more concrete type++@+mapped :: (forall x. Stream (Of a) IO x -> IO (Of b x)) -> Stream (Stream (Of a) IO) IO r -> Stream (Of b) IO r+@++     to process groups which have been demarcated in an effectful, @IO@-based+     stream by grouping functions like 'Streaming.Prelude.group',+     'Streaming.Prelude.split' or 'Streaming.Prelude.breaks'. Summary functions+     like 'Streaming.Prelude.fold', 'Streaming.Prelude.foldM',+     'Streaming.Prelude.mconcat' or 'Streaming.Prelude.toList' are often used+     to define the transformation argument. For example:++@+\>\>\> S.toList_ $ S.mapped S.toList $ S.split 'c' (S.each' "abcde")+["ab","de"]+@++     'Streaming.Prelude.maps' and 'Streaming.Prelude.mapped' obey these rules:++> maps id              = id+> mapped return        = id+> maps f . maps g      = maps (f . g)+> mapped f . mapped g  = mapped (f <=< g)+> maps f . mapped g    = mapped (fmap f . g)+> mapped f . maps g    = mapped (f <=< fmap g)++     where @f@ and @g@ are @Control.Monad@s++     'Streaming.Prelude.maps' is more fundamental than+     'Streaming.Prelude.mapped', which is best understood as a convenience for+     effecting this frequent composition:++> mapped phi = decompose . maps (Compose . phi)+++-}+mapped :: forall f g m r . (Control.Monad m, Control.Functor f) =>+  (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r+mapped phi = loop+  where+  loop :: Stream f m r %1-> Stream g m r+  loop stream = stream & \case+    Return r -> Return r+    Effect m -> Effect $ Control.fmap loop m+    Step f -> Effect $ Control.fmap Step $ phi $ Control.fmap loop f++{- | Map layers of one functor to another with a transformation involving the base monad.+     @mapsMPost@ is essentially the same as 'mapsM', but it imposes a @Control.Functor@ constraint on+     its target functor rather than its source functor. It should be preferred if 'fmap'+     is cheaper for the target functor than for the source functor.++     @mapsPost@ is more fundamental than @mapsMPost@, which is best understood as a convenience+     for effecting this frequent composition:++> mapsMPost phi = decompose . mapsPost (Compose . phi)++     The streaming prelude exports the same function under the better name @mappedPost@,+     which overlaps with the lens libraries.++-}+{-# INLINABLE mapped #-}++mapsMPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>+  (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r+mapsMPost phi = loop+  where+  loop :: Stream f m r %1-> Stream g m r+  loop stream = stream & \case+    Return r -> Return r+    Effect m -> Effect $ Control.fmap loop m+    Step f -> Effect $ Control.fmap (Step . Control.fmap loop) $ phi f+{-# INLINABLE mapsMPost #-}++{-| A version of 'mapped' that imposes a @Control.Functor@ constraint on the target functor rather+    than the source functor. This version should be preferred if 'fmap' on the target+    functor is cheaper.++-}+mappedPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>+  (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r+mappedPost phi = loop+  where+  loop :: Stream f m r %1-> Stream g m r+  loop stream = stream & \case+    Return r -> Return r+    Effect m -> Effect $ Control.fmap loop m+    Step f -> Effect $ Control.fmap (Step . Control.fmap loop) $ phi f+{-# INLINABLE mappedPost #-}++-- | @for@ replaces each element of a stream with an associated stream. Note that the+-- associated stream may layer any control functor.+for :: forall f m r a x . (Control.Monad m, Control.Functor f, Consumable x) =>+  Stream (Of a) m r %1-> (a -> Stream f m x) -> Stream f m r+for stream expand = loop stream+  where+    loop :: Stream (Of a) m r %1-> Stream f m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap loop m+      Step (a :> as) -> Control.do+         x <- expand a+         lseq x $ loop as+{-# INLINABLE for #-}++-- Note: since the 'x' is discarded inside a control functor,+-- we need it to be consumable+--+{-| Replace each element in a stream of individual Haskell values (a @Stream (Of a) m r@) with an associated 'functorial' step.++> for str f  = concats (with str f)+> with str f = for str (yields . f)+> with str f = maps (\(a:>r) -> r <$ f a) str+> with = flip subst+> subst = flip with++@+\>\>\> with (each' [1..3]) (yield . Prelude.show) & intercalates (yield "--") & S.stdoutLn+1+--+2+--+3+@+ -}+with :: forall f m r a x . (Control.Monad m, Control.Functor f, Consumable x) =>+  Stream (Of a) m r %1-> (a -> f x) -> Stream f m r+with s f = loop s+  where+    loop :: Stream (Of a) m r %1-> Stream f m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap loop m+      Step (a :> as) -> Step $ Control.fmap (`lseq` (loop as)) (f a)+{-# INLINABLE with #-}++{-| Replace each element in a stream of individual values with a functorial+    layer of any sort. @subst = flip with@ and is more convenient in+    a sequence of compositions that transform a stream.++> with = flip subst+> for str f = concats $ subst f str+> subst f = maps (\(a:>r) -> r <$ f a)+> S.concat = concats . subst each++-}+subst :: (Control.Monad m, Control.Functor f, Consumable x) =>+  (a -> f x) -> Stream (Of a) m r %1-> Stream f m r+subst = flip with where+  flip :: (a %1-> b -> c) -> b -> a %1-> c+  flip f b a = f a b+{-# INLINE subst #-}++{-| Duplicate the content of a stream, so that it can be acted on twice in different ways,+    but without breaking streaming. Thus, with @each' [1,2]@ I might do:++@+\>\>\> S.print $ each' ["one","two"]+"one"+"two"+\>\>\> S.stdoutLn $ each' ["one","two"]+one+two+@++    With copy, I can do these simultaneously:++@+\>\>\> S.print $ S.stdoutLn $ S.copy $ each' ["one","two"]+"one"+one+"two"+two+@++    'copy' should be understood together with 'effects' and is subject to the rules++> S.effects . S.copy       = id+> hoist S.effects . S.copy = id++    The similar operations in 'Data.ByteString.Streaming' obey the same rules.++    Where the actions you are contemplating are each simple folds over+    the elements, or a selection of elements, then the coupling of the+    folds is often more straightforwardly effected with `Control.Foldl`,+    e.g.++@+\>\>\> L.purely S.fold (liftA2 (,) L.sum L.product) $ each' [1..10]+(55,3628800) :> ()+@++    rather than++@+\>\>\> S.sum $ S.product . S.copy $ each' [1..10]+55 :> (3628800 :> ())+@++    A @Control.Foldl@ fold can be altered to act on a selection of elements by+    using 'Control.Foldl.handles' on an appropriate lens. Some such+    manipulations are simpler and more 'Data.List'-like, using 'copy':++@+\>\>\> L.purely S.fold (liftA2 (,) (L.handles (L.filtered odd) L.sum) (L.handles (L.filtered even) L.product)) $ each' [1..10]+(25,3840) :> ()+@++     becomes++@+\>\>\> S.sum $ S.filter odd $ S.product $ S.filter even $ S.copy' $ each' [1..10]+25 :> (3840 :> ())+@++    or using 'store'++@+\>\>\> S.sum $ S.filter odd $ S.store (S.product . S.filter even) $ each' [1..10]+25 :> (3840 :> ())+@++    But anything that fold of a @Stream (Of a) m r@ into e.g. an @m (Of b r)@+    that has a constraint on @m@ that is carried over into @Stream f m@ -+    e.g. @Control.Monad@, @Control.Functor@, etc. can be used on the stream.+    Thus, I can fold over different groupings of the original stream:++@+\>\>\>  (S.toList . mapped S.toList . chunksOf 5) $  (S.toList . mapped S.toList . chunksOf 3) $ S.copy $ each' [1..10]+[[1,2,3,4,5],[6,7,8,9,10]] :> ([[1,2,3],[4,5,6],[7,8,9],[10]] :> ())+@++    The procedure can be iterated as one pleases, as one can see from this (otherwise unadvisable!) example:++@+\>\>\>  (S.toList . mapped S.toList . chunksOf 4) $ (S.toList . mapped S.toList . chunksOf 3) $ S.copy $ (S.toList . mapped S.toList . chunksOf 2) $ S.copy $ each' [1..12]+[[1,2,3,4],[5,6,7,8],[9,10,11,12]] :> ([[1,2,3],[4,5,6],[7,8,9],[10,11,12]] :> ([[1,2],[3,4],[5,6],[7,8],[9,10],[11,12]] :> ()))+@++@copy@ can be considered a special case of 'expand':++@+  copy = 'expand' $ \p (a :> as) -> a :> p (a :> as)+@++If 'Of' were an instance of 'Control.Comonad.Comonad', then one could write++@+  copy = 'expand' extend+@+-}+copy :: forall a m r . Control.Monad m =>+     Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r+copy = Effect . Control.return . loop+  where+    loop :: Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap loop (Control.lift m)+      Step (a :> as) -> Effect $ Step (a :> Return (Step (a :> loop as)))+{-# INLINABLE copy#-}++{-| An alias for @copy@.+-}+duplicate :: forall a m r . Control.Monad m =>+     Stream (Of a) m r %1-> Stream (Of a) (Stream (Of a) m) r+duplicate = copy+{-# INLINE duplicate#-}+++-- Note: to use the stream linearly the first argument+-- must be a linear function+--+{-| Store the result of any suitable fold over a stream, keeping the stream for+    further manipulation. @store f = f . copy@ :++@+\>\>\> S.print $ S.store S.product $ each' [1..4]+1+2+3+4+24 :> ()+@++@+\>\>\> S.print $ S.store S.sum $ S.store S.product $ each' [1..4]+1+2+3+4+10 :> (24 :> ())+@++   Here the sum (10) and the product (24) have been \'stored\' for use when+   finally we have traversed the stream with 'print' . Needless to say,+   a second 'pass' is excluded conceptually, so the+   folds that you apply successively with @store@ are performed+   simultaneously, and in constant memory -- as they would be if,+   say, you linked them together with @Control.Fold@:++@+\>\>\> L.impurely S.foldM (liftA3 (\a b c -> (b, c)) (L.sink Prelude.print) (L.generalize L.sum) (L.generalize L.product)) $ each' [1..4]+1+2+3+4+(10,24) :> ()+@++   Fusing folds after the fashion of @Control.Foldl@ will generally be a bit faster+   than the corresponding succession of uses of 'store', but by+   constant factor that will be completely dwarfed when any IO is at issue.++   But 'store' \/ 'copy' is /much/ more powerful, as you can see by reflecting on+   uses like this:++@+\>\>\> S.sum $ S.store (S.sum . mapped S.product . chunksOf 2) $ S.store (S.product . mapped S.sum . chunksOf 2) $ each' [1..6]+21 :> (44 :> (231 :> ()))+@++   It will be clear that this cannot be reproduced with any combination of lenses,+   @Control.Fold@ folds, or the like.  (See also the discussion of 'copy'.)++   It would conceivably be clearer to import a series of specializations of 'store'.+   It is intended to be used at types like this:++> storeM ::  (forall s m . Control.Monad m => Stream (Of a) m s %1-> m (Of b s))+>         -> (Control.Monad n => Stream (Of a) n r %1-> Stream (Of a) n (Of b r))+> storeM = store++    It is clear from this type that we are just using the general instance:++> instance (Control.Functor f, Control.Monad m)   => Control.Monad (Stream f m)++    We thus can't be touching the elements of the stream, or the final return value.+    It is the same with other constraints that @Stream (Of a)@ inherits from the underlying monad.+    Thus I can independently filter and write to one file, but+    nub and write to another, or interact with a database and a logfile and the like:++@+\>\>\> (S.writeFile "hello2.txt" . S.nubOrd) $ store (S.writeFile "hello.txt" . S.filter (/= "world")) $ each' ["hello", "world", "goodbye", "world"]+\>\>\> :! cat hello.txt+hello+goodbye+\>\>\> :! cat hello2.txt+hello+world+goodbye+@++-}+store :: Control.Monad m =>+  (Stream (Of a) (Stream (Of a) m) r %1-> t) -> Stream (Of a) m r %1-> t+store f x = f (copy x)+{-# INLINE store #-}++-- Note: since we discard the 'y' inside a control monad, it needs to be+-- consumable+--+{-| Apply an action to all values, re-yielding each.+    The return value (@y@) of the function is ignored.++@+\>\>\> S.product $ S.chain Prelude.print $ S.each' [1..5]+1+2+3+4+5+120 :> ()+@++See also 'mapM' for a variant of this which uses the return value of the function to transorm the values in the stream.+-}+chain :: forall a m r y . (Control.Monad m, Consumable y) =>+  (a -> m y) -> Stream (Of a) m r %1-> Stream (Of a) m r+chain f = loop+  where+    loop :: Stream (Of a) m r %1-> Stream (Of a) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m  -> Effect $ Control.fmap loop m+      Step (a :> as) -> Effect $ Control.do+        y <- f a+        Control.return $ lseq y $ Step (a :> loop as)+{-# INLINABLE chain #-}++-- Note: since the value of type 'a' is inside a control monad but+-- needs to be used in an unrestricted position in 'Of', the input stream+-- needs to hold values of type 'm (Ur a)'.+--+{-| Like the 'Data.List.sequence' but streaming. The result type is a+    stream of a\'s, /but is not accumulated/; the effects of the elements+    of the original stream are interleaved in the resulting stream. Compare:++> sequence :: Monad m =>         [m a]                 ->  m [a]+> sequence :: Control.Monad m => Stream (Of (m a)) m r %1-> Stream (Of a) m r++-}+sequence :: forall a m r . Control.Monad m =>+  Stream (Of (m (Ur a))) m r %1-> Stream (Of a) m r+sequence = loop+  where+    loop :: Stream (Of (m (Ur a))) m r %1-> Stream (Of a) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap loop m+      Step (ma :> mas) -> Effect $ Control.do+        Ur a <- ma+        Control.return $ Step (a :> loop mas)+{-# INLINABLE sequence #-}++{-| Remove repeated elements from a Stream. 'nubOrd' of course accumulates a 'Data.Set.Set' of+    elements that have already been seen and should thus be used with care.++-}+nubOrd :: (Control.Monad m, Ord a) => Stream (Of a) m r %1-> Stream (Of a) m r+nubOrd = nubOrdOn id+{-# INLINE nubOrd #-}++{-|  Use 'nubOrdOn' to have a custom ordering function for your elements. -}+nubOrdOn :: forall m a b r . (Control.Monad m, Ord b) =>+  (a -> b) -> Stream (Of a) m r %1-> Stream (Of a) m r+nubOrdOn f xs = loop Set.empty xs+  where+  loop :: Set.Set b -> Stream (Of a) m r %1-> Stream (Of a) m r+  loop !set stream = stream & \case+    Return r -> Return r+    Effect m -> Effect $ Control.fmap (loop set) m+    Step (a :> as) -> case Set.member (f a) set of+         True -> loop set as+         False-> Step (a :> loop (Set.insert (f a) set) as)++{-| More efficient versions of above when working with 'Int's that use 'Data.IntSet.IntSet'. -}+nubInt :: Control.Monad m => Stream (Of Int) m r %1-> Stream (Of Int) m r+nubInt = nubIntOn id+{-# INLINE nubInt #-}++nubIntOn :: forall m a r . (Control.Monad m) =>+  (a -> Int) -> Stream (Of a) m r %1-> Stream (Of a) m r+nubIntOn f xs = loop IntSet.empty xs+  where+  loop :: IntSet.IntSet -> Stream (Of a) m r %1-> Stream (Of a) m r+  loop !set stream = stream & \case+    Return r -> Return r+    Effect m -> Effect $ Control.fmap (loop set) m+    Step (a :> as) -> case IntSet.member (f a) set of+         True -> loop set as+         False-> Step (a :> loop (IntSet.insert (f a) set) as)++-- | Skip elements of a stream that fail a predicate+filter  :: forall a m r . Control.Monad m =>+  (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m r+filter pred = loop+  where+    loop :: Stream (Of a) m r %1-> Stream (Of a) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap loop m+      Step (a :> as) -> case pred a of+        True -> Step (a :> loop as)+        False -> loop as+{-# INLINE filter #-}++-- | Skip elements of a stream that fail a monadic test+filterM  :: forall a m r . Control.Monad m =>+  (a -> m Bool) -> Stream (Of a) m r %1-> Stream (Of a) m r+filterM pred = loop+  where+    loop :: Stream (Of a) m r %1-> Stream (Of a) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m-> Effect $ Control.fmap loop m+      Step (a :> as) -> Effect $ Control.do+        bool <- pred a+        bool & \case+          True -> Control.return $ Step (a :> loop as)+          False -> Control.return $ loop as+{-# INLINE filterM #-}++{-| Intersperse given value between each element of the stream.++@+\>\>\> S.print $ S.intersperse 0 $ each [1,2,3]+1+0+2+0+3+@++-}+intersperse :: forall a m r . Control.Monad m =>+  a -> Stream (Of a) m r %1-> Stream (Of a) m r+intersperse x stream = stream & \case+    Return r -> Return r+    Effect m -> Effect $ Control.fmap (intersperse x) m+    Step (a :> as) -> loop a as+  where+    -- Given the first element of a stream, intersperse the bound+    -- element named 'x'+    loop :: a -> Stream (Of a) m r %1-> Stream (Of a) m r+    loop !a stream = stream & \case+      Return r -> Step (a :> Return r)+      Effect m -> Effect $ Control.fmap (loop a) m+      Step (a' :> as) -> Step (a :> Step (x :> loop a' as))+{-# INLINABLE intersperse #-}++{-|  Ignore the first n elements of a stream, but carry out the actions++@+\>\>\> S.toList $ S.drop 2 $ S.replicateM 5 getLine+a<Enter>+b<Enter>+c<Enter>+d<Enter>+e<Enter>+["c","d","e"] :> ()+@++     Because it retains the final return value, @drop n@  is a suitable argument+     for @maps@:++@+\>\>\> S.toList $ concats $ maps (S.drop 4) $ chunksOf 5 $ each [1..20]+[5,10,15,20] :> ()+@+  -}+drop :: forall a m r. (HasCallStack, Control.Monad m) =>+  Int -> Stream (Of a) m r %1-> Stream (Of a) m r+drop n stream = case compare n 0 of+  LT -> Prelude.error "drop called with negative int" $ stream+  EQ -> stream+  GT -> loop stream where+    loop :: Stream (Of a) m r %1-> Stream (Of a) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap (drop n) m+      Step (_ :> as) -> drop (n-1) as+{-# INLINABLE drop #-}++{- | Ignore elements of a stream until a test succeeds, retaining the rest.++@+\>\>\> S.print $ S.dropWhile ((< 5) . length) S.stdinLn+one<Enter>+two<Enter>+three<Enter>+"three"+four<Enter>+"four"+^CInterrupted.+@++-}+dropWhile :: forall a m r . Control.Monad m =>+  (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m r+dropWhile pred = loop+  where+    loop :: Stream (Of a) m r %1-> Stream (Of a) m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap loop m+      Step (a :> as) -> case pred a of+        True -> loop as+        False -> Step (a :> as)+{-# INLINABLE dropWhile #-}++{-| Strict left scan, streaming, e.g. successive partial results. The seed+    is yielded first, before any action of finding the next element is performed.++@+\>\>\> S.print $ S.scan (++) "" id $ each' (words "a b c d")+""+"a"+"ab"+"abc"+"abcd"+@++    'scan' is fitted for use with @Control.Foldl@, thus:++@+\>\>\> S.print $ L.purely S.scan L.list $ each' [3..5]+[]+[3]+[3,4]+[3,4,5]+@+-}+scan :: forall a x b m r . Control.Monad m =>+  (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> Stream (Of b) m r+scan step begin done stream = Step (done begin :> loop begin stream)+  where+    loop :: x -> Stream (Of a) m r %1-> Stream (Of b) m r+    loop !acc stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap (loop acc) m+      Step (a :> as) -> Step (done acc' :> loop acc' as) where+        !acc' = step acc a+{-# INLINABLE scan #-}++-- Note: since the accumulated value (inside the control monad) is used both in+-- populating the output stream and in accumulation, it needs to be wrapped in+-- an 'Ur' accross the function+--+{-| Strict left scan, accepting a monadic function. It can be used with+    'FoldM's from @Control.Foldl@ using 'impurely'. Here we yield+    a succession of vectors each recording++@+\>\>\> let v = L.impurely scanM L.vectorM $ each' [1..4::Int] :: Stream (Of (Vector Int)) IO ()+\>\>\> S.print v+[]+[1]+[1,2]+[1,2,3]+[1,2,3,4]+@+-}+scanM :: forall a x b m r . Control.Monad m =>+  (x %1-> a -> m (Ur x)) ->+  m (Ur x) ->+  (x %1-> m (Ur b)) ->+  Stream (Of a) m r %1->+  Stream (Of b) m r+scanM step mx done stream = loop stream+  where+    loop :: Stream (Of a) m r %1-> Stream (Of b) m r+    loop stream = stream & \case+      Return r -> Effect $ Control.do+        Ur x <- mx+        Ur b <- done x+        Control.return $ Step $ b :> Return r+      Effect m -> Effect $ Control.fmap (scanM step mx done) m+      Step (a :> as) -> Effect $ Control.do+        Ur x <- mx+        Ur b <- done x+        Control.return $ Step $ b :> (scanM step (step x a) done as)+{-# INLINABLE scanM #-}++{-| Label each element in a stream with a value accumulated according to a fold.++@+\>\>\> S.print $ S.scanned (*) 1 id $ S.each' [100,200,300]+(100,100)+(200,20000)+(300,6000000)+@++@+\>\>\> S.print $ L.purely S.scanned' L.product $ S.each [100,200,300]+(100,100)+(200,20000)+(300,6000000)+@+-}+scanned :: forall a x b m r . Control.Monad m =>+  (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> Stream (Of (a,b)) m r+scanned step begin done = loop begin+  where+    loop :: x -> Stream (Of a) m r %1-> Stream (Of (a,b)) m r+    loop !x stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap (loop x) m+      Step (a :> as) -> Control.do+        let !acc = done (step x a)+        Step $ (a, acc) :> Return () -- same as yield+        loop (step x a) as+{-# INLINABLE scanned #-}++-- Note: this skips failed parses+-- XXX re-write with Text+--+{- | Make a stream of strings into a stream of parsed values, skipping bad cases++@+\>\>\> S.sum_ $ S.read $ S.takeWhile (/= "total") S.stdinLn :: IO Int+1000<Enter>+2000<Enter>+total<Enter>+3000+@++-}+read :: (Control.Monad m, Read a) =>+  Stream (Of String) m r %1-> Stream (Of a) m r+read = mapMaybe readMaybe+{-# INLINE read #-}++{-| Interpolate a delay of n seconds between yields.+-}+delay :: forall a r. Double -> Stream (Of a) IO r %1-> Stream (Of a) IO r+delay seconds = loop+  where+    pico = Prelude.truncate (seconds * 1000000)+    loop :: Stream (Of a) IO r %1-> Stream (Of a) IO r+    loop stream = Control.do+      e <- Control.lift $ next stream+      e & \case+        Left r -> Return r+        Right (Ur a,rest) -> Control.do+          Step (a :> Return ()) -- same as yield+          Control.lift $ fromSystemIO $ threadDelay pico+          loop rest+{-# INLINABLE delay #-}++show :: (Control.Monad m, Prelude.Show a) =>+  Stream (Of a) m r %1-> Stream (Of String) m r+show = map Prelude.show+{-# INLINE show #-}+++{-| The natural @cons@ for a @Stream (Of a)@.++> cons a stream = yield a Control.>> stream++   Useful for interoperation:++> Data.Text.foldr S.cons (return ()) :: Text -> Stream (Of Char) m ()+> Lazy.foldrChunks S.cons (return ()) :: Lazy.ByteString -> Stream (Of Strict.ByteString) m ()++    and so on.+-}+cons :: Control.Monad m => a -> Stream (Of a) m r %1-> Stream (Of a) m r+cons a str = Step (a :> str)+{-# INLINE cons #-}++-- Note. The action function that is the second argument must be linear since+-- it gets its argument from binding to the first argument, which uses a+-- control monad.+--+{-| Before evaluating the monadic action returning the next step in the 'Stream', @wrapEffect@+    extracts the value in a monadic computation @m a@ and passes it to a computation @a -> m y@.++-}+wrapEffect :: (Control.Monad m, Control.Functor f, Consumable y) =>+  m a -> (a %1-> m y) -> Stream f m r %1-> Stream f m r+wrapEffect ma action stream = stream & \case+  Return r -> Return r+  Effect m -> Effect $ Control.do+    a <- ma+    y <- action a+    lseq y $ m+  Step f -> Effect $ Control.do+    a <- ma+    y <- action a+    Control.return $ lseq y $ Step f++{-| 'slidingWindow' accumulates the first @n@ elements of a stream,+     update thereafter to form a sliding window of length @n@.+     It follows the behavior of the slidingWindow function in+     <https://hackage.haskell.org/package/conduit-combinators-1.0.4/docs/Data-Conduit-Combinators.html#v:slidingWindow conduit-combinators>.++@+\>\>\> S.print $ S.slidingWindow 4 $ S.each "123456"+fromList "1234"+fromList "2345"+fromList "3456"+@+-}+slidingWindow :: forall a b m. Control.Monad m => Int -> Stream (Of a) m b+              %1-> Stream (Of (Seq.Seq a)) m b+slidingWindow n = setup (max 1 n :: Int) Seq.empty+  where+    -- Given the current sliding window, yield it and then recurse with+    -- updated sliding window+    window :: Seq.Seq a -> Stream (Of a) m b %1-> Stream (Of (Seq.Seq a)) m b+    window !sequ str = Control.do+      e <- Control.lift (next str)+      e & \case+        Left r -> Control.return r+        Right (Ur a,rest) -> Control.do+          Step $ (sequ Seq.|> a) :> Return () -- same as yield+          window (Seq.drop 1 sequ Seq.|> a) rest+    -- Collect the first n elements in a sequence and call 'window'+    setup ::+      Int -> Seq.Seq a -> Stream (Of a) m b %1-> Stream (Of (Seq.Seq a)) m b+    setup 0 !sequ str = Control.do+       Step (sequ :> Return ()) -- same as yield+       window (Seq.drop 1 sequ) str+    setup n' sequ str = Control.do+      e <- Control.lift $ next str+      e & \case+        Left r -> Control.do+          Step (sequ :> Return ()) -- same as yield+          Control.return r+        Right (Ur x,rest) -> setup (n'-1) (sequ Seq.|> x) rest+{-# INLINABLE slidingWindow #-}+
+ src/Streaming/Internal/Produce.hs view
@@ -0,0 +1,486 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module provides all functions which produce a+-- 'Stream (Of a) m r' from some given non-stream inputs.+module Streaming.Internal.Produce+  ( -- * Constructing Finite 'Stream's+    yield+  , each'+  , unfoldr+  , fromHandle+  , readFile+  , replicate+  , replicateM+  , replicateZip+  , untilRight+  -- * Working with infinite 'Stream's+  , stdinLnN+  , stdinLnUntil+  , stdinLnUntilM+  , stdinLnZip+  , readLnN+  , readLnUntil+  , readLnUntilM+  , readLnZip+  , iterateN+  , iterateZip+  , iterateMN+  , iterateMZip+  , cycleN+  , cycleZip+  , enumFromN+  , enumFromZip+  , enumFromThenN+  , enumFromThenZip+  ) where++import Streaming.Internal.Type+import Streaming.Internal.Process+import Streaming.Internal.Consume (effects)+import Prelude.Linear (($), (&))+import Prelude (Either(..), Read, Bool(..), FilePath, Enum, otherwise,+               Num(..), Int, otherwise, Eq(..), Ord(..), fromEnum, toEnum)+import qualified Prelude+import qualified Control.Functor.Linear as Control+import Data.Unrestricted.Linear+import System.IO.Linear+import System.IO.Resource+import qualified System.IO as System+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Stack+++-- # The Finite Stream Constructors+-------------------------------------------------------------------------------++{-| A singleton stream++@+\>\>\> stdoutLn $ yield "hello"+hello+@++@+\>\>\> S.sum $ do {yield 1; yield 2; yield 3}+6 :> ()+@+-}+yield :: Control.Monad m => a -> Stream (Of a) m ()+yield x = Step $ x :> Return ()+{-# INLINE yield #-}++{- | Stream the elements of a pure, foldable container.++@+\>\>\> S.print $ each' [1..3]+1+2+3+@+-}+each' :: Control.Monad m => [a] -> Stream (Of a) m ()+each' xs = Prelude.foldr (\a stream -> Step $ a :> stream) (Return ()) xs+{-# INLINABLE each' #-}++{-| Build a @Stream@ by unfolding steps starting from a seed. In particular note+    that @S.unfoldr S.next = id@.++-}+unfoldr :: Control.Monad m =>+  (s %1-> m (Either r (Ur a, s))) -> s %1-> Stream (Of a) m r+unfoldr step s = unfoldr' step s+  where+    unfoldr' :: Control.Monad m =>+      (s %1-> m (Either r (Ur a, s))) -> s %1-> Stream (Of a) m r+    unfoldr' step s = Effect $ step s Control.>>= \case+      Left r -> Control.return $ Return r+      Right (Ur a,s') ->+        Control.return $ Step $ a :> unfoldr step s'+{-# INLINABLE unfoldr #-}++-- Note: we use the RIO monad from linear base to enforce+-- the protocol of file handles and file I/O+fromHandle :: Handle %1-> Stream (Of Text) RIO ()+fromHandle h = loop h+  where+    loop :: Handle %1-> Stream (Of Text) RIO ()+    loop h = Control.do+      (Ur isEOF, h') <- Control.lift $ hIsEOF h+      case isEOF of+        True -> Control.do+          Control.lift $ hClose h'+          Control.return ()+        False -> Control.do+          (Ur text, h'') <- Control.lift $ hGetLine h'+          yield text+          fromHandle h''+{-# INLINABLE fromHandle #-}++{-| Read the lines of a file given the filename.++-}+readFile :: FilePath -> Stream (Of Text) RIO ()+readFile path = Control.do+  handle <- Control.lift $ openFile path System.ReadMode+  fromHandle handle++-- | Repeat an element several times.+replicate :: (HasCallStack, Control.Monad m) => Int -> a -> Stream (Of a) m ()+replicate n a+  | n < 0 = Prelude.error "Cannot replicate a stream of negative length"+  | otherwise = loop n a+    where+      loop :: Control.Monad m => Int -> a -> Stream (Of a) m ()+      loop n a+        | n == 0 = Return ()+        | otherwise = Effect $ Control.return $ Step $ a :> loop (n-1) a+{-# INLINABLE replicate #-}++{-| Repeat an action several times, streaming its results.++@+\>\>\> import qualified Unsafe.Linear as Unsafe+\>\>\> import qualified Data.Time as Time+\>\>\> let getCurrentTime = fromSystemIO (Unsafe.coerce Time.getCurrentTime)+\>\>\> S.print $ S.replicateM 2 getCurrentTime+2015-08-18 00:57:36.124508 UTC+2015-08-18 00:57:36.124785 UTC+@+-}+replicateM :: Control.Monad m =>+  Int -> m (Ur a) -> Stream (Of a) m ()+replicateM n ma+  | n < 0 = Prelude.error "Cannot replicate a stream of negative length"+  | otherwise = loop n ma+    where+      loop :: Control.Monad m => Int -> m (Ur a) -> Stream (Of a) m ()+      loop n ma+        | n == 0 = Return ()+        | otherwise = Effect $ Control.do+          Ur a <- ma+          Control.return $ Step $ a :> (replicateM (n-1) ma)++-- | Replicate a constant element and zip it with the finite stream which+-- is the first argument.+replicateZip :: Control.Monad m =>+  Stream (Of x) m r -> a -> Stream (Of (a,x)) m r+replicateZip stream a = map ((,) a) stream+{-# INLINABLE replicateZip #-}++untilRight :: forall m a r . Control.Monad m =>+  m (Either (Ur a) r) -> Stream (Of a) m r+untilRight mEither = Effect loop+  where+    loop :: m (Stream (Of a) m r)+    loop = Control.do+      either <- mEither+      either & \case+        Left (Ur a) ->+          Control.return $ Step $ a :> (untilRight mEither)+        Right r -> Control.return $ Return r+{-# INLINABLE untilRight #-}+++-- # The \"Affine\" 'Stream'+-------------------------------------------------------------------------------++-- | An *affine stream is represented with a state of type @x@,+-- a possibly terminating step function of type @(x %1-> m (Either (f x) r))@,+-- and a stop-short function @(x %1-> m r)@.+--+-- This mirrors the unfold of a normal stream:+--+-- > data Stream f m r where+-- >   Stream :: x %1-> (x %1-> m (Either (f x) r)) -> Stream f m r+--+-- *Though referred to as an \"affine stream\" this might not be the correct+-- definition for affine streams. Sorting this out requires a bit more+-- careful thought.+data AffineStream f m r where+  AffineStream ::+    x %1->+    (x %1-> m (Either (f x) r)) ->+    (x %1-> m r) ->+    AffineStream f m r++-- | Take @n@ number of elements from the affine stream, for non-negative+-- @n@. (Negative @n@ is treated as 0.)+take :: forall f m r. (Control.Monad m, Control.Functor f) =>+  Int -> AffineStream f m r %1-> Stream f m r+take = loop where+  loop :: Int -> AffineStream f m r %1-> Stream f m r+  loop n (AffineStream s step end)+    | n <= 0 = Effect $ Control.fmap Control.return $ end s+    | otherwise = Effect $ Control.do+        next <- step s+        next & \case+          Right r -> Control.return (Return r)+          Left fx -> Control.return $ Step $+            Control.fmap (\x -> loop (n-1) (AffineStream x step end)) fx+{-# INLINABLE take #-}++-- | Run an affine stream until it ends or a monadic test succeeds.+-- Drop the element it succeeds on.+untilM :: forall a m r. Control.Monad m =>+  (a -> m Bool) -> AffineStream (Of a) m r %1-> Stream (Of a) m r+untilM = loop where+  loop :: (a -> m Bool) -> AffineStream (Of a) m r %1-> Stream (Of a) m r+  loop test (AffineStream s step end) = Effect $ Control.do+    next <- step s+    next & \case+      Right r -> Control.return (Return r)+      Left (a :> next) -> Control.do+        testResult <- test a+        testResult & \case+          False -> Control.return $+            Step $ a :> loop test (AffineStream next step end)+          True -> Control.fmap Control.return $ end next+{-# INLINABLE untilM #-}++-- | Like 'untilM' but without the monadic test.+until :: forall a m r. Control.Monad m =>+  (a -> Bool) -> AffineStream (Of a) m r %1-> Stream (Of a) m r+until = loop where+  loop :: (a -> Bool) -> AffineStream (Of a) m r %1-> Stream (Of a) m r+  loop test (AffineStream s step end) = Effect $ Control.do+    next <- step s+    next & \case+      Right r -> Control.return (Return r)+      Left (a :> next) -> case test a of+        True -> Control.fmap Control.return $ end next+        False -> Control.return $ Step $+          a :> loop test (AffineStream next step end)+{-# INLINABLE until #-}++-- | Zip a finite stream with an affine stream.+zip :: forall a x m r1 r2. Control.Monad m =>+  Stream (Of x) m r1 %1->+  AffineStream (Of a) m r2 %1->+  Stream (Of (x,a)) m (r1,r2)+zip = loop where+  loop ::+    Stream (Of x) m r1 %1->+    AffineStream (Of a) m r2 %1->+    Stream (Of (x,a)) m (r1,r2)+  loop stream (AffineStream s step end) = stream & \case+    Return r1 -> Effect $+      Control.fmap (\r2 -> Control.return $ (r1,r2)) $ end s+    Effect m -> Effect $+      Control.fmap (\str -> loop str (AffineStream s step end)) m+    Step (x :> rest) -> Effect $ Control.do+      next <- step s+      next & \case+        Right r2 -> Control.do+          r1 <- effects rest+          Control.return (Return (r1,r2))+        Left (a :> rest') -> Control.return $ Step $+          (x,a) :> loop rest (AffineStream rest' step end)+{-# INLINABLE zip #-}++-- | An affine stream of standard input lines.+stdinLn :: AffineStream (Of Text) IO ()+stdinLn = AffineStream () getALine Control.pure where+  getALine :: () %1-> IO (Either (Of Text ()) ())+  getALine () = Control.do+    Ur line <- fromSystemIOU System.getLine+    Control.return $ Left (Text.pack line :> ())++-- | An affine stream of reading lines, crashing on failed parse.+readLn :: Read a => AffineStream (Of a) IO ()+readLn = AffineStream () readALine Control.pure where+  readALine :: Read a => () %1-> IO (Either (Of a ()) ())+  readALine () = Control.do+    Ur line <- fromSystemIOU System.getLine+    Control.return $ Left (Prelude.read line :> ())++-- | An affine stream iterating an initial state forever.+iterate :: forall a m.+  Control.Monad m => a -> (a -> a) -> AffineStream (Of a) m ()+iterate a step =+  AffineStream (Ur a) stepper (\x -> Control.return $ consume x)+  where+    stepper :: Ur a %1-> m (Either (Of a (Ur a)) ())+    stepper (Ur a) = Control.return $+      Left $ a :> Ur (step a)++-- | An affine stream monadically iterating an initial state forever.+iterateM :: forall a m. Control.Monad m =>+  m (Ur a) -> (a -> m (Ur a)) -> AffineStream (Of a) m ()+iterateM ma step =+  AffineStream ma stepper (Control.fmap consume)+  where+    stepper :: m (Ur a) %1-> m (Either (Of a (m (Ur a))) ())+    stepper ma = Control.do+      Ur a <- ma+      Control.return $ Left $ a :> (step a)++-- Remark. In order to implement the affine break function, which is the third+-- argument of the constructor, we need to specify the functor as @Of@.+-- Approaches to keeping it functor general seem messy.++-- | An affine stream cycling through a given finite stream forever.+cycle :: forall a m r. (Control.Monad m, Consumable r) =>+  Stream (Of a) m r -> AffineStream (Of a) m r+cycle stream =+  -- Note. The state is (original stream, stream_in_current_cycle)+  AffineStream (Ur stream, stream) stepStream leftoverEffects+  where+    leftoverEffects ::+      (Ur (Stream (Of a) m r), Stream (Of a) m r) %1-> m r+    leftoverEffects (Ur _, str) = effects str++    stepStream :: Control.Functor f =>+      (Ur (Stream f m r), Stream f m r) %1->+      m (Either (f (Ur (Stream f m r), Stream f m r)) r)+    stepStream (Ur s, str) = str & \case+      Return r -> lseq r $ stepStream (Ur s, s)+      Effect m ->+        m Control.>>= (\stream -> stepStream (Ur s, stream))+      Step f -> Control.return $+        Left $ Control.fmap ((,) (Ur s)) f++-- | An affine stream iterating an enumerated stream forever.+enumFrom :: (Control.Monad m, Enum e) => e -> AffineStream (Of e) m ()+enumFrom e = iterate e Prelude.succ++-- | An affine stream iterating an enumerated stream forever, using the+-- first two elements to determine the gap to skip by.+-- E.g., @enumFromThen  3 5@ is like @[3,5..]@.+enumFromThen :: forall e m. (Control.Monad m, Enum e) =>+  e -> e -> AffineStream (Of e) m ()+enumFromThen e e' = iterate e enumStep where+  enumStep :: e -> e+  enumStep enum = toEnum Prelude.$+    (fromEnum enum) + ((fromEnum e') - (fromEnum e))+    -- Think:  \enum -> enum + stepSize where stepSize = (e1 - e0)+++-- # Working with infinite 'Stream's+-------------------------------------------------------------------------------++-- | @stdinLnN n@ is a stream of @n@ lines from standard input+stdinLnN :: Int -> Stream (Of Text) IO ()+stdinLnN n = take n stdinLn+{-# INLINE stdinLnN #-}++-- | Provides a stream of standard input and omits the first line+-- that satisfies the predicate, possibly requiring IO+stdinLnUntilM :: (Text -> IO Bool) -> Stream (Of Text) IO ()+stdinLnUntilM test = untilM test stdinLn+{-# INLINE stdinLnUntilM #-}++-- | Provides a stream of standard input and omits the first line+-- that satisfies the predicate+stdinLnUntil :: (Text -> Bool) -> Stream (Of Text) IO ()+stdinLnUntil test = until test stdinLn+{-# INLINE stdinLnUntil #-}++-- | Given a finite stream, provide a stream of lines of standard input+-- zipped with that finite stream+stdinLnZip :: Stream (Of x) IO r %1-> Stream (Of (x, Text)) IO r+stdinLnZip stream = Control.fmap (\(r,()) -> r) $ zip stream stdinLn+{-# INLINE stdinLnZip #-}++readLnN :: Read a => Int -> Stream (Of a) IO ()+readLnN n = take n readLn+{-# INLINE readLnN #-}++readLnUntilM :: Read a => (a -> IO Bool) -> Stream (Of a) IO ()+readLnUntilM test = untilM test readLn+{-# INLINE readLnUntilM #-}++readLnUntil :: Read a => (a -> Bool) -> Stream (Of a) IO ()+readLnUntil test = until test readLn+{-# INLINE readLnUntil #-}++readLnZip :: Read a => Stream (Of x) IO r %1-> Stream (Of (x, a)) IO r+readLnZip stream = Control.fmap (\(r,()) -> r) $ zip stream readLn+{-# INLINE readLnZip #-}++-- | Iterate a pure function from a seed value,+-- streaming the results forever.+iterateN :: Control.Monad m => Int -> (a -> a) -> a -> Stream (Of a) m ()+iterateN n step a = take n $ iterate a step+{-# INLINE iterateN #-}++iterateZip :: Control.Monad m => Stream (Of x) m r ->+  (a -> a) -> a -> Stream (Of (x,a)) m r+iterateZip stream step a =+  Control.fmap (\(r,()) -> r) $ zip stream $ iterate a step+{-# INLINE iterateZip #-}++-- | Iterate a monadic function from a seed value,+-- streaming the results forever.+iterateMN :: Control.Monad m =>+  Int -> (a -> m (Ur a)) -> m (Ur a) -> Stream (Of a) m ()+iterateMN n step ma = take n $ iterateM ma step+{-# INLINE iterateMN #-}++iterateMZip :: Control.Monad m =>+  Stream (Of x) m r %1->+  (a -> m (Ur a)) -> m (Ur a) -> Stream (Of (x,a)) m r+iterateMZip stream step ma =+  Control.fmap (\(r,()) -> r) $ zip stream $ iterateM ma step+{-# INLINE iterateMZip #-}++-- | Cycle a stream a finite number of times+cycleN :: (Control.Monad m, Consumable r) =>+  Int -> Stream (Of a) m r -> Stream (Of a) m r+cycleN n stream = take n $ cycle stream+{-# INLINE cycleN #-}++-- | @cycleZip s1 s2@ will cycle @s2@ just enough to zip with the given finite+-- stream @s1@. Note that we consume all the effects of the remainder of the+-- cycled stream @s2@. That is, we consume @s2@ the smallest natural number of+-- times we need to zip.+cycleZip :: (Control.Monad m, Consumable s) =>+  Stream (Of a) m r %1-> Stream (Of b) m s -> Stream (Of (a,b)) m (r,s)+cycleZip str stream = zip str $ cycle stream+{-# INLINE cycleZip #-}++{-| An finite sequence of enumerable values at a fixed distance, determined+   by the first and second values.++@+\>\>\> S.print $ S.enumFromThenN 3 100 200+100+200+300+@+-}+enumFromThenN :: (Control.Monad m, Enum e) => Int -> e -> e -> Stream (Of e) m ()+enumFromThenN n e e' = take n $ enumFromThen e e'+{-# INLINE enumFromThenN #-}++-- | A finite sequence of enumerable values at a fixed distance determined+-- by the first and second values. The length is limited by zipping+-- with a given finite stream, i.e., the first argument.+enumFromThenZip :: (Control.Monad m, Enum e) =>+  Stream (Of a) m r %1-> e -> e -> Stream (Of (a,e)) m r+enumFromThenZip stream e e'=+  Control.fmap (\(r,()) -> r) $ zip stream $ enumFromThen e e'+{-# INLINE enumFromThenZip #-}++-- | Like 'enumFromThenN' but where the next element in the enumeration is just+-- the successor @succ n@ for a given enum @n@.+enumFromN :: (Control.Monad m, Enum e) => Int -> e -> Stream (Of e) m ()+enumFromN n e = take n $ enumFrom e+{-# INLINE enumFromN #-}++-- | Like 'enumFromThenZip' but where the next element in the enumeration is just+-- the successor @succ n@ for a given enum @n@.+enumFromZip :: (Control.Monad m, Enum e) =>+  Stream (Of a) m r %1-> e -> Stream (Of (a,e)) m r+enumFromZip str e =+  Control.fmap (\(r,()) -> r) $ zip str $ enumFrom e+{-# INLINE enumFromZip #-}+
+ src/Streaming/Internal/Type.hs view
@@ -0,0 +1,164 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RecordWildCards #-}++module Streaming.Internal.Type+  ( -- * The 'Stream' and 'Of' types+    -- $stream+    Stream (..)+  , Of (..)+  ) where++import qualified Data.Functor.Linear as Data+import qualified Control.Functor.Linear as Control+import qualified Prelude.Linear as Linear+import Prelude.Linear (($), (.))+++-- # Data Definitions+-------------------------------------------------------------------------------+++{- $stream++    The 'Stream' data type is equivalent to @FreeT@ and can represent any effectful+    succession of steps, where the form of the steps or 'commands' is+    specified by the first (functor) parameter. The effects are performed+    exactly once since the monad is a @Control.Monad@ from+    <https://github.com/tweag/linear-base linear-base>.++> data Stream f m r = Step !(f (Stream f m r)) | Effect (m (Stream f m r)) | Return r++    The /producer/ concept uses the simple functor @ (a,_) @ \- or the stricter+    @ Of a _ @. Then the news at each step or layer is just: an individual item of type @a@.+    Since @Stream (Of a) m r@ is equivalent to @Pipe.Producer a m r@, much of+    the @pipes@ @Prelude@ can easily be mirrored in a @streaming@ @Prelude@. Similarly,+    a simple @Consumer a m r@ or @Parser a m r@ concept arises when the base functor is+    @ (a -> _) @ . @Stream ((->) input) m result@ consumes @input@ until it returns a+    @result@.++    To avoid breaking reasoning principles, the constructors+    should not be used directly. A pattern-match should go by way of 'inspect' \+    \- or, in the producer case, 'Streaming.Prelude.next'+-}+data Stream f m r where+  Step :: !(f (Stream f m r)) %1-> Stream f m r+  Effect :: m (Stream f m r) %1-> Stream f m r+  Return :: r %1-> Stream f m r++-- | A left-strict pair; the base functor for streams of individual elements.+data Of a b where+  (:>) :: !a -> b %1-> Of a b++infixr 5 :>+++-- # Control.Monad instance for (Stream f m)+-------------------------------------------------------------------------------++-- Note: we have maintained the weakest prerequisite constraints possible.++-- Note: to consume the 'Stream f m a' in the 'Cons' case, you+-- need 'fmap' to consume the stream. This implies at minimum+-- Data.Functor m and Data.Functor m.+instance (Data.Functor m, Data.Functor f) => Data.Functor (Stream f m) where+  fmap :: (Data.Functor m, Data.Functor f) =>+    (a %1-> b) -> Stream f m a %1-> Stream f m b+  fmap f s = fmap' f s+  {-# INLINABLE fmap #-}++fmap' :: (Data.Functor m, Data.Functor f) =>+  (a %1-> b) -> Stream f m a %1-> Stream f m b+fmap' f (Return r) = Return (f r)+fmap' f (Step fs) = Step $ Data.fmap (Data.fmap f) fs+fmap' f (Effect ms) = Effect $ Data.fmap (Data.fmap f) ms++-- Note: the 'Control.Functor f' instance is needed.+-- Weaker constraints won't do.+instance (Control.Functor m, Control.Functor f) =>+  Data.Applicative (Stream f m) where+  pure :: a -> Stream f m a+  pure = Return+  {-# INLINE pure #-}++  (<*>) :: (Control.Functor m, Control.Functor f) =>+    Stream f m (a %1-> b) %1-> Stream f m a %1-> Stream f m b+  (<*>) s1 s2 = app s1 s2+  {-# INLINABLE (<*>) #-}++app :: (Control.Functor m, Control.Functor f) =>+  Stream f m (a %1-> b) %1-> Stream f m a %1-> Stream f m b+app (Return f) stream = Control.fmap f stream+app (Step fs) stream = Step $ Control.fmap (Data.<*> stream) fs+app (Effect ms) stream = Effect $ Control.fmap (Data.<*> stream) ms++++instance (Control.Functor m, Control.Functor f) =>+  Control.Functor (Stream f m) where+  fmap :: (Data.Functor m, Data.Functor f) =>+    (a %1-> b) %1-> Stream f m a %1-> Stream f m b+  fmap f s = fmap'' f s+  {-# INLINABLE fmap #-}++fmap'' :: (Control.Functor m, Control.Functor f) =>+  (a %1-> b) %1-> Stream f m a %1-> Stream f m b+fmap'' f (Return r) = Return (f r)+fmap'' f (Step fs) = Step $ Control.fmap (Control.fmap f) fs+fmap'' f (Effect ms) = Effect $ Control.fmap (Control.fmap f) ms+++instance (Control.Functor m, Control.Functor f) =>+  Control.Applicative (Stream f m) where+  pure :: a %1-> Stream f m a+  pure = Return+  {-# INLINE pure #-}++  (<*>) :: (Control.Functor m, Control.Functor f) =>+    Stream f m (a %1-> b) %1-> Stream f m a %1-> Stream f m b+  (<*>) = (Data.<*>)+  {-# INLINE (<*>) #-}++instance (Control.Functor m, Control.Functor f) =>+  Control.Monad (Stream f m) where+  (>>=) :: Stream f m a %1-> (a %1-> Stream f m b) %1-> Stream f m b+  (>>=) = bind+  {-# INLINABLE (>>=) #-}++bind :: (Control.Functor m, Control.Functor f) =>+  Stream f m a %1-> (a %1-> Stream f m b) %1-> Stream f m b+bind (Return a) f = f a+bind (Step fs) f = Step $ Control.fmap (Control.>>= f) fs+bind (Effect ms) f = Effect $ Control.fmap (Control.>>= f) ms+++-- # MonadTrans for (Stream f m)+-------------------------------------------------------------------------------++instance Control.Functor f => Control.MonadTrans (Stream f) where+  lift :: (Control.Functor m, Control.Functor f) => m a %1-> Stream f m a+  lift = Effect . Control.fmap Control.return+  {-# INLINE lift #-}+++-- # Control.Functor for (Of)+-------------------------------------------------------------------------------++ofFmap :: (a %1-> b) %1-> (Of x a) %1-> (Of x b)+ofFmap f (a :> b) = a :> f b+{-# INLINE ofFmap #-}++instance Data.Functor (Of a) where+  fmap = Linear.forget ofFmap+  {-# INLINE fmap #-}++instance Control.Functor (Of a) where+  fmap = ofFmap+  {-# INLINE fmap #-}+
+ src/Streaming/Linear.hs view
@@ -0,0 +1,818 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+++module Streaming.Linear+  (+  -- $stream+   module Streaming.Internal.Type+  -- * Constructing a 'Stream' on a given functor+  , yields+  , effect+  , wrap+  , replicates+  , replicatesM+  , unfold+  , untilJust+  , streamBuild+  , delays+  -- * Transforming streams+  , maps+  , mapsPost+  , mapsM+  , mapsMPost+  , mapped+  , mappedPost+  , hoistUnexposed+  , groups+  -- * Inspecting a stream+  , inspect+  -- * Splitting and joining 'Stream's+  , splitsAt+  , chunksOf+  , concats+  , intercalates+  -- * Zipping, unzipping, separating and unseparating streams+  , unzips+  , separate+  , unseparate+  , decompose+  , expand+  , expandPost+  -- * Eliminating a 'Stream'+  , mapsM_+  , run+  , streamFold+  , iterTM+  , iterT+  , destroy+  ) where++import Streaming.Internal.Type+import Streaming.Internal.Process (destroyExposed)+import Data.Functor.Sum+import Data.Functor.Compose+import qualified Streaming.Prelude.Linear as Stream+import System.IO.Linear+import Prelude.Linear (($), (.), (&))+import Prelude (Ordering(..), Ord(..), Num(..), Int, Either(..), Double,+               Maybe(..), fromInteger)+import qualified Prelude+import qualified Control.Functor.Linear as Control+import qualified Data.Functor.Linear as Data+import Data.Unrestricted.Linear+import Control.Concurrent (threadDelay)+import GHC.Stack++{- $stream+    The 'Stream' data type is an effectful series of steps with some+    payload value at the bottom. The steps are represented with functors.+    The effects are represented with some /control/ monad. (Control monads+    must be bound to exactly once; see the documentation in+    <https://github.com/tweag/linear-base/tree/master/src/Control/Monad/Linear.hs linear-base> to learn more+    about control monads, control applicatives and control functors.)++    In words, a @Stream f m r@ is either a payload of type @r@, or+    a step of type @f (Stream f m r)@ or an effect of type @m (Stream f m r)@+    where @f@ is a @Control.Functor@ and @m@ is a @Control.Monad@.++    This module exports combinators that pertain to this general case.+    Some of these are quite abstract and pervade any use of the library,+    e.g.++>   maps    :: (forall x . f x %1-> g x) -> Stream f m r %1-> Stream g m r+>   mapped  :: (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r+>   concats :: Stream (Stream f m) m r %1-> Stream f m r++    (assuming here and thoughout that @m@ or @n@ satisfies+    a @Control.Monad@ constraint, and @f@ or @g@ a @Control.Functor@+    constraint).++    Others are surprisingly determinate in content:++>   chunksOf     :: Int -> Stream f m r %1-> Stream (Stream f m) m r+>   splitsAt     :: Int -> Stream f m r %1-> Stream f m (Stream f m r)+>   intercalates :: Stream f m () -> Stream (Stream f m) m r %1-> Stream f m r+>   unzips       :: Stream (Compose f g) m r %1->  Stream f (Stream g m) r+>   separate     :: Stream (Sum f g) m r -> Stream f (Stream g m) r  -- cp. partitionEithers+>   unseparate   :: Stream f (Stream g) m r -> Stream (Sum f g) m r+>   groups       :: Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r++    One way to see that /any/ streaming library needs some such general type is+    that it is required to represent the segmentation of a stream, and to+    express the equivalents of @Prelude/Data.List@ combinators that involve+    'lists of lists' and the like. See for example this+    <http://www.haskellforall.com/2013/09/perfect-streaming-using-pipes-bytestring.html post>+    on the correct expression of a streaming \'lines\' function.+    The module @Streaming.Prelude@ exports combinators relating to+> Stream (Of a) m r+    where @Of a r = !a :> r@ is a left-strict pair.+   This expresses the concept of a 'Producer' or 'Source' or 'Generator' and+   easily inter-operates with types with such names in e.g. 'conduit',+   'iostreams' and 'pipes'.+-}++-- # Constructing a 'Stream' on a given functor+-------------------------------------------------------------------------------++-- Remark. By default we require `Control.Monad` and `Control.Functor`+-- instances for the `m` and `f` in a `Stream f m r` since these allow the+-- stream to have a `Control.Monad` instance++{-| @yields@ is like @lift@ for items in the streamed functor.+    It makes a singleton or one-layer succession.++> lift :: (Control.Monad m, Control.Functor f)    => m r %1-> Stream f m r+> yields ::  (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r++    Viewed in another light, it is like a functor-general version of @yield@:++> S.yield a = yields (a :> ())++-}+yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r+yields fr = Step $ Control.fmap Return fr+{-# INLINE yields #-}++-- Note: This must consume its input linearly since it must bind to a+-- `Control.Monad`.+{- | Wrap an effect that returns a stream++> effect = join . lift++-}+effect :: (Control.Monad m, Control.Functor f) =>+  m (Stream f m r) %1-> Stream f m r+effect = Effect+{-# INLINE effect #-}++{-| Wrap a new layer of a stream. So, e.g.++> S.cons :: Control.Monad m => a -> Stream (Of a) m r %1-> Stream (Of a) m r+> S.cons a str = wrap (a :> str)++   and, recursively:++> S.each' :: Control.Monad m =>  [a] -> Stream (Of a) m ()+> S.each' = foldr (\a b -> wrap (a :> b)) (return ())++   The two operations++> wrap :: (Control.Monad m, Control.Functor f) =>+>   f (Stream f m r) %1-> Stream f m r+> effect :: (Control.Monad m, Control.Functor f) =>+>   m (Stream f m r) %1-> Stream f m r++   are fundamental. We can define the parallel operations @yields@ and @lift@+   in terms of them++> yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r+> yields = wrap . Control.fmap Control.return+> lift ::  (Control.Monad m, Control.Functor f)  => m r %1-> Stream f m r+> lift = effect . Control.fmap Control.return++-}+wrap :: (Control.Monad m, Control.Functor f) =>+  f (Stream f m r) %1-> Stream f m r+wrap = Step+{-# INLINE wrap #-}++{- | Repeat a functorial layer, command or instruction a fixed number of times.++-}+replicates :: (HasCallStack, Control.Monad m, Control.Functor f) =>+  Int -> f () -> Stream f m ()+replicates n f = replicates' n f+  where+    replicates' :: (HasCallStack, Control.Monad m, Control.Functor f) =>+      Int -> f () -> Stream f m ()+    replicates' n f = case compare n 0 of+      LT -> Prelude.error "replicates called with negative integer"+      EQ -> Return ()+      GT -> Step $ Control.fmap (\() -> replicates (n-1) f) f+{-# INLINE replicates #-}++-- | @replicatesM n@ repeats an effect containing a functorial layer, command+-- or instruction @n@ times.+replicatesM :: forall f m . (Control.Monad m, Control.Functor f) =>+  Int -> m (f ()) -> Stream f m ()+replicatesM = loop+  where+    loop :: Int -> m (f ()) -> Stream f m ()+    loop n mfstep+      | n <= 0 = Return ()+      | Prelude.otherwise = Effect $+          Control.fmap (Step . Control.fmap (\() -> loop (n-1) mfstep)) mfstep+{-# INLINABLE replicatesM #-}++unfold :: (Control.Monad m, Control.Functor f) =>+  (s %1-> m (Either r (f s))) -> s %1-> Stream f m r+unfold step state = unfold' step state+  where+    unfold' :: (Control.Monad m, Control.Functor f) =>+      (s %1-> m (Either r (f s))) -> s %1-> Stream f m r+    unfold' step state = Effect $ Control.do+      either <- step state+      either & \case+        Left r -> Control.return $ Return r+        Right (fs) -> Control.return $ Step $ Control.fmap (unfold step) fs+{-# INLINABLE unfold #-}++-- Note. To keep restrictions minimal, we use the `Data.Applicative`+-- instance.+untilJust :: forall f m r . (Control.Monad m, Data.Applicative f) =>+  m (Maybe r) -> Stream f m r+untilJust action = loop+  where+    loop :: Stream f m r+    loop = Effect $ Control.do+      maybeVal  <- action+      maybeVal & \case+        Nothing -> Control.return $ Step $ Data.pure loop+        Just r  -> Control.return $ Return r+{-# INLINABLE untilJust #-}++-- Remark. The linear church encoding of streams has linear+-- return, effect and step functions.+{- | Reflect a church-encoded stream; cp. @GHC.Exts.build@++> streamFold return_ effect_ step_ (streamBuild psi) = psi return_ effect_ step_+-}+streamBuild ::+  (forall b. (r %1-> b) -> (m b %1-> b) -> (f b %1-> b) -> b) -> Stream f m r+streamBuild = \phi -> phi Return Effect Step+{-# INLINE streamBuild #-}++-- Note. To keep requirements minimal, we use the `Data.Applicative`+-- instance instead of the `Control.Applicative` instance.+delays :: forall f r . (Data.Applicative f) => Double -> Stream f IO r+delays seconds = loop+  where+    loop :: Stream f IO r+    loop = Effect $ Control.do+      let delay = fromInteger (Prelude.truncate (1000000 * seconds))+      () <- fromSystemIO $ threadDelay delay+      Control.return $ Step $ Data.pure loop+{-# INLINABLE delays #-}+++-- # Transforming streams+-------------------------------------------------------------------------------++{- | Map layers of one functor to another with a transformation.++> maps id = id+> maps f . maps g = maps (f . g)++-}+maps :: forall f g m r . (Control.Monad m, Control.Functor f) =>+  (forall x . f x %1-> g x) -> Stream f m r %1-> Stream g m r+maps = Stream.maps+{-# INLINE maps #-}++{- | Map layers of one functor to another with a transformation.++> mapsPost id = id+> mapsPost f . mapsPost g = mapsPost (f . g)+> mapsPost f = maps f++     @mapsPost@ is essentially the same as 'maps', but it imposes a @Control.Functor@ constraint on+     its target functor rather than its source functor. It should be preferred if @Control.fmap@+     is cheaper for the target functor than for the source functor.+-}+mapsPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>+  (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r+mapsPost = Stream.mapsPost+{-# INLINE mapsPost #-}++-- Note. The transformation function must be linear so that the stream+-- held inside a control functor is used linearly.+{- | Map layers of one functor to another with a transformation involving the base monad.+     'maps' is more fundamental than @mapsM@, which is best understood as a convenience+     for effecting this frequent composition:++> mapsM phi = decompose . maps (Compose . phi)++     The streaming prelude exports the same function under the better name @mapped@,+     which overlaps with the lens libraries.++-}+mapsM :: forall f g m r . (Control.Monad m, Control.Functor f) =>+  (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r+mapsM transform = loop where+  loop :: Stream f m r %1-> Stream g m r+  loop stream = stream & \case+    Return r -> Return r+    Step f -> Effect $ Control.fmap Step $ transform $ Control.fmap loop f+    Effect m -> Effect $ Control.fmap loop m+{-# INLINE mapsM #-}++{- | Map layers of one functor to another with a transformation involving the base monad.+     @mapsMPost@ is essentially the same as 'mapsM', but it imposes a @Control.Functor@ constraint on+     its target functor rather than its source functor. It should be preferred if @Control.fmap@+     is cheaper for the target functor than for the source functor.++     @mapsPost@ is more fundamental than @mapsMPost@, which is best understood as a convenience+     for effecting this frequent composition:++> mapsMPost phi = decompose . mapsPost (Compose . phi)++     The streaming prelude exports the same function under the better name @mappedPost@,+     which overlaps with the lens libraries.++-}+mapsMPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>+  (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r+mapsMPost = Stream.mapsMPost+{-# INLINE mapsMPost #-}++{- | Map layers of one functor to another with a transformation involving the base monad.+     This could be trivial, e.g.++> let noteBeginning text x = (fromSystemIO (System.putStrLn text)) Control.>> (Control.return x)++     this is completely functor-general++     @maps@ and @mapped@ obey these rules:++> maps id              = id+> mapped return        = id+> maps f . maps g      = maps (f . g)+> mapped f . mapped g  = mapped (f <=< g)+> maps f . mapped g    = mapped (fmap f . g)+> mapped f . maps g    = mapped (f <=< fmap g)++     @maps@ is more fundamental than @mapped@, which is best understood as a convenience+     for effecting this frequent composition:++> mapped phi = decompose . maps (Compose . phi)+++-}+mapped :: forall f g m r . (Control.Monad m, Control.Functor f) =>+  (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r+mapped = mapsM+{-# INLINE mapped #-}++{-| A version of 'mapped' that imposes a @Control.Functor@ constraint on the target functor rather+    than the source functor. This version should be preferred if @Control.fmap@ on the target+    functor is cheaper.++-}+mappedPost :: forall m f g r. (Control.Monad m, Control.Functor g) =>+  (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r+mappedPost = mapsMPost+{-# INLINE mappedPost #-}++-- | A less-efficient version of 'hoist' that works properly even when its+-- argument is not a monad morphism.+hoistUnexposed :: forall f m n r. (Control.Monad m, Control.Functor f)+               => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r+hoistUnexposed trans = loop where+  loop :: Stream f m r %1-> Stream f n r+  loop = Effect+    . trans+    . inspectC+      (Control.return . Return)+      (Control.return . Step . Control.fmap loop)+{-# INLINABLE hoistUnexposed #-}++-- A version of 'inspect' that takes explicit continuations.+-- Note that due to the linear constructors of 'Stream', these continuations+-- are linear.+inspectC :: forall f m r a. Control.Monad m =>+  (r %1-> m a) -> (f (Stream f m r) %1-> m a) -> Stream f m r %1-> m a+inspectC f g = loop where+  loop :: Stream f m r %1-> m a+  loop (Return r) = f r+  loop (Step x)   = g x+  loop (Effect m) = m Control.>>= loop+{-# INLINE inspectC #-}++{-| Group layers in an alternating stream into adjoining sub-streams+    of one type or another.+-}+groups :: forall f g m r .+  (Control.Monad m, Control.Functor f, Control.Functor g) =>+  Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r+groups = loop+  where+    loop :: Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r+    loop str = Control.do+      e <- Control.lift $ inspect str+      e & \case+        Left r -> Control.return r+        Right ostr -> ostr & \case+          InR gstr -> Step $ InR $ Control.fmap loop $ cleanR (Step (InR gstr))+          InL fstr -> Step $ InL $ Control.fmap loop $ cleanL (Step (InL fstr))++    cleanL :: Stream (Sum f g) m r %1-> Stream f m (Stream (Sum f g) m r)+    cleanL = go+      where+        go :: Stream (Sum f g) m r %1-> Stream f m (Stream (Sum f g) m r)+        go s = Control.do+         e <- Control.lift $ inspect s+         e & \case+          Left r -> Control.return $ Control.return r+          Right (InL fstr) -> Step $ Control.fmap go fstr+          Right (InR gstr) -> Control.return $ Step (InR gstr)++    cleanR  :: Stream (Sum f g) m r %1-> Stream g m (Stream (Sum f g) m r)+    cleanR = go+      where+        go :: Stream (Sum f g) m r %1-> Stream g m (Stream (Sum f g) m r)+        go s = Control.do+         e <- Control.lift $ inspect s+         e & \case+          Left r           -> Control.return $ Control.return r+          Right (InL fstr) -> Control.return $ Step (InL fstr)+          Right (InR gstr) -> Step$ Control.fmap go gstr+{-# INLINABLE groups #-}+++-- # Inspecting a Stream+-------------------------------------------------------------------------------++{-| Inspect the first stage of a freely layered sequence.+    Compare @Pipes.next@ and the replica @Streaming.Prelude.next@.+    This is the 'uncons' for the general 'unfold'.++> unfold inspect = id+> Streaming.Prelude.unfoldr StreamingPrelude.next = id+-}+inspect :: forall f m r . Control.Monad m =>+     Stream f m r %1-> m (Either r (f (Stream f m r)))+inspect = loop+  where+    loop :: Stream f m r %1-> m (Either r (f (Stream f m r)))+    loop stream = stream & \case+      Return r -> Control.return (Left r)+      Effect m -> m Control.>>= loop+      Step fs  -> Control.return (Right fs)+{-# INLINABLE inspect #-}+++-- # Splitting and joining 'Stream's+-------------------------------------------------------------------------------++{-| Split a succession of layers after some number, returning a streaming or+    effectful pair.++\>\>\> rest <- S.print $ S.splitAt 1 $ each' [1..3]+1+\>\>\> S.print rest+2+3++> splitAt 0 = return+> (\stream -> splitAt n stream >>= splitAt m) = splitAt (m+n)++    Thus, e.g.++\>\>\> rest <- S.print $ (\s -> splitsAt 2 s >>= splitsAt 2) each' [1..5]+1+2+3+4+\>\>\> S.print rest+5++-}+splitsAt :: forall f m r .+  (HasCallStack, Control.Monad m, Control.Functor f) =>+  Int -> Stream f m r %1-> Stream f m (Stream f m r)+splitsAt n stream = loop n stream+  where+    loop :: Int -> Stream f m r %1-> Stream f m (Stream f m r)+    loop n stream = case compare n 0 of+      LT -> Prelude.error "splitsAt called with negative index" $ stream+      EQ -> Return stream+      GT -> stream & \case+        Return r -> Return $ Return r+        Effect m -> Effect $ Control.fmap (loop n) m+        Step f -> Step $ Control.fmap (loop (n-1)) f+{-# INLINABLE splitsAt #-}+++{-| Break a stream into substreams each with n functorial layers.++\>\>\>  S.print $ mapped S.sum $ chunksOf 2 $ each' [1,1,1,1,1]+2+2+1+-}+chunksOf :: forall f m r .+  (HasCallStack, Control.Monad m, Control.Functor f) =>+  Int -> Stream f m r %1-> Stream (Stream f m) m r+chunksOf n stream = loop n stream+  where+    loop :: Int -> Stream f m r %1-> Stream (Stream f m) m r+    loop _ (Return r) = Return r+    loop n stream = Step $ Control.fmap (loop n) $ splitsAt n stream+{-# INLINABLE chunksOf #-}++{-| Dissolves the segmentation into layers of @Stream f m@ layers.++-}+concats :: forall f m r . (Control.Monad m, Control.Functor f) =>+  Stream (Stream f m) m r %1-> Stream f m r+concats = loop+  where+    loop :: Stream (Stream f m) m r %1-> Stream f m r+    loop stream = stream & \case+      Return r -> Return r+      Effect m -> Effect $ Control.fmap loop m+      Step f -> Control.do+        rest <- Control.fmap loop f+        rest+{-# INLINE concats #-}++-- Note. To keep the monad of the stream a control monad, we need+-- `(t m)` to be a control monad, and hence `t` to be a control+-- monad transformer.+{-| Interpolate a layer at each segment. This specializes to e.g.++> intercalates :: Stream f m () -> Stream (Stream f m) m r %1-> Stream f m r+-}+intercalates :: forall t m r x .+  (Control.Monad m, Control.Monad (t m), Control.MonadTrans t, Consumable x) =>+  t m x -> Stream (t m) m r %1-> t m r+intercalates sep = go0+  where+    go0 :: Stream (t m) m r %1-> t m r+    go0 f = f & \case+      Return r -> Control.return r+      Effect m -> Control.lift m Control.>>= go0+      Step fstr -> Control.do+        f' <- fstr+        go1 f'++    go1 :: Stream (t m) m r %1-> t m r+    go1 f = f & \case+      Return r -> Control.return r+      Effect m -> Control.lift m Control.>>= go1+      Step fstr -> Control.do+        x  <- sep+        Control.return $ consume x+        f' <- fstr+        go1 f'+{-# INLINABLE intercalates #-}+++-- # Zipping, unzipping, separating and unseparating streams+-------------------------------------------------------------------------------++unzips :: forall f g m r .+  (Control.Monad m, Control.Functor f, Control.Functor g) =>+  Stream (Compose f g) m r %1-> Stream f (Stream g m) r+unzips str = destroyExposed+  str+  (\(Compose fgstr) -> Step (Control.fmap (Effect . yields) fgstr))+  (Effect . Control.lift)+  Return+{-# INLINABLE unzips #-}++{-| Given a stream on a sum of functors, make it a stream on the left functor,+    with the streaming on the other functor as the governing monad. This is+    useful for acting on one or the other functor with a fold, leaving the+    other material for another treatment. It generalizes+    'Data.Either.partitionEithers', but actually streams properly.++\>\>\> let odd_even = S.maps (S.distinguish even) $ S.each' [1..10::Int]+\>\>\> :t separate odd_even+separate odd_even+  :: Monad m => Stream (Of Int) (Stream (Of Int) m) ()++    Now, for example, it is convenient to fold on the left and right values separately:++\>\>\> S.toList $ S.toList $ separate odd_even+[2,4,6,8,10] :> ([1,3,5,7,9] :> ())+++   Or we can write them to separate files or whatever:++\>\>\> S.writeFile "even.txt" . S.show $ S.writeFile "odd.txt" . S.show $ S.separate odd_even+\>\>\> :! cat even.txt+2+4+6+8+10+\>\>\> :! cat odd.txt+1+3+5+7+9++   Of course, in the special case of @Stream (Of a) m r@, we can achieve the above+   effects more simply by using 'Streaming.Prelude.copy'++\>\>\> S.toList . S.filter even $ S.toList . S.filter odd $ S.copy $ each [1..10::Int]+[2,4,6,8,10] :> ([1,3,5,7,9] :> ())+++    But 'separate' and 'unseparate' are functor-general.++-}+separate :: forall f g m r .+  (Control.Monad m, Control.Functor f, Control.Functor g) =>+  Stream (Sum f g) m r -> Stream f (Stream g m) r+separate str = destroyExposed str construct (Effect . Control.lift) Return+  where+    construct :: Sum f g (Stream f (Stream g m) r) %1-> Stream f (Stream g m) r+    construct (InL fss) = Step fss+    construct (InR gss) = Effect (yields gss)+{-# INLINABLE separate #-}++unseparate :: (Control.Monad m, Control.Functor f, Control.Functor g) =>+  Stream f (Stream g m) r -> Stream (Sum f g) m r+unseparate str = destroyExposed+  str+  (Step . InL)+  (Control.join . maps InR)+  Return+{-# INLINABLE unseparate #-}++{-| Rearrange a succession of layers of the form @Compose m (f x)@.++   we could as well define @decompose@ by @mapsM@:++> decompose = mapped getCompose++  but @mapped@ is best understood as:++> mapped phi = decompose . maps (Compose . phi)++  since @maps@ and @hoist@ are the really fundamental operations that preserve the+  shape of the stream:++> maps  :: (Control.Monad m, Control.Functor f) => (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r+> hoist :: (Control.Monad m, Control.Functor f) => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r++-}+decompose :: forall f m r . (Control.Monad m, Control.Functor f) =>+  Stream (Compose m f) m r %1-> Stream f m r+decompose = loop where+  loop :: Stream (Compose m f) m r %1-> Stream f m r+  loop stream = stream & \case+    Return r -> Return r+    Effect m -> Effect $ Control.fmap loop m+    Step (Compose mfs) -> Effect $ Control.do+      fstream <- mfs+      Control.return $ Step (Control.fmap loop fstream)+{-# INLINABLE decompose #-}++-- Note. For 'loop' to recurse over functoral steps, it must be a+-- linear function, and hence, `ext` must be linear in its second argument.+-- Further, the first argument of `ext` ought to be a linear function,+-- because it is typically applied to the input stream in `ext`, and hence+-- should be linear.+-- | If 'Of' had a @Comonad@ instance, then we'd have+--+-- @copy = expand extend@+--+-- See 'expandPost' for a version that requires a @Control.Functor g@+-- instance instead.+expand :: forall f m r g h . (Control.Monad m, Control.Functor f) =>+  (forall a b. (g a %1-> b) -> f a %1-> h b) ->+  Stream f m r %1-> Stream g (Stream h m) r+expand ext = loop where+  loop :: Stream f m r %1-> Stream g (Stream h m) r+  loop (Return r) = Return r+  loop (Step f) = Effect $ Step $ ext (Return . Step) (Control.fmap loop f)+  loop (Effect m) = Effect $ Effect $ Control.fmap (Return . loop) m+{-# INLINABLE expand #-}++-- See note on 'expand'.+-- | If 'Of' had a @Comonad@ instance, then we'd have+--+-- @copy = expandPost extend@+--+-- See 'expand' for a version that requires a @Control.Functor f@ instance+-- instead.+expandPost :: forall f m r g h . (Control.Monad m, Control.Functor g) =>+  (forall a b. (g a %1-> b) -> f a %1-> h b) ->+  Stream f m r %1-> Stream g (Stream h m) r+expandPost ext = loop where+  loop :: Stream f m r %1-> Stream g (Stream h m) r+  loop (Return r) = Return r+  loop (Step f) = Effect $ Step $ ext (Return . Step . Control.fmap loop) f+  loop (Effect m) = Effect $ Effect $ Control.fmap (Return . loop) m+{-# INLINABLE expandPost #-}+++-- # Eliminating a 'Stream'+-------------------------------------------------------------------------------++-- Note. Since the functor step is held linearly in the+-- 'Stream' datatype, the first argument must be a linear function+-- in order to linearly consume the 'Step' case of a stream.+{-| Map each layer to an effect, and run them all.+-}+mapsM_ :: (Control.Functor f, Control.Monad m) =>+  (forall x . f x %1-> m x) -> Stream f m r %1-> m r+mapsM_ f = run . maps f+{-# INLINE mapsM_ #-}++{-| Run the effects in a stream that merely layers effects.+-}+run :: Control.Monad m => Stream m m r %1-> m r+run = loop+  where+    loop :: Control.Monad m => Stream m m r %1-> m r+    loop stream = stream & \case+      Return r   -> Control.return r+      Effect  m  -> m Control.>>= loop+      Step mrest -> mrest Control.>>= loop+{-# INLINABLE run #-}++{-| 'streamFold' reorders the arguments of 'destroy' to be more akin+    to @foldr@  It is more convenient to query in ghci to figure out+    what kind of \'algebra\' you need to write.++\>\>\> :t streamFold Control.return Control.join+(Control.Monad m, Control.Functor f) =>+     (f (m a) %1-> m a) -> Stream f m a %1-> m a        -- iterT++\>\>\> :t streamFold Control.return (Control.join . Control.lift)+(Control.Monad m, Control.Monad (t m), Control.Functor f, Control.MonadTrans t) =>+     (f (t m a) %1-> t m a) -> Stream f m a %1-> t m a  -- iterTM++\>\>\> :t streamFold Control.return effect+(Control.Monad m, Control.Functor f, Control.Functor g) =>+     (f (Stream g m r) %1-> Stream g m r) -> Stream f m r %1-> Stream g m r++\>\>\> :t \f -> streamFold Control.return effect (wrap . f)+(Control.Monad m, Control.Functor f, Control.Functor g) =>+     (f (Stream g m a) %1-> g (Stream g m a))+     -> Stream f m a %1-> Stream g m a                 -- maps++\>\>\> :t \f -> streamFold Control.return effect (effect . Control.fmap wrap . f)+(Control.Monad m, Control.Functor f, Control.Functor g) =>+     (f (Stream g m a) %1-> m (g (Stream g m a)))+     -> Stream f m a %1-> Stream g m a                 -- mapped++@+    streamFold done eff construct+       = eff . iterT (Control.return . construct . Control.fmap eff) . Control.fmap done+@+-}+streamFold :: (Control.Functor f, Control.Monad m) =>+     (r %1-> b) -> (m b %1-> b) ->  (f b %1-> b) -> Stream f m r %1-> b+streamFold done theEffect construct stream =+  destroy stream construct theEffect done+{-# INLINE streamFold #-}++{-| Specialized fold following the usage of @Control.Monad.Trans.Free@++> iterT alg = streamFold Control.return Control.join alg+> iterT alg = runIdentityT . iterTM (IdentityT . alg . Control.fmap runIdentityT)+-}+iterT :: (Control.Functor f, Control.Monad m) =>+  (f (m a) %1-> m a) -> Stream f m a %1-> m a+iterT out stream = destroyExposed stream out Control.join Control.return+{-# INLINE iterT #-}++{-| Specialized fold following the usage of @Control.Monad.Trans.Free@++> iterTM alg = streamFold Control.return (Control.join . Control.lift)+> iterTM alg = iterT alg . hoist Control.lift+-}+iterTM ::+  ( Control.Functor f, Control.Monad m+  , Control.MonadTrans t, Control.Monad (t m)) =>+  (f (t m a) %1-> t m a) -> Stream f m a %1-> t m a+iterTM out stream =+  destroyExposed stream out (Control.join . Control.lift) Control.return+{-# INLINE iterTM #-}++-- Note. 'destroy' needs to use linear functions in its church encoding+-- to consume the stream linearly.+{-| Map a stream to its church encoding; compare @Data.List.foldr@.+    'destroyExposed' may be more efficient in some cases when+    applicable, but it is less safe.++    @+    destroy s construct eff done+      = eff .+        iterT (Control.return . construct . Control.fmap eff) .+        Control.fmap done $ s+    @+-}+destroy :: forall f m r b . (Control.Functor f, Control.Monad m) =>+     Stream f m r %1-> (f b %1-> b) -> (m b %1-> b) -> (r %1-> b) -> b+destroy stream0 construct theEffect done = theEffect (loop stream0)+  where+    loop :: Stream f m r %1-> m b+    loop stream = stream & \case+      Return r -> Control.return $ done r+      Effect m -> m Control.>>= loop+      Step f -> Control.return $ construct $ Control.fmap (theEffect . loop) f+{-# INLINABLE destroy #-}+
+ src/Streaming/Prelude/Linear.hs view
@@ -0,0 +1,66 @@+{-| The names exported by this module are closely modeled on those in @Prelude@ and @Data.List@,+    but also on+    <http://hackage.haskell.org/package/pipes-4.1.9/docs/Pipes-Prelude.html Pipes.Prelude>,+    <http://hackage.haskell.org/package/pipes-group-1.0.3/docs/Pipes-Group.html Pipes.Group>+    and <http://hackage.haskell.org/package/pipes-parse-3.0.6/docs/Pipes-Parse.html Pipes.Parse>.+    The module may be said to give independent expression to the conception of+    Producer \/ Source \/ Generator manipulation+    articulated in the latter two modules. Because we dispense with piping and+    conduiting, the distinction between all of these modules collapses. Some things are+    lost but much is gained: on the one hand, everything comes much closer to ordinary+    beginning Haskell programming and, on the other, acquires the plasticity of programming+    directly with a general free monad type. The leading type, @Stream (Of a) m r@ is chosen to permit an api+    that is as close as possible to that of @Data.List@ and the @Prelude@.++    Import qualified thus:++> import Streaming+> import qualified Streaming.Prelude as S++    For the examples below, one sometimes needs++> import Streaming.Prelude (each, yield, next, mapped, stdoutLn, stdinLn)+> import Data.Function ((&))++   Other libraries that come up in passing are++> import qualified Control.Foldl as L -- cabal install foldl+> import qualified Pipes as P+> import qualified Pipes.Prelude as P+> import qualified System.IO as IO++     Here are some correspondences between the types employed here and elsewhere:++>               streaming             |            pipes               |       conduit       |  io-streams+> -------------------------------------------------------------------------------------------------------------------+> Stream (Of a) m ()                  | Producer a m ()                | Source m a          | InputStream a+>                                     | ListT m a                      | ConduitM () o m ()  | Generator r ()+> -------------------------------------------------------------------------------------------------------------------+> Stream (Of a) m r                   | Producer a m r                 | ConduitM () o m r   | Generator a r+> -------------------------------------------------------------------------------------------------------------------+> Stream (Of a) m (Stream (Of a) m r) | Producer a m (Producer a m r)  |+> --------------------------------------------------------------------------------------------------------------------+> Stream (Stream (Of a) m) r          | FreeT (Producer a m) m r       |+> --------------------------------------------------------------------------------------------------------------------+> --------------------------------------------------------------------------------------------------------------------+> ByteString m ()                     | Producer ByteString m ()       | Source m ByteString  | InputStream ByteString+> --------------------------------------------------------------------------------------------------------------------+>+-}+module Streaming.Prelude.Linear+  ( module Streaming.Internal.Type+  , module Streaming.Internal.Consume+  , module Streaming.Internal.Interop+  , module Streaming.Internal.Many+  , module Streaming.Internal.Process+  , module Streaming.Internal.Produce+  ) where++import Streaming.Internal.Type+import Streaming.Internal.Consume+import Streaming.Internal.Interop+import Streaming.Internal.Many+import Streaming.Internal.Process+import Streaming.Internal.Produce++
+ src/System/IO/Linear.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE UnboxedTuples #-}++-- | This module redefines 'IO' with linear types.+--+-- To use this @IO@, do the following:+--+--  * use @ main = withLinearIO $ do ...@+--  * pull in any safe non-linear 'IO' functions with+--  @fromSystemIO@ and @fromSystemIOU@+--  * for mutable IO references/pointers, file handles, or any resources, use+--  the linear APIs provided here and in other linear @System.IO@ modules+--+-- = Example+-- @+-- import qualified System.IO.Linear as Linear+--+-- main :: IO ()+-- main = Linear.withLinearIO $+--   Linear.fromSystemIOU $ putStrLn "hello world today"+-- @+--+-- = Replacing The Original @IO@ With This Module.+--+-- This module will be deprecated if the definition for 'IO' found here is+-- 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++import Data.IORef (IORef)+import qualified Data.IORef as System+import Control.Exception (Exception)+import qualified Control.Exception as System (throwIO, catch, mask_)+import qualified Control.Functor.Linear as Control+import qualified Data.Functor.Linear as Data+import GHC.Exts (State#, RealWorld)+import Prelude.Linear hiding (IO)+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.+-- The @State# RealWorld@ is the state of the world/machine outside the program.+--+-- The only way, such a computation is run is by putting it in @Main.main@+-- somewhere.+--+-- Note that this is the same definition as the standard IO monad, but with a+-- 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 #))+  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 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+-- The implementation relies on the fact that the monad abstraction for IO+-- actually enforces linear use of the @RealWorld@ token.+--+-- There are potential difficulties coming from the fact that usage differs:+-- returned value in 'System.IO' can be used unrestrictedly, which is not+-- typically possible of linear 'IO'. This means that 'System.IO' action are+-- not actually mere translations of linear 'IO' action. Still I [aspiwack]+-- think that it is safe, hence no "unsafe" in the name.+fromSystemIO = Unsafe.coerce++-- | Coerces a standard IO action to a linear IO action, allowing you to use+-- the result of type @a@ in a non-linear manner by wrapping it inside+-- 'Ur'.+fromSystemIOU :: System.IO a -> IO (Ur a)+fromSystemIOU action =+  fromSystemIO (Ur Prelude.<$> action)++-- | Convert a linear IO action to a "System.IO" action.+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+-- linearly typed version of 'IO':+--+-- @+-- main :: IO ()+-- main = Linear.withLinearIO $ do ...+-- @+withLinearIO :: IO (Ur a) -> System.IO a+withLinearIO action = (\x -> unur x) Prelude.<$> (toSystemIO action)++-- * Monadic interface++instance Control.Functor IO where+  fmap :: forall a b. (a %1-> b) %1-> IO a %1-> IO b+  fmap f x = IO $ \s ->+      cont (unIO x s) f+    where+      -- XXX: long line+      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 a = IO $ \s -> (# s, a #)++  (<*>) :: 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+  x >>= f = IO $ \s ->+      cont (unIO x s) f+    where+      -- XXX: long line+      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+  x >> y = IO $ \s ->+      cont (unIO x s) y+    where+      cont :: (# State# RealWorld, () #) %1-> IO b %1-> (# State# RealWorld, b #)+      cont (# s', () #) y' = unIO y' s'++-- $ioref+-- @IORef@s are mutable references to values, or pointers to values.+-- You can create, mutate and read them from running IO actions.+--+-- Note that all arrows are unrestricted.  This is because IORefs containing+-- linear values can make linear values escape their scope and be used+-- non-linearly.++newIORef :: a -> IO (Ur (IORef a))+newIORef a = fromSystemIOU (System.newIORef a)++readIORef :: IORef a -> IO (Ur a)+readIORef r = fromSystemIOU (System.readIORef r)++writeIORef :: IORef a -> a -> IO ()+writeIORef r a = fromSystemIO $ System.writeIORef r a++-- $exceptions+--+-- Note that the types of @throw@ and @catch@ sport only unrestricted arrows.+-- Having any of the arrows be linear is unsound.+-- See [here](http://dev.stephendiehl.com/hask/index.html#control.exception)+-- to learn about exceptions.++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 body handler =+  fromSystemIO $ System.catch (toSystemIO body) (\e -> toSystemIO (handler e))++mask_ :: IO a -> IO a+mask_ action = fromSystemIO (System.mask_ (toSystemIO action))
+ src/System/IO/Resource.hs view
@@ -0,0 +1,259 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+-- Deactivate warning because it is painful to refactor functions with two+-- rebinded-do with different bind functions. Such as in the 'run'+-- function. Which is a good argument for having support for F#-style builders.+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}++-- | This module defines an IO monad for linearly working with system resources+-- like files. It provides tools to take resources that are currently+-- unsafely accessible from "System.IO" and use them in this monad.+--+-- Import this module qualified to avoid name clashes.+--+-- To use this RIO monad, create some @RIO@ computation,+-- run it to get a "System.IO" computation.+--+-- = A simple example+-- >>> :set -XLinearTypes+-- >>> :set -XQualifiedDo+-- >>> :set -XNoImplicitPrelude+-- >>> import qualified System.IO.Resource as Linear+-- >>> import qualified Control.Functor.Linear as Control+-- >>> import qualified Data.Text as Text+-- >>> import Prelude.Linear+-- >>> import qualified Prelude+-- >>> :{+--  linearWriteToFile :: IO ()+--  linearWriteToFile = Linear.run Prelude.$ Control.do+--    handle1 <- Linear.openFile "/home/user/test.txt" Linear.WriteMode+--    handle2 <- Linear.hPutStrLn handle1 (Text.pack "hello there")+--    () <- Linear.hClose handle2+--    Control.return (Ur ())+-- :}+--+-- To enable do notation, `QualifiedDo` extension is used. But since QualifiedDo+-- only modifies the desugaring of binds, we still need to qualify `Control.return`.+module System.IO.Resource+  ( -- * The Resource I/O Monad+    RIO+  , run+    -- * Using Resource Handles+    -- $monad+    -- $files+  , Handle+    -- ** File I/O+  , openFile+  , System.IOMode (..)+    -- ** Working with Handles+  , hClose+  , hIsEOF+  , hGetChar+  , hPutChar+  , hGetLine+  , hPutStr+  , hPutStrLn+    -- * Creating new types of resources+    -- $new-resources+  , UnsafeResource+  , unsafeRelease+  , unsafeAcquire+  , unsafeFromSystemIOResource+  , unsafeFromSystemIOResource_+  ) where++import Control.Exception (onException, mask, finally)+import qualified Control.Monad as Ur (fmap)+import qualified Data.Functor.Linear as Data+import qualified Control.Functor.Linear as Control+import Data.Coerce+import qualified Data.IORef as System+import Data.IORef (IORef)+import qualified Data.IntMap.Strict as IntMap+import Data.IntMap.Strict (IntMap)+import Data.Text (Text)+import qualified Data.Text.IO as Text+import Prelude.Linear hiding (IO)+import qualified Prelude+import qualified System.IO.Linear as Linear+import qualified System.IO as System++-- XXX: This would be better as a multiplicity-parametric relative monad, but+-- until we have multiplicity polymorphism, we use a linear monad.+++newtype ReleaseMap = ReleaseMap (IntMap (Linear.IO ()))++-- | The resource-aware I/O monad. This monad guarantees that acquired resources+-- are always released.+newtype RIO a = RIO (IORef ReleaseMap -> Linear.IO a)+  deriving (Data.Functor, Data.Applicative) via (Control.Data RIO)+unRIO :: RIO a %1-> IORef ReleaseMap -> Linear.IO a+unRIO (RIO action) = action++-- | Take a @RIO@ computation with a value @a@ that is not linearly bound and+-- make it a "System.IO" computation.+run :: RIO (Ur a) -> System.IO a+run (RIO action) = do+    rrm <- System.newIORef (ReleaseMap IntMap.empty)+    mask (\restore ->+      onException+        (restore (Linear.withLinearIO (action rrm)))+        (do -- release stray resources+           ReleaseMap releaseMap <- System.readIORef rrm+           safeRelease Prelude.$ Ur.fmap snd Prelude.$ IntMap.toList releaseMap))+      -- Remarks: resources are guaranteed to be released on non-exceptional+      -- return. So, contrary to a standard bracket/ResourceT implementation, we+      -- only release exceptions in the release map upon exception.+  where+    safeRelease :: [Linear.IO ()] -> System.IO ()+    safeRelease [] = Prelude.return ()+    safeRelease (finalizer:fs) = Linear.withLinearIO (moveLinearIO finalizer)+      `finally` safeRelease fs+    -- Should be just an application of a linear `(<$>)`.+    moveLinearIO :: Movable a => Linear.IO a %1-> Linear.IO (Ur a)+    moveLinearIO action' = Control.do+        result <- action'+        Control.return $ move result++-- | Should not be applied to a function that acquires or releases resources.+unsafeFromSystemIO :: System.IO a %1-> RIO a+unsafeFromSystemIO action = RIO (\ _ -> Linear.fromSystemIO action)++-- $monad++instance Control.Functor RIO where+  fmap f (RIO action) = RIO $ \releaseMap ->+    Control.fmap f (action releaseMap)++instance Control.Applicative RIO where+  pure a = RIO $ \_releaseMap -> Control.pure a+  (<*>) = Control.ap++instance Control.Monad RIO where+  x >>= f = RIO $ \releaseMap -> Control.do+      a <- unRIO x releaseMap+      unRIO (f a) releaseMap++  x >> y = RIO $ \releaseMap -> Control.do+      unRIO x releaseMap+      unRIO y releaseMap++-- $files++-- Remark: Handle needs to be private otherwise `Data.Coerce.coerce` could wreak+-- Havoc on the abstraction. But we could provide a smart constructor/view to+-- unsafely convert to file handles in order for the Handle API to be+-- extensible.++newtype Handle = Handle (UnsafeResource System.Handle)++-- | See 'System.IO.openFile'+openFile :: FilePath -> System.IOMode -> RIO Handle+openFile path mode = Control.do+    h <- unsafeAcquire+      (Linear.fromSystemIOU Prelude.$ System.openFile path mode)+      (\h -> Linear.fromSystemIO $ System.hClose h)+    Control.return $ Handle h++hClose :: Handle %1-> RIO ()+hClose (Handle h) = unsafeRelease h++hIsEOF :: Handle %1-> RIO (Ur Bool, Handle)+hIsEOF = coerce (unsafeFromSystemIOResource System.hIsEOF)++hGetChar :: Handle %1-> RIO (Ur Char, Handle)+hGetChar = coerce (unsafeFromSystemIOResource System.hGetChar)++hPutChar :: Handle %1-> Char -> RIO Handle+hPutChar h c = flipHPutChar c h -- needs a multiplicity polymorphic flip+  where+    flipHPutChar :: Char -> Handle %1-> RIO Handle+    flipHPutChar c =+      coerce (unsafeFromSystemIOResource_ (\h' -> System.hPutChar h' c))++hGetLine :: Handle %1-> RIO (Ur Text, Handle)+hGetLine = coerce (unsafeFromSystemIOResource Text.hGetLine)++hPutStr :: Handle %1-> Text -> RIO Handle+hPutStr h s = flipHPutStr s h -- needs a multiplicity polymorphic flip+  where+    flipHPutStr :: Text -> Handle %1-> RIO Handle+    flipHPutStr s =+      coerce (unsafeFromSystemIOResource_ (\h' -> Text.hPutStr h' s))++hPutStrLn :: Handle %1-> Text -> RIO Handle+hPutStrLn h s = flipHPutStrLn s h -- needs a multiplicity polymorphic flip+  where+    flipHPutStrLn :: Text -> Handle %1-> RIO Handle+    flipHPutStrLn s =+      coerce (unsafeFromSystemIOResource_ (\h' -> Text.hPutStrLn h' s))++-- $new-resources++-- | The type of system resources.  To create and use resources, you need to+-- use the API since the constructor is not released.+data UnsafeResource a where+  UnsafeResource :: Int -> a -> UnsafeResource a+ -- Note that both components are unrestricted.++-- | Given an unsafe resource, release it with the linear IO action provided+-- when the resrouce was acquired.+unsafeRelease :: UnsafeResource a %1-> RIO ()+unsafeRelease (UnsafeResource key _) = RIO (\st -> Linear.mask_ (releaseWith key st))+  where+    releaseWith key rrm = Control.do+        Ur (ReleaseMap releaseMap) <- Linear.readIORef rrm+        () <- releaseMap IntMap.! key+        Linear.writeIORef rrm (ReleaseMap (IntMap.delete key releaseMap))++-- | Given a resource in the "System.IO.Linear.IO" monad, and+-- given a function to release that resource, provides that resource in+-- the @RIO@ monad. For example, releasing a @Handle@ from "System.IO"+-- would be done with @fromSystemIO hClose@. Because this release function+-- is an input, and could be wrong, this function is unsafe.+unsafeAcquire+  :: Linear.IO (Ur a)+  -> (a -> Linear.IO ())+  -> RIO (UnsafeResource a)+unsafeAcquire acquire release = RIO $ \rrm -> Linear.mask_ (Control.do+    Ur resource <- acquire+    Ur (ReleaseMap releaseMap) <- Linear.readIORef rrm+    () <-+      Linear.writeIORef+        rrm+        (ReleaseMap+          (IntMap.insert (releaseKey releaseMap) (release resource) releaseMap))+    Control.return $ UnsafeResource (releaseKey releaseMap) resource)+  where+    releaseKey releaseMap =+      case IntMap.null releaseMap of+        True -> 0+        False -> fst (IntMap.findMax releaseMap) + 1++-- | Given a "System.IO" computation on an unsafe resource,+-- lift it to @RIO@ computaton on the acquired resource.+-- That is function of type @a -> IO b@ turns into a function of type+-- @UnsafeResource a %1-> RIO (Ur b)@ +-- along with threading the @UnsafeResource a@.+--+-- Note that the result @b@ can be used non-linearly.+unsafeFromSystemIOResource+  :: (a -> System.IO b)+  -> (UnsafeResource a %1-> RIO (Ur b, UnsafeResource a))+unsafeFromSystemIOResource action (UnsafeResource key resource) =+    unsafeFromSystemIO (do+      c <- action resource+      Prelude.return (Ur c, UnsafeResource key resource))++unsafeFromSystemIOResource_+  :: (a -> System.IO ())+  -> (UnsafeResource a %1-> RIO (UnsafeResource a))+unsafeFromSystemIOResource_ action resource = Control.do+    (Ur _, resource) <- unsafeFromSystemIOResource action resource+    Control.return resource
+ src/Unsafe/Linear.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE LinearTypes #-}++-- | Unsafe coercions for linearly typed code.+--+-- Use this module to coerce non-linear functions to be linear or values+-- bound linearly to be another type. /All/ functions in this module are+-- unsafe.+--+-- Hence:+--+-- * Import this module qualifed as Unsafe.+-- * 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+    coerce,+    toLinear,+    toLinear2,+    toLinear3,+  )+  where++import qualified Unsafe.Coerce as NonLinear+import GHC.Exts (TYPE, RuntimeRep)++-- | Linearly typed @unsafeCoerce@+coerce :: a %1-> b+coerce = NonLinear.unsafeCoerce NonLinear.unsafeCoerce++-- | 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++-- | 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++-- | 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
+ test/Main.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Test.Tasty+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.Polarized (polarizedArrayTests)++main :: IO ()+main = defaultMain allTests++allTests :: TestTree+allTests = testGroup "All tests"+  [ mutArrTests+  , mutVecTests+  , mutHMTests+  , mutSetTests+  , destArrayTests+  , polarizedArrayTests+  ]+
+ test/Test/Data/Destination.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Test.Data.Destination (destArrayTests) where++import Test.Tasty+import Test.Tasty.Hedgehog (testProperty)+import qualified Data.Array.Destination as DArray+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified Data.Vector as Vector+import Prelude.Linear+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+  ]++list :: Gen [Int]+list = Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 100))++randInt :: Gen Int+randInt = Gen.int (Range.linear (-500) 500)++randNonnegInt :: Gen Int+randNonnegInt = Gen.int (Range.linear 0 500)+++-- # Properties+-------------------------------------------------------------------------------++roundTrip :: Property+roundTrip = property Prelude.$ do+  xs <- forAll list+  let v = Vector.fromList xs+  let n = Vector.length v+  v === DArray.alloc n (DArray.mirror v id)++replicateTest :: Property+replicateTest = property Prelude.$ do+  n <- forAll randNonnegInt+  x <- forAll randInt+  let v = Vector.replicate n x+  v === DArray.alloc n (DArray.replicate x)+++fillTest :: Property+fillTest = property Prelude.$ do+  x <- forAll randInt+  let v = Vector.singleton x+  v === DArray.alloc 1 (DArray.fill x)++fromFuncEnum :: Property+fromFuncEnum = property Prelude.$ do+  n <- forAll randNonnegInt+  start <- forAll randInt+  let v = Vector.enumFromN start n+  v === DArray.alloc n (DArray.fromFunction (Prelude.+ start))+
+ test/Test/Data/Mutable/Array.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++-- |+-- Tests for mutable arrays.+--+-- See the testing framework explained in Test.Data.Mutable.Set.+--+-- The combination of axioms and homomorphisms provided functionally specify+-- the behavior of arrays.+--+-- Remarks:+--  * We don't test for failure on out-of-bound access+--  * We don't test the empty constructor because+module Test.Data.Mutable.Array+  ( mutArrTests,+  )+where++import qualified Data.Array.Mutable.Linear as Array+import Data.Unrestricted.Linear+import qualified Data.Functor.Linear as Data+import qualified Data.Ord.Linear as Linear+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)++-- # Exported Tests+--------------------------------------------------------------------------------++mutArrTests :: TestTree+mutArrTests = testGroup "Mutable array tests" group++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+      "∀ 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+  ]++-- # Internal Library+--------------------------------------------------------------------------------++type ArrayTester = Array.Array Int %1-> Ur (TestT IO ())++nonEmptyList :: Gen [Int]+nonEmptyList = Gen.list (Range.linear 1 1000) value++list :: Gen [Int]+list = Gen.list (Range.linear 0 1000) value++-- | A random value+value :: Gen Int+value = Gen.int (Range.linear (-1000) 1000)++compInts ::+  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 (a, b) = lseq b a+++-- # Tests+--------------------------------------------------------------------------------++readAlloc :: Property+readAlloc = property $ do+  size <- forAll $ Gen.int $ Range.linear 1 1000+  val <- forAll value+  ix <- forAll $ Gen.element [0..size-1]+  test $ unur Linear.$ Array.alloc size val (readAllocTest ix val)++readAllocTest :: Int -> Int -> ArrayTester+readAllocTest ix val arr = compInts (getFst (Array.read arr ix)) (move val)++readResize :: Property+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]+  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)++readWrite1 :: Property+readWrite1 = property $ do+  l <- forAll nonEmptyList+  let size = length l+  ix <- forAll $ Gen.element [0..size-1]+  val <- forAll value+  let tester = readWrite1Test ix val+  test $ unur Linear.$ Array.fromList l tester++readWrite1Test :: Int -> Int -> ArrayTester+readWrite1Test ix val arr =+  compInts (move val) (getFst Linear.$ Array.read (Array.write arr ix val) ix)++readWrite2 :: Property+readWrite2 = property $ do+  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 ]+  val <- forAll value+  let tester = readWrite2Test ix jx val+  test $ unur Linear.$ Array.fromList l tester++readWrite2Test :: Int -> Int -> Int -> ArrayTester+readWrite2Test ix jx val arr = fromRead (Array.read arr ix)+  where+    fromRead ::+      (Ur Int, Array.Array Int) %1-> Ur (TestT IO ())+    fromRead (val1, arr) =+      compInts+        val1+        (getFst Linear.$ Array.read (Array.write arr jx val) ix)++allocBeside :: Property+allocBeside = property $ do+  l <- forAll nonEmptyList+  let size = length l+  newSize <- forAll $ Gen.element [size..(size*4)]+  val <- forAll value+  ix <- forAll $ Gen.element [0..newSize-1]+  let tester = allocBesideTest newSize val ix+  test $ unur Linear.$ Array.fromList l tester++allocBesideTest :: Int -> Int -> Int -> ArrayTester+allocBesideTest newSize val ix arr =+  Array.allocBeside newSize val arr+    Linear.& getFst+    Linear.& \arr -> Array.read arr ix+    Linear.& getFst+    Linear.& compInts (move val)++lenAlloc :: Property+lenAlloc = property $ do+  size <- forAll $ Gen.int $ Range.linear 0 1000+  val <- forAll value+  test $ unur Linear.$ Array.alloc size val (lenAllocTest size)++lenAllocTest :: Int -> ArrayTester+lenAllocTest size arr =+  compInts (move size) (getFst Linear.$ Array.size arr)++lenWrite :: Property+lenWrite = property $ do+  l <- forAll nonEmptyList+  let size = length l+  val <- forAll value+  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)+    (getFst Linear.$ Array.size (Array.write arr ix val))++lenResizeSeed :: Property+lenResizeSeed = property $ do+  l <- forAll list+  let size = length l+  val <- forAll value+  newSize <- forAll $ Gen.element [size..(size*4)]+  let tester = lenResizeSeedTest newSize val+  test $ unur Linear.$ Array.fromList l tester++lenResizeSeedTest :: Int -> Int -> ArrayTester+lenResizeSeedTest newSize val arr =+  compInts+    (move newSize)+    (getFst Linear.$ Array.size (Array.resize newSize val arr))++writeRef :: Property+writeRef = property $ do+  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+  l' === unur (Array.fromList l (Array.toList Linear.. Array.set ix v))++readRef :: Property+readRef = property $ do+  l <- forAll nonEmptyList+  ix <- forAll $ Gen.int $ Range.linear 0 (length l - 1)+  (l List.!! ix) === (unur (Array.fromList l (getFst Linear.. Array.get ix)))++sizeRef :: Property+sizeRef = property $ do+  l <- forAll list+  length l === (unur (Array.fromList l (getFst Linear.. Array.size)))++resizeRef :: Property+resizeRef = property $ do+  l <- forAll list+  n <- forAll $ Gen.int (Range.linear 0 (length l * 2))+  x <- forAll value+  let expected = take n $ l ++ repeat x+      actual =+        unur Linear.. Array.fromList l Linear.$ \arr ->+          Array.resize n x arr+            Linear.& Array.toList+  actual === expected++refToListFromList :: Property+refToListFromList = property $ do+  xs <- forAll list+  let Ur actual = Array.fromList xs Array.toList+  xs === actual++sliceRef :: Property+sliceRef = property $ do+  xs <- forAll list+  s <- forAll $ Gen.int (Range.linear 0 (length xs))+  n <- forAll $ Gen.int (Range.linear 0 (length xs - s))+  let expected = take n . drop s $ xs+      Ur actual =+        Array.fromList xs Linear.$ \arr ->+          Array.slice s n arr+            Linear.& \(old, 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 = (Linear.> 0)+      expected = map (Linear.forget f) xs+      Ur actual =+        Array.fromList xs Linear.$ \arr ->+          Array.toList (f Data.<$> arr)+  expected === actual++refFreeze :: Property+refFreeze = property $ do+  xs <- forAll list+  let Ur vec = Array.fromList xs Array.freeze+  xs === Vector.toList vec++refDupable :: Property+refDupable = property $ do+  xs <- forAll list+  let Ur (r1, r2) =+        Array.fromList xs Linear.$ \arr ->+          dup2 arr Linear.& \(arr1, arr2) ->+            Array.toList arr1 Linear.& \(Ur l1) ->+              Array.toList arr2 Linear.& \(Ur l2) ->+                Ur (l1, l2)+  xs === r1+  xs === r2++-- https://github.com/tweag/linear-base/pull/135+readAndWriteTest :: Property+readAndWriteTest = withTests 1 . property $+  unur (Array.fromList "a" test) === 'a'+  where+    test :: Array.Array Char %1-> Ur Char+    test arr =+      Array.read arr 0 Linear.& \(before, arr') ->+        Array.write arr' 0 'b' Linear.& \arr'' ->+          arr'' `Linear.lseq` before++-- https://github.com/tweag/linear-base/issues/142+strictnessTest :: Property+strictnessTest = withTests 1 . property $+  unur (Array.fromList [()] test) === ()+  where+    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 ()
+ test/Test/Data/Mutable/HashMap.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++-- |+-- Tests for mutable hashmaps+--+-- See the testing framework explained in Test.Data.Mutable.Set.+--+-- The combination of axioms and homomorphisms provided (for the most part)+-- functionally specify the behavior of hashmaps. There are a few things+-- we leave out and mention below.+--+-- Remarks:+-- * We don't test trivial things like: empty, capacity+-- * We don't test member since we test lookup+-- * We don't test alter and hope insert and delete tests suffice+-- * We don't test filterWithKey and hope the test for filter suffices+-- * We don't test mapMaybe since mapMaybeWithKey is more general+module Test.Data.Mutable.HashMap+  ( mutHMTests,+  )+where++import qualified Data.Functor.Linear as Linear+import qualified Data.HashMap.Mutable.Linear as HashMap+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)++-- # Exported Tests+--------------------------------------------------------------------------------++mutHMTests :: TestTree+mutHMTests = testGroup "Mutable hashmap tests" group++group :: [TestTree]+group =+  [ -- Axiomatic tests+    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+      "∀ 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+  ]++-- # Internal Library+--------------------------------------------------------------------------------++-- # Mini Testing Framework+----------------------------------------++-- | All tests are on maps from int to string+type HMap = HashMap.HashMap Int String++-- | A test checks a boolean property on a hashmap and consumes it+type HMTest = HMap %1-> Ur Bool+++maxSize :: Int+maxSize = 800++-- HashMap's have lots of corner cases, so we try harder to find them.+defProperty :: PropertyT IO () -> Property+defProperty = withTests 1000 . property++-- | Run a test on a random HashMap+testOnAnyHM :: PropertyT IO HMTest -> Property+testOnAnyHM propHmtest = defProperty $ do+  kvs <- forAll keyVals+  hmtest <- propHmtest+  assert $ unur Linear.$ HashMap.fromList kvs hmtest++testKVPairExists :: (Int, String) -> HMTest+testKVPairExists (k, v) hmap =+  fromLookup Linear.$ getFst Linear.$ HashMap.lookup k hmap+  where+    fromLookup :: Ur (Maybe String) %1-> Ur Bool+    fromLookup (Ur Nothing) = Ur False+    fromLookup (Ur (Just v')) = Ur (v' == v)++testKeyMember :: Int -> HMTest+testKeyMember key hmap = getFst Linear.$ HashMap.member key hmap++testKeyNotMember :: Int -> HMTest+testKeyNotMember key hmap = Linear.fmap Linear.not (testKeyMember key hmap)++-- | That is, test that lookup gives us `Nothing`+testKeyMissing :: Int -> HMTest+testKeyMissing key hmap =+  fromLookup Linear.$ getFst Linear.$ HashMap.lookup key hmap+  where+    fromLookup :: Ur (Maybe String) %1-> Ur Bool+    fromLookup (Ur Nothing) = Ur True+    fromLookup (Ur _) = Ur False++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 (look1, hmap') =+      compareMaybes look1 (getFst Linear.$ HashMap.lookup k (f 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 (a, b) = lseq b a++compareMaybes :: Eq a =>+  Ur (Maybe a) %1->+  Ur (Maybe a) %1->+  Ur Bool+compareMaybes (Ur a) (Ur b) = Ur (a == b)++-- # Random Generation+----------------------------------------++-- | Key generator+key :: Gen Int+key = Gen.int $ Range.linearFrom 0 (-20) 20++-- | Value generator+val :: Gen String+val = do+  let strSize = Range.singleton 3+  Gen.string strSize Gen.alpha++-- | Random pairs with no duplicate keys+keyVals :: Gen [(Int, String)]+keyVals = do+  size <- Gen.int $ Range.linear 0 maxSize+  let sizeGen = Range.singleton size+  keys <- Gen.list sizeGen key+  vals <- Gen.list sizeGen val+  return $ zip keys vals++-- # Tests+--------------------------------------------------------------------------------++lookupInsert1 :: Property+lookupInsert1 = testOnAnyHM $ do+  k <- forAll key+  v <- forAll val+  let insertKV = insertPair (k, v)+  let checkKV = testKVPairExists (k, v)+  return (checkKV Linear.. insertKV)++lookupInsert2 :: Property+lookupInsert2 = testOnAnyHM $ do+  k <- forAll key+  k' <- forAll $ Gen.filter (/= k) key+  v <- forAll val+  let insertKV = insertPair (k, v)+  return (testLookupUnchanged insertKV k')++lookupDelete1 :: Property+lookupDelete1 = testOnAnyHM $ do+  k <- forAll key+  let checkNoKey = testKeyMissing k+  return (checkNoKey Linear.. HashMap.delete k)++lookupDelete2 :: Property+lookupDelete2 = testOnAnyHM $ do+  k <- forAll key+  k' <- forAll $ Gen.filter (/= k) key+  return (testLookupUnchanged (HashMap.delete k) k')++memberInsert :: Property+memberInsert = testOnAnyHM $ do+  k <- forAll key+  v <- forAll val+  let insertKV = insertPair (k, v)+  let isMemberK = testKeyMember k+  return (isMemberK Linear.. insertKV)++memberDelete :: Property+memberDelete = testOnAnyHM $ do+  k <- forAll key+  v <- forAll val+  let pair = (k, v)+  let insertKV = insertPair pair+  let checkNotMember = testKeyNotMember k+  return (checkNotMember Linear.. HashMap.delete k Linear.. insertKV)++sizeInsert :: Property+sizeInsert = testOnAnyHM $ do+  k <- forAll key+  v <- forAll val+  let pair = (k, v)+  let insertCheckSize = checkSizeAfterInsert pair+  return (insertCheckSize Linear.. HashMap.delete k)++checkSizeAfterInsert :: (Int, String) -> HMTest+checkSizeAfterInsert (k, v) hmap = withSize Linear.$ HashMap.size hmap+  where+    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 (Ur old) (Ur new) =+      Ur ((old + 1) == new)++deleteSize :: Property+deleteSize = testOnAnyHM $ do+  k <- forAll key+  v <- forAll val+  let insertKV = insertPair (k, v)+  let checkSize = checkSizeAfterDelete k+  return (checkSize Linear.. insertKV)++checkSizeAfterDelete :: Int -> HMTest+checkSizeAfterDelete key hmap = fromSize (HashMap.size hmap)+  where+    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 (Ur orgSize) (Ur newSize) =+      Ur ((newSize + 1) == orgSize)++refInsert :: Property+refInsert = defProperty $ do+  k <- forAll key+  v <- forAll val+  kvs <- forAll keyVals+  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)++refDelete :: Property+refDelete = defProperty $ do+  k <- forAll key+  kvs <- forAll keyVals+  let kvs' = filter ((/= k) . fst) kvs+  let listInsert = HashMap.fromList kvs' HashMap.toList+  let hmInsert = HashMap.fromList kvs (HashMap.toList Linear.. HashMap.delete k)+  sort (unur listInsert) === sort (unur hmInsert)++refLookup :: Property+refLookup = defProperty $ do+  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)+  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)+  kvs <- forAll keyVals+  let (#.) = (Linear..)+  let mappedList = mapMaybe f' (nubOrdOn fst (List.reverse kvs))+  let mappedHm = HashMap.fromList kvs (HashMap.toList #. 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))++refToListFromList :: Property+refToListFromList = defProperty $ do+  xs <- forAll keyVals++  let expected = Map.fromList xs+                   & Map.toList++      Ur actual = HashMap.fromList xs HashMap.toList++  sort expected === sort actual++refFilter :: Property+refFilter = defProperty $ do+  xs <- forAll keyVals++  let predicate "" = False+      predicate (i:_) = i < 'h'++      expected = Map.fromList xs+                   & Map.filter predicate+                   & Map.toList++      Ur actual = HashMap.fromList xs Linear.$+        HashMap.toList Linear.. HashMap.filter predicate++  sort expected === sort actual++refMappend :: Property+refMappend = defProperty $ do+  xs <- forAll keyVals+  ys <- forAll keyVals++  let Ur expected =+        HashMap.fromList (xs <> ys) Linear.$ HashMap.toList++      Ur actual =+        HashMap.fromList xs Linear.$ \hx ->+          HashMap.fromList ys Linear.$ \hy ->+            HashMap.toList (hx Linear.<> hy)++  sort expected === sort actual++refUnionWith :: Property+refUnionWith = defProperty $ do+  xs <- forAll keyVals+  ys <- forAll keyVals++  let combine a b = a ++ "," ++ b++      expected = Map.unionWith combine+                  (Map.fromList xs)+                  (Map.fromList ys)+                  & Map.toList++      Ur actual =+        HashMap.fromList xs Linear.$ \hx ->+          HashMap.fromList ys Linear.$ \hy ->+            HashMap.unionWith combine hx hy+              Linear.& HashMap.toList++  sort expected === sort actual++refIntersectionWith :: Property+refIntersectionWith = defProperty $ do+  xs <- forAll keyVals+  ys <- forAll keyVals++  let expected = Map.intersectionWith (,)+                  (Map.fromList xs)+                  (Map.fromList ys)+                  & Map.toList++      Ur actual =+        HashMap.fromList xs Linear.$ \hx ->+          HashMap.fromList ys Linear.$ \hy ->+            HashMap.intersectionWith (,) hx hy+              Linear.& HashMap.toList++  sort expected === sort actual++shrinkToFitTest :: Property+shrinkToFitTest = defProperty $ do+  kvs <- forAll keyVals+  let (#.) = (Linear..)+  let shrunk = (HashMap.fromList kvs (HashMap.toList #. HashMap.shrinkToFit))+  sort (nubOrdOn fst (List.reverse kvs)) === sort (unur shrunk)+
+ test/Test/Data/Mutable/Set.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+-- |+-- Tests for mutable sets.+--+-- = How we designed the tests+--+-- We use hedgehog to test properties that are axioms that funtionally define+-- the behavior of sets. There is at least one axiom per each combination of+-- accessor and constructor/mutator. So for the accessor @f@, and+-- constructor/mutator @g@, we have one axiom of the form @f (g (...)) = ...@.+--+-- If however, this is cumbersome, we can often just test against an existing+-- implementation. This is like a homomorphism test (but it's not quite a+-- homomorphism). For unions, this is like saying if we have two lists A and B,+-- and we take their union as lists, then sort and nub (remove duplicates)+-- this is the same as using @Set.fromList@ to make them into sets, taking+-- the union as sets, converting back with @Set.toList@ and then sorting+-- the output list.+--+-- To have such a test replace an axiom, however, we need to have+-- "homomorphisms" for each accessor or modifier. In general, we want to be+-- able to say for any modifier or accessor @f@,+--+-- >  toList (f set) = f' (toList set)+--+-- where @f'@ is some reference implementation we know. The key idea is a kind+-- of "homomorphism" between @f@ and a reference implementation @f'@ that+-- holds across the conversion function @toList@.+--+-- Note: We could also formulate this in terms of @fromList@.+--+-- For example, we'd want to have @member x (fromList l) = elem x l@+-- for any @x@ and @l@.+--+-- With this we can prove+--+-- >  member x (intersect set1 set2) = member x set1 && member x set2+--+-- Thusly:+--+-- >  member x (intersect set1 set2) =+-- >  member x (intersect (fromList l1) (fromList l2)) =  -- for some l1, l2+-- >  member x (fromList (intersect l1 l2)) =+-- >  elem x (intersect l1 l2)) =+-- >  elem x l1 && elem x l2 =+-- >  member x (fromList l1) && member x (fromList l2) =+-- >  member x set1 && member x set2+--+-- See https://softwarefoundations.cis.upenn.edu/vfa-current/ADT.html+-- for more about how ADT axioms work.+--+-- Remark: we are not testing @empty@ since it is trivial.+module Test.Data.Mutable.Set+  ( mutSetTests,+  )+where++import qualified Data.Set.Mutable.Linear as Set+import Data.Set.Mutable.Linear (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+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++-- # Exported Tests+--------------------------------------------------------------------------------++mutSetTests :: TestTree+mutSetTests = testGroup "Mutable set tests" group++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+      "sort . nub ((toList s) ∪ (toList s')) = sort . toList (s ∪ s')"+      unionHomomorphism+  , testProperty+      "sort . nub ((toList s) ∩ (toList s')) = sort . toList (s ∩ s')"+      intersectHomomorphism+  ]++-- # Internal Library+--------------------------------------------------------------------------------++type SetTester = Set.Set Int %1-> Ur (TestT IO ())++-- | A random list+list :: Gen [Int]+list = do+  size <- Gen.int $ Range.linearFrom 0 0 1000+  let size' = Range.singleton size+  Gen.list size' $ Gen.int $ Range.linearFrom 0 (-100) 100++-- | A random value+value :: Gen Int+value = Gen.int (Range.linear (-100) 100)++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 (a, b) = lseq b a++-- # Tests+--------------------------------------------------------------------------------++memberInsert1 :: Property+memberInsert1 = property $ do+  val <- forAll value+  l <- forAll list+  let tester = memberInsert1Test val+  test $ unur Linear.$ Set.fromList l tester++memberInsert1Test :: Int -> SetTester+memberInsert1Test val set =+  testEqual+    (Ur True)+    (getFst (Set.member val (Set.insert val set)))++memberInsert2 :: Property+memberInsert2 = property $ do+  val1 <- forAll value+  val2 <- forAll $ Gen.filter (/= val1) value+  l <- forAll list+  let tester = memberInsert2Test val1 val2+  test $ unur Linear.$ Set.fromList l tester++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 (memberVal2, set) =+      testEqual+        memberVal2+        (getFst (Set.member val2 (Set.insert val1 set)))++memberDelete1 :: Property+memberDelete1 = property $ do+  val <- forAll value+  l <- forAll list+  let tester = memberDelete1Test val+  test $ unur Linear.$ Set.fromList l tester++memberDelete1Test :: Int -> SetTester+memberDelete1Test val set =+  testEqual+    (Ur False)+    (getFst (Set.member val (Set.delete val set)))++memberDelete2 :: Property+memberDelete2 = property $ do+  val1 <- forAll value+  val2 <- forAll $ Gen.filter (/= val1) value+  l <- forAll list+  let tester = memberDelete2Test val1 val2+  test $ unur Linear.$ Set.fromList l tester++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 (memberVal2, set) =+      testEqual+        memberVal2+        (getFst Linear.$ Set.member val2 (Set.delete val1 set))++sizeInsert1 :: Property+sizeInsert1 = property $ do+  l <- forAll list+  val <- forAll $ Gen.filter (`elem` l) value+  let tester = sizeInsert1Test val+  test $ unur Linear.$ Set.fromList l tester++sizeInsert1Test :: Int -> SetTester+sizeInsert1Test val set = fromRead (Set.size set)+  where+    fromRead :: (Ur Int, Set.Set Int) %1-> Ur (TestT IO ())+    fromRead (sizeOriginal, set) =+      testEqual+        sizeOriginal+        (getFst Linear.$ (Set.size (Set.insert val set)))++sizeInsert2 :: Property+sizeInsert2 = property $ do+  l <- forAll list+  val <- forAll $ Gen.filter (not . (`elem` l)) value+  let tester = sizeInsert2Test val+  test $ unur Linear.$ Set.fromList l tester++sizeInsert2Test :: Int -> SetTester+sizeInsert2Test val set = fromRead (Set.size set)+  where+    fromRead :: (Ur Int, Set.Set Int) %1-> Ur (TestT IO ())+    fromRead (sizeOriginal, set) =+      testEqual+        ((Linear.+ 1) Data.<$> sizeOriginal)+        (getFst Linear.$ (Set.size (Set.insert val set)))++sizeDelete1 :: Property+sizeDelete1 = property $ do+  l <- forAll list+  val <- forAll $ Gen.filter (`elem` l) value+  let tester = sizeDelete1Test val+  test $ unur Linear.$ Set.fromList l tester++sizeDelete1Test :: Int -> SetTester+sizeDelete1Test val set = fromRead (Set.size set)+  where+    fromRead :: (Ur Int, Set.Set Int) %1-> Ur (TestT IO ())+    fromRead (sizeOriginal, set) =+      testEqual+        ((Linear.- 1) Data.<$> sizeOriginal)+        (getFst Linear.$ (Set.size (Set.delete val set)))++sizeDelete2 :: Property+sizeDelete2 = property $ do+  l <- forAll list+  val <- forAll $ Gen.filter (not . (`elem` l)) value+  let tester = sizeDelete2Test val+  test $ unur Linear.$ Set.fromList l tester++sizeDelete2Test :: Int -> SetTester+sizeDelete2Test val set = fromRead (Set.size set)+  where+    fromRead :: (Ur Int, Set.Set Int) %1-> Ur (TestT IO ())+    fromRead (sizeOriginal, set) =+      testEqual+        sizeOriginal+        (getFst Linear.$ (Set.size (Set.delete val set)))++toListFromList :: Property+toListFromList = property $ do+  l <- forAll list+  let outsideSet = nubOrd . List.sort $ l+  List.sort (unur (Set.fromList l Set.toList)) === outsideSet++unionHomomorphism :: Property+unionHomomorphism = property $ do+  l <- forAll list+  l' <- forAll list+  let listUnion = nubOrd $ List.sort $ List.union l l'+  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 l l' f = Set.fromList l (\s -> Set.fromList l' (\s' -> f s s'))++    doUnion :: Set Int %1-> Set Int %1-> Ur [Int]+    doUnion s s' = Set.toList (Set.union s s')++intersectHomomorphism :: Property+intersectHomomorphism = property $ do+  l <- forAll list+  l' <- forAll list+  let listIntersect = nubOrd $ List.sort $ List.intersect l l'+  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 l l' f = Set.fromList l (\s -> Set.fromList l' (\s' -> f s s'))++    doIntersect :: Set Int %1-> Set Int %1-> Ur [Int]+    doIntersect s s' = Set.toList (Set.intersection s s')++memberHomomorphism :: Property+memberHomomorphism = property $ do+  l <- forAll list+  x <- forAll value+  elem x l === (unur Linear.$ Set.fromList l (getFst Linear.. Set.member x))++sizeHomomorphism :: Property+sizeHomomorphism = property $ do+  l <- forAll list+  length (nubOrd l) === (unur (Set.fromList l (getFst Linear.. Set.size)))+
+ test/Test/Data/Mutable/Vector.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++-- |+-- Tests for mutable vectors.+--+-- See the testing framework explained in Test.Data.Mutable.Set.+--+-- The combination of axioms and homomorphisms provided functionally specify+-- the behavior of vectors.+--+-- Remarks:+--  * We don't test for failure on out-of-bound access+--  * We don't test the empty constructor+module Test.Data.Mutable.Vector+  ( mutVecTests,+  )+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 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)++-- # Exported Tests+--------------------------------------------------------------------------------++mutVecTests :: TestTree+mutVecTests = testGroup "Mutable vector tests" group++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+      "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+      "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+  ]++-- # Internal Library+--------------------------------------------------------------------------------++type VectorTester = Vector.Vector Int %1-> Ur (TestT IO ())++nonEmptyList :: Gen [Int]+nonEmptyList = Gen.list (Range.linear 1 1000) val++list :: Gen [Int]+list = Gen.list (Range.linear 0 1000) val++val :: Gen Int+val = Gen.int (Range.linear (-1000) 1000)++compInts ::+  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 (a, b) = lseq b a++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+  actual === 42++-- | Constant should give us a constant vector.+readConst :: Property+readConst = property $ do+  size <- forAll $ Gen.int $ Range.linear 1 1000+  v <- forAll val+  ix <- forAll $ Gen.element [0..size-1]+  test $ unur Linear.$ Vector.constant size v (readConstTest ix v)++readConstTest :: Int -> Int -> VectorTester+readConstTest ix val vec = compInts (getFst (Vector.read vec ix)) (move val)++readWrite1 :: Property+readWrite1 = property $ do+  l <- forAll nonEmptyList+  let size = length l+  ix <- forAll $ Gen.element [0..size-1]+  v <- forAll val+  let tester = readWrite1Test ix v+  test $ unur Linear.$ Vector.fromList l tester++readWrite1Test :: Int -> Int -> VectorTester+readWrite1Test ix val vec =+  compInts (move val) (getFst Linear.$ Vector.read (Vector.write vec ix val) ix)++readWrite2 :: Property+readWrite2 = property $ do+  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 ]+  v <- forAll val+  let tester = readWrite2Test ix jx v+  test $ unur Linear.$ Vector.fromList l tester++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 (val1, vec) =+      compInts+        val1+        (getFst Linear.$ Vector.read (Vector.write vec jx val) ix)++readPush1 :: Property+readPush1 = property $ do+  l <- forAll nonEmptyList+  let size = length l+  v <- forAll val+  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 (val', vec) =+      compInts (getFst (Vector.get ix (Vector.push val vec))) val'+++readPush2 :: Property+readPush2 = property $ do+  l <- forAll list+  v <- forAll val+  let tester = readPush2Test v+  test $ unur Linear.$ Vector.fromList l tester++readPush2Test :: Int -> VectorTester+readPush2Test val vec = fromLen (Vector.size vec)+  where+    fromLen ::+      (Ur Int, Vector.Vector Int) %1->+      Ur (TestT IO ())+    fromLen (Ur len, vec) =+      compInts (getFst (Vector.get len (Vector.push val vec))) (move val)++lenConst :: Property+lenConst = property $ do+  size <- forAll $ Gen.int $ Range.linear 1 1000+  v <- forAll val+  test $ unur Linear.$ Vector.constant size v (lenConstTest size)++lenConstTest :: Int -> VectorTester+lenConstTest size vec =+  compInts (move size) (getFst Linear.$ Vector.size vec)++lenWrite :: Property+lenWrite = property $ do+  l <- forAll nonEmptyList+  let size = length l+  v <- forAll val+  ix <- forAll $ Gen.element [0..size-1]+  let tester = lenWriteTest size v ix+  test $ unur Linear.$ Vector.fromList l tester++lenWriteTest :: Int -> Int -> Int -> VectorTester+lenWriteTest size val ix vec =+  compInts+    (move size)+    (getFst Linear.$ Vector.size (Vector.write vec ix val))++lenPush :: Property+lenPush = property $ do+ 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 (TestT IO ())+    fromLen (Ur len, 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)]+  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++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)]+  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 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++refPush :: Property+refPush = property $ do+  l <- forAll list+  v <- forAll val+  let l' = l ++ [v]+  l' === unur (Vector.fromList l (Vector.toList Linear.. Vector.push v))++refPop :: Property+refPop = property $ do+  l <- forAll nonEmptyList+  let v = Vector.fromList l (Vector.toList Linear.. getSnd Linear.. Vector.pop)+  List.init l === unur v++refRead :: Property+refRead = property $ do+  l <- forAll nonEmptyList+  ix <- forAll $ Gen.element [0..(length l - 1)]+  let value = l List.!! ix+  value === unur (Vector.fromList l (getFst Linear.. Vector.get ix))++refSize :: Property+refSize = property $ do+  l <- forAll list+  length l === unur (Vector.fromList l (getFst Linear.. Vector.size))++refShrinkToFit :: Property+refShrinkToFit = property $ do+  l <- forAll list+  l === unur (Vector.fromList l (Vector.toList Linear.. Vector.shrinkToFit))++refToListFromList :: Property+refToListFromList = property $ do+  xs <- forAll list+  let Ur actual = Vector.fromList xs Vector.toList+  xs === actual++refToListWithExtraCapacity :: Property+refToListWithExtraCapacity = property $ do+  xs <- forAll list+  let val = 12+      expected = xs ++ [val]+      Ur actual =+        Vector.fromList xs Linear.$ \vec ->+          Vector.push val vec -- This will cause the vector to grow.+            Linear.& Vector.toList+  expected === actual++refPopPush :: Property+refPopPush = property $ do+  xs <- forAll list+  let Ur actual =+        Vector.fromList xs Linear.$ \vec ->+          Vector.push (error "not used") vec+            Linear.& Vector.pop+            Linear.& \(Ur _, vec) ->+                        Vector.toList vec+  xs === actual++refPushPop :: Property+refPushPop = property $ do+  xs <- forAll nonEmptyList+  let Ur actual =+        Vector.fromList xs Linear.$ \vec ->+          Vector.pop vec+            Linear.& \(Ur (Just a), vec) ->+                        Vector.push a vec+            Linear.& Vector.toList+  xs === actual++refToListViaPop :: Property+refToListViaPop = property $ do+  xs <- forAll list+  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'++refFromListViaPush :: Property+refFromListViaPush = property $ do+  xs <- forAll list+  let Ur actual =+        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++refSlice :: Property+refSlice = property $ do+  xs <- forAll list+  s <- forAll $ Gen.int (Range.linear 0 (length xs))+  n <- forAll $ Gen.int (Range.linear 0 (length xs - s))+  let expected = take n . drop s $ xs+      Ur actual =+        Vector.fromList xs Linear.$ \arr ->+          Vector.slice s n arr+            Linear.& Vector.toList+  expected === actual++refMappend :: Property+refMappend = property $ do+  xs <- forAll list+  ys <- forAll list+  let expected = xs <> ys+      Ur actual =+        Vector.fromList xs Linear.$ \vx ->+          Vector.fromList ys Linear.$ \vy ->+            Vector.toList (vx Linear.<> vy)+  expected === actual++refFmap :: Property+refFmap = property $ do+  xs <- forAll list+  let -- An arbitrary function+      f :: Int %1-> Bool+      f = (Linear.> 0)+      expected = map (Linear.forget f) xs+      Ur actual =+        Vector.fromList xs Linear.$ \vec ->+          Vector.toList (f Data.<$> vec)+  expected === actual++refMapMaybe :: Property+refMapMaybe = property $ do+  xs <- forAll list+  let -- An arbitrary function+      f :: Int -> Maybe Bool+      f = (\a -> if a Prelude.< 0 then Nothing else Just (a `mod` 2 == 0))+      expected = mapMaybe f xs+      Ur actual =+        Vector.fromList xs Linear.$ \vec ->+          Vector.mapMaybe vec f+            Linear.& Vector.toList+  expected === actual++refFilter :: Property+refFilter = property $ do+  xs <- forAll list+  let -- An arbitrary function+      f :: Int -> Bool+      f = (Prelude.< 0)+      expected = filter f xs+      Ur actual =+        Vector.fromList xs Linear.$ \vec ->+          Vector.filter vec f+            Linear.& Vector.toList+  expected === actual++refFreeze :: Property+refFreeze = property $ do+  xs <- forAll list++  -- Add a new element at the end of the vector+  -- to force resizing, to test the case where+  -- sz < cap.+  shouldAppend <- forAll Gen.bool++  let expected =+        if shouldAppend+        then xs ++ [12]+        else xs++      Ur actual = Vector.fromList xs Linear.$ \vec ->+           (if shouldAppend+            then Vector.push 12 vec+            else vec+           ) 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'+  where+    test :: Vector.Vector Char %1-> Ur Char+    test vec =+      Vector.read vec 0 Linear.& \(before, vec') ->+        Vector.write vec' 0 'b' Linear.& \vec'' ->+          vec'' `Linear.lseq` before
+ test/Test/Data/Polarized.hs view
@@ -0,0 +1,116 @@+{-# 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.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 Prelude.Linear+import qualified Prelude++{- TODO:++ * test fmap on push arrays+ * test zip on different length pull arrays errors++-}+++-- # 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+  ]++list :: Gen [Int]+list = Gen.list (Range.linear 0 1000) randInt++randInt :: Gen Int+randInt = Gen.int (Range.linear (-500) 500)++randNonnegInt :: Gen Int+randNonnegInt = Gen.int (Range.linear 0 500)+++-- # Properties+-------------------------------------------------------------------------------++polarRoundTrip :: Property+polarRoundTrip = property Prelude.$ do+  xs <- forAll list+  let v = Vector.fromList xs+  v === Push.alloc (Polar.transfer (Pull.fromVector v))++pushAppend :: Property+pushAppend = property Prelude.$ do+  xs <- forAll list+  ys <- forAll list+  let v1 = Vector.fromList xs+  let v2 = Vector.fromList ys+  let sumVecs = v1 Vector.++ v2+  sumVecs === Push.alloc (Polar.walk v1 <> Polar.walk v2)++pushMake :: Property+pushMake = property Prelude.$ do+  n <- forAll randNonnegInt+  x <- forAll randInt+  let v = Vector.replicate n x+  v === Push.alloc (Push.make x n)++pullAppend :: Property+pullAppend = property Prelude.$ do+  xs <- forAll list+  ys <- forAll list+  let v1 = Vector.fromList xs+  let v2 = Vector.fromList ys+  let sumVecs = v1 Vector.++ v2+  sumVecs === Pull.toVector (Pull.fromVector v1 <> Pull.fromVector v2)++pullAsList :: Property+pullAsList = property Prelude.$ do+  xs <- forAll list+  xs === Pull.asList (Pull.fromVector (Vector.fromList xs))++pullSingleton :: Property+pullSingleton = property Prelude.$ do+  x <- forAll randInt+  [x] === Pull.asList (Pull.singleton x)++pullSplitAt :: Property+pullSplitAt = property Prelude.$ do+  xs <- forAll list+  n <- forAll randNonnegInt+  let v = Vector.fromList xs+  let (l,r) = Pull.split n (Pull.fromVector v)+  (Pull.asList l, Pull.asList r) === splitAt n xs++pullMake :: Property+pullMake = property Prelude.$ do+  x <- forAll randInt+  n <- forAll randNonnegInt+  replicate n x === Pull.asList (Pull.make x n)++pullZip :: Property+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' = Pull.fromVector (Vector.fromList xs)+  let ys' = Pull.fromVector (Vector.fromList ys)+  zip xs ys === Pull.asList (Pull.zip xs' ys')+