linear-base 0.4.0 → 0.8.1
raw patch · 58 files changed
Files
- CHANGELOG.md +55/−0
- README.md +9/−1
- bench/Data/Mutable/HashMap.hs +4/−4
- bench/Data/Mutable/Quicksort.hs +40/−0
- bench/Main.hs +3/−1
- docs/USER_GUIDE.md +0/−33
- examples/Generic/Traverse.hs +0/−52
- examples/Main.hs +0/−18
- examples/Simple/Quicksort.hs +28/−17
- examples/Simple/TopSort.hs +8/−9
- examples/Test/Foreign.hs +0/−102
- examples/Test/Generic.hs +0/−11
- examples/Test/Quicksort.hs +0/−19
- linear-base.cabal +58/−44
- src/Control/Functor/Linear/Internal/Reader.hs +12/−0
- src/Control/Monad/IO/Class/Linear.hs +11/−0
- src/Control/Optics/Linear/Internal.hs +1/−1
- src/Control/Optics/Linear/Prism.hs +1/−1
- src/Data/Array/Mutable/Linear/Internal.hs +8/−8
- src/Data/Array/Mutable/Unlifted/Linear.hs +22/−3
- src/Data/Array/Polarized.hs +6/−8
- src/Data/Array/Polarized/Pull.hs +3/−2
- src/Data/Array/Polarized/Pull/Internal.hs +8/−3
- src/Data/Functor/Linear/Internal/Functor.hs +6/−0
- src/Data/Functor/Linear/Internal/Traversable.hs +8/−1
- src/Data/HashMap/Mutable/Linear/Internal.hs +16/−12
- src/Data/List/Linear.hs +53/−17
- src/Data/List/NonEmpty/Linear.hs +211/−0
- src/Data/Monoid/Linear/Internal/Semigroup.hs +12/−3
- src/Data/Num/Linear.hs +127/−19
- src/Data/Ord/Linear/Internal/Eq.hs +4/−0
- src/Data/Ord/Linear/Internal/Ord.hs +6/−1
- src/Data/Replicator/Linear/Internal.hs +6/−6
- src/Data/Replicator/Linear/Internal/ReplicationStream.hs +4/−4
- src/Data/Set/Mutable/Linear/Internal.hs +13/−5
- src/Data/Unrestricted/Linear.hs +1/−1
- src/Data/Unrestricted/Linear/Internal/Instances.hs +58/−4
- src/Data/Unrestricted/Linear/Internal/Movable.hs +7/−7
- src/Data/V/Linear/Internal.hs +4/−4
- src/Data/Vector/Mutable/Linear/Internal.hs +7/−7
- src/Foreign/Marshal/Pure/Internal.hs +6/−6
- src/Streaming/Linear.hs +16/−16
- src/Streaming/Linear/Internal/Consume.hs +20/−19
- src/Streaming/Linear/Internal/Many.hs +13/−13
- src/Streaming/Linear/Internal/Process.hs +47/−47
- src/Streaming/Linear/Internal/Produce.hs +12/−11
- src/System/IO/Resource/Linear.hs +5/−0
- src/System/IO/Resource/Linear/Internal.hs +18/−4
- test-examples/Main.hs +16/−0
- test-examples/Test/Foreign.hs +102/−0
- test-examples/Test/Simple/Quicksort.hs +29/−0
- test/Main.hs +5/−1
- test/Test/Data/Functor/Linear.hs +59/−0
- test/Test/Data/List.hs +66/−0
- test/Test/Data/Mutable/Vector.hs +1/−1
- test/Test/Data/Polarized.hs +13/−1
- test/Test/Data/Replicator.hs +3/−3
- test/Test/Data/V.hs +4/−4
CHANGELOG.md view
@@ -1,5 +1,60 @@ # Change Log +## [v0.8.1](https://github.com/tweag/linear-base/tree/v0.8.1) (2026-06-24)++[Full Changelog](https://github.com/tweag/linear-base/compare/v0.8.0...v0.8.1)++### Headline changes++- Restore compatibility with GHC 9.2: Import Multiplicity from GHC.Types [\#509](https://github.com/tweag/linear-base/pull/509) ([tomsmeding](https://github.com/tomsmeding))++## [v0.8.0](https://github.com/tweag/linear-base/tree/v0.8.0) (2026-05-12)++[Full Changelog](https://github.com/tweag/linear-base/compare/v0.7.0...v0.8.0)++### Headline changes++- Add MonadIO instances for StateT and ReaderT [\#506](https://github.com/tweag/linear-base/pull/506) ([dcastro](https://github.com/dcastro))+- Coerce `System.IO` and `Linear.IO` into `RIO` [\#505](https://github.com/tweag/linear-base/pull/505) ([dcastro](https://github.com/dcastro))++## [v0.7.0](https://github.com/tweag/linear-base/tree/v0.7.0) (2026-02-27)++[Full Changelog](https://github.com/tweag/linear-base/compare/v0.6.0...v0.7.0)++### Headline changes++- Add instance Consumable/Dupable/Movable for ByteString, ShortByteString and Text [\#501](https://github.com/tweag/linear-base/pull/501) ([Bodigrim](https://github.com/Bodigrim))+- feat: Adds missing instances for `NonEmpty` and adds some Linear counterpart of `Data.List.NonEmpty` [\#495](https://github.com/tweag/linear-base/pull/495) ([konn](https://github.com/konn))+- use Unsatisfiable for banned instances \(unrestricted Monoid / Semigroup for linear containers\) [\#494](https://github.com/tweag/linear-base/pull/494) ([konn](https://github.com/konn))+- Control Monad instance for linear arrows [\#493](https://github.com/tweag/linear-base/pull/493) ([konn](https://github.com/konn))++## [v0.6.0](https://github.com/tweag/linear-base/tree/v0.6.0) (2025-11-18)++[Full Changelog](https://github.com/tweag/linear-base/compare/v0.5.0...v0.6.0)++### Headline changes++- Make List.zipWith as lazy as expected [\#492](https://github.com/tweag/linear-base/pull/492) ([aspiwack](https://github.com/aspiwack))++## [v0.5.0](https://github.com/tweag/linear-base/tree/v0.5.0) (2025-04-07)++[Full Changelog](https://github.com/tweag/linear-base/compare/v0.4.0...v0.5.0)++### Headline changes++- Data.List.Linear.{take,drop} take one list element too many [\#484](https://github.com/tweag/linear-base/issues/484)+- Remove pull array index \(unsafe\), add uncons. [\#475](https://github.com/tweag/linear-base/pull/475) ([sjoerdvisscher](https://github.com/sjoerdvisscher))+- Adds missing Data.Num.Linear.\* instances for Word, Integer, Natural, Float, Word8/16/32/64 Int8/16/32/64 [\#467](https://github.com/tweag/linear-base/pull/467) ([Qqwy](https://github.com/Qqwy))+- In scope-passing style: use a `Movable b` instead of `Ur b` (it's fully backward compatible compatible)[\#473](https://github.com/tweag/linear-base/pull/473) ([aspiwack](https://github.com/aspiwack))++### Miscellaneous++- Clarify Ur documentation [\#476](https://github.com/tweag/linear-base/issues/476)+- Test with GHC 9.10 and GHC 9.12+ - 9.10 [\#479](https://github.com/tweag/linear-base/pull/479) ([tbagrel1](https://github.com/tbagrel1))+ - 9.12 [\#487](https://github.com/tweag/linear-base/pull/487) ([aspiwack](https://github.com/aspiwack))+- Improve wording about Ur [\#478](https://github.com/tweag/linear-base/pull/478) ([aspiwack](https://github.com/aspiwack))+ ## [v0.4.0](https://github.com/tweag/linear-base/tree/v0.4.0) (2023-10-13) [Full Changelog](https://github.com/tweag/linear-base/compare/v0.3.1...v0.4.0)
README.md view
@@ -1,9 +1,9 @@ # Linear base [](https://github.com/tweag/linear-base/blob/master/LICENSE)-[](https://buildkite.com/tweag-1/linear-base) [][hackage-pkg] [][stackage-pkg]+[][discord] 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`]@@ -39,6 +39,10 @@ {-# LANGUAGE LinearTypes #-} ``` +To get in touch, you can join our+[][discord] server++ ## User Guide If you already know what `-XLinearTypes` does and what the linear@@ -85,6 +89,9 @@ To contribute please see the [Design Document] for instructions and advice on making pull requests. +A great first step is to join our+[][discord] server+ ## Licence See the [Licence file](https://github.com/tweag/linear-base/blob/master/LICENSE).@@ -97,3 +104,4 @@ [Design Document]: https://github.com/tweag/linear-base/blob/master/docs/DESIGN.md [hackage-pkg]: https://hackage.haskell.org/package/linear-base [stackage-pkg]: https://www.stackage.org/nightly/package/linear-base+[discord]: https://discord.com/invite/7yg5GxzvDJ
bench/Data/Mutable/HashMap.hs view
@@ -22,7 +22,7 @@ import qualified Data.HashTable.ST.Basic as BasicST import qualified Data.HashTable.ST.Cuckoo as CuckooST import Data.Hashable (Hashable (..), hashWithSalt)-import Data.List (foldl')+import qualified Data.List as List import qualified Data.Unrestricted.Linear as Linear import GHC.Generics (Generic) import qualified Prelude.Linear as Linear@@ -135,7 +135,7 @@ look :: LMap.HashMap Key Int %1 -> Key -> LMap.HashMap Key Int look hmap k =- LMap.lookup k hmap Linear.& \case+ case LMap.lookup k hmap of (Linear.Ur Nothing, hmap0) -> hmap0 (Linear.Ur (Just v), hmap0) -> Linear.seq (force v) hmap0 @@ -199,7 +199,7 @@ 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+ foldlx f xs b = List.foldl' f b xs look :: Map.HashMap Key Int -> Key -> Map.HashMap Key Int look m k = case m Map.!? k of@@ -208,7 +208,7 @@ bench1 :: Benchmark bench1 = mkBench 0 $- \xs hm -> foldl' (\m (k, v) -> Map.delete k (Map.insert k v m)) hm xs+ \xs hm -> List.foldl' (\m (k, v) -> Map.delete k (Map.insert k v m)) hm xs bench2 :: Benchmark bench2 = mkBench 1 $
+ bench/Data/Mutable/Quicksort.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE NumericUnderscores #-}++module Data.Mutable.Quicksort (benchmarks) where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.List (sort)+import Simple.Quicksort (quicksortUsingArray, quicksortUsingList)+import System.Random+import Test.Tasty.Bench++-- Follows thread from https://discourse.haskell.org/t/linear-haskell-quicksort-performance/10280++gen :: StdGen+gen = mkStdGen 4541645642++randomListBuilder :: Int -> IO [Int]+randomListBuilder size = evaluate $ force $ take size (randoms gen :: [Int])++sizes :: [Int]+sizes = [1_000, 50_000, 1_000_000]++benchmarks :: Benchmark+benchmarks =+ bgroup+ "quicksort"+ ( ( \size ->+ env (randomListBuilder size) $ \randomList ->+ bgroup+ ("size " ++ (show size))+ [ bench "quicksortUsingArray" $+ nf quicksortUsingArray randomList,+ bench "quicksortUsingList" $+ nf quicksortUsingList randomList,+ bench "sortStdLib" $+ nf sort randomList+ ]+ )+ <$> sizes+ )
bench/Main.hs view
@@ -2,11 +2,13 @@ import qualified Data.Mutable.Array as Array import qualified Data.Mutable.HashMap as HashMap+import qualified Data.Mutable.Quicksort as Quicksort import Test.Tasty.Bench (defaultMain) main :: IO () main = do defaultMain [ Array.benchmarks,- HashMap.benchmarks+ HashMap.benchmarks,+ Quicksort.benchmarks ]
docs/USER_GUIDE.md view
@@ -107,39 +107,6 @@ ## 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.--This workaround will no longer be needed in GHC 9.2, where this limitation-has been lifted and `case` can be used in a linear context.- ### `let` and `where` bindings are not linear The following will **fail** to type check:
− examples/Generic/Traverse.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Generic.Traverse (genericTraverseTests) where--import Data.Functor.Linear (genericTraverse)-import qualified Data.Functor.Linear as Data-import Generics.Linear.TH-import Hedgehog-import Prelude.Linear-import Test.Tasty-import Test.Tasty.Hedgehog (testPropertyNamed)-import qualified Prelude--data Pair a = MkPair a a- deriving (Show, Prelude.Eq)--$(deriveGeneric1 ''Pair)--instance Data.Functor Pair where- fmap f (MkPair x y) = MkPair (f x) (f y)--instance Data.Traversable Pair where- traverse = genericTraverse--genericTraverseTests :: TestTree-genericTraverseTests =- testGroup- "genericTraverse examples"- [pairTest]--pairTest :: TestTree-pairTest =- testPropertyNamed "traverse via genericTraverse with WithLog and Pair" "propertyPairTest" propertyPairTest--propertyPairTest :: Property-propertyPairTest =- property $- ( Data.traverse- (\x -> (Sum (1 :: Int), 2 * x))- (MkPair 3 4 :: Pair Int)- )- === (Sum 2, (MkPair 6 8))
− examples/Main.hs
@@ -1,18 +0,0 @@-module Main where--import Test.Foreign (foreignGCTests)-import Test.Generic (genericTests)-import Test.Quicksort (quickSortTests)-import Test.Tasty--main :: IO ()-main = defaultMain allTests--allTests :: TestTree-allTests =- testGroup- "All tests"- [ foreignGCTests,- quickSortTests,- genericTests- ]
examples/Simple/Quicksort.hs view
@@ -1,8 +1,12 @@ {-# LANGUAGE LinearTypes #-} {-# LANGUAGE NoImplicitPrelude #-} +-- Uncomment the line below to observe the generated (optimised) Core. It will+-- land in a file named “Quicksort.dump-simpl”+-- {-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all -dsuppress-uniques #-}+ -- | This module implements quicksort with mutable arrays from linear-base-module Simple.Quicksort (quickSort) where+module Simple.Quicksort where import Data.Array.Mutable.Linear (Array) import qualified Data.Array.Mutable.Linear as Array@@ -13,15 +17,22 @@ -- # Quicksort ------------------------------------------------------------------------------- -quickSort :: [Int] -> [Int]-quickSort xs = unur $ Array.fromList xs $ Array.toList . arrQuicksort+quicksortUsingList :: (Ord a) => [a] -> [a]+quicksortUsingList [] = []+quicksortUsingList (x : xs) = quicksortUsingList ltx ++ x : quicksortUsingList gex+ where+ ltx = [y | y <- xs, y < x]+ gex = [y | y <- xs, y >= x] -arrQuicksort :: Array Int %1 -> Array Int-arrQuicksort arr =+quicksortUsingArray :: (Ord a) => [a] -> [a]+quicksortUsingArray xs = unur $ Array.fromList xs $ Array.toList . quicksortArray++quicksortArray :: (Ord a) => Array a %1 -> Array a+quicksortArray arr = Array.size arr & \(Ur len, arr1) -> go 0 (len - 1) arr1 -go :: Int -> Int -> Array Int %1 -> Array Int+go :: (Ord a) => Int -> Int -> Array a %1 -> Array a go lo hi arr | lo >= hi = arr | otherwise =@@ -39,23 +50,23 @@ -- @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))+partition :: (Ord a) => Array a %1 -> a -> Int -> Int -> (Array a, Ur Int)+partition arr pivot lo hi+ | (hi < lo) = (arr, Ur (lo - 1)) | otherwise =- Array.read arr lx+ Array.read arr lo & \(Ur lVal, arr1) ->- Array.read arr1 rx+ Array.read arr1 hi & \(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)+ (True, True) -> partition arr2 pivot (lo + 1) (hi - 1)+ (True, False) -> partition arr2 pivot (lo + 1) hi+ (False, True) -> partition arr2 pivot lo (hi - 1) (False, False) ->- swap arr2 lx rx- & \arr3 -> partition arr3 pivot (lx + 1) (rx - 1)+ swap arr2 lo hi+ & \arr3 -> partition arr3 pivot (lo + 1) (hi - 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 :: (HasCallStack) => Array a %1 -> Int -> Int -> Array a swap arr i j = Array.read arr i & \(Ur ival, arr1) ->
examples/Simple/TopSort.hs view
@@ -13,7 +13,6 @@ import qualified Data.HashMap.Mutable.Linear as HMap import Data.Maybe.Linear (catMaybes) import Data.Unrestricted.Linear-import Prelude.Linear ((&)) import qualified Prelude.Linear as Linear -- # The topological sort of a DAG@@ -36,7 +35,7 @@ postOrderHM :: [Node] -> InDegGraph %1 -> Ur [Node] postOrderHM nodes dag =- findSources nodes (computeInDeg nodes dag) & \case+ case findSources nodes (computeInDeg nodes dag) of (dag, Ur sources) -> pluckSources sources [] dag where -- O(V + N)@@ -46,7 +45,7 @@ -- Increment in-degree of all neighbors incChildren :: InDegGraph %1 -> Ur Node %1 -> InDegGraph incChildren dag (Ur node) =- HMap.lookup node dag & \case+ case HMap.lookup node dag of (Ur Nothing, dag) -> dag (Ur (Just (xs, i)), dag) -> incNodes (move xs) dag where@@ -55,7 +54,7 @@ incNode :: InDegGraph %1 -> Ur Node %1 -> InDegGraph incNode dag (Ur node) =- HMap.lookup node dag & \case+ case HMap.lookup node dag of (Ur Nothing, dag') -> dag' (Ur (Just (n, d)), dag') -> HMap.insert node (n, d + 1) dag'@@ -66,10 +65,10 @@ pluckSources :: [Node] -> [Node] -> InDegGraph %1 -> Ur [Node] pluckSources [] postOrd dag = lseq dag (move postOrd) pluckSources (s : ss) postOrd dag =- HMap.lookup s dag & \case+ case HMap.lookup s dag of (Ur Nothing, dag) -> pluckSources ss (s : postOrd) dag (Ur (Just (xs, i)), dag) ->- walk xs dag & \case+ case walk xs dag of (dag', Ur newSrcs) -> pluckSources (newSrcs ++ ss) (s : postOrd) dag' where@@ -81,7 +80,7 @@ -- 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+ case HMap.lookup node dag of (Ur Nothing, dag') -> (dag', Ur Nothing) (Ur (Just (n, d)), dag') -> checkSource node (HMap.insert node (n, d - 1) dag')@@ -94,7 +93,7 @@ -- | 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+ case HMap.lookup node dag of (Ur Nothing, dag) -> (dag, Ur Nothing) (Ur (Just (xs, 0)), dag) -> (dag, Ur (Just node)) (Ur (Just (xs, n)), dag) -> (dag, Ur Nothing)@@ -103,5 +102,5 @@ (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+ case mapAccum f xs b of (b, Ur cs) -> second (Data.fmap (: cs)) (f x b)
− examples/Test/Foreign.hs
@@ -1,102 +0,0 @@-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Test.Foreign (foreignGCTests) where--import Control.Exception hiding (assert)-import Control.Monad (void)-import Data.Typeable-import qualified Foreign.Heap as Heap-import Foreign.List (List)-import qualified Foreign.List as List-import qualified Foreign.Marshal.Pure as Manual-import Hedgehog-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range-import Prelude.Linear-import Test.Tasty-import Test.Tasty.Hedgehog (testPropertyNamed)-import qualified Prelude---- # Organizing tests----------------------------------------------------------------------------------foreignGCTests :: TestTree-foreignGCTests =- testGroup- "foreignGCTests"- [ listExampleTests,- heapExampleTests- ]--listExampleTests :: TestTree-listExampleTests =- testGroup- "list tests"- [ testPropertyNamed "List.toList . List.fromList = id" "invertNonGCList" invertNonGCList,- testPropertyNamed "map id = id" "mapIdNonGCList" mapIdNonGCList,- testPropertyNamed "memory freed post-exception" "testExceptionOnMem" testExceptionOnMem- ]--heapExampleTests :: TestTree-heapExampleTests =- testGroup- "heap tests"- [testPropertyNamed "sort = heapsort" "nonGCHeapSort" 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 $ do- xs <- forAll list- let xs' =- unur $- Manual.withPool (\p -> move $ List.toList $ List.ofList xs p)- xs === xs'--mapIdNonGCList :: Property-mapIdNonGCList = property $ do- xs <- forAll list- let boolTest = unur $- Manual.withPool $ \p ->- dup3 p & \(p0, p1, p2) ->- eqList (List.ofList xs p0) (List.map id (List.ofList xs p1) p2)- assert boolTest--testExceptionOnMem :: Property-testExceptionOnMem = property $ 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 $ do- xs <- forAll list- let ys :: [(Int, ())] = zip xs $ Prelude.replicate (Prelude.length xs) ()- (Heap.sort ys) === (reverse $ sort ys)
− examples/Test/Generic.hs
@@ -1,11 +0,0 @@-module Test.Generic (genericTests) where--import Generic.Traverse (genericTraverseTests)-import Test.Tasty--genericTests :: TestTree-genericTests =- testGroup- "Generic tests"- [ genericTraverseTests- ]
− examples/Test/Quicksort.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test.Quicksort (quickSortTests) where--import Data.List (sort)-import Hedgehog-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range-import Simple.Quicksort (quickSort)-import Test.Tasty-import Test.Tasty.Hedgehog (testPropertyNamed)--quickSortTests :: TestTree-quickSortTests = testPropertyNamed "quicksort sorts" "testQuicksort" testQuicksort--testQuicksort :: Property-testQuicksort = property $ do- xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int $ Range.linear 0 100)- sort xs === quickSort xs
linear-base.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: linear-base-version: 0.4.0+version: 0.8.1 license: MIT license-file: LICENSE copyright: (c) Tweag Holding and affiliates@@ -21,13 +21,26 @@ type: git location: https://github.com/tweag/linear-base -common warnings- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances+common build-opts+ ghc-options: -O2 -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -- Additional warnings we may consider adding: -- * -Wredundant-constraints : would need deactivating in the modules which use Nat+common rts-opts-multithread+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N"+common rts-opts-monothread-stats+ ghc-options: -rtsopts "-with-rtsopts=-T" library- import: warnings+ import: build-opts+ hs-source-dirs: src+ if impl(ghc >= 9.4.0)+ hs-source-dirs: src-version-changes/ghc94/after+ else+ hs-source-dirs: src-version-changes/ghc94/before+ if impl(ghc >= 9.6.0)+ hs-source-dirs: src-version-changes/ghc96/after+ else+ hs-source-dirs: src-version-changes/ghc96/before exposed-modules: Control.Monad.IO.Class.Linear Control.Functor.Linear@@ -66,6 +79,7 @@ Data.HashMap.Mutable.Linear Data.HashMap.Mutable.Linear.Internal Data.List.Linear+ Data.List.NonEmpty.Linear Data.Maybe.Linear Data.Monoid.Linear Data.Monoid.Linear.Internal.Monoid@@ -118,23 +132,13 @@ System.IO.Resource.Linear System.IO.Resource.Linear.Internal Unsafe.Linear-- hs-source-dirs: src- if impl(ghc >= 9.4.0)- hs-source-dirs: src-version-changes/ghc94/after- else- hs-source-dirs: src-version-changes/ghc94/before- if impl(ghc >= 9.6.0)- hs-source-dirs: src-version-changes/ghc96/after- else- hs-source-dirs: src-version-changes/ghc96/before- default-language: Haskell2010 build-depends:- base >=4.16 && <5,+ bytestring, containers, ghc-prim,+ ghc-bignum, hashable, linear-generics >= 0.2, storable-tuple,@@ -143,23 +147,42 @@ vector >=0.12.2, primitive +library examples+ import: build-opts+ hs-source-dirs: examples+ exposed-modules:+ Foreign.List+ Foreign.Heap+ Simple.FileIO+ Simple.Pure+ Simple.Quicksort+ Simple.TopSort+ build-depends:+ base,+ linear-base,+ storable-tuple,+ vector,+ text+ default-language: Haskell2010+ test-suite test- import: warnings+ import: build-opts+ import: rts-opts-multithread type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test other-modules: Test.Data.Destination+ Test.Data.Functor.Linear+ Test.Data.List Test.Data.Mutable.Array- Test.Data.Mutable.Vector Test.Data.Mutable.HashMap Test.Data.Mutable.Set+ Test.Data.Mutable.Vector Test.Data.Polarized- Test.Data.V Test.Data.Replicator-+ Test.Data.V default-language: Haskell2010- ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: inspection-testing, tasty-inspection-testing,@@ -170,47 +193,37 @@ tasty, tasty-hedgehog >= 1.2, mmorph,- vector+ vector,+ linear-generics -test-suite examples- import: warnings+test-suite test-examples+ import: build-opts+ import: rts-opts-multithread type: exitcode-stdio-1.0 main-is: Main.hs- hs-source-dirs: examples+ hs-source-dirs: test-examples other-modules: Test.Foreign- Test.Quicksort- Test.Generic- Foreign.List- Foreign.Heap- Simple.FileIO- Simple.Pure- Simple.Quicksort- Simple.TopSort- Generic.Traverse-+ Test.Simple.Quicksort default-language: Haskell2010- ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base, linear-base, tasty, tasty-hedgehog, hedgehog,- storable-tuple,- vector,- text,- linear-generics+ examples -benchmark mutable-data- import: warnings+benchmark bench+ import: build-opts+ import: rts-opts-monothread-stats type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench other-modules: Data.Mutable.HashMap Data.Mutable.Array-+ Data.Mutable.Quicksort default-language: Haskell2010 build-depends: base,@@ -224,4 +237,5 @@ random-shuffle, tasty-bench >= 0.3, unordered-containers,- MonadRandom+ MonadRandom,+ examples
src/Control/Functor/Linear/Internal/Reader.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE LinearTypes #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} @@ -28,8 +32,10 @@ import Data.Functor.Identity import qualified Data.Functor.Linear.Internal.Applicative as Data import qualified Data.Functor.Linear.Internal.Functor as Data+import Data.Kind (FUN) import Data.Unrestricted.Linear.Internal.Consumable import Data.Unrestricted.Linear.Internal.Dupable+import GHC.Types (Multiplicity (..)) import Prelude.Linear.Internal (runIdentity', ($), (.)) -- # Linear ReaderT@@ -119,3 +125,9 @@ instance MonadTrans (NonLinear.ReaderT r) where lift x = NonLinear.ReaderT (\_ -> x)++deriving via Reader r instance (Dupable r) => Data.Applicative (FUN 'One r)++deriving via Reader r instance (Dupable r) => Applicative (FUN 'One r)++deriving via Reader r instance (Dupable r) => Monad (FUN 'One r)
src/Control/Monad/IO/Class/Linear.hs view
@@ -7,6 +7,8 @@ import Prelude.Linear import qualified System.IO as System import qualified System.IO.Linear as Linear+import System.IO.Resource.Linear (RIO)+import qualified System.IO.Resource.Linear as RIO -- | Like 'NonLinear.MonadIO' but allows to lift both linear -- and non-linear 'IO' actions into a linear monad.@@ -19,3 +21,12 @@ instance MonadIO Linear.IO where liftIO = id++instance MonadIO RIO where+ liftIO = RIO.fromIO++instance (MonadIO m) => MonadIO (Linear.StateT s m) where+ liftIO = Linear.lift . liftIO++instance (MonadIO m, Dupable r) => MonadIO (Linear.ReaderT r m) where+ liftIO = Linear.lift . liftIO
src/Control/Optics/Linear/Internal.hs view
@@ -173,7 +173,7 @@ lengthOf :: (MultIdentity r) => Optic_ (NonLinear.Kleisli (Const (Sum r))) s t a b -> s -> r lengthOf l s =- (gets l (const (Sum one)) s) & \case+ case gets l (const (Sum one)) s of Sum r -> r -- XXX: the below two functions will be made redundant with multiplicity
src/Control/Optics/Linear/Prism.hs view
@@ -23,7 +23,7 @@ -- -- (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+-- case Data.fmap modLisc (match pIdLiscPrism personId) of -- Left personId' -> personId' -- Right lisc -> build pIdLiscPrism lisc -- where
src/Data/Array/Mutable/Linear/Internal.hs view
@@ -62,11 +62,11 @@ -- | Allocate a constant array given a size and an initial value -- The size must be non-negative, otherwise this errors. alloc ::- (HasCallStack) =>+ (HasCallStack, Movable b) => Int -> a ->- (Array a %1 -> Ur b) %1 ->- Ur b+ (Array a %1 -> b) %1 ->+ b alloc s x f | s < 0 = (error ("Array.alloc: negative size: " ++ show s) :: x %1 -> x)@@ -89,11 +89,11 @@ -- | Allocate an array from a list fromList ::- (HasCallStack) =>+ (HasCallStack, Movable b) => [a] ->- (Array a %1 -> Ur b) %1 ->- Ur b-fromList list (f :: Array a %1 -> Ur b) =+ (Array a %1 -> b) %1 ->+ b+fromList list (f :: Array a %1 -> b) = alloc (Prelude.length list) (error "invariant violation: unintialized array position")@@ -190,7 +190,7 @@ Array a %1 -> (Array a, Array a) slice from targetSize arr =- size arr & \case+ case size arr of (Ur s, Array old) | s < from + targetSize -> Unlifted.lseq
src/Data/Array/Mutable/Unlifted/Linear.hs view
@@ -60,13 +60,32 @@ -- | 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 =+alloc :: (Movable b) => Int -> a -> (Array# a %1 -> b) %1 -> b+alloc i a f = case move (unsafe_alloc i a f) of+ Ur b -> b+{-# INLINEABLE alloc #-}++-- The `alloc` function is split in two. One very unsafe below (it's very+-- unsafe, because `unafe_alloc 57 0 id` returns an unrestricted _mutable_+-- `Array#` breaking the module's invariants). Because `unsafe_alloc` calls+-- `runRW#`, it's marked as `NOINLINE`.+--+-- It's made safe by the wrapping function `alloc`, which restricts `b` to be+-- `Movable` (`Array#` is crucially not `Movable`, therefore `alloc 57 0 id`+-- doesn't type). Furthermore, `alloc` cases on `move` to make sure that all the+-- effects have been run by the time we evaluate the result of an `alloc`. It's+-- fine that `alloc` is inlined: its semantics is preserved by program+-- transformations. It's useful that `alloc` be inlined, because in most+-- instance `case move … of` will trigger a case-of-known-constructor avoiding+-- an extra allocation. This is in particular the case for the common case where+-- `b = Ur x`.+unsafe_alloc :: Int -> a -> (Array# a %1 -> b) %1 -> b+unsafe_alloc (GHC.I# s) a f = let new = GHC.runRW# Prelude.$ \st -> case GHC.newArray# s a st of (# _, arr #) -> Array# arr in f new-{-# NOINLINE alloc #-} -- prevents runRW# from floating outwards+{-# NOINLINE unsafe_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
src/Data/Array/Polarized.hs view
@@ -55,14 +55,12 @@ -- 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+-- loop arr f = case Pull.uncons arr of+-- Nothing -> Pull.empty+-- Just (a, as) ->+-- if f a+-- then Pull.append (Pull.singleton a) (loop as f)+-- else loop as f -- @ -- --
src/Data/Array/Polarized/Pull.hs view
@@ -13,6 +13,7 @@ fromVector, make, singleton,+ empty, -- * Consumption toVector,@@ -27,7 +28,7 @@ findLength, split, reverse,- index,+ uncons, ) where @@ -45,7 +46,7 @@ import qualified Data.Functor.Linear as Data import Data.Vector (Vector) import qualified Data.Vector as Vector-import Prelude.Linear hiding (foldMap, foldr, reverse, zip, zipWith)+import Prelude.Linear hiding (foldMap, foldr, reverse, uncons, zip, zipWith) import qualified Unsafe.Linear as Unsafe -- | Convert a pull array into a list.
src/Data/Array/Polarized/Pull/Internal.hs view
@@ -37,6 +37,10 @@ -- is interesting in and of itself: I think this is like an n-ary With), and -- changing the other arrows makes no difference) +-- | Create an empty pull array+empty :: Array a+empty = fromFunction (\_ -> error "Data.Array.Polarized.Pull.Internal.empty: this should never be called") 0+ -- | 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)@@ -110,6 +114,7 @@ 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)+-- | Decompose an array into its head and tail, returns @Nothing@ if the array is empty.+uncons :: Array a %1 -> Maybe (a, Array a)+uncons (Array _ 0) = Nothing+uncons (Array f n) = Just (f 0, fromFunction (\x -> f (x + 1)) (n - 1))
src/Data/Functor/Linear/Internal/Functor.hs view
@@ -32,6 +32,7 @@ import Data.Functor.Product import Data.Functor.Sum import Data.Kind (FUN)+import Data.List.NonEmpty (NonEmpty) import Data.Unrestricted.Linear.Internal.Consumable import Data.Unrestricted.Linear.Internal.Ur import GHC.Types (Multiplicity (..))@@ -75,6 +76,11 @@ go :: [a] %1 -> [b] go [] = [] go (a : as) = f a : go as++deriving via+ Generically1 NonEmpty+ instance+ Functor NonEmpty deriving via Generically1 (Const x)
src/Data/Functor/Linear/Internal/Traversable.hs view
@@ -34,6 +34,7 @@ import Data.Functor.Const import qualified Data.Functor.Linear.Internal.Applicative as Data import qualified Data.Functor.Linear.Internal.Functor as Data+import Data.List.NonEmpty (NonEmpty (..)) import GHC.Types (Multiplicity (..)) import Generics.Linear import Prelude.Linear.Internal@@ -131,6 +132,12 @@ go [] = Control.pure [] go (x : xs) = Control.liftA2 (:) (f x) (go xs) +instance Traversable NonEmpty where+ -- We define traverse explicitly both to allow specialization+ -- to the appropriate Applicative and to allow specialization to+ -- the passed function. The generic definition allows neither, sadly.+ traverse f (x :| xs) = (:|) Control.<$> f x Control.<*> traverse f xs+ instance Traversable ((,) a) where traverse = genericTraverse @@ -239,7 +246,7 @@ {-# INLINE gtraverse #-} instance GTraversable V1 where- gtraverse _ v = Control.pure ((\case {}) v)+ gtraverse _ v = Control.pure (case v of {}) instance GTraversable UAddr where gtraverse _ (UAddr x) = Control.pure (UAddr x)
src/Data/HashMap/Mutable/Linear/Internal.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-}@@ -25,7 +27,9 @@ import Data.Hashable import qualified Data.Maybe as NonLinear import Data.Unrestricted.Linear+import GHC.TypeLits (ErrorMessage (..)) import Prelude.Linear hiding (filter, insert, lookup, mapMaybe, read, (+))+import Prelude.Linear.Unsatisfiable (Unsatisfiable, unsatisfiable) import Unsafe.Coerce (unsafeCoerce) import qualified Unsafe.Linear as Unsafe import Prelude ((+))@@ -133,10 +137,10 @@ -- | Run a computation with an empty 'HashMap' with given capacity. empty :: forall k v b.- (Keyed k) =>+ (Keyed k, Movable b) => Int ->- (HashMap k v %1 -> Ur b) %1 ->- Ur b+ (HashMap k v %1 -> b) %1 ->+ b empty size scope = let cap = max 1 size in Array.alloc cap Nothing (\arr -> scope (HashMap 0 cap arr))@@ -151,10 +155,10 @@ -- | Run a computation with an 'HashMap' containing given key-value pairs. fromList :: forall k v b.- (Keyed k) =>+ (Keyed k, Movable b) => [(k, v)] ->- (HashMap k v %1 -> Ur b) %1 ->- Ur b+ (HashMap k v %1 -> b) %1 ->+ b fromList xs scope = let cap = max@@ -295,7 +299,7 @@ then (Ur count, shiftSegmentBackward dec (end + 1) arr 0) else (Ur count, arr) | otherwise =- Array.unsafeRead arr ix & \case+ case Array.unsafeRead arr ix of (Ur Nothing, arr1) -> mapAndPushBack (ix + 1) end (False, 0) count arr1 (Ur (Just (RobinVal (PSL p) k v)), arr1) -> case f' k v of@@ -397,7 +401,7 @@ HashMap k c go _ hm (Ur []) acc = hm `lseq` acc go f hm (Ur ((k, b) : xs)) acc =- lookup k hm & \case+ case lookup k hm of (Ur Nothing, hm') -> go f hm' (Ur xs) acc (Ur (Just a), hm') -> go f hm' (Ur xs) (insert k (f a b) acc) @@ -446,7 +450,7 @@ -- | 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+ case lookup k hm of (Ur Nothing, hm') -> (Ur False, hm') (Ur (Just _), hm') -> (Ur True, hm') @@ -481,8 +485,8 @@ ) arr -instance Prelude.Semigroup (HashMap k v) where- (<>) = error "Prelude.<>: invariant violation, unrestricted HashMap"+instance (Unsatisfiable ('Text "Using Prelude's Semigroup methods on a Data.HashMap.Mutable.Linear is vacuous as there can't be an unrestricted such Hashmap")) => Prelude.Semigroup (HashMap k v) where+ (<>) = unsatisfiable instance (Keyed k) => Semigroup (HashMap k v) where (<>) = union@@ -557,7 +561,7 @@ Int -> RobinArr k v shiftSegmentBackward dec s arr ix =- Array.unsafeRead arr ix & \case+ case Array.unsafeRead arr ix of (Ur Nothing, arr') -> arr' (Ur (Just (RobinVal 0 _ _)), arr') -> arr' (Ur (Just val), arr') ->
src/Data/List/Linear.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -80,6 +80,7 @@ zip3, zipWith, zipWith',+ zipFold, zipWith3, unzip, unzip3,@@ -117,7 +118,7 @@ filter :: (Dupable a) => (a %1 -> Bool) -> [a] %1 -> [a] filter _ [] = [] filter p (x : xs) =- dup x & \case+ case dup x of (x', x'') -> if p x' then x'' : filter p xs@@ -149,10 +150,10 @@ span :: (Dupable a) => (a %1 -> Bool) -> [a] %1 -> ([a], [a]) span _ [] = ([], []) span f (x : xs) =- dup x & \case+ case dup x of (x', x'') -> if f x'- then span f xs & \case (ts, fs) -> (x'' : ts, fs)+ then case span f xs of (ts, fs) -> (x'' : ts, fs) else ([x''], xs) -- The partition function takes a predicate a list and returns the@@ -191,13 +192,13 @@ take :: (Consumable a) => Int -> [a] %1 -> [a] take _ [] = [] take i (x : xs)- | i Prelude.< 0 = (x, xs) `lseq` []+ | 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+ | i Prelude.<= 0 = x : xs | otherwise = x `lseq` drop (i - 1) xs -- | The intersperse function takes an element and a list and@@ -310,7 +311,7 @@ scanr :: (Dupable b) => (a %1 -> b %1 -> b) -> b %1 -> [a] %1 -> [b] scanr _ b [] = [b] scanr f b (a : as) =- scanr f b as & \case+ case scanr f b as of (b' : bs') -> dup2 b' & \(b'', b''') -> f a b'' : b''' : bs'@@ -322,7 +323,7 @@ scanr1 _ [] = [] scanr1 _ [a] = [a] scanr1 f (a : as) =- scanr1 f as & \case+ case scanr1 f as of (a' : as') -> dup2 a' & \(a'', a''') -> f a a'' : a''' : as'@@ -354,18 +355,53 @@ 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+zipWith f =+ zipFold (\a b cs -> f a b : cs) [] consume2 consume2+ where+ consume2 :: forall x y z. (Consumable x, Consumable y) => x %1 -> y %1 -> [z]+ consume2 x y = x `lseq` y `lseq` [] -- | Same as 'zipWith', but returns the leftovers instead of consuming them.+-- Because the leftovers are returned at toplevel, @zipWith'@ is pretty strict:+-- forcing the first cons cell of the returned list forces all the recursive+-- calls. zipWith' :: (a %1 -> b %1 -> c) -> [a] %1 -> [b] %1 -> ([c], Maybe (Either (NonEmpty a) (NonEmpty b)))-zipWith' _ [] [] = ([], Nothing)-zipWith' _ (a : as) [] = ([], Just (Left (a :| as)))-zipWith' _ [] (b : bs) = ([], Just (Right (b :| bs)))-zipWith' f (a : as) (b : bs) =- zipWith' f as bs & \case- (cs, rest) -> (f a b : cs, rest)+zipWith' f =+ zipFold+ (\a b !(cs, rest) -> ((f a b : cs), rest))+ ([], Nothing)+ (\a as -> ([], Just (Left (a :| as))))+ (\b bs -> ([], Just (Right (b :| bs))))++-- | A function which combines zipping and 'foldr'. It's more general than all+-- the zip-family functions ('zip', 'zip'', 'zipWith', 'zipWith'').+--+-- If @k < n@, then+--+-- * @'zipFold' cons nil lefta leftb [a₁, a₂, …, aₙ] [b₁, b₂, …, bₖ] = cons a₁ b₁ (cons a₂ b₂ (… (cons aₖ bₖ (lefta aₖ₊₁ [aₖ₊₂, …, aₙ]))))@+-- * @'zipFold' cons nil lefta leftb [a₁, a₂, …, aₖ] [b₁, b₂, …, bₙ] = cons a₁ b₁ (cons a₂ b₂ (… (cons aₖ bₖ (leftb bₖ₊₁ [bₖ₊₂, …, bₙ]))))@+-- * @'zipFold' cons nil lefta leftb [a₁, a₂, …, aₖ] [b₁, b₂, …, bₖ] = cons a₁ b₁ (cons a₂ b₂ (… (cons aₖ bₖ nil)))@+zipFold ::+ forall r a b.+ -- | Combines elements at the same index+ (a %1 -> b %1 -> r %1 -> r) ->+ -- | Starting value if both lists have the same length+ r ->+ -- | Starting value if the first list is longer+ (a %1 -> [a] %1 -> r) ->+ -- | Starting value if the second list is longer+ (b %1 -> [b] %1 -> r) ->+ [a] %1 ->+ [b] %1 ->+ r+zipFold cons nil lefta leftb =+ go+ where+ go :: [a] %1 -> [b] %1 -> r+ go [] [] = nil+ go (a : as) [] = lefta a as+ go [] (b : bs) = leftb b bs+ go (a : as) (b : bs) = cons a b (go as bs) 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` []
+ src/Data/List/NonEmpty/Linear.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- Linear versions of 'NonEmpty' functions.+--+-- This module only contains minimal amount of documentation; consult the+-- original "Data.List.NonEmpty" module for more detailed information.+module Data.List.NonEmpty.Linear+ ( -- * Non-empty stream transformations+ NonEmpty (..),+ map,+ intersperse,+ scanl,+ scanr,+ scanl1,+ scanr1,+ transpose,+ NonLinear.sortBy,+ NonLinear.sortWith,++ -- * Basic functions+ length,+ NonLinear.head,+ NonLinear.tail,+ NonLinear.last,+ NonLinear.init,+ singleton,+ (<|),+ cons,+ uncons,+ unfoldr,+ NonLinear.sort,+ reverse,+ append,+ appendList,+ prependList,++ -- * Extracting sublists+ take,+ drop,+ splitAt,+ takeWhile,+ dropWhile,+ span,+ break,+ filter,+ partition,++ -- * Zipping and unzipping streams+ zip,+ zipWith,+ zip',+ zipWith',+ unzip,+ unzip3,++ -- * Converting to and from a list+ fromList,+ toList,+ nonEmpty,+ xor,+ )+where++import qualified Data.List.Linear as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonLinear+import Data.Vector.Internal.Check (HasCallStack)+import Prelude.Linear hiding (drop, dropWhile, filter, intersperse, length, map, partition, reverse, scanl, scanl1, scanr, scanr1, span, splitAt, take, takeWhile, transpose, uncons, unfoldr, unzip, unzip3, zip, zip', zipWith, zipWith')+import qualified Unsafe.Linear as Unsafe+import qualified Prelude as Prelude++map :: (a %1 -> b) -> NonEmpty a %1 -> NonEmpty b+map f (x :| xs) = f x :| List.map f xs++intersperse :: a -> NonEmpty a %1 -> NonEmpty a+intersperse a = Unsafe.toLinear (NonLinear.intersperse a)++reverse :: NonEmpty a %1 -> NonEmpty a+reverse = Unsafe.toLinear NonLinear.reverse++scanl :: (Dupable b) => (b %1 -> a %1 -> b) -> b %1 -> NonEmpty a %1 -> NonEmpty b+scanl f z = fromList . List.scanl f z . toList++scanr :: (Dupable b) => (a %1 -> b %1 -> b) -> b %1 -> NonEmpty a %1 -> NonEmpty b+scanr f z = fromList . List.scanr f z . toList++scanl1 :: (Dupable a) => (a %1 -> a %1 -> a) -> NonEmpty a %1 -> NonEmpty a+scanl1 f (x :| xs) = fromList $ List.scanl f x xs++scanr1 :: (Dupable a) => (a %1 -> a %1 -> a) -> NonEmpty a %1 -> NonEmpty a+scanr1 f (x :| xs) = fromList $ List.scanr1 f (x : xs)++transpose :: NonEmpty (NonEmpty a) %1 -> NonEmpty (NonEmpty a)+transpose = Unsafe.toLinear NonLinear.transpose++singleton :: a %1 -> NonEmpty a+singleton = (:| [])++infixr 5 <|++(<|) :: a %1 -> NonEmpty a %1 -> NonEmpty a+a <| bs = a :| toList bs++cons :: a %1 -> NonEmpty a %1 -> NonEmpty a+cons = (<|)++uncons :: NonEmpty a %1 -> (a, Maybe (NonEmpty a))+uncons (x :| xs) = (x, nonEmpty xs)++unfoldr :: (a %1 -> (b, Maybe a)) -> a %1 -> NonEmpty b+unfoldr f a = case f a of+ (b, mc) -> b :| maybe [] go mc+ where+ go c = case f c of+ (d, me) -> d : maybe [] go me++append :: NonEmpty a %1 -> NonEmpty a %1 -> NonEmpty a+append = (<>)++appendList :: NonEmpty a %1 -> [a] %1 -> NonEmpty a+appendList (x :| xs) ys = x :| (xs <> ys)++prependList :: [a] %1 -> NonEmpty a %1 -> NonEmpty a+prependList ls ne = case ls of+ [] -> ne+ (y : ys) -> y :| (ys <> toList ne)++-- | __NOTE__: This does not short-circuit and always traverses the+-- entire list to consume the rest of the elements.+take :: (Consumable a) => Int -> NonEmpty a %1 -> [a]+take n = List.take n . toList++drop :: (Consumable a) => Int -> NonEmpty a %1 -> [a]+drop n = List.drop n . toList++splitAt :: (Consumable a) => Int -> NonEmpty a %1 -> ([a], [a])+splitAt n = List.splitAt n . toList++-- | __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) -> NonEmpty a %1 -> [a]+takeWhile p = List.takeWhile p . toList++dropWhile :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> [a]+dropWhile p = List.dropWhile p . toList++span :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> ([a], [a])+span p = List.span p . toList++break :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> ([a], [a])+break p = span (not . p)++filter :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> [a]+filter p = List.filter p . toList++partition :: (Dupable a) => (a %1 -> Bool) -> NonEmpty a %1 -> ([a], [a])+partition p = List.partition p . toList++-- | Return the length of the given list alongside with the list itself.+length :: NonEmpty a %1 -> (Ur Int, NonEmpty a)+length = Unsafe.toLinear $ \xs ->+ (Ur (NonLinear.length xs), xs)++fromList :: (HasCallStack) => [a] %1 -> (NonEmpty a)+fromList (x : xs) = x :| xs+fromList [] = Prelude.error "NonEmpty.Linear.fromList: empty list"++toList :: NonEmpty a %1 -> [a]+toList (x :| xs) = x : xs++nonEmpty :: [a] %1 -> Maybe (NonEmpty a)+nonEmpty (x : xs) = Just (x :| xs)+nonEmpty [] = Nothing++xor :: NonEmpty Bool %1 -> Bool+xor = Unsafe.toLinear NonLinear.xor++zip :: (Consumable a, Consumable b) => NonEmpty a %1 -> NonEmpty b %1 -> NonEmpty (a, b)+zip = zipWith (,)++zipWith :: (Consumable a, Consumable b) => (a %1 -> b %1 -> c) -> NonEmpty a %1 -> NonEmpty b %1 -> NonEmpty c+zipWith f (a :| as) (b :| bs) = f a b :| List.zipWith f as bs++-- | Same as 'zipWith', but returns the leftovers instead of consuming them.+-- Because the leftovers are returned at toplevel, @zipWith'@ is pretty strict:+-- forcing the second cons cell of the returned list forces all the recursive+-- calls.+zipWith' :: (a %1 -> b %1 -> c) -> NonEmpty a %1 -> NonEmpty b %1 -> (NonEmpty c, Maybe (Either (NonEmpty a) (NonEmpty b)))+zipWith' f (a :| as) (b :| bs) =+ case List.zipWith' f as bs of+ (cs, may) -> (f a b :| cs, may)++-- | Same as 'zip', but returns the leftovers instead of consuming them.+zip' :: NonEmpty a %1 -> NonEmpty b %1 -> (NonEmpty (a, b), Maybe (Either (NonEmpty a) (NonEmpty b)))+zip' = zipWith' (,)++unzip :: NonEmpty (a, b) %1 -> (NonEmpty a, NonEmpty b)+unzip ((a, b) :| asbs) =+ List.unzip asbs & \(as, bs) ->+ (a :| as, b :| bs)++unzip3 :: NonEmpty (a, b, c) %1 -> (NonEmpty a, NonEmpty b, NonEmpty c)+unzip3 ((a, b, c) :| abs) =+ List.unzip3 abs & \(as, bs, cs) ->+ (a :| as, b :| bs, c :| cs)
src/Data/Monoid/Linear/Internal/Semigroup.hs view
@@ -11,6 +11,7 @@ module Data.Monoid.Linear.Internal.Semigroup ( -- * Semigroup Semigroup (..),+ sconcat, -- * Endo Endo (..),@@ -34,6 +35,7 @@ import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) import qualified Data.Functor.Product as Functor+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Monoid as Monoid import Data.Ord (Down (..)) import Data.Proxy (Proxy (..))@@ -65,6 +67,13 @@ (<>) :: a %1 -> a %1 -> a infixr 6 <> -- same fixity as base.<> +sconcat :: (Semigroup a) => NonEmpty a %1 -> a+sconcat (x :| xs :: NonEmpty a) = go x xs+ where+ go :: a %1 -> [a] %1 -> a+ go acc [] = acc+ go acc (x' : xs') = go (acc <> x') xs'+ -- | 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)@@ -126,14 +135,14 @@ instance (Consumable a) => Semigroup (Monoid.First a) where (Monoid.First Nothing) <> y = y x <> (Monoid.First y) =- y & \case+ case y of Nothing -> x Just y' -> y' `lseq` x instance (Consumable a) => Semigroup (Monoid.Last a) where x <> (Monoid.Last Nothing) = x (Monoid.Last x) <> y =- x & \case+ case x of Nothing -> y Just x' -> x' `lseq` y @@ -174,7 +183,7 @@ instance (Consumable a, Consumable b) => Semigroup (Either a b) where Left x <> y = x `lseq` y x <> y =- y & \case+ case y of Left y' -> y' `lseq` x Right y' -> y' `lseq` x
src/Data/Num/Linear.hs view
@@ -42,8 +42,11 @@ -- TODO: flesh out laws +import qualified Data.Int import Data.Monoid.Linear import Data.Unrestricted.Linear+import qualified Data.Word+import GHC.Num.Natural (Natural) import qualified Unsafe.Linear as Unsafe import qualified Prelude @@ -208,38 +211,143 @@ instance (AddIdentity a) => Monoid (Sum a) where mempty = Sum zero +{- ORMOLU_DISABLE -} 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.Int instance MultIdentity Prelude.Int+deriving via MovableNum Prelude.Int instance Semiring Prelude.Int+deriving via MovableNum Prelude.Int instance Ring Prelude.Int+deriving via MovableNum Prelude.Int instance FromInteger Prelude.Int+deriving via MovableNum Prelude.Int instance Num Prelude.Int +deriving via MovableNum Prelude.Word instance Additive Prelude.Word+deriving via MovableNum Prelude.Word instance AddIdentity Prelude.Word+deriving via MovableNum Prelude.Word instance AdditiveGroup Prelude.Word+deriving via MovableNum Prelude.Word instance Multiplicative Prelude.Word+deriving via MovableNum Prelude.Word instance MultIdentity Prelude.Word+deriving via MovableNum Prelude.Word instance Semiring Prelude.Word+deriving via MovableNum Prelude.Word instance Ring Prelude.Word+deriving via MovableNum Prelude.Word instance FromInteger Prelude.Word+deriving via MovableNum Prelude.Word instance Num Prelude.Word++deriving via MovableNum Prelude.Double instance Additive Prelude.Double+deriving via MovableNum Prelude.Double instance AddIdentity Prelude.Double+deriving via MovableNum Prelude.Double instance AdditiveGroup Prelude.Double deriving via MovableNum Prelude.Double instance Multiplicative Prelude.Double+deriving via MovableNum Prelude.Double instance MultIdentity Prelude.Double+deriving via MovableNum Prelude.Double instance Semiring Prelude.Double+deriving via MovableNum Prelude.Double instance Ring Prelude.Double+deriving via MovableNum Prelude.Double instance FromInteger Prelude.Double+deriving via MovableNum Prelude.Double instance Num Prelude.Double -deriving via MovableNum Prelude.Int instance MultIdentity Prelude.Int+deriving via MovableNum Prelude.Float instance Additive Prelude.Float+deriving via MovableNum Prelude.Float instance AddIdentity Prelude.Float+deriving via MovableNum Prelude.Float instance AdditiveGroup Prelude.Float+deriving via MovableNum Prelude.Float instance Multiplicative Prelude.Float+deriving via MovableNum Prelude.Float instance MultIdentity Prelude.Float+deriving via MovableNum Prelude.Float instance Semiring Prelude.Float+deriving via MovableNum Prelude.Float instance Ring Prelude.Float+deriving via MovableNum Prelude.Float instance FromInteger Prelude.Float+deriving via MovableNum Prelude.Float instance Num Prelude.Float -deriving via MovableNum Prelude.Double instance MultIdentity Prelude.Double+deriving via MovableNum Prelude.Integer instance Additive Prelude.Integer+deriving via MovableNum Prelude.Integer instance AddIdentity Prelude.Integer+deriving via MovableNum Prelude.Integer instance AdditiveGroup Prelude.Integer+deriving via MovableNum Prelude.Integer instance Multiplicative Prelude.Integer+deriving via MovableNum Prelude.Integer instance MultIdentity Prelude.Integer+deriving via MovableNum Prelude.Integer instance Semiring Prelude.Integer+deriving via MovableNum Prelude.Integer instance Ring Prelude.Integer+deriving via MovableNum Prelude.Integer instance FromInteger Prelude.Integer+deriving via MovableNum Prelude.Integer instance Num Prelude.Integer -deriving via MovableNum Prelude.Int instance Semiring Prelude.Int+deriving via MovableNum Natural instance Additive Natural+deriving via MovableNum Natural instance AddIdentity Natural+deriving via MovableNum Natural instance AdditiveGroup Natural+deriving via MovableNum Natural instance Multiplicative Natural+deriving via MovableNum Natural instance MultIdentity Natural+deriving via MovableNum Natural instance Semiring Natural+-- NOTE: Natural is not a Ring; no element but 0 has an additive inverse.+deriving via MovableNum Natural instance FromInteger Natural -deriving via MovableNum Prelude.Double instance Semiring Prelude.Double+deriving via MovableNum Data.Int.Int8 instance Additive Data.Int.Int8+deriving via MovableNum Data.Int.Int8 instance AddIdentity Data.Int.Int8+deriving via MovableNum Data.Int.Int8 instance AdditiveGroup Data.Int.Int8+deriving via MovableNum Data.Int.Int8 instance Multiplicative Data.Int.Int8+deriving via MovableNum Data.Int.Int8 instance MultIdentity Data.Int.Int8+deriving via MovableNum Data.Int.Int8 instance Semiring Data.Int.Int8+deriving via MovableNum Data.Int.Int8 instance Ring Data.Int.Int8+deriving via MovableNum Data.Int.Int8 instance FromInteger Data.Int.Int8+deriving via MovableNum Data.Int.Int8 instance Num Data.Int.Int8 -deriving via MovableNum Prelude.Int instance Ring Prelude.Int+deriving via MovableNum Data.Int.Int16 instance Additive Data.Int.Int16+deriving via MovableNum Data.Int.Int16 instance AddIdentity Data.Int.Int16+deriving via MovableNum Data.Int.Int16 instance AdditiveGroup Data.Int.Int16+deriving via MovableNum Data.Int.Int16 instance Multiplicative Data.Int.Int16+deriving via MovableNum Data.Int.Int16 instance MultIdentity Data.Int.Int16+deriving via MovableNum Data.Int.Int16 instance Semiring Data.Int.Int16+deriving via MovableNum Data.Int.Int16 instance Ring Data.Int.Int16+deriving via MovableNum Data.Int.Int16 instance FromInteger Data.Int.Int16+deriving via MovableNum Data.Int.Int16 instance Num Data.Int.Int16 -deriving via MovableNum Prelude.Double instance Ring Prelude.Double+deriving via MovableNum Data.Int.Int32 instance Additive Data.Int.Int32+deriving via MovableNum Data.Int.Int32 instance AddIdentity Data.Int.Int32+deriving via MovableNum Data.Int.Int32 instance AdditiveGroup Data.Int.Int32+deriving via MovableNum Data.Int.Int32 instance Multiplicative Data.Int.Int32+deriving via MovableNum Data.Int.Int32 instance MultIdentity Data.Int.Int32+deriving via MovableNum Data.Int.Int32 instance Semiring Data.Int.Int32+deriving via MovableNum Data.Int.Int32 instance Ring Data.Int.Int32+deriving via MovableNum Data.Int.Int32 instance FromInteger Data.Int.Int32+deriving via MovableNum Data.Int.Int32 instance Num Data.Int.Int32 -deriving via MovableNum Prelude.Int instance FromInteger Prelude.Int+deriving via MovableNum Data.Int.Int64 instance Additive Data.Int.Int64+deriving via MovableNum Data.Int.Int64 instance AddIdentity Data.Int.Int64+deriving via MovableNum Data.Int.Int64 instance AdditiveGroup Data.Int.Int64+deriving via MovableNum Data.Int.Int64 instance Multiplicative Data.Int.Int64+deriving via MovableNum Data.Int.Int64 instance MultIdentity Data.Int.Int64+deriving via MovableNum Data.Int.Int64 instance Semiring Data.Int.Int64+deriving via MovableNum Data.Int.Int64 instance Ring Data.Int.Int64+deriving via MovableNum Data.Int.Int64 instance FromInteger Data.Int.Int64+deriving via MovableNum Data.Int.Int64 instance Num Data.Int.Int64 -deriving via MovableNum Prelude.Double instance FromInteger Prelude.Double+deriving via MovableNum Data.Word.Word8 instance Additive Data.Word.Word8+deriving via MovableNum Data.Word.Word8 instance AddIdentity Data.Word.Word8+deriving via MovableNum Data.Word.Word8 instance AdditiveGroup Data.Word.Word8+deriving via MovableNum Data.Word.Word8 instance Multiplicative Data.Word.Word8+deriving via MovableNum Data.Word.Word8 instance MultIdentity Data.Word.Word8+deriving via MovableNum Data.Word.Word8 instance Semiring Data.Word.Word8+deriving via MovableNum Data.Word.Word8 instance Ring Data.Word.Word8+deriving via MovableNum Data.Word.Word8 instance FromInteger Data.Word.Word8+deriving via MovableNum Data.Word.Word8 instance Num Data.Word.Word8 -deriving via MovableNum Prelude.Int instance Num Prelude.Int+deriving via MovableNum Data.Word.Word16 instance Additive Data.Word.Word16+deriving via MovableNum Data.Word.Word16 instance AddIdentity Data.Word.Word16+deriving via MovableNum Data.Word.Word16 instance AdditiveGroup Data.Word.Word16+deriving via MovableNum Data.Word.Word16 instance Multiplicative Data.Word.Word16+deriving via MovableNum Data.Word.Word16 instance MultIdentity Data.Word.Word16+deriving via MovableNum Data.Word.Word16 instance Semiring Data.Word.Word16+deriving via MovableNum Data.Word.Word16 instance Ring Data.Word.Word16+deriving via MovableNum Data.Word.Word16 instance FromInteger Data.Word.Word16+deriving via MovableNum Data.Word.Word16 instance Num Data.Word.Word16 -deriving via MovableNum Prelude.Double instance Num Prelude.Double+deriving via MovableNum Data.Word.Word32 instance Additive Data.Word.Word32+deriving via MovableNum Data.Word.Word32 instance AddIdentity Data.Word.Word32+deriving via MovableNum Data.Word.Word32 instance AdditiveGroup Data.Word.Word32+deriving via MovableNum Data.Word.Word32 instance Multiplicative Data.Word.Word32+deriving via MovableNum Data.Word.Word32 instance MultIdentity Data.Word.Word32+deriving via MovableNum Data.Word.Word32 instance Semiring Data.Word.Word32+deriving via MovableNum Data.Word.Word32 instance Ring Data.Word.Word32+deriving via MovableNum Data.Word.Word32 instance FromInteger Data.Word.Word32+deriving via MovableNum Data.Word.Word32 instance Num Data.Word.Word32++deriving via MovableNum Data.Word.Word64 instance Additive Data.Word.Word64+deriving via MovableNum Data.Word.Word64 instance AddIdentity Data.Word.Word64+deriving via MovableNum Data.Word.Word64 instance AdditiveGroup Data.Word.Word64+deriving via MovableNum Data.Word.Word64 instance Multiplicative Data.Word.Word64+deriving via MovableNum Data.Word.Word64 instance MultIdentity Data.Word.Word64+deriving via MovableNum Data.Word.Word64 instance Semiring Data.Word.Word64+deriving via MovableNum Data.Word.Word64 instance Ring Data.Word.Word64+deriving via MovableNum Data.Word.Word64 instance FromInteger Data.Word.Word64+deriving via MovableNum Data.Word.Word64 instance Num Data.Word.Word64+{- ORMOLU_ENABLE -}
src/Data/Ord/Linear/Internal/Eq.hs view
@@ -13,6 +13,7 @@ import Data.Bool.Linear import Data.Int (Int16, Int32, Int64, Int8)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Unrestricted.Linear import Data.Word (Word16, Word32, Word64, Word8) import Prelude.Linear.Internal@@ -46,6 +47,9 @@ [] == [] = True (x : xs) == (y : ys) = x == y && xs == ys xs == ys = (xs, ys) `lseq` False++instance (Consumable a, Eq a) => Eq (NonEmpty a) where+ (x :| xs) == (y :| ys) = x == y && xs == ys instance (Consumable a, Eq a) => Eq (Prelude.Maybe a) where Prelude.Nothing == Prelude.Nothing = True
src/Data/Ord/Linear/Internal/Ord.hs view
@@ -15,6 +15,7 @@ import Data.Bool.Linear (Bool (..), not) import Data.Int (Int16, Int32, Int64, Int8)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid.Linear import Data.Ord (Ordering (..)) import Data.Ord.Linear.Internal.Eq@@ -115,9 +116,13 @@ compare xs [] = xs `lseq` GT compare [] ys = ys `lseq` LT compare (x : xs) (y : ys) =- compare x y & \case+ case compare x y of EQ -> compare xs ys res -> (xs, ys) `lseq` res++instance (Consumable a, Ord a) => Ord (NonEmpty a) where+ compare (x :| xs) (y :| ys) =+ compare x y <> compare xs ys instance (Ord a, Ord b) => Ord (a, b) where (a, b) `compare` (a', b') =
src/Data/Replicator/Linear/Internal.hs view
@@ -89,7 +89,7 @@ next :: Replicator a %1 -> (a, Replicator a) next (Moved x) = (x, Moved x) next (Streamed (ReplicationStream s give dups consumes)) =- dups s & \case+ case dups s of (s1, s2) -> (give s1, Streamed (ReplicationStream s2 give dups consumes)) {-# INLINEABLE next #-} @@ -98,18 +98,18 @@ next# :: Replicator a %1 -> (# a, Replicator a #) next# (Moved x) = (# x, Moved x #) next# (Streamed (ReplicationStream s give dups consumes)) =- dups s & \case+ case dups s of (s1, s2) -> (# give s1, Streamed (ReplicationStream s2 give dups consumes) #) {-# INLINEABLE next# #-} -- | @'take' n as@ is a list of size @n@, containing @n@ replicas from @as@. take :: Prelude.Int -> Replicator a %1 -> [a] take 0 r =- consume r & \case+ case consume r of () -> [] take 1 r = [extract r] take n r =- next r & \case+ case next r of (a, r') -> a : take (n - 1) r' -- | Returns the next item from @'Replicator' a@ and efficiently consumes@@ -170,7 +170,7 @@ instance Elim 'Z a b where elim' b r =- consume r & \case+ case consume r of () -> b {-# INLINE elim' #-} @@ -180,6 +180,6 @@ instance (Elim ('S n) a b) => Elim ('S ('S n)) a b where elim' g r =- next r & \case+ case next r of (a, r') -> elim' @('S n) (g a) r' {-# INLINE elim' #-}
src/Data/Replicator/Linear/Internal/ReplicationStream.hs view
@@ -70,11 +70,11 @@ (sf, sx) (\(sf', sx') -> givef sf' (givex sx')) ( \(sf', sx') ->- (dupsf sf', dupsx sx') & \case+ case (dupsf sf', dupsx sx') of ((sf1, sf2), (sx1, sx2)) -> ((sf1, sx1), (sf2, sx2)) ) ( \(sf', sx') ->- consumesf sf' & \case+ case consumesf sf' of () -> consumesx sx' ) @@ -84,11 +84,11 @@ (sa, sb) (\(sa', sb') -> f (givea sa') (giveb sb')) ( \(sa', sb') ->- (dupsa sa', dupsb sb') & \case+ case (dupsa sa', dupsb sb') of ((sa1, sa2), (sb1, sb2)) -> ((sa1, sb1), (sa2, sb2)) ) ( \(sa', sb') ->- consumesa sa' & \case+ case consumesa sa' of () -> consumesb sb' ) -- We need to inline this to get good results with generic deriving
src/Data/Set/Mutable/Linear/Internal.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_HADDOCK hide #-}@@ -14,7 +17,9 @@ import qualified Data.HashMap.Mutable.Linear as Linear import Data.Monoid.Linear import Data.Unrestricted.Linear+import GHC.TypeLits (ErrorMessage (..)) import qualified Prelude.Linear as Linear hiding (insert)+import Prelude.Linear.Unsatisfiable (Unsatisfiable, unsatisfiable) import Prelude (Bool, Int) import qualified Prelude @@ -29,8 +34,8 @@ -- # Constructors and Mutators ------------------------------------------------------------------------------- -empty :: (Keyed a) => Int -> (Set a %1 -> Ur b) %1 -> Ur b-empty s (f :: Set a %1 -> Ur b) =+empty :: (Keyed a, Movable b) => Int -> (Set a %1 -> b) %1 -> b+empty s (f :: Set a %1 -> b) = Linear.empty s (\hm -> f (Set hm)) toList :: (Keyed a) => Set a %1 -> Ur [a]@@ -63,15 +68,18 @@ 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 :: (Keyed a, Movable b) => [a] -> (Set a %1 -> b) %1 -> 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+ (Unsatisfiable ('Text "Using Prelude's Semigroup methods on a Data.Set.Mutable.Linear is vacuous as there can't be an unrestricted such Set")) =>+ Prelude.Semigroup (Set a)+ where+ (<>) = unsatisfiable instance (Keyed a) => Semigroup (Set a) where (<>) = union
src/Data/Unrestricted/Linear.hs view
@@ -4,7 +4,7 @@ -- = /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+-- be used in a linear way. Its use is __restricted__. By contrast, -- an argument in a non-linear function is __unrestricted__. -- -- Hence, a linear function with an argument of @Ur a@ (@Ur@ is short for
src/Data/Unrestricted/Linear/Internal/Instances.hs view
@@ -21,10 +21,13 @@ -- other classes (for cleanness) in this module to avoid this dependence. module Data.Unrestricted.Linear.Internal.Instances where +import Data.ByteString (ByteString)+import Data.ByteString.Short (ShortByteString) import qualified Data.Functor.Linear.Internal.Applicative as Data import qualified Data.Functor.Linear.Internal.Functor as Data import Data.Monoid.Linear import Data.Replicator.Linear.Internal.Instances ()+import qualified Data.Text import Data.Unrestricted.Linear.Internal.Consumable import Data.Unrestricted.Linear.Internal.Dupable import Data.Unrestricted.Linear.Internal.Movable@@ -33,6 +36,8 @@ import qualified Data.V.Linear.Internal as V import qualified Data.Vector as Vector import GHC.Int+import GHC.Num.Integer (Integer (..))+import GHC.Num.Natural (Natural (..)) import GHC.TypeLits import GHC.Word import Prelude.Linear.Internal@@ -45,17 +50,17 @@ instance (Movable a) => Movable (AsMovable a) where move (AsMovable x) =- move x & \case+ case move x of Ur x' -> Ur (AsMovable x') instance (Movable a) => Consumable (AsMovable a) where consume x =- move x & \case+ case move x of Ur _ -> () instance (Movable a) => Dupable (AsMovable a) where dupR x =- move x & \case+ case move x of Ur x' -> Data.pure x' deriving via (AsMovable Int8) instance Consumable Int8@@ -146,6 +151,33 @@ -- copying an 'Word64#' and using it several times. /!\ move (W64# i) = Unsafe.toLinear (\j -> Ur (W64# j)) i +deriving via (AsMovable Integer) instance Consumable Integer++deriving via (AsMovable Integer) instance Dupable Integer++instance Movable Integer where+ -- /!\ 'Integer' is a sum type whose three possibilities each are strict wrappers of unboxed unlifed data types.+ -- (source: https://hackage.haskell.org/package/ghc-bignum-1.2/docs/GHC-Num-Integer.html#t:Integer)+ -- 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 'Integer' and using it several times. /!\+ move (IS i) = Unsafe.toLinear (\j -> Ur (IS j)) i+ move (IP i) = Unsafe.toLinear (\j -> Ur (IP j)) i+ move (IN i) = Unsafe.toLinear (\j -> Ur (IN j)) i++deriving via (AsMovable Natural) instance Consumable Natural++deriving via (AsMovable Natural) instance Dupable Natural++instance Movable Natural where+ -- /!\ 'Natural' is a sum type whose two possibilities each are strict wrappers of unboxed unlifed data types.+ -- (source: https://hackage.haskell.org/package/ghc-bignum-1.2/docs/GHC-Num-Natural.html#t:Natural)+ -- 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 'Integer' and using it several times. /!\+ move (NS i) = Unsafe.toLinear (\j -> Ur (NS j)) i+ move (NB i) = Unsafe.toLinear (\j -> Ur (NB j)) i+ -- TODO: instances for longer primitive tuples -- TODO: default instances based on the Generic framework @@ -157,8 +189,30 @@ instance (KnownNat n, Dupable a) => Dupable (V n a) where dupR (V xs) =- V . Unsafe.toLinear (Vector.fromListN (V.theLength @n))+ V+ . Unsafe.toLinear (Vector.fromListN (V.theLength @n)) Data.<$> dupR (Unsafe.toLinear Vector.toList xs)++instance Movable ByteString where+ move = Unsafe.toLinear $ \s -> s `seq` Ur s++deriving via (AsMovable ByteString) instance Consumable ByteString++deriving via (AsMovable ByteString) instance Dupable ByteString++instance Movable ShortByteString where+ move = Unsafe.toLinear $ \s -> s `seq` Ur s++deriving via (AsMovable ShortByteString) instance Consumable ShortByteString++deriving via (AsMovable ShortByteString) instance Dupable ShortByteString++instance Movable Data.Text.Text where+ move = Unsafe.toLinear $ \s -> s `seq` Ur s++deriving via (AsMovable Data.Text.Text) instance Consumable Data.Text.Text++deriving via (AsMovable Data.Text.Text) instance Dupable Data.Text.Text -- Some stock instances
src/Data/Unrestricted/Linear/Internal/Movable.hs view
@@ -172,15 +172,15 @@ gmove U1 = Ur U1 instance (GMovable f, GMovable g) => GMovable (f :+: g) where- gmove (L1 a) = gmove a & \case (Ur x) -> Ur (L1 x)- gmove (R1 a) = gmove a & \case (Ur x) -> Ur (R1 x)+ gmove (L1 a) = case gmove a of Ur x -> Ur (L1 x)+ gmove (R1 a) = case gmove a of Ur x -> Ur (R1 x) instance (GMovable f, GMovable g) => GMovable (f :*: g) where gmove (a :*: b) =- gmove a & \case- (Ur x) ->- gmove b & \case- (Ur y) -> Ur (x :*: y)+ case gmove a of+ Ur x ->+ case gmove b of+ Ur y -> Ur (x :*: y) instance (Movable c) => GMovable (K1 i c) where gmove (K1 c) = lcoerce (move c)@@ -192,7 +192,7 @@ gmove (MP1 x) = Ur (MP1 x) instance (GMovable f) => GMovable (MP1 'One f) where- gmove (MP1 a) = gmove a & \case Ur x -> Ur (MP1 x)+ gmove (MP1 a) = case gmove a of Ur x -> Ur (MP1 x) instance GMovable UChar where gmove (UChar c) = Unsafe.toLinear (\x -> Ur (UChar x)) c
src/Data/V/Linear/Internal.hs view
@@ -78,8 +78,8 @@ (<*>) :: V n (a %1 -> b) %1 -> V n a %1 -> V n b (V fs) <*> (V xs) =- V $- Unsafe.toLinear2 (Vector.zipWith (\f x -> f $ x)) fs xs+ V+ $ Unsafe.toLinear2 (Vector.zipWith (\f x -> f $ x)) fs xs infixl 4 <*> -- same fixity as base.<*> @@ -145,13 +145,13 @@ instance Elim 'Z a b where elim' b v =- consume v & \case+ case consume v of () -> b {-# INLINE elim' #-} instance (1 <= 1 + PeanoToNat n, (1 + PeanoToNat n) - 1 ~ PeanoToNat n, Elim n a b) => Elim ('S n) a b where elim' g v =- uncons v & \case+ case uncons v of (a, v') -> elim' @n (g a) v' {-# INLINE elim' #-}
src/Data/Vector/Mutable/Linear/Internal.hs view
@@ -56,17 +56,17 @@ & \(Ur size', arr') -> Vec size' arr' -- Allocate an empty vector-empty :: (Vector a %1 -> Ur b) %1 -> Ur b+empty :: (Movable b) => (Vector a %1 -> b) %1 -> 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) =>+ (HasCallStack, Movable b) => Int -> a ->- (Vector a %1 -> Ur b) %1 ->- Ur b+ (Vector a %1 -> b) %1 ->+ b constant size' x f | size' < 0 = (error ("Trying to construct a vector of size " ++ show size') :: x %1 -> x)@@ -74,7 +74,7 @@ | otherwise = Array.alloc size' x (f . fromArray) -- | Allocator from a list-fromList :: (HasCallStack) => [a] -> (Vector a %1 -> Ur b) %1 -> Ur b+fromList :: (HasCallStack, Movable b) => [a] -> (Vector a %1 -> b) %1 -> b fromList xs f = Array.fromList xs (f . fromArray) -- | Number of elements inside the vector.@@ -101,7 +101,7 @@ -- 'shrinkToFit' to remove the wasted space. pop :: Vector a %1 -> (Ur (Maybe a), Vector a) pop vec =- size vec & \case+ case size vec of (Ur 0, vec') -> (Ur Nothing, vec') (Ur s, vec') ->@@ -201,7 +201,7 @@ -- 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+ case unsafeGet r vec' of (Ur a, vec'') | Just b <- f a -> go (r + 1) (w + 1) s (unsafeSet w (Unsafe.coerce b) vec'')
src/Foreign/Marshal/Pure/Internal.hs view
@@ -29,10 +29,10 @@ import Foreign.Ptr import Foreign.Storable import Foreign.Storable.Tuple ()-import Prelude.Linear hiding (Eq (..), ($))+import Prelude.Linear hiding (Eq (..)) import System.IO.Unsafe import qualified Unsafe.Linear as Unsafe-import Prelude (Eq (..), return, ($), (<$>), (<*>), (=<<))+import Prelude (Eq (..), return, (<$>), (<*>), (=<<)) -- XXX: [2018-02-09] I'm having trouble with the `constraints` package (it seems -- that the version of Type.Reflection.Unsafe in the linear ghc compiler is not@@ -290,12 +290,12 @@ -- 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+withPool :: forall b. (Movable b) => (Pool %1 -> b) %1 -> b+withPool scope = unur $ Unsafe.toLinear performScope scope where -- XXX: do ^ without `toLinear` by using linear IO - performScope :: (Pool %1 -> Ur b) -> Ur b+ performScope :: (Pool %1 -> b) -> Ur b performScope scope' = unsafeDupablePerformIO $ do -- Initialise the pool backPtr <- malloc@@ -303,7 +303,7 @@ start <- DLL nullPtr nullPtr <$> new end -- always at the start of the list poke backPtr start -- Run the computation- evaluate (scope' (Pool start))+ evaluate (move $ scope' (Pool start)) `finally` -- Clean up remaining variables. (freeAll start end)
src/Streaming/Linear.hs view
@@ -65,7 +65,7 @@ import Data.Functor.Sum import Data.Unrestricted.Linear import GHC.Stack-import Prelude.Linear (($), (&), (.))+import Prelude.Linear (($), (.)) import Streaming.Linear.Internal.Process (destroyExposed) import Streaming.Linear.Internal.Type import qualified Streaming.Prelude.Linear as Stream@@ -244,7 +244,7 @@ Stream f m r unfold' step state = Effect $ Control.do either <- step state- either & \case+ case either of Left r -> Control.return $ Return r Right (fs) -> Control.return $ Step $ Control.fmap (unfold step) fs {-# INLINEABLE unfold #-}@@ -261,7 +261,7 @@ loop :: Stream f m r loop = Effect $ Control.do maybeVal <- action- maybeVal & \case+ case maybeVal of Nothing -> Control.return $ Step $ Data.pure loop Just r -> Control.return $ Return r {-# INLINEABLE untilJust #-}@@ -344,7 +344,7 @@ where loop :: Stream f m r %1 -> Stream g m r loop stream =- stream & \case+ case stream of Return r -> Return r Step f -> Effect $ Control.fmap Step $ transform $ Control.fmap loop f Effect m -> Effect $ Control.fmap loop m@@ -461,10 +461,10 @@ 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+ case e of Left r -> Control.return r Right ostr ->- ostr & \case+ case ostr of InR gstr -> Step $ InR $ Control.fmap loop $ cleanR (Step (InR gstr)) InL fstr -> Step $ InL $ Control.fmap loop $ cleanL (Step (InL fstr)) @@ -474,7 +474,7 @@ 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+ case e of Left r -> Control.return $ Control.return r Right (InL fstr) -> Step $ Control.fmap go fstr Right (InR gstr) -> Control.return $ Step (InR gstr)@@ -485,7 +485,7 @@ 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+ case e of Left r -> Control.return $ Control.return r Right (InL fstr) -> Control.return $ Step (InL fstr) Right (InR gstr) -> Step $ Control.fmap go gstr@@ -509,7 +509,7 @@ where loop :: Stream f m r %1 -> m (Either r (f (Stream f m r))) loop stream =- stream & \case+ case stream of Return r -> Control.return (Left r) Effect m -> m Control.>>= loop Step fs -> Control.return (Right fs)@@ -552,7 +552,7 @@ LT -> Prelude.error "splitsAt called with negative index" $ stream EQ -> Return stream GT ->- stream & \case+ case stream of Return r -> Return $ Return r Effect m -> Effect $ Control.fmap (loop n) m Step f -> Step $ Control.fmap (loop (n - 1)) f@@ -587,7 +587,7 @@ where loop :: Stream (Stream f m) m r %1 -> Stream f m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step f -> Control.do@@ -612,7 +612,7 @@ where go0 :: Stream (t m) m r %1 -> t m r go0 f =- f & \case+ case f of Return r -> Control.return r Effect m -> Control.lift m Control.>>= go0 Step fstr -> Control.do@@ -621,7 +621,7 @@ go1 :: Stream (t m) m r %1 -> t m r go1 f =- f & \case+ case f of Return r -> Control.return r Effect m -> Control.lift m Control.>>= go1 Step fstr -> Control.do@@ -736,7 +736,7 @@ where loop :: Stream (Compose m f) m r %1 -> Stream f m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step (Compose mfs) -> Effect $ Control.do@@ -814,7 +814,7 @@ where loop :: (Control.Monad m) => Stream m m r %1 -> m r loop stream =- stream & \case+ case stream of Return r -> Control.return r Effect m -> m Control.>>= loop Step mrest -> mrest Control.>>= loop@@ -915,7 +915,7 @@ where loop :: Stream f m r %1 -> m b loop stream =- stream & \case+ case stream of Return r -> Control.return $ done r Effect m -> m Control.>>= loop Step f -> Control.return $ construct $ Control.fmap (theEffect . loop) f
src/Streaming/Linear/Internal/Consume.hs view
@@ -62,13 +62,14 @@ where import qualified Control.Functor.Linear as Control+import Control.Monad.IO.Class.Linear (liftSystemIO) import qualified Data.Bool.Linear as Linear import Data.Functor.Identity import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Unrestricted.Linear-import Prelude.Linear (($), (&), (.))+import Prelude.Linear (($), (.)) import Streaming.Linear.Internal.Process import Streaming.Linear.Internal.Type import qualified System.IO as System@@ -112,11 +113,11 @@ where loop :: Stream (Of Text) IO r %1 -> IO r loop stream =- stream & \case+ case stream of Return r -> Control.return r Effect ms -> ms Control.>>= stdoutLn' Step (str :> stream) -> Control.do- fromSystemIO $ Text.putStrLn str+ liftSystemIO $ Text.putStrLn str stdoutLn' stream {-# INLINEABLE stdoutLn' #-} @@ -130,7 +131,7 @@ where loop :: Handle %1 -> Stream (Of Text) RIO r %1 -> RIO (r, Handle) loop handle stream =- stream & \case+ case stream of Return r -> Control.return (r, handle) Effect ms -> ms Control.>>= toHandle handle Step (text :> stream') -> Control.do@@ -170,7 +171,7 @@ where loop :: Stream (Of a) m r %1 -> m r loop stream =- stream & \case+ case stream of Return r -> Control.return r Effect ms -> ms Control.>>= effects Step (_ :> stream') -> effects stream'@@ -182,7 +183,7 @@ where loop :: Stream (Of a) m r %1 -> Stream Identity m r loop stream =- stream & \case+ case stream of Return r -> Return r Step (_ :> stream') -> Step $ Identity (erase stream') Effect ms -> Effect $ ms Control.>>= (Control.return . erase)@@ -242,7 +243,7 @@ where loop :: Stream (Of a) m r %1 -> m r loop stream =- stream & \case+ case stream of Return r -> Control.return r Effect ms -> ms Control.>>= mapM_ f Step (a :> stream') -> Control.do@@ -302,7 +303,7 @@ where loop :: Stream (Of a) m r %1 -> m (Of b r) loop stream =- stream & \case+ case stream of 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'@@ -335,7 +336,7 @@ where loop :: Stream (Of a) m r %1 -> m b loop stream =- stream & \case+ case stream of 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'@@ -370,7 +371,7 @@ where loop :: Stream (Of a) m r %1 -> m (b, r) loop stream =- stream & \case+ case stream of 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'@@ -391,7 +392,7 @@ where loop :: Stream (Of a) m r %1 -> m b loop stream =- stream & \case+ case stream of 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'@@ -464,7 +465,7 @@ -- 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+ case str of Return r -> Control.return (Nothing :> r) Effect m -> m Control.>>= head Step (a :> rest) ->@@ -475,7 +476,7 @@ -- 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+ case str of Return r -> lseq r $ Control.return Nothing Effect m -> m Control.>>= head_ Step (a :> rest) ->@@ -491,7 +492,7 @@ Stream (Of a) m r %1 -> m (Of (Maybe a) r) loop m s =- s & \case+ case s of Return r -> Control.return (m :> r) Effect m -> m Control.>>= last Step (a :> rest) -> loop (Just a) rest@@ -506,7 +507,7 @@ Stream (Of a) m r %1 -> m (Maybe a) loop m s =- s & \case+ case s of Return r -> lseq r $ Control.return m Effect m -> m Control.>>= last_ Step (a :> rest) -> loop (Just a) rest@@ -522,7 +523,7 @@ where loop :: Stream (Of a) m r %1 -> m (Of Bool r) loop stream =- stream & \case+ case stream of Return r -> Control.return $ False :> r Effect ms -> ms Control.>>= elem a Step (a' :> stream') -> case a == a' of@@ -542,7 +543,7 @@ where loop :: Stream (Of a) m r %1 -> m Bool loop stream =- stream & \case+ case stream of Return r -> lseq r $ Control.return False Effect ms -> ms Control.>>= elem_ a Step (a' :> stream') -> case a == a' of@@ -681,7 +682,7 @@ where loop :: Stream (Of a) m r %1 -> m r loop stream =- stream & \case+ case stream of Return r -> Control.return r Effect m -> m Control.>>= foldrM step Step (a :> as) -> step a (foldrM step as)@@ -702,7 +703,7 @@ where loop :: Stream (Of a) m r %1 -> t m r loop stream =- stream & \case+ case stream of Return r -> Control.return r Effect ms -> (Control.lift ms) Control.>>= foldrT step Step (a :> as) -> step a (foldrT step as)
src/Streaming/Linear/Internal/Many.hs view
@@ -36,7 +36,7 @@ where import qualified Control.Functor.Linear as Control-import Prelude.Linear (($), (&))+import Prelude.Linear (($)) import Streaming.Linear.Internal.Consume import Streaming.Linear.Internal.Type import Prelude (Either (..), Ord (..), Ordering (..))@@ -115,7 +115,7 @@ Stream (Of (a, b)) m r %1 -> Stream (Of a) (Stream (Of b) m) r loop stream =- stream & \case+ case stream of 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))))@@ -169,14 +169,14 @@ Stream (Of b) m r2 %1 -> Stream (Of c) m (ZipResidual a b m r1 r2) loop f st1 st2 =- st1 & \case+ case st1 of Effect ms -> Effect $ Control.fmap (\s -> loop f s st2) ms Return r1 ->- st2 & \case+ case st2 of Return r2 -> Return $ Left3 (r1, r2) st2' -> Return $ Middle3 (r1, st2') Step (a :> as) ->- st2 & \case+ case st2 of Effect ms -> Effect $ Control.fmap (\s -> loop f (Step (a :> as)) s) ms Return r2 -> Return $ Right3 (Step (a :> as), r2)@@ -191,7 +191,7 @@ Stream (Of c) m (r1, r2) zipWith f s1 s2 = Control.do result <- zipWithR f s1 s2- result & \case+ case result of Left3 rets -> Control.return rets Middle3 (r1, s2') -> Control.do r2 <- Control.lift $ effects s2'@@ -251,20 +251,20 @@ 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+ case s1 of Effect ms -> Effect $ Control.fmap (\s -> loop f s s2 s3) ms Return r1 ->- (s2, s3) & \case+ case (s2, s3) of (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+ case s2 of 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+ case s3 of Effect ms -> Effect $ Control.fmap (\s -> loop f (Step $ a :> as) (Step $ b :> bs) s) ms@@ -283,7 +283,7 @@ Stream (Of d) m (r1, r2, r3) zipWith3 f s1 s2 s3 = Control.do result <- zipWith3R f s1 s2 s3- result & \case+ case result of (res1, res2, res3) -> Control.do r1 <- Control.lift $ extractResult res1 r2 <- Control.lift $ extractResult res2@@ -377,14 +377,14 @@ 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+ case s1 of 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+ case s2 of Return s -> Effect $ effects as Control.>>= \r -> Control.return $ Return (r, s) Effect ms ->
src/Streaming/Linear/Internal/Process.hs view
@@ -96,7 +96,7 @@ import qualified Data.Set as Set import Data.Unrestricted.Linear import GHC.Stack-import Prelude.Linear (($), (&), (.))+import Prelude.Linear (($), (.)) import Streaming.Linear.Internal.Type import System.IO.Linear import Text.Read (readMaybe)@@ -128,7 +128,7 @@ Stream (Stream (Of a) m) m r %1 -> Stream (Stream (Of a) m) m r consFirstChunk a stream =- stream & \case+ case stream of Return r -> Step (Step (a :> Return (Return r))) Effect m -> Effect $ Control.fmap (consFirstChunk a) m Step f -> Step (Step (a :> f))@@ -151,7 +151,7 @@ Stream f m r %1 -> b loop stream =- stream & \case+ case stream of Return r -> done r Effect m -> theEffect (Control.fmap loop m) Step f -> construct (Control.fmap loop f)@@ -180,7 +180,7 @@ where loop :: Stream (Of a) m r %1 -> m (Either r (Ur a, Stream (Of a) m r)) loop stream =- stream & \case+ case stream of Return r -> Control.return $ Left r Effect ms -> ms Control.>>= next Step (a :> as) -> Control.return $ Right (Ur a, as)@@ -196,7 +196,7 @@ where loop :: Stream (Of a) m r %1 -> m (Maybe (a, Stream (Of a) m r)) loop stream =- stream & \case+ case stream of Return r -> lseq r $ Control.return Nothing Effect ms -> ms Control.>>= uncons Step (a :> as) -> Control.return $ Just (a, as)@@ -219,7 +219,7 @@ 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+ case stream of Return r -> Return (Return r) Effect m -> Effect $ m Control.>>= (Control.return . splitAt n) Step f -> Step $ Control.fmap (splitAt (n - 1)) f@@ -244,7 +244,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Stream (Of a) m) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ m Control.>>= (Control.return . split x) Step (a :> as) -> case a == x of@@ -273,7 +273,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of a) m (Stream (Of a) m r) loop stream =- stream & \case+ case stream of Return r -> Return (Return r) Effect m -> Effect $ Control.fmap (break f) m Step (a :> as) -> case f a of@@ -303,7 +303,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Stream (Of a) m) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (breaks f) m Step (a :> as) -> case f a of@@ -347,7 +347,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of a) m (Stream (Of a) m r) loop stream =- stream & \case+ case stream of 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@@ -395,11 +395,11 @@ where loop :: Stream (Of a) m r %1 -> Stream (Stream (Of a) m) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (groupBy equals) m Step (a :> as) ->- as & \case+ case as of Return r -> Step (Step (a :> Return (Return r))) Effect m -> Effect $@@ -523,7 +523,7 @@ where fromSum :: Sum f g (Stream f (Stream g m) r) %1 -> (Stream f (Stream g m) r) fromSum x =- x & \case+ case x of InL fss -> Step fss InR gss -> Effect (Step $ Control.fmap Return gss) {-# INLINEABLE separate #-}@@ -551,7 +551,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of a) (Stream (Of a) m) r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect (Control.fmap loop (Control.lift m)) Step (a :> as) -> case pred a of@@ -576,7 +576,7 @@ Stream (Of (Either a b)) m r %1 -> Stream (Of a) (Stream (Of b) m) r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop (Control.lift m) Step (Left a :> as) -> Step (a :> loop as)@@ -593,7 +593,7 @@ where loop :: (Control.Monad m) => Stream (Of (Maybe a)) m r %1 -> Stream (Of a) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap catMaybes m Step (maybe :> as) -> case maybe of@@ -614,7 +614,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of b) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect ms -> Effect $ ms Control.>>= (Control.return . mapMaybe f) Step (a :> s) -> case f a of@@ -639,12 +639,12 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of b) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (mapMaybeM f) m Step (a :> as) -> Effect $ Control.do mb <- f a- mb & \case+ case mb of Nothing -> Control.return $ mapMaybeM f as Just (Ur b) -> Control.return $ Step (b :> mapMaybeM f as) {-# INLINEABLE mapMaybeM #-}@@ -668,7 +668,7 @@ where loop :: Stream f m r %1 -> Stream f n r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ f $ Control.fmap loop m Step f -> Step $ Control.fmap loop f@@ -706,7 +706,7 @@ where loop :: Stream f m r %1 -> Stream g m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (maps phi) m Step f -> Step (phi (Control.fmap loop f))@@ -745,7 +745,7 @@ Stream (Of a) m r %1 -> Stream (Of b) m r loop f stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (loop f) m Step (a :> as) -> Effect $ Control.do@@ -773,7 +773,7 @@ where loop :: Stream f m r %1 -> Stream g m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step f -> Step $ Control.fmap loop $ phi f@@ -825,7 +825,7 @@ where loop :: Stream f m r %1 -> Stream g m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step f -> Effect $ Control.fmap Step $ phi $ Control.fmap loop f@@ -854,7 +854,7 @@ where loop :: Stream f m r %1 -> Stream g m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step f -> Effect $ Control.fmap (Step . Control.fmap loop) $ phi f@@ -873,7 +873,7 @@ where loop :: Stream f m r %1 -> Stream g m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step f -> Effect $ Control.fmap (Step . Control.fmap loop) $ phi f@@ -891,7 +891,7 @@ where loop :: Stream (Of a) m r %1 -> Stream f m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step (a :> as) -> Control.do@@ -929,7 +929,7 @@ where loop :: Stream (Of a) m r %1 -> Stream f m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step (a :> as) -> Step $ Control.fmap (`lseq` (loop as)) (f a)@@ -1060,7 +1060,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of a) (Stream (Of a) m) r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop (Control.lift m) Step (a :> as) -> Effect $ Step (a :> Return (Step (a :> loop as)))@@ -1193,7 +1193,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of a) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step (a :> as) -> Effect $ Control.do@@ -1221,7 +1221,7 @@ where loop :: Stream (Of (m (Ur a))) m r %1 -> Stream (Of a) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step (ma :> mas) -> Effect $ Control.do@@ -1246,7 +1246,7 @@ where loop :: Set.Set b -> Stream (Of a) m r %1 -> Stream (Of a) m r loop !set stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (loop set) m Step (a :> as) -> case Set.member (f a) set of@@ -1268,7 +1268,7 @@ where loop :: IntSet.IntSet -> Stream (Of a) m r %1 -> Stream (Of a) m r loop !set stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (loop set) m Step (a :> as) -> case IntSet.member (f a) set of@@ -1286,7 +1286,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of a) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step (a :> as) -> case pred a of@@ -1305,12 +1305,12 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of a) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step (a :> as) -> Effect $ Control.do bool <- pred a- bool & \case+ case bool of True -> Control.return $ Step (a :> loop as) False -> Control.return $ loop as {-# INLINE filterM #-}@@ -1332,7 +1332,7 @@ Stream (Of a) m r %1 -> Stream (Of a) m r intersperse x stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (intersperse x) m Step (a :> as) -> loop a as@@ -1341,7 +1341,7 @@ -- element named 'x' loop :: a -> Stream (Of a) m r %1 -> Stream (Of a) m r loop !a stream =- stream & \case+ case stream of Return r -> Step (a :> Return r) Effect m -> Effect $ Control.fmap (loop a) m Step (a' :> as) -> Step (a :> Step (x :> loop a' as))@@ -1379,7 +1379,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of a) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (drop n) m Step (_ :> as) -> drop (n - 1) as@@ -1407,7 +1407,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of a) m r loop stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap loop m Step (a :> as) -> case pred a of@@ -1448,7 +1448,7 @@ where loop :: x -> Stream (Of a) m r %1 -> Stream (Of b) m r loop !acc stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (loop acc) m Step (a :> as) -> Step (done acc' :> loop acc' as)@@ -1486,7 +1486,7 @@ where loop :: Stream (Of a) m r %1 -> Stream (Of b) m r loop stream =- stream & \case+ case stream of Return r -> Effect $ Control.do Ur x <- mx Ur b <- done x@@ -1525,7 +1525,7 @@ where loop :: x -> Stream (Of a) m r %1 -> Stream (Of (a, b)) m r loop !x stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.fmap (loop x) m Step (a :> as) -> Control.do@@ -1562,7 +1562,7 @@ loop :: Stream (Of a) IO r %1 -> Stream (Of a) IO r loop stream = Control.do e <- Control.lift $ next stream- e & \case+ case e of Left r -> Return r Right (Ur a, rest) -> Control.do Step (a :> Return ()) -- same as yield@@ -1605,7 +1605,7 @@ Stream f m r %1 -> Stream f m r wrapEffect ma action stream =- stream & \case+ case stream of Return r -> Return r Effect m -> Effect $ Control.do a <- ma@@ -1640,7 +1640,7 @@ 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+ case e of Left r -> Control.return r Right (Ur a, rest) -> Control.do Step $ (sequ Seq.|> a) :> Return () -- same as yield@@ -1653,7 +1653,7 @@ window (Seq.drop 1 sequ) str setup n' sequ str = Control.do e <- Control.lift $ next str- e & \case+ case e of Left r -> Control.do Step (sequ :> Return ()) -- same as yield Control.return r
src/Streaming/Linear/Internal/Produce.hs view
@@ -45,11 +45,12 @@ where import qualified Control.Functor.Linear as Control+import Control.Monad.IO.Class.Linear (liftSystemIOU) import Data.Text (Text) import qualified Data.Text as Text import Data.Unrestricted.Linear import GHC.Stack-import Prelude.Linear (($), (&))+import Prelude.Linear (($)) import Streaming.Linear.Internal.Consume (effects) import Streaming.Linear.Internal.Process import Streaming.Linear.Internal.Type@@ -206,7 +207,7 @@ loop :: m (Stream (Of a) m r) loop = Control.do either <- mEither- either & \case+ case either of Left (Ur a) -> Control.return $ Step $ a :> (untilRight mEither) Right r -> Control.return $ Return r@@ -249,7 +250,7 @@ | n <= 0 = Effect $ Control.fmap Control.return $ end s | otherwise = Effect $ Control.do next <- step s- next & \case+ case next of Right r -> Control.return (Return r) Left fx -> Control.return $@@ -270,11 +271,11 @@ 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+ case next of Right r -> Control.return (Return r) Left (a :> next) -> Control.do testResult <- test a- testResult & \case+ case testResult of False -> Control.return $ Step $@@ -294,7 +295,7 @@ 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+ case next of Right r -> Control.return (Return r) Left (a :> next) -> case test a of True -> Control.fmap Control.return $ end next@@ -318,7 +319,7 @@ AffineStream (Of a) m r2 %1 -> Stream (Of (x, a)) m (r1, r2) loop stream (AffineStream s step end) =- stream & \case+ case stream of Return r1 -> Effect $ Control.fmap (\r2 -> Control.return $ (r1, r2)) $@@ -328,7 +329,7 @@ Control.fmap (\str -> loop str (AffineStream s step end)) m Step (x :> rest) -> Effect $ Control.do next <- step s- next & \case+ case next of Right r2 -> Control.do r1 <- effects rest Control.return (Return (r1, r2))@@ -344,7 +345,7 @@ where getALine :: () %1 -> IO (Either (Of Text ()) ()) getALine () = Control.do- Ur line <- fromSystemIOU System.getLine+ Ur line <- liftSystemIOU System.getLine Control.return $ Left (Text.pack line :> ()) -- | An affine stream of reading lines, crashing on failed parse.@@ -353,7 +354,7 @@ where readALine :: (Read a) => () %1 -> IO (Either (Of a ()) ()) readALine () = Control.do- Ur line <- fromSystemIOU System.getLine+ Ur line <- liftSystemIOU System.getLine Control.return $ Left (Prelude.read line :> ()) -- | An affine stream iterating an initial state forever.@@ -410,7 +411,7 @@ (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+ case str of Return r -> lseq r $ stepStream (Ur s, s) Effect m -> m Control.>>= (\stream -> stepStream (Ur s, stream))
src/System/IO/Resource/Linear.hs view
@@ -32,6 +32,11 @@ RIO, run, + -- * Interfacing with IO+ fromIO,+ fromSystemIO,+ fromSystemIOU,+ -- * Using Resource Handles -- $monad -- $files
src/System/IO/Resource/Linear/Internal.hs view
@@ -88,10 +88,24 @@ 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)+-- | Coerces a linear IO action into a 'RIO' action.+fromIO :: Linear.IO a %1 -> RIO a+fromIO action = RIO (\_ -> action) +-- | Coerces a standard IO action into a 'RIO' action.+-- Note that the value @a@ must be used linearly in the 'RIO' monad.+fromSystemIO :: System.IO a %1 -> RIO a+fromSystemIO action =+ -- Should not be applied to a function that acquires or releases resources.+ fromIO (Linear.fromSystemIO action)++-- | Coerces a standard IO action into a 'RIO' action, allowing you to use+-- the result of type @a@ in a non-linear manner by wrapping it inside+-- 'Ur'.+fromSystemIOU :: System.IO a -> RIO (Ur a)+fromSystemIOU action =+ fromIO (Linear.fromSystemIOU action)+ -- monad instance Control.Functor RIO where@@ -235,7 +249,7 @@ (a -> System.IO b) -> (Resource a %1 -> RIO (Ur b, Resource a)) unsafeFromSystemIOResource action (UnsafeResource key resource) =- unsafeFromSystemIO+ fromSystemIO ( do c <- action resource Prelude.return (Ur c, UnsafeResource key resource)
+ test-examples/Main.hs view
@@ -0,0 +1,16 @@+module Main where++import Test.Foreign (foreignGCTests)+import Test.Simple.Quicksort (quicksortTests)+import Test.Tasty++main :: IO ()+main = defaultMain allTests++allTests :: TestTree+allTests =+ testGroup+ "All tests"+ [ foreignGCTests,+ quicksortTests+ ]
+ test-examples/Test/Foreign.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Test.Foreign (foreignGCTests) where++import Control.Exception hiding (assert)+import Control.Monad (void)+import Data.Typeable+import qualified Foreign.Heap as Heap+import Foreign.List (List)+import qualified Foreign.List as List+import qualified Foreign.Marshal.Pure as Manual+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude.Linear+import Test.Tasty+import Test.Tasty.Hedgehog (testPropertyNamed)+import qualified Prelude++-- # Organizing tests+-------------------------------------------------------------------------------++foreignGCTests :: TestTree+foreignGCTests =+ testGroup+ "foreignGCTests"+ [ listExampleTests,+ heapExampleTests+ ]++listExampleTests :: TestTree+listExampleTests =+ testGroup+ "list tests"+ [ testPropertyNamed "List.toList . List.fromList = id" "invertNonGCList" invertNonGCList,+ testPropertyNamed "map id = id" "mapIdNonGCList" mapIdNonGCList,+ testPropertyNamed "memory freed post-exception" "testExceptionOnMem" testExceptionOnMem+ ]++heapExampleTests :: TestTree+heapExampleTests =+ testGroup+ "heap tests"+ [testPropertyNamed "sort = heapsort" "nonGCHeapSort" 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 $ do+ xs <- forAll list+ let xs' =+ unur $+ Manual.withPool (\p -> move $ List.toList $ List.ofList xs p)+ xs === xs'++mapIdNonGCList :: Property+mapIdNonGCList = property $ do+ xs <- forAll list+ let boolTest = unur $+ Manual.withPool $ \p ->+ dup3 p & \(p0, p1, p2) ->+ eqList (List.ofList xs p0) (List.map id (List.ofList xs p1) p2)+ assert boolTest++testExceptionOnMem :: Property+testExceptionOnMem = property $ 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 $ do+ xs <- forAll list+ let ys :: [(Int, ())] = zip xs $ Prelude.replicate (Prelude.length xs) ()+ (Heap.sort ys) === (reverse $ sort ys)
+ test-examples/Test/Simple/Quicksort.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Simple.Quicksort (quicksortTests) where++import Data.List (sort)+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Simple.Quicksort (quicksortUsingArray, quicksortUsingList)+import Test.Tasty+import Test.Tasty.Hedgehog (testPropertyNamed)++quicksortTests :: TestTree+quicksortTests =+ testGroup+ "quicksort tests"+ [ testPropertyNamed "sort xs === quicksortUsingArray xs" "testQuicksortUsingArray" testQuicksortUsingArray,+ testPropertyNamed "sort xs === quicksortUsingList xs" "testQuicksortUsingList" testQuicksortUsingList+ ]++testQuicksortUsingArray :: Property+testQuicksortUsingArray = property $ do+ xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int $ Range.linear 0 100)+ sort xs === quicksortUsingArray xs++testQuicksortUsingList :: Property+testQuicksortUsingList = property $ do+ xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int $ Range.linear 0 100)+ sort xs === quicksortUsingList xs
test/Main.hs view
@@ -4,6 +4,8 @@ module Main where import Test.Data.Destination (destArrayTests)+import Test.Data.Functor.Linear (genericTests)+import Test.Data.List (listTests) import Test.Data.Mutable.Array (mutArrTests) import Test.Data.Mutable.HashMap (mutHMTests) import Test.Data.Mutable.Set (mutSetTests)@@ -27,7 +29,9 @@ mutHMTests, mutSetTests, destArrayTests,- polarizedArrayTests+ polarizedArrayTests,+ listTests,+ genericTests ], testGroup "Inspection tests"
+ test/Test/Data/Functor/Linear.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Test.Data.Functor.Linear (genericTests) where++import Data.Functor.Linear (genericTraverse)+import qualified Data.Functor.Linear as Data+import Generics.Linear.TH+import Hedgehog+import Prelude.Linear+import Test.Tasty+import Test.Tasty.Hedgehog (testPropertyNamed)+import qualified Prelude++data Pair a = MkPair a a+ deriving (Show, Prelude.Eq)++$(deriveGeneric1 ''Pair)++instance Data.Functor Pair where+ fmap f (MkPair x y) = MkPair (f x) (f y)++instance Data.Traversable Pair where+ traverse = genericTraverse++genericTests :: TestTree+genericTests =+ testGroup+ "Generic tests"+ [ genericTraverseTests+ ]++genericTraverseTests :: TestTree+genericTraverseTests =+ testGroup+ "genericTraverse examples"+ [pairTest]++pairTest :: TestTree+pairTest =+ testPropertyNamed "traverse via genericTraverse with WithLog and Pair" "propertyPairTest" propertyPairTest++propertyPairTest :: Property+propertyPairTest =+ property $+ ( Data.traverse+ (\x -> (Sum (1 :: Int), 2 * x))+ (MkPair 3 4 :: Pair Int)+ )+ === (Sum 2, (MkPair 6 8))
+ test/Test/Data/List.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-x-partial #-}++module Test.Data.List (listTests) where++import qualified Data.List.Linear as List+import qualified Data.Num.Linear as Num+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude.Linear+import Test.Tasty+import Test.Tasty.Hedgehog (testPropertyNamed)+import qualified Prelude++listTests :: TestTree+listTests =+ testGroup+ "List tests"+ [ testPropertyNamed "take n ++ drop n = id" "take_drop" take_drop,+ testPropertyNamed "length . take n = const n" "take_length" take_length,+ testPropertyNamed "zipWith is lazy" "zipWith_lazy" zipWith_lazy,+ testPropertyNamed "zipWith3 is lazy" "zipWith3_lazy" zipWith3_lazy+ ]++take_drop :: Property+take_drop = property $ do+ n <- forAll $ Gen.int (Range.linear 0 50)+ classify "0" $ n == 0+ xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 40))+ classify "length > n" $ Prelude.length xs > n+ List.take n xs ++ List.drop n xs === xs++take_length :: Property+take_length = property $ do+ n <- forAll $ Gen.int (Range.linear 0 50)+ classify "0" $ n == 0+ xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 40))+ classify "length > n" $ Prelude.length xs > n+ case Prelude.length xs > n of+ True -> do+ annotate "Prelude.length xs > n"+ Prelude.length (List.take n xs) === n+ False -> do+ annotate "Prelude.length xs < n"+ Prelude.length (List.take n xs) === Prelude.length xs++zipWith_lazy :: Property+zipWith_lazy = property $ do+ lgth <- forAll $ Gen.word (Range.linear 0 50)+ _ <- eval $ Prelude.head (xs lgth)+ Prelude.return ()+ where+ xs :: Word -> [Word]+ xs lgth = List.zipWith (Num.+) (0 : error "bottom") [0 .. lgth]++zipWith3_lazy :: Property+zipWith3_lazy = property $ do+ lgth1 <- forAll $ Gen.word (Range.linear 0 50)+ lgth2 <- forAll $ Gen.word (Range.linear 0 50)+ _ <- eval $ Prelude.head (xs lgth1 lgth2)+ Prelude.return ()+ where+ xs :: Word -> Word -> [Word]+ xs lgth1 lgth2 = List.zipWith3 (\x y z -> x Num.+ y Num.+ z) (0 : error "bottom") [0 .. lgth1] [0 .. lgth2]
test/Test/Data/Mutable/Vector.hs view
@@ -354,7 +354,7 @@ where popAll :: [a] -> Vector.Vector a %1 -> Ur [a] popAll acc vec =- Vector.pop vec Linear.& \case+ case Vector.pop vec of (Ur Nothing, vec') -> vec' `lseq` Ur acc (Ur (Just x), vec') -> popAll (x : acc) vec'
test/Test/Data/Polarized.hs view
@@ -6,6 +6,7 @@ import qualified Data.Array.Polarized as Polar import qualified Data.Array.Polarized.Pull as Pull import qualified Data.Array.Polarized.Push as Push+import Data.Functor.Linear (fmap) import qualified Data.Vector as Vector import Hedgehog import qualified Hedgehog.Gen as Gen@@ -34,10 +35,12 @@ testPropertyNamed "Push.make ~ Vec.replicate" "pushMake" pushMake, testPropertyNamed "Pull.append ~ Vec.append" "pullAppend" pullAppend, testPropertyNamed "Pull.asList . Pull.fromVector ~ id" "pullAsList" pullAsList,+ testPropertyNamed "Pull.empty = []" "pullEmpty" pullEmpty, testPropertyNamed "Pull.singleton x = [x]" "pullSingleton" pullSingleton, testPropertyNamed "Pull.splitAt ~ splitAt" "pullSplitAt" pullSplitAt, testPropertyNamed "Pull.make ~ Vec.replicate" "pullMake" pullMake,- testPropertyNamed "Pull.zip ~ zip" "pullZip" pullZip+ testPropertyNamed "Pull.zip ~ zip" "pullZip" pullZip,+ testPropertyNamed "Pull.uncons ~ uncons" "pullUncons" pullUncons ] list :: Gen [Int]@@ -88,6 +91,10 @@ xs <- forAll list xs === Pull.asList (Pull.fromVector (Vector.fromList xs)) +pullEmpty :: Property+pullEmpty = property Prelude.$ do+ ([] :: [Int]) === Pull.asList Pull.empty+ pullSingleton :: Property pullSingleton = property Prelude.$ do x <- forAll randInt@@ -115,3 +122,8 @@ let xs' = Pull.fromVector (Vector.fromList xs) let ys' = Pull.fromVector (Vector.fromList ys) zip xs ys === Pull.asList (Pull.zip xs' ys')++pullUncons :: Property+pullUncons = property Prelude.$ do+ xs <- forAll list+ uncons xs === fmap (fmap Pull.asList) (Pull.uncons (Pull.fromVector (Vector.fromList xs)))
test/Test/Data/Replicator.hs view
@@ -23,9 +23,9 @@ manualElim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> Replicator a %1 -> [a] manualElim3 f r =- Replicator.next r & \case+ case Replicator.next r of (x, r') ->- Replicator.next r' & \case+ case Replicator.next r' of (y, r'') ->- Replicator.extract r'' & \case+ case Replicator.extract r'' of z -> f x y z
test/Test/Data/V.hs view
@@ -32,11 +32,11 @@ manualElim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> V 3 a %1 -> [a] manualElim3 f v =- V.uncons v & \case+ case V.uncons v of (x, v') ->- V.uncons v' & \case+ case V.uncons v' of (y, v'') ->- V.uncons v'' & \case+ case V.uncons v'' of (z, v''') ->- V.consume v''' & \case+ case V.consume v''' of () -> f x y z