diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Change Log + +## [0.1.0] - 2021-02-09 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/bench/Data/Mutable/HashMap.hs b/bench/Data/Mutable/HashMap.hs new file mode 100644 --- /dev/null +++ b/bench/Data/Mutable/HashMap.hs @@ -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) + diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import Gauge +import Data.Mutable.HashMap (hmbench, getHMInput) + +main :: IO () +main = do + hmInput <- getHMInput + defaultMain + [ hmbench hmInput + ] + diff --git a/docs/DESIGN.md b/docs/DESIGN.md new file mode 100644 --- /dev/null +++ b/docs/DESIGN.md @@ -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 diff --git a/docs/USER_GUIDE.md b/docs/USER_GUIDE.md new file mode 100644 --- /dev/null +++ b/docs/USER_GUIDE.md @@ -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 diff --git a/examples/Foreign/Heap.hs b/examples/Foreign/Heap.hs new file mode 100644 --- /dev/null +++ b/examples/Foreign/Heap.hs @@ -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 diff --git a/examples/Foreign/List.hs b/examples/Foreign/List.hs new file mode 100644 --- /dev/null +++ b/examples/Foreign/List.hs @@ -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 diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -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 + ] + diff --git a/examples/Simple/FileIO.hs b/examples/Simple/FileIO.hs new file mode 100644 --- /dev/null +++ b/examples/Simple/FileIO.hs @@ -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 diff --git a/examples/Simple/Pure.hs b/examples/Simple/Pure.hs new file mode 100644 --- /dev/null +++ b/examples/Simple/Pure.hs @@ -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. +-} diff --git a/examples/Simple/Quicksort.hs b/examples/Simple/Quicksort.hs new file mode 100644 --- /dev/null +++ b/examples/Simple/Quicksort.hs @@ -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 diff --git a/examples/Simple/TopSort.hs b/examples/Simple/TopSort.hs new file mode 100644 --- /dev/null +++ b/examples/Simple/TopSort.hs @@ -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) + diff --git a/examples/Test/Foreign.hs b/examples/Test/Foreign.hs new file mode 100644 --- /dev/null +++ b/examples/Test/Foreign.hs @@ -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) + diff --git a/examples/Test/Quicksort.hs b/examples/Test/Quicksort.hs new file mode 100644 --- /dev/null +++ b/examples/Test/Quicksort.hs @@ -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 + diff --git a/linear-base.cabal b/linear-base.cabal new file mode 100644 --- /dev/null +++ b/linear-base.cabal @@ -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 diff --git a/src/Control/Functor/Linear.hs b/src/Control/Functor/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Linear.hs @@ -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). + diff --git a/src/Control/Functor/Linear/Internal/Class.hs b/src/Control/Functor/Linear/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Linear/Internal/Class.hs @@ -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 + diff --git a/src/Control/Functor/Linear/Internal/Instances.hs b/src/Control/Functor/Linear/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Linear/Internal/Instances.hs @@ -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 + diff --git a/src/Control/Functor/Linear/Internal/MonadTrans.hs b/src/Control/Functor/Linear/Internal/MonadTrans.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Linear/Internal/MonadTrans.hs @@ -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 + diff --git a/src/Control/Functor/Linear/Internal/Reader.hs b/src/Control/Functor/Linear/Internal/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Linear/Internal/Reader.hs @@ -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) + diff --git a/src/Control/Functor/Linear/Internal/State.hs b/src/Control/Functor/Linear/Internal/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Linear/Internal/State.hs @@ -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) + diff --git a/src/Control/Monad/IO/Class/Linear.hs b/src/Control/Monad/IO/Class/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IO/Class/Linear.hs @@ -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 diff --git a/src/Control/Optics/Linear.hs b/src/Control/Optics/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Control/Optics/Linear.hs @@ -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 diff --git a/src/Control/Optics/Linear/Internal.hs b/src/Control/Optics/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Optics/Linear/Internal.hs @@ -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 diff --git a/src/Control/Optics/Linear/Iso.hs b/src/Control/Optics/Linear/Iso.hs new file mode 100644 --- /dev/null +++ b/src/Control/Optics/Linear/Iso.hs @@ -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 diff --git a/src/Control/Optics/Linear/Lens.hs b/src/Control/Optics/Linear/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Control/Optics/Linear/Lens.hs @@ -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 diff --git a/src/Control/Optics/Linear/Prism.hs b/src/Control/Optics/Linear/Prism.hs new file mode 100644 --- /dev/null +++ b/src/Control/Optics/Linear/Prism.hs @@ -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 diff --git a/src/Control/Optics/Linear/Traversal.hs b/src/Control/Optics/Linear/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Optics/Linear/Traversal.hs @@ -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 diff --git a/src/Data/Array/Destination.hs b/src/Data/Array/Destination.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Destination.hs @@ -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 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. + diff --git a/src/Data/Array/Mutable/Linear.hs b/src/Data/Array/Mutable/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Mutable/Linear.hs @@ -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" diff --git a/src/Data/Array/Mutable/Unlifted/Linear.hs b/src/Data/Array/Mutable/Unlifted/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Mutable/Unlifted/Linear.hs @@ -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` diff --git a/src/Data/Array/Polarized.hs b/src/Data/Array/Polarized.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Polarized.hs @@ -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 diff --git a/src/Data/Array/Polarized/Pull.hs b/src/Data/Array/Polarized/Pull.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Polarized/Pull.hs @@ -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) diff --git a/src/Data/Array/Polarized/Pull/Internal.hs b/src/Data/Array/Polarized/Pull/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Polarized/Pull/Internal.hs @@ -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) diff --git a/src/Data/Array/Polarized/Push.hs b/src/Data/Array/Polarized/Push.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Polarized/Push.hs @@ -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. + diff --git a/src/Data/Bifunctor/Linear.hs b/src/Data/Bifunctor/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Linear.hs @@ -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 + diff --git a/src/Data/Bifunctor/Linear/Internal/Bifunctor.hs b/src/Data/Bifunctor/Linear/Internal/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Linear/Internal/Bifunctor.hs @@ -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) + diff --git a/src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs b/src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs @@ -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 + diff --git a/src/Data/Bool/Linear.hs b/src/Data/Bool/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bool/Linear.hs @@ -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 diff --git a/src/Data/Either/Linear.hs b/src/Data/Either/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either/Linear.hs @@ -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) diff --git a/src/Data/Functor/Linear.hs b/src/Data/Functor/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Linear.hs @@ -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 diff --git a/src/Data/Functor/Linear/Internal/Applicative.hs b/src/Data/Functor/Linear/Internal/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Linear/Internal/Applicative.hs @@ -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) + diff --git a/src/Data/Functor/Linear/Internal/Functor.hs b/src/Data/Functor/Linear/Internal/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Linear/Internal/Functor.hs @@ -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)) + diff --git a/src/Data/Functor/Linear/Internal/Traversable.hs b/src/Data/Functor/Linear/Internal/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Linear/Internal/Traversable.hs @@ -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 +-- . +-- +-- * \"The Essence of the Iterator Pattern\", +-- by Jeremy Gibbons and Bruno Oliveira, +-- in /Mathematically-Structured Functional Programming/, 2006, online at +-- . +-- +-- * \"An Investigation of the Laws of Traversals\", +-- by Mauro Jaskelioff and Ondrej Rypacek, +-- in /Mathematically-Structured Functional Programming/, 2012, online at +-- . +-- +class Data.Functor t => Traversable t where + {-# MINIMAL traverse | sequence #-} + + traverse :: Control.Applicative f => (a %1-> f b) -> t a %1-> f (t b) + {-# 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 diff --git a/src/Data/HashMap/Mutable/Linear.hs b/src/Data/HashMap/Mutable/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Linear.hs @@ -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. diff --git a/src/Data/List/Linear.hs b/src/Data/List/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Linear.hs @@ -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 diff --git a/src/Data/Maybe/Linear.hs b/src/Data/Maybe/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe/Linear.hs @@ -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) diff --git a/src/Data/Monoid/Linear.hs b/src/Data/Monoid/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/Linear.hs @@ -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 + diff --git a/src/Data/Monoid/Linear/Internal/Monoid.hs b/src/Data/Monoid/Linear/Internal/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/Linear/Internal/Monoid.hs @@ -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 + diff --git a/src/Data/Monoid/Linear/Internal/Semigroup.hs b/src/Data/Monoid/Linear/Internal/Semigroup.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/Linear/Internal/Semigroup.hs @@ -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. + diff --git a/src/Data/Num/Linear.hs b/src/Data/Num/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Num/Linear.hs @@ -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 diff --git a/src/Data/Ord/Linear.hs b/src/Data/Ord/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ord/Linear.hs @@ -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 + diff --git a/src/Data/Ord/Linear/Internal/Eq.hs b/src/Data/Ord/Linear/Internal/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ord/Linear/Internal/Eq.hs @@ -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 + diff --git a/src/Data/Ord/Linear/Internal/Ord.hs b/src/Data/Ord/Linear/Internal/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ord/Linear/Internal/Ord.hs @@ -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 + diff --git a/src/Data/Profunctor/Kleisli/Linear.hs b/src/Data/Profunctor/Kleisli/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Kleisli/Linear.hs @@ -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))) diff --git a/src/Data/Profunctor/Linear.hs b/src/Data/Profunctor/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Linear.hs @@ -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)) diff --git a/src/Data/Set/Mutable/Linear.hs b/src/Data/Set/Mutable/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Mutable/Linear.hs @@ -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) diff --git a/src/Data/Tuple/Linear.hs b/src/Data/Tuple/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tuple/Linear.hs @@ -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) diff --git a/src/Data/Unrestricted/Internal/Consumable.hs b/src/Data/Unrestricted/Internal/Consumable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Internal/Consumable.hs @@ -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 + diff --git a/src/Data/Unrestricted/Internal/Dupable.hs b/src/Data/Unrestricted/Internal/Dupable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Internal/Dupable.hs @@ -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 + diff --git a/src/Data/Unrestricted/Internal/Instances.hs b/src/Data/Unrestricted/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Internal/Instances.hs @@ -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) + diff --git a/src/Data/Unrestricted/Internal/Movable.hs b/src/Data/Unrestricted/Internal/Movable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Internal/Movable.hs @@ -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 + diff --git a/src/Data/Unrestricted/Internal/Ur.hs b/src/Data/Unrestricted/Internal/Ur.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Internal/Ur.hs @@ -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) + diff --git a/src/Data/Unrestricted/Linear.hs b/src/Data/Unrestricted/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Unrestricted/Linear.hs @@ -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 + diff --git a/src/Data/V/Linear.hs b/src/Data/V/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/V/Linear.hs @@ -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. +-} + diff --git a/src/Data/V/Linear/Internal/Instances.hs b/src/Data/V/Linear/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/V/Linear/Internal/Instances.hs @@ -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) + diff --git a/src/Data/V/Linear/Internal/V.hs b/src/Data/V/Linear/Internal/V.hs new file mode 100644 --- /dev/null +++ b/src/Data/V/Linear/Internal/V.hs @@ -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 + diff --git a/src/Data/Vector/Mutable/Linear.hs b/src/Data/Vector/Mutable/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Mutable/Linear.hs @@ -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" diff --git a/src/Debug/Trace/Linear.hs b/src/Debug/Trace/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Trace/Linear.hs @@ -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) diff --git a/src/Foreign/Marshal/Pure.hs b/src/Foreign/Marshal/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Pure.hs @@ -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 @ +-- then declare the following instance: +-- +-- @instance Representable where {type AsKnown = AsKnown }@ +-- +-- And the default instance mechanism will create the appropriate +-- 'Representable' instance. +-- +-- Laws of 'MkRepresentable': +-- +-- * 'toRepr' must be total +-- * 'ofRepr' may be partial, but must be total on the image of 'toRepr' +-- * @ofRepr . toRepr = id@ +class Representable b => MkRepresentable a b | a -> b where + toRepr :: a %1-> b + ofRepr :: b %1-> a + + +-- TODO: Briefly explain the Dupable-reader style of API, below, and fix +-- details. + +-- | Pools represent collections of values. A 'Pool' can be 'consume'-ed. This +-- is a no-op: it does not deallocate the data in that pool. It cannot do so, +-- because accessible values might still exist. Consuming a pool simply makes it +-- impossible to add new data to the pool. +data Pool where + Pool :: DLL (Ptr ()) -> Pool + -- /!\ Black magic: the pointers in the pool are only used to deallocate + -- dangling pointers. Therefore their 'sizeOf' does not matter. It is simpler + -- to cast all the pointers to some canonical type (here `Ptr ()`) so that we + -- don't have to deal with heterogeneous types. /!\ + +-- Implementing a doubly-linked list with `Ptr` + +data DLL a = DLL { prev :: Ptr (DLL a), elt :: Ptr a, next :: Ptr (DLL a) } + deriving Eq + +-- XXX: probably replaceable by storable-generic +instance Storable (DLL a) where + sizeOf _ = sizeOf (undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a))) + alignment _ = alignment (undefined :: (Ptr (DLL a), Ptr a, Ptr (DLL a))) + + peek ptr = do + (p, e, n) <- peek (castPtr ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))) + return $ DLL p e n + + poke ptr (DLL p e n) = + poke (castPtr ptr :: Ptr (Ptr (DLL a), Ptr a, Ptr (DLL a))) (p, e, n) + +-- Precondition: in `insertAfter start ptr`, `next start` must be initalised, +-- and so must be `prev =<< peek (next start)` +insertAfter :: Storable a => DLL a -> a -> IO (Ptr (DLL a)) +insertAfter start ptr = do + secondLink <- peek $ next start + newLink <- DLL <$> new start <*> new ptr <*> new secondLink + poke (next start) newLink + poke (prev secondLink) newLink + new newLink + +delete :: DLL a -> IO () +delete link = do + prevLink <- peek $ prev link + nextLink <- peek $ next link + poke (next prevLink) nextLink + poke (prev nextLink) prevLink + +-- /Doubly-linked list + +-- @freeAll start end@ frees all pointer in the linked list. Assumes that @end@ +-- doesn't have a pointer, and indeed terminates the list. +-- +freeAll :: DLL (Ptr ()) -> DLL (Ptr ()) -> IO () +freeAll start end = do + nextLink <- peek (next start) + if nextLink == end then do + free (next start) + free (prev end) + else do + delete nextLink + free (prev nextLink) + free (elt nextLink) + free (next nextLink) + freeAll start end + +-- TODO: document individual functions + +-- | Given a linear computation that manages memory, run that computation. +withPool :: (Pool %1-> Ur b) %1-> Ur b +withPool scope = Unsafe.toLinear performScope scope + -- XXX: do ^ without `toLinear` by using linear IO + where + performScope :: (Pool %1-> Ur b) -> Ur b + performScope scope' = unsafeDupablePerformIO $ do + -- Initialise the pool + backPtr <- malloc + let end = DLL backPtr nullPtr nullPtr -- always at the end of the list + start <- DLL nullPtr nullPtr <$> new end -- always at the start of the list + poke backPtr start + -- Run the computation + evaluate (scope' (Pool start)) `finally` + -- Clean up remaining variables. + (freeAll start end) + +instance Consumable Pool where + consume (Pool _) = () + +instance Dupable Pool where + dupV (Pool l) = Data.pure (Pool l) + +-- | 'Box a' is the abstract type of manually managed data. It can be used as +-- part of data type definitions in order to store linked data structure off +-- heap. See @Foreign.List@ and @Foreign.Pair@ in the @examples@ directory of +-- the source repository. +data Box a where + Box :: Ptr (DLL (Ptr ())) -> Ptr a -> Box a + +-- XXX: if Box is a newtype, can be derived +instance Storable (Box a) where + sizeOf _ = sizeOf (undefined :: (Ptr (DLL (Ptr ())), Ptr a)) + alignment _ = alignment (undefined :: (Ptr (DLL (Ptr ())), Ptr a)) + peek ptr = do + (pool, ptr') <- peek (castPtr ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a)) + return (Box pool ptr') + poke ptr (Box pool ptr') = + poke (castPtr ptr :: Ptr (Ptr (DLL (Ptr ())), Ptr a)) (pool, ptr') + +instance KnownRepresentable (Box a) where +instance Representable (Box a) where + type AsKnown (Box a) = Box a + ofKnown = id + toKnown = id + +-- TODO: a way to store GC'd data using a StablePtr + +-- TODO: reference counted pointer. Remarks: rc pointers are Dupable but not +-- Movable. In order to be useful, need some kind of borrowing on the values, I +-- guess. 'Box' can be realloced, but not RC pointers. + +reprPoke :: forall a. Representable a => Ptr a -> a %1-> IO () +reprPoke ptr a | Dict <- storable @(AsKnown a) = + Unsafe.toLinear (poke (castPtr ptr :: Ptr (AsKnown a))) (toKnown a) + +reprNew :: forall a. Representable a => a %1-> IO (Ptr a) +reprNew a = + Unsafe.toLinear mkPtr a + where + -- XXX: should be improved by using linear IO + mkPtr :: a -> IO (Ptr a) + mkPtr a' | Dict <- storable @(AsKnown a) = + do + ptr0 <- malloc @(AsKnown a) + let ptr = castPtr ptr0 :: Ptr a + reprPoke ptr a' + return ptr + +-- TODO: Ideally, we would like to avoid having a boxed representation of the +-- data before a pointer is created. A better solution is to have a destination +-- passing-style API (but there is still some design to be done there). This +-- alloc primitive would then be derived (but most of the time we would rather +-- write bespoke constructors). +-- | Store a value @a@ on the system heap that is not managed by the GC. +alloc :: forall a. Representable a => a %1-> Pool %1-> Box a +alloc a (Pool pool) = + Unsafe.toLinear mkPtr a + where + -- XXX: should be improved by using linear IO + mkPtr :: a -> Box a + mkPtr a' = unsafeDupablePerformIO $ do + ptr <- reprNew a' + poolPtr <- insertAfter pool (castPtr ptr :: Ptr ()) + return (Box poolPtr ptr) + +-- TODO: would be better in linear IO, for we pretend that we are making an +-- unrestricted 'a', where really we are not. +reprPeek :: forall a. Representable a => Ptr a -> IO a +reprPeek ptr | Dict <- storable @(AsKnown a) = do + knownRepr <- peek (castPtr ptr :: Ptr (AsKnown a)) + return (ofKnown knownRepr) + +-- | Retrieve the value stored on system heap memory. +deconstruct :: Representable a => Box a %1-> a +deconstruct (Box poolPtr ptr) = unsafeDupablePerformIO $ mask_ $ do + res <- reprPeek ptr + delete =<< peek poolPtr + free ptr + free poolPtr + return res diff --git a/src/Prelude/Linear.hs b/src/Prelude/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Prelude/Linear.hs @@ -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 diff --git a/src/Prelude/Linear/Internal.hs b/src/Prelude/Linear/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Prelude/Linear/Internal.hs @@ -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 + diff --git a/src/Streaming/Internal/Consume.hs b/src/Streaming/Internal/Consume.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Internal/Consume.hs @@ -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 +t +["s","t"] +u +v +["u","v"] +@ +-} +toList :: Control.Monad m => Stream (Of a) m r %1-> m (Of [a] r) +toList = fold (\diff a ls -> diff (a: ls)) id (\diff -> diff []) +{-# INLINE toList #-} + +{-| Convert an effectful @Stream (Of a)@ into a list of @as@ + + Note: Needless to say, this function does not stream properly. + It is basically the same as Prelude 'mapM' which, like 'replicateM', + 'sequence' and similar operations on traversable containers + is a leading cause of space leaks. + +-} +toList_ :: Control.Monad m => Stream (Of a) m () %1-> m [a] +toList_ = fold_ (\diff a ls -> diff (a: ls)) id (\diff -> diff []) +{-# INLINE toList_ #-} + +{-| Fold streamed items into their monoidal sum + -} +mconcat :: (Control.Monad m, Prelude.Monoid w) => Stream (Of w) m r %1-> m (Of w r) +mconcat = fold (Prelude.<>) Prelude.mempty id +{-# INLINE mconcat #-} + +mconcat_ :: (Consumable r, Control.Monad m, Prelude.Monoid w) => + Stream (Of w) m r %1-> m w +mconcat_ = fold_ (Prelude.<>) Prelude.mempty id +{-# INLINE mconcat_ #-} + +minimum :: (Control.Monad m, Ord a) => Stream (Of a) m r %1-> m (Of (Maybe a) r) +minimum = fold getMin Nothing id . map Just +{-# INLINE minimum #-} + +minimum_ :: (Consumable r, Control.Monad m, Ord a) => + Stream (Of a) m r %1-> m (Maybe a) +minimum_ = fold_ getMin Nothing id . map Just +{-# INLINE minimum_ #-} + +maximum :: (Control.Monad m, Ord a) => Stream (Of a) m r %1-> m (Of (Maybe a) r) +maximum = fold getMax Nothing id . map Just +{-# INLINE maximum #-} + +maximum_ :: (Consumable r, Control.Monad m, Ord a) => + Stream (Of a) m r %1-> m (Maybe a) +maximum_ = fold_ getMax Nothing id . map Just +{-# INLINE maximum_ #-} + +getMin :: Ord a => Maybe a -> Maybe a -> Maybe a +getMin = mCompare Prelude.min + +getMax :: Ord a => Maybe a -> Maybe a -> Maybe a +getMax = mCompare Prelude.max + +mCompare :: Ord a => (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +mCompare _ Nothing Nothing = Nothing +mCompare _ (Just a) Nothing = Just a +mCompare _ Nothing (Just a) = Just a +mCompare comp (Just x) (Just y) = Just $ comp x y + +{-| A natural right fold for consuming a stream of elements. + See also the more general 'iterT' in the 'Streaming' module and the + still more general 'destroy' +-} +foldrM :: forall a m r. Control.Monad m + => (a -> m r %1-> m r) -> Stream (Of a) m r %1-> m r +foldrM step stream = loop stream where + loop :: Stream (Of a) m r %1-> m r + loop stream = stream & \case + Return r -> Control.return r + Effect m -> m Control.>>= foldrM step + Step (a :> as) -> step a (foldrM step as) +{-# INLINABLE foldrM #-} + +{-| A natural right fold for consuming a stream of elements. + See also the more general 'iterTM' in the 'Streaming' module + and the still more general 'destroy' + +> foldrT (\a p -> Streaming.yield a >> p) = id + +-} +foldrT :: forall a t m r. + (Control.Monad m, Control.MonadTrans t, Control.Monad (t m)) => + (a -> t m r %1-> t m r) -> Stream (Of a) m r %1-> t m r +foldrT step stream = loop stream where + loop :: Stream (Of a) m r %1-> t m r + loop stream = stream & \case + Return r -> Control.return r + Effect ms -> (Control.lift ms) Control.>>= foldrT step + Step (a :> as) -> step a (foldrT step as) +{-# INLINABLE foldrT #-} + diff --git a/src/Streaming/Internal/Interop.hs b/src/Streaming/Internal/Interop.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Internal/Interop.hs @@ -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 #-} + diff --git a/src/Streaming/Internal/Many.hs b/src/Streaming/Internal/Many.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Internal/Many.hs @@ -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 #-} + diff --git a/src/Streaming/Internal/Process.hs b/src/Streaming/Internal/Process.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Internal/Process.hs @@ -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 +b +c +d +e +["c","d","e"] :> () +@ + + Because it retains the final return value, @drop n@ is a suitable argument + for @maps@: + +@ +\>\>\> S.toList $ concats $ maps (S.drop 4) $ chunksOf 5 $ each [1..20] +[5,10,15,20] :> () +@ + -} +drop :: forall a m r. (HasCallStack, Control.Monad m) => + Int -> Stream (Of a) m r %1-> Stream (Of a) m r +drop n stream = case compare n 0 of + LT -> Prelude.error "drop called with negative int" $ stream + EQ -> stream + GT -> loop stream where + loop :: Stream (Of a) m r %1-> Stream (Of a) m r + loop stream = stream & \case + Return r -> Return r + Effect m -> Effect $ Control.fmap (drop n) m + Step (_ :> as) -> drop (n-1) as +{-# INLINABLE drop #-} + +{- | Ignore elements of a stream until a test succeeds, retaining the rest. + +@ +\>\>\> S.print $ S.dropWhile ((< 5) . length) S.stdinLn +one +two +three +"three" +four +"four" +^CInterrupted. +@ + +-} +dropWhile :: forall a m r . Control.Monad m => + (a -> Bool) -> Stream (Of a) m r %1-> Stream (Of a) m r +dropWhile pred = loop + where + loop :: Stream (Of a) m r %1-> Stream (Of a) m r + loop stream = stream & \case + Return r -> Return r + Effect m -> Effect $ Control.fmap loop m + Step (a :> as) -> case pred a of + True -> loop as + False -> Step (a :> as) +{-# INLINABLE dropWhile #-} + +{-| Strict left scan, streaming, e.g. successive partial results. The seed + is yielded first, before any action of finding the next element is performed. + +@ +\>\>\> S.print $ S.scan (++) "" id $ each' (words "a b c d") +"" +"a" +"ab" +"abc" +"abcd" +@ + + 'scan' is fitted for use with @Control.Foldl@, thus: + +@ +\>\>\> S.print $ L.purely S.scan L.list $ each' [3..5] +[] +[3] +[3,4] +[3,4,5] +@ +-} +scan :: forall a x b m r . Control.Monad m => + (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> Stream (Of b) m r +scan step begin done stream = Step (done begin :> loop begin stream) + where + loop :: x -> Stream (Of a) m r %1-> Stream (Of b) m r + loop !acc stream = stream & \case + Return r -> Return r + Effect m -> Effect $ Control.fmap (loop acc) m + Step (a :> as) -> Step (done acc' :> loop acc' as) where + !acc' = step acc a +{-# INLINABLE scan #-} + +-- Note: since the accumulated value (inside the control monad) is used both in +-- populating the output stream and in accumulation, it needs to be wrapped in +-- an 'Ur' accross the function +-- +{-| Strict left scan, accepting a monadic function. It can be used with + 'FoldM's from @Control.Foldl@ using 'impurely'. Here we yield + a succession of vectors each recording + +@ +\>\>\> let v = L.impurely scanM L.vectorM $ each' [1..4::Int] :: Stream (Of (Vector Int)) IO () +\>\>\> S.print v +[] +[1] +[1,2] +[1,2,3] +[1,2,3,4] +@ +-} +scanM :: forall a x b m r . Control.Monad m => + (x %1-> a -> m (Ur x)) -> + m (Ur x) -> + (x %1-> m (Ur b)) -> + Stream (Of a) m r %1-> + Stream (Of b) m r +scanM step mx done stream = loop stream + where + loop :: Stream (Of a) m r %1-> Stream (Of b) m r + loop stream = stream & \case + Return r -> Effect $ Control.do + Ur x <- mx + Ur b <- done x + Control.return $ Step $ b :> Return r + Effect m -> Effect $ Control.fmap (scanM step mx done) m + Step (a :> as) -> Effect $ Control.do + Ur x <- mx + Ur b <- done x + Control.return $ Step $ b :> (scanM step (step x a) done as) +{-# INLINABLE scanM #-} + +{-| Label each element in a stream with a value accumulated according to a fold. + +@ +\>\>\> S.print $ S.scanned (*) 1 id $ S.each' [100,200,300] +(100,100) +(200,20000) +(300,6000000) +@ + +@ +\>\>\> S.print $ L.purely S.scanned' L.product $ S.each [100,200,300] +(100,100) +(200,20000) +(300,6000000) +@ +-} +scanned :: forall a x b m r . Control.Monad m => + (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r %1-> Stream (Of (a,b)) m r +scanned step begin done = loop begin + where + loop :: x -> Stream (Of a) m r %1-> Stream (Of (a,b)) m r + loop !x stream = stream & \case + Return r -> Return r + Effect m -> Effect $ Control.fmap (loop x) m + Step (a :> as) -> Control.do + let !acc = done (step x a) + Step $ (a, acc) :> Return () -- same as yield + loop (step x a) as +{-# INLINABLE scanned #-} + +-- Note: this skips failed parses +-- XXX re-write with Text +-- +{- | Make a stream of strings into a stream of parsed values, skipping bad cases + +@ +\>\>\> S.sum_ $ S.read $ S.takeWhile (/= "total") S.stdinLn :: IO Int +1000 +2000 +total +3000 +@ + +-} +read :: (Control.Monad m, Read a) => + Stream (Of String) m r %1-> Stream (Of a) m r +read = mapMaybe readMaybe +{-# INLINE read #-} + +{-| Interpolate a delay of n seconds between yields. +-} +delay :: forall a r. Double -> Stream (Of a) IO r %1-> Stream (Of a) IO r +delay seconds = loop + where + pico = Prelude.truncate (seconds * 1000000) + loop :: Stream (Of a) IO r %1-> Stream (Of a) IO r + loop stream = Control.do + e <- Control.lift $ next stream + e & \case + Left r -> Return r + Right (Ur a,rest) -> Control.do + Step (a :> Return ()) -- same as yield + Control.lift $ fromSystemIO $ threadDelay pico + loop rest +{-# INLINABLE delay #-} + +show :: (Control.Monad m, Prelude.Show a) => + Stream (Of a) m r %1-> Stream (Of String) m r +show = map Prelude.show +{-# INLINE show #-} + + +{-| The natural @cons@ for a @Stream (Of a)@. + +> cons a stream = yield a Control.>> stream + + Useful for interoperation: + +> Data.Text.foldr S.cons (return ()) :: Text -> Stream (Of Char) m () +> Lazy.foldrChunks S.cons (return ()) :: Lazy.ByteString -> Stream (Of Strict.ByteString) m () + + and so on. +-} +cons :: Control.Monad m => a -> Stream (Of a) m r %1-> Stream (Of a) m r +cons a str = Step (a :> str) +{-# INLINE cons #-} + +-- Note. The action function that is the second argument must be linear since +-- it gets its argument from binding to the first argument, which uses a +-- control monad. +-- +{-| Before evaluating the monadic action returning the next step in the 'Stream', @wrapEffect@ + extracts the value in a monadic computation @m a@ and passes it to a computation @a -> m y@. + +-} +wrapEffect :: (Control.Monad m, Control.Functor f, Consumable y) => + m a -> (a %1-> m y) -> Stream f m r %1-> Stream f m r +wrapEffect ma action stream = stream & \case + Return r -> Return r + Effect m -> Effect $ Control.do + a <- ma + y <- action a + lseq y $ m + Step f -> Effect $ Control.do + a <- ma + y <- action a + Control.return $ lseq y $ Step f + +{-| 'slidingWindow' accumulates the first @n@ elements of a stream, + update thereafter to form a sliding window of length @n@. + It follows the behavior of the slidingWindow function in + . + +@ +\>\>\> S.print $ S.slidingWindow 4 $ S.each "123456" +fromList "1234" +fromList "2345" +fromList "3456" +@ +-} +slidingWindow :: forall a b m. Control.Monad m => Int -> Stream (Of a) m b + %1-> Stream (Of (Seq.Seq a)) m b +slidingWindow n = setup (max 1 n :: Int) Seq.empty + where + -- Given the current sliding window, yield it and then recurse with + -- updated sliding window + window :: Seq.Seq a -> Stream (Of a) m b %1-> Stream (Of (Seq.Seq a)) m b + window !sequ str = Control.do + e <- Control.lift (next str) + e & \case + Left r -> Control.return r + Right (Ur a,rest) -> Control.do + Step $ (sequ Seq.|> a) :> Return () -- same as yield + window (Seq.drop 1 sequ Seq.|> a) rest + -- Collect the first n elements in a sequence and call 'window' + setup :: + Int -> Seq.Seq a -> Stream (Of a) m b %1-> Stream (Of (Seq.Seq a)) m b + setup 0 !sequ str = Control.do + Step (sequ :> Return ()) -- same as yield + window (Seq.drop 1 sequ) str + setup n' sequ str = Control.do + e <- Control.lift $ next str + e & \case + Left r -> Control.do + Step (sequ :> Return ()) -- same as yield + Control.return r + Right (Ur x,rest) -> setup (n'-1) (sequ Seq.|> x) rest +{-# INLINABLE slidingWindow #-} + diff --git a/src/Streaming/Internal/Produce.hs b/src/Streaming/Internal/Produce.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Internal/Produce.hs @@ -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 #-} + diff --git a/src/Streaming/Internal/Type.hs b/src/Streaming/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Internal/Type.hs @@ -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 + . + +> data Stream f m r = Step !(f (Stream f m r)) | Effect (m (Stream f m r)) | Return r + + The /producer/ concept uses the simple functor @ (a,_) @ \- or the stricter + @ Of a _ @. Then the news at each step or layer is just: an individual item of type @a@. + Since @Stream (Of a) m r@ is equivalent to @Pipe.Producer a m r@, much of + the @pipes@ @Prelude@ can easily be mirrored in a @streaming@ @Prelude@. Similarly, + a simple @Consumer a m r@ or @Parser a m r@ concept arises when the base functor is + @ (a -> _) @ . @Stream ((->) input) m result@ consumes @input@ until it returns a + @result@. + + To avoid breaking reasoning principles, the constructors + should not be used directly. A pattern-match should go by way of 'inspect' \ + \- or, in the producer case, 'Streaming.Prelude.next' +-} +data Stream f m r where + Step :: !(f (Stream f m r)) %1-> Stream f m r + Effect :: m (Stream f m r) %1-> Stream f m r + Return :: r %1-> Stream f m r + +-- | A left-strict pair; the base functor for streams of individual elements. +data Of a b where + (:>) :: !a -> b %1-> Of a b + +infixr 5 :> + + +-- # Control.Monad instance for (Stream f m) +------------------------------------------------------------------------------- + +-- Note: we have maintained the weakest prerequisite constraints possible. + +-- Note: to consume the 'Stream f m a' in the 'Cons' case, you +-- need 'fmap' to consume the stream. This implies at minimum +-- Data.Functor m and Data.Functor m. +instance (Data.Functor m, Data.Functor f) => Data.Functor (Stream f m) where + fmap :: (Data.Functor m, Data.Functor f) => + (a %1-> b) -> Stream f m a %1-> Stream f m b + fmap f s = fmap' f s + {-# INLINABLE fmap #-} + +fmap' :: (Data.Functor m, Data.Functor f) => + (a %1-> b) -> Stream f m a %1-> Stream f m b +fmap' f (Return r) = Return (f r) +fmap' f (Step fs) = Step $ Data.fmap (Data.fmap f) fs +fmap' f (Effect ms) = Effect $ Data.fmap (Data.fmap f) ms + +-- Note: the 'Control.Functor f' instance is needed. +-- Weaker constraints won't do. +instance (Control.Functor m, Control.Functor f) => + Data.Applicative (Stream f m) where + pure :: a -> Stream f m a + pure = Return + {-# INLINE pure #-} + + (<*>) :: (Control.Functor m, Control.Functor f) => + Stream f m (a %1-> b) %1-> Stream f m a %1-> Stream f m b + (<*>) s1 s2 = app s1 s2 + {-# INLINABLE (<*>) #-} + +app :: (Control.Functor m, Control.Functor f) => + Stream f m (a %1-> b) %1-> Stream f m a %1-> Stream f m b +app (Return f) stream = Control.fmap f stream +app (Step fs) stream = Step $ Control.fmap (Data.<*> stream) fs +app (Effect ms) stream = Effect $ Control.fmap (Data.<*> stream) ms + + + +instance (Control.Functor m, Control.Functor f) => + Control.Functor (Stream f m) where + fmap :: (Data.Functor m, Data.Functor f) => + (a %1-> b) %1-> Stream f m a %1-> Stream f m b + fmap f s = fmap'' f s + {-# INLINABLE fmap #-} + +fmap'' :: (Control.Functor m, Control.Functor f) => + (a %1-> b) %1-> Stream f m a %1-> Stream f m b +fmap'' f (Return r) = Return (f r) +fmap'' f (Step fs) = Step $ Control.fmap (Control.fmap f) fs +fmap'' f (Effect ms) = Effect $ Control.fmap (Control.fmap f) ms + + +instance (Control.Functor m, Control.Functor f) => + Control.Applicative (Stream f m) where + pure :: a %1-> Stream f m a + pure = Return + {-# INLINE pure #-} + + (<*>) :: (Control.Functor m, Control.Functor f) => + Stream f m (a %1-> b) %1-> Stream f m a %1-> Stream f m b + (<*>) = (Data.<*>) + {-# INLINE (<*>) #-} + +instance (Control.Functor m, Control.Functor f) => + Control.Monad (Stream f m) where + (>>=) :: Stream f m a %1-> (a %1-> Stream f m b) %1-> Stream f m b + (>>=) = bind + {-# INLINABLE (>>=) #-} + +bind :: (Control.Functor m, Control.Functor f) => + Stream f m a %1-> (a %1-> Stream f m b) %1-> Stream f m b +bind (Return a) f = f a +bind (Step fs) f = Step $ Control.fmap (Control.>>= f) fs +bind (Effect ms) f = Effect $ Control.fmap (Control.>>= f) ms + + +-- # MonadTrans for (Stream f m) +------------------------------------------------------------------------------- + +instance Control.Functor f => Control.MonadTrans (Stream f) where + lift :: (Control.Functor m, Control.Functor f) => m a %1-> Stream f m a + lift = Effect . Control.fmap Control.return + {-# INLINE lift #-} + + +-- # Control.Functor for (Of) +------------------------------------------------------------------------------- + +ofFmap :: (a %1-> b) %1-> (Of x a) %1-> (Of x b) +ofFmap f (a :> b) = a :> f b +{-# INLINE ofFmap #-} + +instance Data.Functor (Of a) where + fmap = Linear.forget ofFmap + {-# INLINE fmap #-} + +instance Control.Functor (Of a) where + fmap = ofFmap + {-# INLINE fmap #-} + diff --git a/src/Streaming/Linear.hs b/src/Streaming/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Linear.hs @@ -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 + to learn more + about control monads, control applicatives and control functors.) + + In words, a @Stream f m r@ is either a payload of type @r@, or + a step of type @f (Stream f m r)@ or an effect of type @m (Stream f m r)@ + where @f@ is a @Control.Functor@ and @m@ is a @Control.Monad@. + + This module exports combinators that pertain to this general case. + Some of these are quite abstract and pervade any use of the library, + e.g. + +> maps :: (forall x . f x %1-> g x) -> Stream f m r %1-> Stream g m r +> mapped :: (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r +> concats :: Stream (Stream f m) m r %1-> Stream f m r + + (assuming here and thoughout that @m@ or @n@ satisfies + a @Control.Monad@ constraint, and @f@ or @g@ a @Control.Functor@ + constraint). + + Others are surprisingly determinate in content: + +> chunksOf :: Int -> Stream f m r %1-> Stream (Stream f m) m r +> splitsAt :: Int -> Stream f m r %1-> Stream f m (Stream f m r) +> intercalates :: Stream f m () -> Stream (Stream f m) m r %1-> Stream f m r +> unzips :: Stream (Compose f g) m r %1-> Stream f (Stream g m) r +> separate :: Stream (Sum f g) m r -> Stream f (Stream g m) r -- cp. partitionEithers +> unseparate :: Stream f (Stream g) m r -> Stream (Sum f g) m r +> groups :: Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r + + One way to see that /any/ streaming library needs some such general type is + that it is required to represent the segmentation of a stream, and to + express the equivalents of @Prelude/Data.List@ combinators that involve + 'lists of lists' and the like. See for example this + + on the correct expression of a streaming \'lines\' function. + The module @Streaming.Prelude@ exports combinators relating to +> Stream (Of a) m r + where @Of a r = !a :> r@ is a left-strict pair. + This expresses the concept of a 'Producer' or 'Source' or 'Generator' and + easily inter-operates with types with such names in e.g. 'conduit', + 'iostreams' and 'pipes'. +-} + +-- # Constructing a 'Stream' on a given functor +------------------------------------------------------------------------------- + +-- Remark. By default we require `Control.Monad` and `Control.Functor` +-- instances for the `m` and `f` in a `Stream f m r` since these allow the +-- stream to have a `Control.Monad` instance + +{-| @yields@ is like @lift@ for items in the streamed functor. + It makes a singleton or one-layer succession. + +> lift :: (Control.Monad m, Control.Functor f) => m r %1-> Stream f m r +> yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r + + Viewed in another light, it is like a functor-general version of @yield@: + +> S.yield a = yields (a :> ()) + +-} +yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r +yields fr = Step $ Control.fmap Return fr +{-# INLINE yields #-} + +-- Note: This must consume its input linearly since it must bind to a +-- `Control.Monad`. +{- | Wrap an effect that returns a stream + +> effect = join . lift + +-} +effect :: (Control.Monad m, Control.Functor f) => + m (Stream f m r) %1-> Stream f m r +effect = Effect +{-# INLINE effect #-} + +{-| Wrap a new layer of a stream. So, e.g. + +> S.cons :: Control.Monad m => a -> Stream (Of a) m r %1-> Stream (Of a) m r +> S.cons a str = wrap (a :> str) + + and, recursively: + +> S.each' :: Control.Monad m => [a] -> Stream (Of a) m () +> S.each' = foldr (\a b -> wrap (a :> b)) (return ()) + + The two operations + +> wrap :: (Control.Monad m, Control.Functor f) => +> f (Stream f m r) %1-> Stream f m r +> effect :: (Control.Monad m, Control.Functor f) => +> m (Stream f m r) %1-> Stream f m r + + are fundamental. We can define the parallel operations @yields@ and @lift@ + in terms of them + +> yields :: (Control.Monad m, Control.Functor f) => f r %1-> Stream f m r +> yields = wrap . Control.fmap Control.return +> lift :: (Control.Monad m, Control.Functor f) => m r %1-> Stream f m r +> lift = effect . Control.fmap Control.return + +-} +wrap :: (Control.Monad m, Control.Functor f) => + f (Stream f m r) %1-> Stream f m r +wrap = Step +{-# INLINE wrap #-} + +{- | Repeat a functorial layer, command or instruction a fixed number of times. + +-} +replicates :: (HasCallStack, Control.Monad m, Control.Functor f) => + Int -> f () -> Stream f m () +replicates n f = replicates' n f + where + replicates' :: (HasCallStack, Control.Monad m, Control.Functor f) => + Int -> f () -> Stream f m () + replicates' n f = case compare n 0 of + LT -> Prelude.error "replicates called with negative integer" + EQ -> Return () + GT -> Step $ Control.fmap (\() -> replicates (n-1) f) f +{-# INLINE replicates #-} + +-- | @replicatesM n@ repeats an effect containing a functorial layer, command +-- or instruction @n@ times. +replicatesM :: forall f m . (Control.Monad m, Control.Functor f) => + Int -> m (f ()) -> Stream f m () +replicatesM = loop + where + loop :: Int -> m (f ()) -> Stream f m () + loop n mfstep + | n <= 0 = Return () + | Prelude.otherwise = Effect $ + Control.fmap (Step . Control.fmap (\() -> loop (n-1) mfstep)) mfstep +{-# INLINABLE replicatesM #-} + +unfold :: (Control.Monad m, Control.Functor f) => + (s %1-> m (Either r (f s))) -> s %1-> Stream f m r +unfold step state = unfold' step state + where + unfold' :: (Control.Monad m, Control.Functor f) => + (s %1-> m (Either r (f s))) -> s %1-> Stream f m r + unfold' step state = Effect $ Control.do + either <- step state + either & \case + Left r -> Control.return $ Return r + Right (fs) -> Control.return $ Step $ Control.fmap (unfold step) fs +{-# INLINABLE unfold #-} + +-- Note. To keep restrictions minimal, we use the `Data.Applicative` +-- instance. +untilJust :: forall f m r . (Control.Monad m, Data.Applicative f) => + m (Maybe r) -> Stream f m r +untilJust action = loop + where + loop :: Stream f m r + loop = Effect $ Control.do + maybeVal <- action + maybeVal & \case + Nothing -> Control.return $ Step $ Data.pure loop + Just r -> Control.return $ Return r +{-# INLINABLE untilJust #-} + +-- Remark. The linear church encoding of streams has linear +-- return, effect and step functions. +{- | Reflect a church-encoded stream; cp. @GHC.Exts.build@ + +> streamFold return_ effect_ step_ (streamBuild psi) = psi return_ effect_ step_ +-} +streamBuild :: + (forall b. (r %1-> b) -> (m b %1-> b) -> (f b %1-> b) -> b) -> Stream f m r +streamBuild = \phi -> phi Return Effect Step +{-# INLINE streamBuild #-} + +-- Note. To keep requirements minimal, we use the `Data.Applicative` +-- instance instead of the `Control.Applicative` instance. +delays :: forall f r . (Data.Applicative f) => Double -> Stream f IO r +delays seconds = loop + where + loop :: Stream f IO r + loop = Effect $ Control.do + let delay = fromInteger (Prelude.truncate (1000000 * seconds)) + () <- fromSystemIO $ threadDelay delay + Control.return $ Step $ Data.pure loop +{-# INLINABLE delays #-} + + +-- # Transforming streams +------------------------------------------------------------------------------- + +{- | Map layers of one functor to another with a transformation. + +> maps id = id +> maps f . maps g = maps (f . g) + +-} +maps :: forall f g m r . (Control.Monad m, Control.Functor f) => + (forall x . f x %1-> g x) -> Stream f m r %1-> Stream g m r +maps = Stream.maps +{-# INLINE maps #-} + +{- | Map layers of one functor to another with a transformation. + +> mapsPost id = id +> mapsPost f . mapsPost g = mapsPost (f . g) +> mapsPost f = maps f + + @mapsPost@ is essentially the same as 'maps', but it imposes a @Control.Functor@ constraint on + its target functor rather than its source functor. It should be preferred if @Control.fmap@ + is cheaper for the target functor than for the source functor. +-} +mapsPost :: forall m f g r. (Control.Monad m, Control.Functor g) => + (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r +mapsPost = Stream.mapsPost +{-# INLINE mapsPost #-} + +-- Note. The transformation function must be linear so that the stream +-- held inside a control functor is used linearly. +{- | Map layers of one functor to another with a transformation involving the base monad. + 'maps' is more fundamental than @mapsM@, which is best understood as a convenience + for effecting this frequent composition: + +> mapsM phi = decompose . maps (Compose . phi) + + The streaming prelude exports the same function under the better name @mapped@, + which overlaps with the lens libraries. + +-} +mapsM :: forall f g m r . (Control.Monad m, Control.Functor f) => + (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r +mapsM transform = loop where + loop :: Stream f m r %1-> Stream g m r + loop stream = stream & \case + Return r -> Return r + Step f -> Effect $ Control.fmap Step $ transform $ Control.fmap loop f + Effect m -> Effect $ Control.fmap loop m +{-# INLINE mapsM #-} + +{- | Map layers of one functor to another with a transformation involving the base monad. + @mapsMPost@ is essentially the same as 'mapsM', but it imposes a @Control.Functor@ constraint on + its target functor rather than its source functor. It should be preferred if @Control.fmap@ + is cheaper for the target functor than for the source functor. + + @mapsPost@ is more fundamental than @mapsMPost@, which is best understood as a convenience + for effecting this frequent composition: + +> mapsMPost phi = decompose . mapsPost (Compose . phi) + + The streaming prelude exports the same function under the better name @mappedPost@, + which overlaps with the lens libraries. + +-} +mapsMPost :: forall m f g r. (Control.Monad m, Control.Functor g) => + (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r +mapsMPost = Stream.mapsMPost +{-# INLINE mapsMPost #-} + +{- | Map layers of one functor to another with a transformation involving the base monad. + This could be trivial, e.g. + +> let noteBeginning text x = (fromSystemIO (System.putStrLn text)) Control.>> (Control.return x) + + this is completely functor-general + + @maps@ and @mapped@ obey these rules: + +> maps id = id +> mapped return = id +> maps f . maps g = maps (f . g) +> mapped f . mapped g = mapped (f <=< g) +> maps f . mapped g = mapped (fmap f . g) +> mapped f . maps g = mapped (f <=< fmap g) + + @maps@ is more fundamental than @mapped@, which is best understood as a convenience + for effecting this frequent composition: + +> mapped phi = decompose . maps (Compose . phi) + + +-} +mapped :: forall f g m r . (Control.Monad m, Control.Functor f) => + (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r +mapped = mapsM +{-# INLINE mapped #-} + +{-| A version of 'mapped' that imposes a @Control.Functor@ constraint on the target functor rather + than the source functor. This version should be preferred if @Control.fmap@ on the target + functor is cheaper. + +-} +mappedPost :: forall m f g r. (Control.Monad m, Control.Functor g) => + (forall x. f x %1-> m (g x)) -> Stream f m r %1-> Stream g m r +mappedPost = mapsMPost +{-# INLINE mappedPost #-} + +-- | A less-efficient version of 'hoist' that works properly even when its +-- argument is not a monad morphism. +hoistUnexposed :: forall f m n r. (Control.Monad m, Control.Functor f) + => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r +hoistUnexposed trans = loop where + loop :: Stream f m r %1-> Stream f n r + loop = Effect + . trans + . inspectC + (Control.return . Return) + (Control.return . Step . Control.fmap loop) +{-# INLINABLE hoistUnexposed #-} + +-- A version of 'inspect' that takes explicit continuations. +-- Note that due to the linear constructors of 'Stream', these continuations +-- are linear. +inspectC :: forall f m r a. Control.Monad m => + (r %1-> m a) -> (f (Stream f m r) %1-> m a) -> Stream f m r %1-> m a +inspectC f g = loop where + loop :: Stream f m r %1-> m a + loop (Return r) = f r + loop (Step x) = g x + loop (Effect m) = m Control.>>= loop +{-# INLINE inspectC #-} + +{-| Group layers in an alternating stream into adjoining sub-streams + of one type or another. +-} +groups :: forall f g m r . + (Control.Monad m, Control.Functor f, Control.Functor g) => + Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r +groups = loop + where + loop :: Stream (Sum f g) m r %1-> Stream (Sum (Stream f m) (Stream g m)) m r + loop str = Control.do + e <- Control.lift $ inspect str + e & \case + Left r -> Control.return r + Right ostr -> ostr & \case + InR gstr -> Step $ InR $ Control.fmap loop $ cleanR (Step (InR gstr)) + InL fstr -> Step $ InL $ Control.fmap loop $ cleanL (Step (InL fstr)) + + cleanL :: Stream (Sum f g) m r %1-> Stream f m (Stream (Sum f g) m r) + cleanL = go + where + go :: Stream (Sum f g) m r %1-> Stream f m (Stream (Sum f g) m r) + go s = Control.do + e <- Control.lift $ inspect s + e & \case + Left r -> Control.return $ Control.return r + Right (InL fstr) -> Step $ Control.fmap go fstr + Right (InR gstr) -> Control.return $ Step (InR gstr) + + cleanR :: Stream (Sum f g) m r %1-> Stream g m (Stream (Sum f g) m r) + cleanR = go + where + go :: Stream (Sum f g) m r %1-> Stream g m (Stream (Sum f g) m r) + go s = Control.do + e <- Control.lift $ inspect s + e & \case + Left r -> Control.return $ Control.return r + Right (InL fstr) -> Control.return $ Step (InL fstr) + Right (InR gstr) -> Step$ Control.fmap go gstr +{-# INLINABLE groups #-} + + +-- # Inspecting a Stream +------------------------------------------------------------------------------- + +{-| Inspect the first stage of a freely layered sequence. + Compare @Pipes.next@ and the replica @Streaming.Prelude.next@. + This is the 'uncons' for the general 'unfold'. + +> unfold inspect = id +> Streaming.Prelude.unfoldr StreamingPrelude.next = id +-} +inspect :: forall f m r . Control.Monad m => + Stream f m r %1-> m (Either r (f (Stream f m r))) +inspect = loop + where + loop :: Stream f m r %1-> m (Either r (f (Stream f m r))) + loop stream = stream & \case + Return r -> Control.return (Left r) + Effect m -> m Control.>>= loop + Step fs -> Control.return (Right fs) +{-# INLINABLE inspect #-} + + +-- # Splitting and joining 'Stream's +------------------------------------------------------------------------------- + +{-| Split a succession of layers after some number, returning a streaming or + effectful pair. + +\>\>\> rest <- S.print $ S.splitAt 1 $ each' [1..3] +1 +\>\>\> S.print rest +2 +3 + +> splitAt 0 = return +> (\stream -> splitAt n stream >>= splitAt m) = splitAt (m+n) + + Thus, e.g. + +\>\>\> rest <- S.print $ (\s -> splitsAt 2 s >>= splitsAt 2) each' [1..5] +1 +2 +3 +4 +\>\>\> S.print rest +5 + +-} +splitsAt :: forall f m r . + (HasCallStack, Control.Monad m, Control.Functor f) => + Int -> Stream f m r %1-> Stream f m (Stream f m r) +splitsAt n stream = loop n stream + where + loop :: Int -> Stream f m r %1-> Stream f m (Stream f m r) + loop n stream = case compare n 0 of + LT -> Prelude.error "splitsAt called with negative index" $ stream + EQ -> Return stream + GT -> stream & \case + Return r -> Return $ Return r + Effect m -> Effect $ Control.fmap (loop n) m + Step f -> Step $ Control.fmap (loop (n-1)) f +{-# INLINABLE splitsAt #-} + + +{-| Break a stream into substreams each with n functorial layers. + +\>\>\> S.print $ mapped S.sum $ chunksOf 2 $ each' [1,1,1,1,1] +2 +2 +1 +-} +chunksOf :: forall f m r . + (HasCallStack, Control.Monad m, Control.Functor f) => + Int -> Stream f m r %1-> Stream (Stream f m) m r +chunksOf n stream = loop n stream + where + loop :: Int -> Stream f m r %1-> Stream (Stream f m) m r + loop _ (Return r) = Return r + loop n stream = Step $ Control.fmap (loop n) $ splitsAt n stream +{-# INLINABLE chunksOf #-} + +{-| Dissolves the segmentation into layers of @Stream f m@ layers. + +-} +concats :: forall f m r . (Control.Monad m, Control.Functor f) => + Stream (Stream f m) m r %1-> Stream f m r +concats = loop + where + loop :: Stream (Stream f m) m r %1-> Stream f m r + loop stream = stream & \case + Return r -> Return r + Effect m -> Effect $ Control.fmap loop m + Step f -> Control.do + rest <- Control.fmap loop f + rest +{-# INLINE concats #-} + +-- Note. To keep the monad of the stream a control monad, we need +-- `(t m)` to be a control monad, and hence `t` to be a control +-- monad transformer. +{-| Interpolate a layer at each segment. This specializes to e.g. + +> intercalates :: Stream f m () -> Stream (Stream f m) m r %1-> Stream f m r +-} +intercalates :: forall t m r x . + (Control.Monad m, Control.Monad (t m), Control.MonadTrans t, Consumable x) => + t m x -> Stream (t m) m r %1-> t m r +intercalates sep = go0 + where + go0 :: Stream (t m) m r %1-> t m r + go0 f = f & \case + Return r -> Control.return r + Effect m -> Control.lift m Control.>>= go0 + Step fstr -> Control.do + f' <- fstr + go1 f' + + go1 :: Stream (t m) m r %1-> t m r + go1 f = f & \case + Return r -> Control.return r + Effect m -> Control.lift m Control.>>= go1 + Step fstr -> Control.do + x <- sep + Control.return $ consume x + f' <- fstr + go1 f' +{-# INLINABLE intercalates #-} + + +-- # Zipping, unzipping, separating and unseparating streams +------------------------------------------------------------------------------- + +unzips :: forall f g m r . + (Control.Monad m, Control.Functor f, Control.Functor g) => + Stream (Compose f g) m r %1-> Stream f (Stream g m) r +unzips str = destroyExposed + str + (\(Compose fgstr) -> Step (Control.fmap (Effect . yields) fgstr)) + (Effect . Control.lift) + Return +{-# INLINABLE unzips #-} + +{-| Given a stream on a sum of functors, make it a stream on the left functor, + with the streaming on the other functor as the governing monad. This is + useful for acting on one or the other functor with a fold, leaving the + other material for another treatment. It generalizes + 'Data.Either.partitionEithers', but actually streams properly. + +\>\>\> let odd_even = S.maps (S.distinguish even) $ S.each' [1..10::Int] +\>\>\> :t separate odd_even +separate odd_even + :: Monad m => Stream (Of Int) (Stream (Of Int) m) () + + Now, for example, it is convenient to fold on the left and right values separately: + +\>\>\> S.toList $ S.toList $ separate odd_even +[2,4,6,8,10] :> ([1,3,5,7,9] :> ()) + + + Or we can write them to separate files or whatever: + +\>\>\> S.writeFile "even.txt" . S.show $ S.writeFile "odd.txt" . S.show $ S.separate odd_even +\>\>\> :! cat even.txt +2 +4 +6 +8 +10 +\>\>\> :! cat odd.txt +1 +3 +5 +7 +9 + + Of course, in the special case of @Stream (Of a) m r@, we can achieve the above + effects more simply by using 'Streaming.Prelude.copy' + +\>\>\> S.toList . S.filter even $ S.toList . S.filter odd $ S.copy $ each [1..10::Int] +[2,4,6,8,10] :> ([1,3,5,7,9] :> ()) + + + But 'separate' and 'unseparate' are functor-general. + +-} +separate :: forall f g m r . + (Control.Monad m, Control.Functor f, Control.Functor g) => + Stream (Sum f g) m r -> Stream f (Stream g m) r +separate str = destroyExposed str construct (Effect . Control.lift) Return + where + construct :: Sum f g (Stream f (Stream g m) r) %1-> Stream f (Stream g m) r + construct (InL fss) = Step fss + construct (InR gss) = Effect (yields gss) +{-# INLINABLE separate #-} + +unseparate :: (Control.Monad m, Control.Functor f, Control.Functor g) => + Stream f (Stream g m) r -> Stream (Sum f g) m r +unseparate str = destroyExposed + str + (Step . InL) + (Control.join . maps InR) + Return +{-# INLINABLE unseparate #-} + +{-| Rearrange a succession of layers of the form @Compose m (f x)@. + + we could as well define @decompose@ by @mapsM@: + +> decompose = mapped getCompose + + but @mapped@ is best understood as: + +> mapped phi = decompose . maps (Compose . phi) + + since @maps@ and @hoist@ are the really fundamental operations that preserve the + shape of the stream: + +> maps :: (Control.Monad m, Control.Functor f) => (forall x. f x %1-> g x) -> Stream f m r %1-> Stream g m r +> hoist :: (Control.Monad m, Control.Functor f) => (forall a. m a %1-> n a) -> Stream f m r %1-> Stream f n r + +-} +decompose :: forall f m r . (Control.Monad m, Control.Functor f) => + Stream (Compose m f) m r %1-> Stream f m r +decompose = loop where + loop :: Stream (Compose m f) m r %1-> Stream f m r + loop stream = stream & \case + Return r -> Return r + Effect m -> Effect $ Control.fmap loop m + Step (Compose mfs) -> Effect $ Control.do + fstream <- mfs + Control.return $ Step (Control.fmap loop fstream) +{-# INLINABLE decompose #-} + +-- Note. For 'loop' to recurse over functoral steps, it must be a +-- linear function, and hence, `ext` must be linear in its second argument. +-- Further, the first argument of `ext` ought to be a linear function, +-- because it is typically applied to the input stream in `ext`, and hence +-- should be linear. +-- | If 'Of' had a @Comonad@ instance, then we'd have +-- +-- @copy = expand extend@ +-- +-- See 'expandPost' for a version that requires a @Control.Functor g@ +-- instance instead. +expand :: forall f m r g h . (Control.Monad m, Control.Functor f) => + (forall a b. (g a %1-> b) -> f a %1-> h b) -> + Stream f m r %1-> Stream g (Stream h m) r +expand ext = loop where + loop :: Stream f m r %1-> Stream g (Stream h m) r + loop (Return r) = Return r + loop (Step f) = Effect $ Step $ ext (Return . Step) (Control.fmap loop f) + loop (Effect m) = Effect $ Effect $ Control.fmap (Return . loop) m +{-# INLINABLE expand #-} + +-- See note on 'expand'. +-- | If 'Of' had a @Comonad@ instance, then we'd have +-- +-- @copy = expandPost extend@ +-- +-- See 'expand' for a version that requires a @Control.Functor f@ instance +-- instead. +expandPost :: forall f m r g h . (Control.Monad m, Control.Functor g) => + (forall a b. (g a %1-> b) -> f a %1-> h b) -> + Stream f m r %1-> Stream g (Stream h m) r +expandPost ext = loop where + loop :: Stream f m r %1-> Stream g (Stream h m) r + loop (Return r) = Return r + loop (Step f) = Effect $ Step $ ext (Return . Step . Control.fmap loop) f + loop (Effect m) = Effect $ Effect $ Control.fmap (Return . loop) m +{-# INLINABLE expandPost #-} + + +-- # Eliminating a 'Stream' +------------------------------------------------------------------------------- + +-- Note. Since the functor step is held linearly in the +-- 'Stream' datatype, the first argument must be a linear function +-- in order to linearly consume the 'Step' case of a stream. +{-| Map each layer to an effect, and run them all. +-} +mapsM_ :: (Control.Functor f, Control.Monad m) => + (forall x . f x %1-> m x) -> Stream f m r %1-> m r +mapsM_ f = run . maps f +{-# INLINE mapsM_ #-} + +{-| Run the effects in a stream that merely layers effects. +-} +run :: Control.Monad m => Stream m m r %1-> m r +run = loop + where + loop :: Control.Monad m => Stream m m r %1-> m r + loop stream = stream & \case + Return r -> Control.return r + Effect m -> m Control.>>= loop + Step mrest -> mrest Control.>>= loop +{-# INLINABLE run #-} + +{-| 'streamFold' reorders the arguments of 'destroy' to be more akin + to @foldr@ It is more convenient to query in ghci to figure out + what kind of \'algebra\' you need to write. + +\>\>\> :t streamFold Control.return Control.join +(Control.Monad m, Control.Functor f) => + (f (m a) %1-> m a) -> Stream f m a %1-> m a -- iterT + +\>\>\> :t streamFold Control.return (Control.join . Control.lift) +(Control.Monad m, Control.Monad (t m), Control.Functor f, Control.MonadTrans t) => + (f (t m a) %1-> t m a) -> Stream f m a %1-> t m a -- iterTM + +\>\>\> :t streamFold Control.return effect +(Control.Monad m, Control.Functor f, Control.Functor g) => + (f (Stream g m r) %1-> Stream g m r) -> Stream f m r %1-> Stream g m r + +\>\>\> :t \f -> streamFold Control.return effect (wrap . f) +(Control.Monad m, Control.Functor f, Control.Functor g) => + (f (Stream g m a) %1-> g (Stream g m a)) + -> Stream f m a %1-> Stream g m a -- maps + +\>\>\> :t \f -> streamFold Control.return effect (effect . Control.fmap wrap . f) +(Control.Monad m, Control.Functor f, Control.Functor g) => + (f (Stream g m a) %1-> m (g (Stream g m a))) + -> Stream f m a %1-> Stream g m a -- mapped + +@ + streamFold done eff construct + = eff . iterT (Control.return . construct . Control.fmap eff) . Control.fmap done +@ +-} +streamFold :: (Control.Functor f, Control.Monad m) => + (r %1-> b) -> (m b %1-> b) -> (f b %1-> b) -> Stream f m r %1-> b +streamFold done theEffect construct stream = + destroy stream construct theEffect done +{-# INLINE streamFold #-} + +{-| Specialized fold following the usage of @Control.Monad.Trans.Free@ + +> iterT alg = streamFold Control.return Control.join alg +> iterT alg = runIdentityT . iterTM (IdentityT . alg . Control.fmap runIdentityT) +-} +iterT :: (Control.Functor f, Control.Monad m) => + (f (m a) %1-> m a) -> Stream f m a %1-> m a +iterT out stream = destroyExposed stream out Control.join Control.return +{-# INLINE iterT #-} + +{-| Specialized fold following the usage of @Control.Monad.Trans.Free@ + +> iterTM alg = streamFold Control.return (Control.join . Control.lift) +> iterTM alg = iterT alg . hoist Control.lift +-} +iterTM :: + ( Control.Functor f, Control.Monad m + , Control.MonadTrans t, Control.Monad (t m)) => + (f (t m a) %1-> t m a) -> Stream f m a %1-> t m a +iterTM out stream = + destroyExposed stream out (Control.join . Control.lift) Control.return +{-# INLINE iterTM #-} + +-- Note. 'destroy' needs to use linear functions in its church encoding +-- to consume the stream linearly. +{-| Map a stream to its church encoding; compare @Data.List.foldr@. + 'destroyExposed' may be more efficient in some cases when + applicable, but it is less safe. + + @ + destroy s construct eff done + = eff . + iterT (Control.return . construct . Control.fmap eff) . + Control.fmap done $ s + @ +-} +destroy :: forall f m r b . (Control.Functor f, Control.Monad m) => + Stream f m r %1-> (f b %1-> b) -> (m b %1-> b) -> (r %1-> b) -> b +destroy stream0 construct theEffect done = theEffect (loop stream0) + where + loop :: Stream f m r %1-> m b + loop stream = stream & \case + Return r -> Control.return $ done r + Effect m -> m Control.>>= loop + Step f -> Control.return $ construct $ Control.fmap (theEffect . loop) f +{-# INLINABLE destroy #-} + diff --git a/src/Streaming/Prelude/Linear.hs b/src/Streaming/Prelude/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Prelude/Linear.hs @@ -0,0 +1,66 @@ +{-| The names exported by this module are closely modeled on those in @Prelude@ and @Data.List@, + but also on + , + + and . + The module may be said to give independent expression to the conception of + Producer \/ Source \/ Generator manipulation + articulated in the latter two modules. Because we dispense with piping and + conduiting, the distinction between all of these modules collapses. Some things are + lost but much is gained: on the one hand, everything comes much closer to ordinary + beginning Haskell programming and, on the other, acquires the plasticity of programming + directly with a general free monad type. The leading type, @Stream (Of a) m r@ is chosen to permit an api + that is as close as possible to that of @Data.List@ and the @Prelude@. + + Import qualified thus: + +> import Streaming +> import qualified Streaming.Prelude as S + + For the examples below, one sometimes needs + +> import Streaming.Prelude (each, yield, next, mapped, stdoutLn, stdinLn) +> import Data.Function ((&)) + + Other libraries that come up in passing are + +> import qualified Control.Foldl as L -- cabal install foldl +> import qualified Pipes as P +> import qualified Pipes.Prelude as P +> import qualified System.IO as IO + + Here are some correspondences between the types employed here and elsewhere: + +> streaming | pipes | conduit | io-streams +> ------------------------------------------------------------------------------------------------------------------- +> Stream (Of a) m () | Producer a m () | Source m a | InputStream a +> | ListT m a | ConduitM () o m () | Generator r () +> ------------------------------------------------------------------------------------------------------------------- +> Stream (Of a) m r | Producer a m r | ConduitM () o m r | Generator a r +> ------------------------------------------------------------------------------------------------------------------- +> Stream (Of a) m (Stream (Of a) m r) | Producer a m (Producer a m r) | +> -------------------------------------------------------------------------------------------------------------------- +> Stream (Stream (Of a) m) r | FreeT (Producer a m) m r | +> -------------------------------------------------------------------------------------------------------------------- +> -------------------------------------------------------------------------------------------------------------------- +> ByteString m () | Producer ByteString m () | Source m ByteString | InputStream ByteString +> -------------------------------------------------------------------------------------------------------------------- +> +-} +module Streaming.Prelude.Linear + ( module Streaming.Internal.Type + , module Streaming.Internal.Consume + , module Streaming.Internal.Interop + , module Streaming.Internal.Many + , module Streaming.Internal.Process + , module Streaming.Internal.Produce + ) where + +import Streaming.Internal.Type +import Streaming.Internal.Consume +import Streaming.Internal.Interop +import Streaming.Internal.Many +import Streaming.Internal.Process +import Streaming.Internal.Produce + + diff --git a/src/System/IO/Linear.hs b/src/System/IO/Linear.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Linear.hs @@ -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)) diff --git a/src/System/IO/Resource.hs b/src/System/IO/Resource.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Resource.hs @@ -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 diff --git a/src/Unsafe/Linear.hs b/src/Unsafe/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Unsafe/Linear.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] + diff --git a/test/Test/Data/Destination.hs b/test/Test/Data/Destination.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Destination.hs @@ -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)) + diff --git a/test/Test/Data/Mutable/Array.hs b/test/Test/Data/Mutable/Array.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Mutable/Array.hs @@ -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 () diff --git a/test/Test/Data/Mutable/HashMap.hs b/test/Test/Data/Mutable/HashMap.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Mutable/HashMap.hs @@ -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) + diff --git a/test/Test/Data/Mutable/Set.hs b/test/Test/Data/Mutable/Set.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Mutable/Set.hs @@ -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))) + diff --git a/test/Test/Data/Mutable/Vector.hs b/test/Test/Data/Mutable/Vector.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Mutable/Vector.hs @@ -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 diff --git a/test/Test/Data/Polarized.hs b/test/Test/Data/Polarized.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Polarized.hs @@ -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') +