├── Setup.hs ├── stack.yaml ├── .dir-locals.el ├── cabal.project ├── src ├── Data │ ├── Ord │ │ ├── Linear.hs │ │ └── Linear │ │ │ └── Internal │ │ │ ├── Eq.hs │ │ │ └── Ord.hs │ ├── Monoid │ │ ├── Linear.hs │ │ └── Linear │ │ │ └── Internal │ │ │ └── Monoid.hs │ ├── Arity │ │ ├── Linear.hs │ │ └── Linear │ │ │ └── Internal.hs │ ├── Tuple │ │ └── Linear.hs │ ├── Set │ │ └── Mutable │ │ │ ├── Linear.hs │ │ │ └── Linear │ │ │ └── Internal.hs │ ├── HashMap │ │ └── Mutable │ │ │ └── Linear.hs │ ├── Replicator │ │ ├── Linear │ │ │ └── Internal │ │ │ │ ├── Instances.hs │ │ │ │ └── ReplicationStream.hs │ │ └── Linear.hs │ ├── Bool │ │ └── Linear.hs │ ├── Bifunctor │ │ ├── Linear.hs │ │ └── Linear │ │ │ └── Internal │ │ │ ├── Bifunctor.hs │ │ │ └── SymmetricMonoidal.hs │ ├── Maybe │ │ └── Linear.hs │ ├── Array │ │ ├── Mutable │ │ │ └── Linear.hs │ │ ├── Polarized │ │ │ ├── Pull.hs │ │ │ ├── Pull │ │ │ │ └── Internal.hs │ │ │ └── Push.hs │ │ ├── Destination │ │ │ └── Internal.hs │ │ └── Destination.hs │ ├── V │ │ ├── Linear │ │ │ └── Internal │ │ │ │ └── Instances.hs │ │ └── Linear.hs │ ├── Functor │ │ └── Linear.hs │ ├── Vector │ │ └── Mutable │ │ │ └── Linear.hs │ ├── Unrestricted │ │ ├── Linear │ │ │ └── Internal │ │ │ │ ├── UrT.hs │ │ │ │ └── Ur.hs │ │ └── Linear.hs │ ├── Either │ │ └── Linear.hs │ └── Profunctor │ │ └── Kleisli │ │ └── Linear.hs ├── Control │ ├── Functor │ │ ├── Linear │ │ │ └── Internal │ │ │ │ ├── MonadTrans.hs │ │ │ │ ├── Instances.hs │ │ │ │ ├── Kan.hs │ │ │ │ ├── State.hs │ │ │ │ └── Reader.hs │ │ └── Linear.hs │ ├── Monad │ │ └── IO │ │ │ └── Class │ │ │ └── Linear.hs │ └── Optics │ │ └── Linear │ │ ├── Iso.hs │ │ ├── Lens.hs │ │ ├── Prism.hs │ │ └── Traversal.hs ├── Prelude │ ├── Linear │ │ ├── Generically.hs │ │ ├── Unsatisfiable.hs │ │ ├── Internal.hs │ │ └── GenericUtil.hs │ └── Linear.hs ├── Streaming │ ├── Linear │ │ └── Internal │ │ │ └── Interop.hs │ └── Prelude │ │ └── Linear.hs ├── System │ └── IO │ │ └── Resource │ │ └── Linear.hs ├── Foreign │ └── Marshal │ │ └── Pure.hs └── Debug │ └── Trace │ └── Linear.hs ├── .gitignore ├── test-examples ├── Main.hs └── Test │ ├── Simple │ └── Quicksort.hs │ └── Foreign.hs ├── examples ├── README.md ├── Simple │ ├── Quicksort.hs │ ├── TopSort.hs │ └── FileIO.hs └── Foreign │ └── List.hs ├── bench ├── Main.hs └── Data │ └── Mutable │ └── Quicksort.hs ├── format.sh ├── nix ├── shell-stack.nix ├── cabal-docspec.nix └── sources.json ├── src-version-changes ├── ghc94 │ ├── after │ │ └── Prelude │ │ │ └── Linear │ │ │ └── Internal │ │ │ ├── Generically.hs │ │ │ └── TypeEq.hs │ └── before │ │ └── Prelude │ │ └── Linear │ │ └── Internal │ │ ├── TypeEq.hs │ │ └── Generically.hs └── ghc96 │ ├── before │ └── Data │ │ └── Tuple │ │ └── Linear │ │ └── Compat.hs │ └── after │ └── Data │ └── Tuple │ └── Linear │ └── Compat.hs ├── stack.yaml.lock ├── test ├── Test │ └── Data │ │ ├── Replicator.hs │ │ ├── V.hs │ │ ├── Functor │ │ └── Linear.hs │ │ ├── Destination.hs │ │ ├── List.hs │ │ └── Polarized.hs └── Main.hs ├── .github ├── settings.yml └── workflows │ └── ci.yaml ├── LICENSE ├── shell.nix ├── .hlint.yaml ├── CONTRIBUTING.md ├── docs ├── DESIGN.md └── USER_GUIDE.md └── README.md /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.34 2 | packages: 3 | - '.' 4 | extra-deps: 5 | -------------------------------------------------------------------------------- /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((nil . ((dante-repl-command-line . ("stack" "ghci" "--ghci-options" "-fdiagnostics-color=never"))))) 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: *.cabal 2 | 3 | tests: True 4 | benchmarks: True 5 | allow-newer: all 6 | index-state: 2024-09-13T13:31:57Z 7 | -------------------------------------------------------------------------------- /src/Data/Ord/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Data.Ord.Linear 4 | ( module Data.Ord.Linear.Internal.Ord, 5 | module Data.Ord.Linear.Internal.Eq, 6 | ) 7 | where 8 | 9 | import Data.Ord.Linear.Internal.Eq 10 | import Data.Ord.Linear.Internal.Ord 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | #vim 2 | *.swp 3 | 4 | # Haskell 5 | dist 6 | dist-* 7 | cabal-dev 8 | *.o 9 | *.hi 10 | *.chi 11 | *.chs.h 12 | *.dyn_o 13 | *.dyn_hi 14 | .hpc 15 | .hsenv 16 | .cabal-sandbox/ 17 | cabal.sandbox.config 18 | *.prof 19 | *.aux 20 | *.hp 21 | *.eventlog 22 | .stack-work/ 23 | cabal.project.local 24 | .HTF/ 25 | -------------------------------------------------------------------------------- /test-examples/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Foreign (foreignGCTests) 4 | import Test.Simple.Quicksort (quicksortTests) 5 | import Test.Tasty 6 | 7 | main :: IO () 8 | main = defaultMain allTests 9 | 10 | allTests :: TestTree 11 | allTests = 12 | testGroup 13 | "All tests" 14 | [ foreignGCTests, 15 | quicksortTests 16 | ] 17 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | # Examples 2 | 3 | * `Simple` 4 | * These are tutorial level examples for understanding linear 5 | types and using bread-and-butter tools in linear base. 6 | * Recommended order: `Pure`, `FileIO`. 7 | * `Foreign` 8 | * These are examples of explicitly allocating off the GC heap's 9 | memory and on the system heap's memory 10 | 11 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Mutable.Array as Array 4 | import qualified Data.Mutable.HashMap as HashMap 5 | import qualified Data.Mutable.Quicksort as Quicksort 6 | import Test.Tasty.Bench (defaultMain) 7 | 8 | main :: IO () 9 | main = do 10 | defaultMain 11 | [ Array.benchmarks, 12 | HashMap.benchmarks, 13 | Quicksort.benchmarks 14 | ] 15 | -------------------------------------------------------------------------------- /src/Data/Monoid/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | -- | This module provides linear versions of 'Monoid' and related classes. 4 | module Data.Monoid.Linear 5 | ( module Data.Monoid.Linear.Internal.Monoid, 6 | module Data.Monoid.Linear.Internal.Semigroup, 7 | ) 8 | where 9 | 10 | import Data.Monoid.Linear.Internal.Monoid 11 | import Data.Monoid.Linear.Internal.Semigroup 12 | -------------------------------------------------------------------------------- /src/Data/Arity/Linear.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- This module provides type-level helpers and classes to deal with n-ary 3 | -- functions. 4 | -- 5 | -- See 'Data.V.Linear.make', 'Data.V.Linear.elim' and 6 | -- 'Data.Replicator.Linear.elim' for use-cases. 7 | module Data.Arity.Linear 8 | ( Peano (..), 9 | NatToPeano, 10 | PeanoToNat, 11 | FunN, 12 | Arity, 13 | IsFunN, 14 | ) 15 | where 16 | 17 | import Data.Arity.Linear.Internal 18 | -------------------------------------------------------------------------------- /format.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # Format linear-base using the version of Ormolu specified in stack.yaml. 3 | 4 | set -e 5 | 6 | export LANG="C.UTF-8" 7 | 8 | stack build ormolu 9 | ## We can't format cabal at the moment because `cabal format` inlines 10 | ## common stanzas, which is very much something that we don't want. See 11 | ## https://github.com/haskell/cabal/issues/5734 12 | # 13 | # cabal format 14 | stack exec ormolu -- -m inplace $(find . -type f -name "*.hs-boot" -o -name "*.hs") 15 | -------------------------------------------------------------------------------- /nix/shell-stack.nix: -------------------------------------------------------------------------------- 1 | # Provide Nix support to Stack by expressing system packages required, rather than manually having to install stuff like Zlib 2 | # Inspired by https://docs.haskellstack.org/en/stable/nix_integration/#using-a-custom-shellnix-file 3 | { ghc, system ? builtins.currentSystem, sources ? import ./sources.nix, pkgs ? import sources.nixpkgs { inherit system; } }: 4 | 5 | pkgs.haskell.lib.buildStackProject { 6 | inherit ghc; 7 | name = "linear-base"; 8 | buildInputs = [ ]; 9 | } 10 | -------------------------------------------------------------------------------- /src-version-changes/ghc94/after/Prelude/Linear/Internal/Generically.hs: -------------------------------------------------------------------------------- 1 | -- | Prior to GHC 9.4, linear-base defined its own versions of `Generically` and 2 | -- `Generically1`. As a temporary workaround to enable compilation on both 3 | -- GHC 9.4 and 9.2, this module simply re-exports Generics.Linear, while the 4 | -- 9.2 version exposes linear-base's own implementations. 5 | module Prelude.Linear.Internal.Generically 6 | ( module Generics.Linear, 7 | ) 8 | where 9 | 10 | import Generics.Linear 11 | -------------------------------------------------------------------------------- /src/Control/Functor/Linear/Internal/MonadTrans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# OPTIONS_HADDOCK hide #-} 6 | 7 | module Control.Functor.Linear.Internal.MonadTrans 8 | ( MonadTrans (..), 9 | ) 10 | where 11 | 12 | import Control.Functor.Linear.Internal.Class 13 | 14 | class (forall m. (Monad m) => Monad (t m)) => MonadTrans t where 15 | lift :: (Monad m) => m a %1 -> t m a 16 | -------------------------------------------------------------------------------- /src/Prelude/Linear/Generically.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Prelude.Linear.Generically 5 | ( unGenerically, 6 | unGenerically1, 7 | module Prelude.Linear.Internal.Generically, 8 | ) 9 | where 10 | 11 | import Prelude.Linear.Internal.Generically 12 | 13 | unGenerically :: Generically a %1 -> a 14 | unGenerically (Generically a) = a 15 | 16 | unGenerically1 :: Generically1 f a %1 -> f a 17 | unGenerically1 (Generically1 fa) = fa 18 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: edbd50d7e7c85c13ad5f5835ae2db92fab1e9cf05ecf85340e2622ec0a303df1 10 | size: 720020 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/34.yaml 12 | original: lts-22.34 13 | -------------------------------------------------------------------------------- /nix/cabal-docspec.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: 2 | 3 | pkgs.stdenv.mkDerivation { 4 | name = "cabal-docspec"; 5 | 6 | src = pkgs.fetchurl { 7 | url = "https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz"; 8 | sha256 = "48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76"; 9 | }; 10 | 11 | phases = ["installPhase"]; 12 | 13 | installPhase = '' 14 | mkdir -p $out/bin 15 | ${pkgs.xz}/bin/xz -d < $src > $out/bin/cabal-docspec 16 | chmod a+x $out/bin/cabal-docspec 17 | ''; 18 | } 19 | -------------------------------------------------------------------------------- /src/Data/Tuple/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | This module provides linear functions commonly used on tuples. 5 | module Data.Tuple.Linear 6 | ( fst, 7 | snd, 8 | swap, 9 | curry, 10 | uncurry, 11 | ) 12 | where 13 | 14 | import Data.Unrestricted.Linear.Internal.Consumable 15 | import Prelude.Linear.Internal (curry, uncurry) 16 | 17 | fst :: (Consumable b) => (a, b) %1 -> a 18 | fst (a, b) = lseq b a 19 | 20 | snd :: (Consumable a) => (a, b) %1 -> b 21 | snd (a, b) = lseq a b 22 | 23 | swap :: (a, b) %1 -> (b, a) 24 | swap (a, b) = (b, a) 25 | -------------------------------------------------------------------------------- /src-version-changes/ghc94/before/Prelude/Linear/Internal/TypeEq.hs: -------------------------------------------------------------------------------- 1 | -- | As of GHC 9.4, @~@ is a type operator exported from `Data.Type.Equality` 2 | -- rather than a language construct. As a temporary workaround to enable 3 | -- compilation on both GHC 9.4 and 9.2, this module is empty, while the GHC 4 | -- 9.4 version re-exports the new type operator. As a result, files which 5 | -- depend on this module will likely have -Wno-unused-imports enabled (and 6 | -- potentially also -Wno-dodgy exports if they re-export it). These should be 7 | -- removed once support for GHC 9.2 is dropped. 8 | module Prelude.Linear.Internal.TypeEq where 9 | -------------------------------------------------------------------------------- /src/Data/Set/Mutable/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | -- | 4 | -- This module defines linear mutable sets. 5 | -- 6 | -- The underlying implementation uses 'Data.HashMap.Linear', so it inherits 7 | -- the time and memory characteristics of it. 8 | -- 9 | -- Please import this module qualified to avoid name clashes. 10 | module Data.Set.Mutable.Linear 11 | ( -- * Mutable Sets 12 | Set, 13 | empty, 14 | insert, 15 | delete, 16 | union, 17 | intersection, 18 | size, 19 | member, 20 | fromList, 21 | toList, 22 | Keyed, 23 | ) 24 | where 25 | 26 | import Data.Set.Mutable.Linear.Internal 27 | -------------------------------------------------------------------------------- /src-version-changes/ghc96/before/Data/Tuple/Linear/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | 3 | module Data.Tuple.Linear.Compat where 4 | 5 | import Data.Tuple 6 | 7 | -- | The 'Solo' data constructor was renamed to 'MkSolo' in GHC 9.6 (see 8 | -- [#437](https://github.com/tweag/linear-base/issues/437)). Because at present 9 | -- there is no linear pattern synonym, and in order to stay compatible with GHC 10 | -- 9.4 we use a constructor and a destructor functions as a workaround (it's 11 | -- quite easy in the case of 'Solo' anyway). 12 | unSolo :: Solo a %p -> a 13 | unSolo (Solo a) = a 14 | 15 | -- | See 'unSolo'. 16 | mkSolo :: a %p -> Solo a 17 | mkSolo = Solo 18 | -------------------------------------------------------------------------------- /src-version-changes/ghc96/after/Data/Tuple/Linear/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | 3 | module Data.Tuple.Linear.Compat where 4 | 5 | import Data.Tuple 6 | 7 | -- | The 'Solo' data constructor was renamed to 'MkSolo' in GHC 9.6 (see 8 | -- [#437](https://github.com/tweag/linear-base/issues/437)). Because at present 9 | -- there is no linear pattern synonym, and in order to stay compatible with GHC 10 | -- 9.4 we use a constructor and a destructor functions as a workaround (it's 11 | -- quite easy in the case of 'Solo' anyway). 12 | unSolo :: Solo a %p -> a 13 | unSolo (MkSolo a) = a 14 | 15 | -- | See 'unSolo'. 16 | mkSolo :: a %p -> Solo a 17 | mkSolo = MkSolo 18 | -------------------------------------------------------------------------------- /src-version-changes/ghc94/after/Prelude/Linear/Internal/TypeEq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | As of GHC 9.4, @~@ is a type operator exported from `Data.Type.Equality` 5 | -- rather than a language construct. As a temporary workaround to enable 6 | -- compilation on both GHC 9.4 and 9.2, this module re-exports the new type 7 | -- operator, while the 9.2 version is empty. As a result, files which depend 8 | -- on this module will likely have -Wno-unused-imports enabled (and potentially 9 | -- also -Wno-dodgy exports if they re-export it). These should be removed once 10 | -- support for GHC 9.2 is dropped. 11 | module Prelude.Linear.Internal.TypeEq 12 | ( type (~), 13 | ) 14 | where 15 | 16 | import Data.Type.Equality (type (~)) 17 | -------------------------------------------------------------------------------- /src/Control/Monad/IO/Class/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Control.Monad.IO.Class.Linear where 5 | 6 | import qualified Control.Functor.Linear as Linear 7 | import Prelude.Linear 8 | import qualified System.IO as System 9 | import qualified System.IO.Linear as Linear 10 | 11 | -- | Like 'NonLinear.MonadIO' but allows to lift both linear 12 | -- and non-linear 'IO' actions into a linear monad. 13 | class (Linear.Monad m) => MonadIO m where 14 | liftIO :: Linear.IO a %1 -> m a 15 | liftSystemIO :: System.IO a -> m a 16 | liftSystemIO io = liftIO (Linear.fromSystemIO io) 17 | liftSystemIOU :: System.IO a -> m (Ur a) 18 | liftSystemIOU io = liftIO (Linear.fromSystemIOU io) 19 | 20 | instance MonadIO Linear.IO where 21 | liftIO = id 22 | -------------------------------------------------------------------------------- /src/Data/HashMap/Mutable/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | -- | 4 | -- This module provides mutable hashmaps with a linear interface. 5 | -- 6 | -- It is implemented with Robin Hood hashing which has amortized 7 | -- constant time lookups and updates. 8 | module Data.HashMap.Mutable.Linear 9 | ( -- * A mutable hashmap 10 | HashMap, 11 | Keyed, 12 | 13 | -- * Constructors 14 | empty, 15 | fromList, 16 | 17 | -- * Modifiers 18 | insert, 19 | insertAll, 20 | delete, 21 | filter, 22 | filterWithKey, 23 | mapMaybe, 24 | mapMaybeWithKey, 25 | shrinkToFit, 26 | alter, 27 | alterF, 28 | 29 | -- * Accessors 30 | size, 31 | capacity, 32 | lookup, 33 | member, 34 | toList, 35 | 36 | -- * Combining maps 37 | union, 38 | unionWith, 39 | intersectionWith, 40 | ) 41 | where 42 | 43 | import Data.HashMap.Mutable.Linear.Internal 44 | -------------------------------------------------------------------------------- /src/Data/Replicator/Linear/Internal/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wno-orphans #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | 4 | module Data.Replicator.Linear.Internal.Instances where 5 | 6 | import qualified Data.Functor.Linear as Data 7 | import Data.Replicator.Linear.Internal 8 | import qualified Data.Replicator.Linear.Internal as Replicator 9 | import Data.Replicator.Linear.Internal.ReplicationStream 10 | import qualified Data.Replicator.Linear.Internal.ReplicationStream as ReplicationStream 11 | 12 | instance Data.Functor ReplicationStream where 13 | fmap = ReplicationStream.map 14 | 15 | instance Data.Applicative ReplicationStream where 16 | pure = ReplicationStream.pure 17 | f <*> x = f ReplicationStream.<*> x 18 | 19 | instance Data.Functor Replicator where 20 | fmap = Replicator.map 21 | 22 | instance Data.Applicative Replicator where 23 | pure = Replicator.pure 24 | f <*> x = f Replicator.<*> x 25 | liftA2 = Replicator.liftA2 26 | -------------------------------------------------------------------------------- /src/Data/Bool/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | This module provides linear functions on the standard 'Bool' type. 5 | module Data.Bool.Linear 6 | ( -- * The Boolean type 7 | Bool (..), 8 | 9 | -- * Operators 10 | (&&), 11 | (||), 12 | not, 13 | otherwise, 14 | ) 15 | where 16 | 17 | import Prelude (Bool (..), otherwise) 18 | 19 | -- | @True@ iff both are @True@. 20 | -- __NOTE:__ this is strict and not lazy! 21 | (&&) :: Bool %1 -> Bool %1 -> Bool 22 | False && False = False 23 | False && True = False 24 | True && x = x 25 | 26 | infixr 3 && -- same as base.&& 27 | 28 | -- | @True@ iff either is @True@ 29 | -- __NOTE:__ this is strict and not lazy! 30 | (||) :: Bool %1 -> Bool %1 -> Bool 31 | True || False = True 32 | True || True = True 33 | False || x = x 34 | 35 | infixr 2 || -- same as base.|| 36 | 37 | -- | @not b@ is @True@ iff b is @False@ 38 | -- __NOTE:__ this is strict and not lazy! 39 | not :: Bool %1 -> Bool 40 | not False = True 41 | not True = False 42 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | 7 | -- | This module provides Bifunctor and related classes. 8 | -- 9 | -- == 'Bifunctor' 10 | -- 11 | -- Use a bifunctor instance to map functions over data structures 12 | -- that have two type paramaters @a@ and @b@ and could be have a 13 | -- functor instance for either the @a@s or @b@s. 14 | -- For instance, you might want to map a function on either the left 15 | -- or right element of a @(Int, Bool)@: 16 | -- 17 | -- > import Prelude.Linear 18 | -- > import Data.Bifunctor.Linear 19 | -- > 20 | -- > -- Map over the second element 21 | -- > negateRight :: (Int, Bool) %1-> (Int, Bool) 22 | -- > negateRight x = second not x 23 | module Data.Bifunctor.Linear 24 | ( Bifunctor (..), 25 | SymmetricMonoidal (..), 26 | ) 27 | where 28 | 29 | import Data.Bifunctor.Linear.Internal.Bifunctor 30 | import Data.Bifunctor.Linear.Internal.SymmetricMonoidal 31 | -------------------------------------------------------------------------------- /test/Test/Data/Replicator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE LinearTypes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# OPTIONS_GHC -O -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} 6 | 7 | module Test.Data.Replicator (replicatorInspectionTests) where 8 | 9 | import Data.Replicator.Linear (Replicator) 10 | import qualified Data.Replicator.Linear as Replicator 11 | import Prelude.Linear 12 | import Test.Tasty 13 | import Test.Tasty.Inspection 14 | 15 | replicatorInspectionTests :: TestTree 16 | replicatorInspectionTests = 17 | testGroup 18 | "Inspection testing of elim for Replicator" 19 | [$(inspectTest $ 'elim3 === 'manualElim3)] 20 | 21 | elim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> Replicator a %1 -> [a] 22 | elim3 = Replicator.elim 23 | 24 | manualElim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> Replicator a %1 -> [a] 25 | manualElim3 f r = 26 | case Replicator.next r of 27 | (x, r') -> 28 | case Replicator.next r' of 29 | (y, r'') -> 30 | case Replicator.extract r'' of 31 | z -> f x y z 32 | -------------------------------------------------------------------------------- /.github/settings.yml: -------------------------------------------------------------------------------- 1 | repository: 2 | has_wiki: false 3 | 4 | labels: 5 | - name: "Bikeshedding" 6 | color: ff800e 7 | - name: "duplicate" 8 | color: cfd3d7 9 | - name: "good first issue" 10 | color: 7057ff 11 | - name: "invalid" 12 | color: cfd3d7 13 | - name: "more data needed" 14 | color: bfdadc 15 | - name: "P0" 16 | color: b60205 17 | description: "blocker: fix immediately!" 18 | - name: "P1" 19 | color: d93f0b 20 | description: "critical: next release" 21 | - name: "P2" 22 | color: e99695 23 | description: "major: an upcoming release" 24 | - name: "P3" 25 | color: fbca04 26 | description: "minor: not priorized" 27 | - name: "P4" 28 | color: fef2c0 29 | description: "unimportant: consider wontfix or other priority" 30 | - name: "question" 31 | color: d876e3 32 | - name: "type: bug" 33 | color: 0052cc 34 | - name: "type: documentation" 35 | color: 0052cc 36 | - name: "type: feature request" 37 | color: 0052cc 38 | - name: "wontfix" 39 | color: ffffff 40 | - name: "merge-queue" 41 | color: 0e8a16 42 | description: "merge on green CI" 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) Tweag Holding and its affiliates. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /test-examples/Test/Simple/Quicksort.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Test.Simple.Quicksort (quicksortTests) where 4 | 5 | import Data.List (sort) 6 | import Hedgehog 7 | import qualified Hedgehog.Gen as Gen 8 | import qualified Hedgehog.Range as Range 9 | import Simple.Quicksort (quicksortUsingArray, quicksortUsingList) 10 | import Test.Tasty 11 | import Test.Tasty.Hedgehog (testPropertyNamed) 12 | 13 | quicksortTests :: TestTree 14 | quicksortTests = 15 | testGroup 16 | "quicksort tests" 17 | [ testPropertyNamed "sort xs === quicksortUsingArray xs" "testQuicksortUsingArray" testQuicksortUsingArray, 18 | testPropertyNamed "sort xs === quicksortUsingList xs" "testQuicksortUsingList" testQuicksortUsingList 19 | ] 20 | 21 | testQuicksortUsingArray :: Property 22 | testQuicksortUsingArray = property $ do 23 | xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int $ Range.linear 0 100) 24 | sort xs === quicksortUsingArray xs 25 | 26 | testQuicksortUsingList :: Property 27 | testQuicksortUsingList = property $ do 28 | xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int $ Range.linear 0 100) 29 | sort xs === quicksortUsingList xs 30 | -------------------------------------------------------------------------------- /src-version-changes/ghc94/before/Prelude/Linear/Internal/Generically.hs: -------------------------------------------------------------------------------- 1 | -- | Prior to GHC 9.4, linear-base defined its own versions of @Generically@ and 2 | -- @Generically1@. As a temporary workaround to enable compilation on both GHC 3 | -- 9.4 and 9.2, this module exposes linear-base's own implementations of those 4 | -- types, while the 9.4 version simply re-exports @Generics.Linear@. 5 | module Prelude.Linear.Internal.Generically 6 | ( Generically (..), 7 | Generically1 (..), 8 | module Generics.Linear, 9 | ) 10 | where 11 | 12 | import Generics.Linear 13 | 14 | -- | A datatype whose instances are defined generically, using the 15 | -- 'Generics.Linear.Generic' representation. 16 | -- Generic instances can be derived via @'Generically' A@ using 17 | -- @-XDerivingVia@. 18 | newtype Generically a = Generically a 19 | 20 | -- | A type whose instances are defined generically, using the 21 | -- 'Generics.Linear.Generic1' representation. 'Generically1' is a higher-kinded 22 | -- version of 'Generically'. 23 | -- 24 | -- Generic instances can be derived for type constructors via 25 | -- @'Generically1' F@ using @-XDerivingVia@. 26 | newtype Generically1 f a = Generically1 (f a) 27 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Main where 5 | 6 | import Test.Data.Destination (destArrayTests) 7 | import Test.Data.Functor.Linear (genericTests) 8 | import Test.Data.List (listTests) 9 | import Test.Data.Mutable.Array (mutArrTests) 10 | import Test.Data.Mutable.HashMap (mutHMTests) 11 | import Test.Data.Mutable.Set (mutSetTests) 12 | import Test.Data.Mutable.Vector (mutVecTests) 13 | import Test.Data.Polarized (polarizedArrayTests) 14 | import Test.Data.Replicator (replicatorInspectionTests) 15 | import Test.Data.V (vInspectionTests) 16 | import Test.Tasty 17 | 18 | main :: IO () 19 | main = defaultMain allTests 20 | 21 | allTests :: TestTree 22 | allTests = 23 | testGroup 24 | "All tests" 25 | [ testGroup 26 | "Functional tests" 27 | [ mutArrTests, 28 | mutVecTests, 29 | mutHMTests, 30 | mutSetTests, 31 | destArrayTests, 32 | polarizedArrayTests, 33 | listTests, 34 | genericTests 35 | ], 36 | testGroup 37 | "Inspection tests" 38 | [ vInspectionTests, 39 | replicatorInspectionTests 40 | ] 41 | ] 42 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "niv": { 3 | "branch": "master", 4 | "description": "Easy dependency management for Nix projects", 5 | "homepage": "https://github.com/nmattia/niv", 6 | "owner": "nmattia", 7 | "repo": "niv", 8 | "rev": "dd678782cae74508d6b4824580d2b0935308011e", 9 | "sha256": "0dk8dhh9vla2s409anmrfkva6h3r32xmz3cm8ha09wyk8iyf1f87", 10 | "type": "tarball", 11 | "url": "https://github.com/nmattia/niv/archive/dd678782cae74508d6b4824580d2b0935308011e.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "nixpkgs": { 15 | "branch": "master", 16 | "description": "Nix Packages collection", 17 | "homepage": "https://github.com/NixOS/nixpkgs", 18 | "owner": "NixOS", 19 | "repo": "nixpkgs", 20 | "rev": "0c501072d51fca9fc0f9fd123e106ad2f89c6b09", 21 | "sha256": "0xmhs479g1gzqv320zlmx44wzqlnb741kp6zwj1m3nzzdv94v472", 22 | "type": "tarball", 23 | "url": "https://github.com/NixOS/nixpkgs/archive/0c501072d51fca9fc0f9fd123e106ad2f89c6b09.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { system ? builtins.currentSystem, sources ? import ./nix/sources.nix, ghcVersion ? "96", installHls ? true }: 2 | 3 | let 4 | selectHls = self: super: { 5 | haskell-language-server = super.haskell-language-server.override { supportedGhcVersions = [ "${ghcVersion}" ]; }; 6 | }; 7 | pkgs = import sources.nixpkgs { inherit system; overlays = [ selectHls ]; }; 8 | cabal-docspec = import ./nix/cabal-docspec.nix { inherit pkgs; }; 9 | stack-wrapped = pkgs.symlinkJoin { 10 | name = "stack"; 11 | paths = [ pkgs.stack ]; 12 | buildInputs = [ pkgs.makeWrapper ]; 13 | postBuild = '' 14 | wrapProgram $out/bin/stack \ 15 | --add-flags "\ 16 | --nix \ 17 | --nix-path=\\"nixpkgs=${pkgs.path}\\" 18 | --nix-shell-file nix/shell-stack.nix \ 19 | " 20 | ''; 21 | }; 22 | in with pkgs; 23 | 24 | mkShell { 25 | # Set UTF-8 local so that run-tests can parse GHC's unicode output. 26 | LANG="C.UTF-8"; 27 | NIX_PATH = "nixpkgs=${pkgs.path}"; 28 | 29 | buildInputs = [ 30 | haskell.compiler."ghc${ghcVersion}" 31 | cabal-install 32 | stack-wrapped 33 | nix 34 | cabal-docspec 35 | ] ++ (if installHls then [ haskell-language-server ] else []); 36 | } 37 | -------------------------------------------------------------------------------- /src/Control/Functor/Linear/Internal/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wno-orphans #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE QuantifiedConstraints #-} 5 | {-# LANGUAGE RebindableSyntax #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TupleSections #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | {-# OPTIONS_HADDOCK hide #-} 10 | 11 | module Control.Functor.Linear.Internal.Instances 12 | ( Data (..), 13 | ) 14 | where 15 | 16 | import Control.Functor.Linear.Internal.Class 17 | import qualified Data.Functor.Linear.Internal.Applicative as Data 18 | import qualified Data.Functor.Linear.Internal.Functor as Data 19 | 20 | -- # Deriving Data.XXX in terms of Control.XXX 21 | ------------------------------------------------------------------------------- 22 | 23 | -- | This is a newtype for deriving Data.XXX classes from 24 | -- Control.XXX classes. 25 | newtype Data f a = Data (f a) 26 | 27 | -- # Basic instances 28 | ------------------------------------------------------------------------------- 29 | 30 | instance (Functor f) => Data.Functor (Data f) where 31 | fmap f (Data x) = Data (fmap f x) 32 | 33 | instance (Applicative f) => Data.Applicative (Data f) where 34 | pure x = Data (pure x) 35 | Data f <*> Data x = Data (f <*> x) 36 | -------------------------------------------------------------------------------- /bench/Data/Mutable/Quicksort.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | 3 | module Data.Mutable.Quicksort (benchmarks) where 4 | 5 | import Control.DeepSeq (force) 6 | import Control.Exception (evaluate) 7 | import Data.List (sort) 8 | import Simple.Quicksort (quicksortUsingArray, quicksortUsingList) 9 | import System.Random 10 | import Test.Tasty.Bench 11 | 12 | -- Follows thread from https://discourse.haskell.org/t/linear-haskell-quicksort-performance/10280 13 | 14 | gen :: StdGen 15 | gen = mkStdGen 4541645642 16 | 17 | randomListBuilder :: Int -> IO [Int] 18 | randomListBuilder size = evaluate $ force $ take size (randoms gen :: [Int]) 19 | 20 | sizes :: [Int] 21 | sizes = [1_000, 50_000, 1_000_000] 22 | 23 | benchmarks :: Benchmark 24 | benchmarks = 25 | bgroup 26 | "quicksort" 27 | ( ( \size -> 28 | env (randomListBuilder size) $ \randomList -> 29 | bgroup 30 | ("size " ++ (show size)) 31 | [ bench "quicksortUsingArray" $ 32 | nf quicksortUsingArray randomList, 33 | bench "quicksortUsingList" $ 34 | nf quicksortUsingList randomList, 35 | bench "sortStdLib" $ 36 | nf sort randomList 37 | ] 38 | ) 39 | <$> sizes 40 | ) 41 | -------------------------------------------------------------------------------- /test/Test/Data/V.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# OPTIONS_GHC -O -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} 7 | 8 | module Test.Data.V (vInspectionTests) where 9 | 10 | import Data.V.Linear (V) 11 | import qualified Data.V.Linear as V 12 | import Prelude.Linear 13 | import Test.Tasty 14 | import Test.Tasty.Inspection 15 | 16 | vInspectionTests :: TestTree 17 | vInspectionTests = 18 | testGroup 19 | "Inspection testing of elim and make for V" 20 | [ $(inspectTest $ 'make3 ==- 'manualMake3), 21 | $(inspectTest $ 'elim3 ==- 'manualElim3) 22 | ] 23 | 24 | make3 :: a %1 -> a %1 -> a %1 -> V 3 a 25 | make3 = V.make 26 | 27 | manualMake3 :: a %1 -> a %1 -> a %1 -> V 3 a 28 | manualMake3 x y z = V.cons x . V.cons y . V.cons z $ V.empty 29 | 30 | elim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> V 3 a %1 -> [a] 31 | elim3 = V.elim 32 | 33 | manualElim3 :: (a %1 -> a %1 -> a %1 -> [a]) %1 -> V 3 a %1 -> [a] 34 | manualElim3 f v = 35 | case V.uncons v of 36 | (x, v') -> 37 | case V.uncons v' of 38 | (y, v'') -> 39 | case V.uncons v'' of 40 | (z, v''') -> 41 | case V.consume v''' of 42 | () -> f x y z 43 | -------------------------------------------------------------------------------- /src/Data/Maybe/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | This module provides linear functions on the standard 'Maybe' type. 5 | module Data.Maybe.Linear 6 | ( Maybe (..), 7 | maybe, 8 | fromMaybe, 9 | maybeToList, 10 | catMaybes, 11 | mapMaybe, 12 | ) 13 | where 14 | 15 | import qualified Data.Functor.Linear as Linear 16 | import Prelude (Maybe (..)) 17 | 18 | -- | @maybe b f m@ returns @(f a)@ where @a@ is in 19 | -- @m@ if it exists and @b@ otherwise 20 | maybe :: b -> (a %1 -> b) -> Maybe a %1 -> b 21 | maybe x _ Nothing = x 22 | maybe _ f (Just y) = f y 23 | 24 | -- | @fromMaybe default m@ is the @a@ in 25 | -- @m@ if it exists and the @default@ otherwise 26 | fromMaybe :: a -> Maybe a %1 -> a 27 | fromMaybe a Nothing = a 28 | fromMaybe _ (Just a') = a' 29 | 30 | -- | @maybeToList m@ creates a singleton or an empty list 31 | -- based on the @Maybe a@. 32 | maybeToList :: Maybe a %1 -> [a] 33 | maybeToList Nothing = [] 34 | maybeToList (Just a) = [a] 35 | 36 | -- | @catMaybes xs@ discards the @Nothing@s in @xs@ 37 | -- and extracts the @a@s 38 | catMaybes :: [Maybe a] %1 -> [a] 39 | catMaybes [] = [] 40 | catMaybes (Nothing : xs) = catMaybes xs 41 | catMaybes (Just a : xs) = a : catMaybes xs 42 | 43 | -- | @mapMaybe f xs = catMaybes (map f xs)@ 44 | mapMaybe :: (a %1 -> Maybe b) -> [a] %1 -> [b] 45 | mapMaybe f xs = catMaybes (Linear.fmap f xs) 46 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Linear/Internal/Bifunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# OPTIONS_HADDOCK hide #-} 5 | 6 | module Data.Bifunctor.Linear.Internal.Bifunctor 7 | ( Bifunctor (..), 8 | ) 9 | where 10 | 11 | import Prelude.Linear 12 | 13 | -- | The Bifunctor class 14 | -- 15 | -- == Laws 16 | -- 17 | -- If 'bimap' is supplied, then 18 | -- @'bimap' 'id' 'id' = 'id'@ 19 | -- 20 | -- * If 'first' and 'second' are supplied, then 21 | -- @ 22 | -- 'first' 'id' ≡ 'id' 23 | -- 'second' 'id' ≡ 'id' 24 | -- @ 25 | -- 26 | -- * If all are supplied, then 27 | -- @'bimap' f g = 'first' f '.' 'second' g 28 | class Bifunctor p where 29 | {-# MINIMAL bimap | (first, second) #-} 30 | bimap :: (a %1 -> b) -> (c %1 -> d) -> a `p` c %1 -> b `p` d 31 | bimap f g x = first f (second g x) 32 | {-# INLINE bimap #-} 33 | 34 | first :: (a %1 -> b) -> a `p` c %1 -> b `p` c 35 | first f = bimap f id 36 | {-# INLINE first #-} 37 | 38 | second :: (b %1 -> c) -> a `p` b %1 -> a `p` c 39 | second = bimap id 40 | {-# INLINE second #-} 41 | 42 | -- # Instances 43 | ------------------------------------------------------------------------------- 44 | 45 | instance Bifunctor (,) where 46 | bimap f g (x, y) = (f x, g y) 47 | first f (x, y) = (f x, y) 48 | second g (x, y) = (x, g y) 49 | 50 | instance Bifunctor Either where 51 | bimap f g = either (Left . f) (Right . g) 52 | -------------------------------------------------------------------------------- /src/Data/Array/Mutable/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | 3 | -- | 4 | -- This module provides a pure linear interface for arrays with in-place 5 | -- mutation. 6 | -- 7 | -- To use these mutable arrays, create a linear computation of type 8 | -- @Array a %1-> Ur b@ and feed it to 'alloc' or 'fromList'. 9 | -- 10 | -- == A Tiny Example 11 | -- 12 | -- >>> :set -XLinearTypes 13 | -- >>> :set -XNoImplicitPrelude 14 | -- >>> import Prelude.Linear 15 | -- >>> import qualified Data.Array.Mutable.Linear as Array 16 | -- >>> :{ 17 | -- isFirstZero :: Array.Array Int %1-> Ur Bool 18 | -- isFirstZero arr = 19 | -- Array.get 0 arr 20 | -- & \(Ur val, arr') -> arr' `lseq` Ur (val == 0) 21 | -- :} 22 | -- 23 | -- >>> unur $ Array.fromList [0..10] isFirstZero 24 | -- True 25 | -- >>> unur $ Array.fromList [1,2,3] isFirstZero 26 | -- False 27 | module Data.Array.Mutable.Linear 28 | ( -- * Mutable Linear Arrays 29 | Array, 30 | 31 | -- * Performing Computations with Arrays 32 | alloc, 33 | allocBeside, 34 | fromList, 35 | 36 | -- * Modifications 37 | set, 38 | unsafeSet, 39 | resize, 40 | map, 41 | 42 | -- * Accessors 43 | get, 44 | unsafeGet, 45 | size, 46 | slice, 47 | toList, 48 | freeze, 49 | 50 | -- * Mutable-style interface 51 | read, 52 | unsafeRead, 53 | write, 54 | unsafeWrite, 55 | ) 56 | where 57 | 58 | import Data.Array.Mutable.Linear.Internal 59 | import Prelude hiding (map, read) 60 | -------------------------------------------------------------------------------- /src/Data/V/Linear/Internal/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wno-orphans #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE NoImplicitPrelude #-} 7 | {-# OPTIONS_HADDOCK hide #-} 8 | 9 | -- | This module contains all instances for V 10 | module Data.V.Linear.Internal.Instances where 11 | 12 | import qualified Data.Functor.Linear.Internal.Applicative as Data 13 | import qualified Data.Functor.Linear.Internal.Functor as Data 14 | import qualified Data.Functor.Linear.Internal.Traversable as Data 15 | import Data.V.Linear.Internal (V (..)) 16 | import qualified Data.V.Linear.Internal as V 17 | import qualified Data.Vector as Vector 18 | import GHC.TypeLits 19 | import Prelude.Linear.Internal 20 | import qualified Unsafe.Linear as Unsafe 21 | import qualified Prelude 22 | 23 | -- # Instances of V 24 | ------------------------------------------------------------------------------- 25 | 26 | instance Data.Functor (V n) where 27 | fmap = V.map 28 | 29 | instance (KnownNat n) => Data.Applicative (V n) where 30 | pure = V.pure 31 | a <*> b = a V.<*> b 32 | 33 | instance (KnownNat n) => Prelude.Applicative (V n) where 34 | pure = V.pure 35 | V fs <*> V xs = V $ Vector.zipWith ($) fs xs 36 | 37 | instance (KnownNat n) => Data.Traversable (V n) where 38 | traverse f (V xs) = 39 | (V . Unsafe.toLinear (Vector.fromListN (V.theLength @n))) 40 | Data.<$> Data.traverse f (Unsafe.toLinear Vector.toList xs) 41 | -------------------------------------------------------------------------------- /src/Data/Functor/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | = The data functor hierarchy 5 | -- 6 | -- This module defines the data functor library. Unlike in the case of 7 | -- non-linear, unrestricted, functors, there is a split between data functors, 8 | -- which represent containers, and control functors which represent effects. 9 | -- Please read this 10 | -- [blog post](https://www.tweag.io/posts/2020-01-16-data-vs-control.html). 11 | -- For more details, see "Control.Functor.Linear". 12 | -- 13 | -- * Linear data functors should be thought of as containers of data. 14 | -- * Linear data applicative functors should be thought of as containers 15 | -- that can be zipped. 16 | -- * Linear data traversable functors should be thought of as 17 | -- containers which store a finite number of values. 18 | -- 19 | -- This module also defines 'genericTraverse' for types implementing 20 | -- 'Generics.Linear.Generic1'. 21 | module Data.Functor.Linear 22 | ( -- * Data Functor Hierarchy 23 | Functor (..), 24 | (<$>), 25 | (<$), 26 | void, 27 | Applicative (..), 28 | Const (..), 29 | 30 | -- * Linear traversable hierarchy 31 | Traversable (..), 32 | genericTraverse, 33 | GTraversable, 34 | mapM, 35 | sequenceA, 36 | for, 37 | forM, 38 | mapAccumL, 39 | mapAccumR, 40 | ) 41 | where 42 | 43 | import Data.Functor.Const 44 | import Data.Functor.Linear.Internal.Applicative 45 | import Data.Functor.Linear.Internal.Functor 46 | import Data.Functor.Linear.Internal.Traversable 47 | -------------------------------------------------------------------------------- /src/Streaming/Linear/Internal/Interop.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE LinearTypes #-} 3 | {-# LANGUAGE QualifiedDo #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 6 | {-# OPTIONS_HADDOCK hide #-} 7 | 8 | -- | This module contains functions for interoperating with other 9 | -- streaming libraries. 10 | module Streaming.Linear.Internal.Interop 11 | ( -- * Interoperating with other streaming libraries 12 | reread, 13 | ) 14 | where 15 | 16 | import qualified Control.Functor.Linear as Control 17 | import Data.Unrestricted.Linear 18 | import Prelude.Linear (($)) 19 | import Streaming.Linear.Internal.Produce 20 | import Streaming.Linear.Internal.Type 21 | import Prelude (Maybe (..)) 22 | 23 | -- | Read an @IORef (Maybe a)@ or a similar device until it reads @Nothing@. 24 | -- @reread@ provides convenient exit from the @io-streams@ library 25 | -- 26 | -- > reread readIORef :: IORef (Maybe a) -> Stream (Of a) IO () 27 | -- > reread Streams.read :: System.IO.Streams.InputStream a -> Stream (Of a) IO () 28 | reread :: 29 | (Control.Monad m) => 30 | (s -> m (Ur (Maybe a))) -> 31 | s -> 32 | Stream (Of a) m () 33 | reread f s = reread' f s 34 | where 35 | reread' :: 36 | (Control.Monad m) => 37 | (s -> m (Ur (Maybe a))) -> 38 | s -> 39 | Stream (Of a) m () 40 | reread' f s = Effect $ Control.do 41 | Ur maybeA <- f s 42 | case maybeA of 43 | Nothing -> Control.return $ Return () 44 | Just a -> Control.return $ (yield a Control.>> reread f s) 45 | {-# INLINEABLE reread #-} 46 | -------------------------------------------------------------------------------- /src/Data/Vector/Mutable/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | -- | Mutable vectors with a linear API. 4 | -- 5 | -- Vectors are arrays that grow automatically, that you can append to with 6 | -- 'push'. They never shrink automatically to reduce unnecessary copying, 7 | -- use 'shrinkToFit' to get rid of the wasted space. 8 | -- 9 | -- To use mutable vectors, create a linear computation of type 10 | -- @Vector a %1-> Ur b@ and feed it to 'constant' or 'fromList'. 11 | -- 12 | -- == Example 13 | -- 14 | -- >>> :set -XLinearTypes 15 | -- >>> import Prelude.Linear 16 | -- >>> import qualified Data.Vector.Mutable.Linear as Vector 17 | -- >>> :{ 18 | -- isFirstZero :: Vector.Vector Int %1-> Ur Bool 19 | -- isFirstZero vec = 20 | -- Vector.get 0 vec 21 | -- & \(Ur ret, vec) -> vec `lseq` Ur (ret == 0) 22 | -- :} 23 | -- 24 | -- >>> unur $ Vector.fromList [0..10] isFirstZero 25 | -- True 26 | -- >>> unur $ Vector.fromList [1,2,3] isFirstZero 27 | -- False 28 | module Data.Vector.Mutable.Linear 29 | ( -- * A mutable vector 30 | Vector, 31 | 32 | -- * Run a computation with a vector 33 | empty, 34 | constant, 35 | fromList, 36 | 37 | -- * Mutators 38 | set, 39 | unsafeSet, 40 | modify, 41 | modify_, 42 | push, 43 | pop, 44 | filter, 45 | mapMaybe, 46 | slice, 47 | shrinkToFit, 48 | 49 | -- * Accessors 50 | get, 51 | unsafeGet, 52 | size, 53 | capacity, 54 | toList, 55 | freeze, 56 | 57 | -- * Mutable-style interface 58 | read, 59 | unsafeRead, 60 | write, 61 | unsafeWrite, 62 | ) 63 | where 64 | 65 | import Data.Vector.Mutable.Linear.Internal 66 | -------------------------------------------------------------------------------- /test/Test/Data/Functor/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE LinearTypes #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE NoImplicitPrelude #-} 12 | 13 | module Test.Data.Functor.Linear (genericTests) where 14 | 15 | import Data.Functor.Linear (genericTraverse) 16 | import qualified Data.Functor.Linear as Data 17 | import Generics.Linear.TH 18 | import Hedgehog 19 | import Prelude.Linear 20 | import Test.Tasty 21 | import Test.Tasty.Hedgehog (testPropertyNamed) 22 | import qualified Prelude 23 | 24 | data Pair a = MkPair a a 25 | deriving (Show, Prelude.Eq) 26 | 27 | $(deriveGeneric1 ''Pair) 28 | 29 | instance Data.Functor Pair where 30 | fmap f (MkPair x y) = MkPair (f x) (f y) 31 | 32 | instance Data.Traversable Pair where 33 | traverse = genericTraverse 34 | 35 | genericTests :: TestTree 36 | genericTests = 37 | testGroup 38 | "Generic tests" 39 | [ genericTraverseTests 40 | ] 41 | 42 | genericTraverseTests :: TestTree 43 | genericTraverseTests = 44 | testGroup 45 | "genericTraverse examples" 46 | [pairTest] 47 | 48 | pairTest :: TestTree 49 | pairTest = 50 | testPropertyNamed "traverse via genericTraverse with WithLog and Pair" "propertyPairTest" propertyPairTest 51 | 52 | propertyPairTest :: Property 53 | propertyPairTest = 54 | property $ 55 | ( Data.traverse 56 | (\x -> (Sum (1 :: Int), 2 * x)) 57 | (MkPair 3 4 :: Pair Int) 58 | ) 59 | === (Sum 2, (MkPair 6 8)) 60 | -------------------------------------------------------------------------------- /src/Data/Replicator/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | This module defines a stream-like type named 'Replicator', which is 5 | -- mainly used in the definition of the 'Data.Unrestricted.Linear.Dupable' 6 | -- class to provide efficient linear duplication. 7 | -- The API of 'Replicator' is close to the one of an infinite stream: it 8 | -- can either produce a new value linearly (with 'next' or 'next#'), or be 9 | -- linearly discarded (with 'consume' or 'extract'). 10 | -- 11 | -- A crucial aspect, from a performance standpoint, is that the 'pure' function 12 | -- (which takes an unrestricted argument) is implemented efficiently: the 13 | -- 'Replicator' returns /the same/ value on each call to 'next'. That is, the 14 | -- pointer is always shared. This will allow 'Data.Unrestricted.Linear.Movable' 15 | -- types to be given an efficient instance of 'Data.Unrestricted.Linear.Dupable'. 16 | -- Instances of both 'Data.Unrestricted.Linear.Movable' and 17 | -- 'Data.Unrestricted.Linear.Dupable' typically involve deep copies. The 18 | -- implementation of 'pure' lets us make sure that, for @Movable@ types, only one 19 | -- deep copy is performed, rather than one per additional replica. 20 | -- 21 | -- Strictly speaking, the implementation of '(<*>)' plays a role in all this as 22 | -- well: 23 | -- For two 'pure' 'Replicators' @fs@ and @as@, @fs \<*\> as@ is a pure 24 | -- 'Replicator'. Together, 'pure' and '(<*>)' form the 25 | -- 'Data.Functor.Linear.Applicative' instance of 'Replicator'. 26 | module Data.Replicator.Linear 27 | ( Replicator, 28 | consume, 29 | duplicate, 30 | map, 31 | pure, 32 | (<*>), 33 | next, 34 | next#, 35 | take, 36 | extract, 37 | extend, 38 | Elim, 39 | elim, 40 | ) 41 | where 42 | 43 | import Data.Replicator.Linear.Internal 44 | import Data.Replicator.Linear.Internal.Instances () 45 | -------------------------------------------------------------------------------- /src/Control/Optics/Linear/Iso.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides linear isomorphisms. 2 | -- 3 | -- An @Iso a b s t@ is equivalent to a @(s %1-> a, b %1-> t)@. In the simple 4 | -- case of an @Iso' a s@, this is equivalent to inverse functions 5 | -- @(s %1-> a, a %1-> s)@. In the general case an @Iso a b s t@ means if you 6 | -- have the isomorphisms @(a %1-> b, b %1-> a)@ and @(s %1-> t, t %1-> s)@, then 7 | -- you can form isomorphisms between @s@, @t@, @a@ and @b@. 8 | -- 9 | -- = Example 10 | -- 11 | -- @ 12 | -- {-# LANGUAGE LinearTypes #-} 13 | -- {-# LANGUAGE NoImplicitPrelude #-} 14 | -- {-# LANGUAGE GADTs #-} 15 | -- 16 | -- import Control.Optics.Linear.Internal 17 | -- import Prelude.Linear 18 | -- import qualified Data.Functor.Linear as Data 19 | -- 20 | -- -- A toy example of operating over two isomorphic linear types 21 | -- closureFmap :: (a %1-> b) -> ClosureEither x a %1-> ClosureEither x b 22 | -- closureFmap f = over isoEithers (Data.fmap f) 23 | -- 24 | -- data ClosureEither a b where 25 | -- CLeft :: x %1-> (x %1-> a) %1-> ClosureEither a b 26 | -- CRight :: x %1-> (x %1-> b) %1-> ClosureEither a b 27 | -- 28 | -- isoEithers :: 29 | -- Iso (ClosureEither a b) (ClosureEither a b') (Either a b) (Either a b') 30 | -- isoEithers = iso fromClosure fromEither 31 | -- where 32 | -- fromEither :: Either a b %1-> ClosureEither a b 33 | -- fromEither (Left a) = CLeft () (\() -> a) 34 | -- fromEither (Right b) = CRight () (\() -> b) 35 | -- 36 | -- fromClosure :: ClosureEither a b %1-> Either a b 37 | -- fromClosure (CLeft x f) = Left (f x) 38 | -- fromClosure (CRight x f) = Right (f x) 39 | -- @ 40 | module Control.Optics.Linear.Iso 41 | ( -- * Types 42 | Iso, 43 | Iso', 44 | 45 | -- * Composing optics 46 | (.>), 47 | 48 | -- * Common optics 49 | swap, 50 | assoc, 51 | 52 | -- * Using optics 53 | withIso, 54 | 55 | -- * Constructing optics 56 | iso, 57 | ) 58 | where 59 | 60 | import Control.Optics.Linear.Internal 61 | -------------------------------------------------------------------------------- /src/Control/Optics/Linear/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LinearTypes #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | 5 | -- | This module provides linear lenses. 6 | -- 7 | -- A @Lens s t a b@ is equivalent to a @(s %1-> (a,b %1-> t)@. It is a way to 8 | -- cut up an instance of a /product type/ @s@ into an @a@ and a way to take a 9 | -- @b@ to fill the place of the @a@ in @s@ which yields a @t@. When @a=b@ and 10 | -- @s=t@, this type is much more intuitive: @(s %1-> (a,a %1-> s))@. This is a 11 | -- traversal on exactly one @a@ in a @s@. 12 | -- 13 | -- = Example 14 | -- 15 | -- @ 16 | -- {-# LANGUAGE LinearTypes #-} 17 | -- {-# LANGUAGE FlexibleContexts #-} 18 | -- {-# LANGUAGE NoImplicitPrelude #-} 19 | -- 20 | -- import Control.Optics.Linear.Internal 21 | -- import Prelude.Linear 22 | -- 23 | -- import Control.Optics.Linear.Internal 24 | -- import Prelude.Linear 25 | -- -- We can use a lens to, for instance, linearly modify a sub-piece in 26 | -- -- a nested record 27 | -- modPersonZip :: Person %1-> Person 28 | -- modPersonZip = over (personLocL .> locZipL) (\x -> x + 1) 29 | -- 30 | -- -- A person has a name and location 31 | -- data Person = Person String Location 32 | -- 33 | -- -- A location is a zip code and address 34 | -- data Location = Location Int String 35 | -- 36 | -- personLocL :: Lens' Person Location 37 | -- personLocL = lens (\(Person s l) -> (l, \l' -> Person s l')) 38 | -- 39 | -- locZipL :: Lens' Location Int 40 | -- locZipL = lens (\(Location i s) -> (i, \i' -> Location i' s)) 41 | -- @ 42 | module Control.Optics.Linear.Lens 43 | ( -- * Types 44 | Lens, 45 | Lens', 46 | 47 | -- * Composing lens 48 | (.>), 49 | 50 | -- * Common optics 51 | _1, 52 | _2, 53 | 54 | -- * Using optics 55 | get, 56 | set, 57 | gets, 58 | setSwap, 59 | over, 60 | overU, 61 | reifyLens, 62 | withLens, 63 | 64 | -- * Constructing optics 65 | lens, 66 | ) 67 | where 68 | 69 | import Control.Optics.Linear.Internal 70 | -------------------------------------------------------------------------------- /src/Prelude/Linear/Unsatisfiable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE EmptyCase #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE UndecidableSuperClasses #-} 9 | 10 | -- | An ergonomic class for unsatisfiable constraints. This is based on 11 | -- the @trivial-constraint@ package and the 12 | -- 13 | -- Once that proposal is implemented, we can use it. 14 | module Prelude.Linear.Unsatisfiable 15 | ( Unsatisfiable, 16 | unsatisfiable, 17 | Bottom, 18 | ) 19 | where 20 | 21 | import Data.Void 22 | import GHC.Exts (Any, TYPE) 23 | import GHC.TypeLits (ErrorMessage, TypeError) 24 | 25 | -- The 'Any' constraint prevents anyone from instantiating 'Bottom' with 26 | -- unsatisfiable' = undefined if they don't understand what it's for. 27 | 28 | -- | A constraint that cannot be satisfied. Users should normally use 29 | -- 'Unsatisfiable' instead of using this class directly. 30 | class (Any) => Bottom where 31 | unsatisfiable' :: Void 32 | 33 | -- | An unsatisfiable constraint with a user-provided error message. Under an 34 | -- @Unsatisfiable@ constraint, users can use 'unsatisfiable' to get a value of 35 | -- any type (and runtime representation) they desire. For example, 36 | -- 37 | -- @ 38 | -- instance Unsatisfiable 39 | -- (\'Text \"V1 cannot have an Applicative instance because it cannot implement pure\") 40 | -- => Applicative V1 where 41 | -- pure = unsatisfiable 42 | -- (<*>) = unsatisfiable 43 | -- @ 44 | class (Bottom, TypeError e) => Unsatisfiable (e :: ErrorMessage) 45 | 46 | -- | Produce a value of any type (and runtime representation) under 47 | -- an 'Unsatisfiable' or 'Bottom' constraint. 48 | unsatisfiable :: forall {rep} (a :: TYPE rep). (Bottom) => a 49 | unsatisfiable = case unsatisfiable' of {} 50 | -------------------------------------------------------------------------------- /src/Data/Unrestricted/Linear/Internal/UrT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | 4 | -- | `UrT` creates non-linear monads from linear monads. 5 | -- The effect of @UrT m@ is the same as the effect of @m@ with the same linearity. 6 | -- It's just that the @a@ in @m a@ must be used linearly, but the @a@ in @UrT m a@ can be used unrestricted. 7 | -- Since @UrT@ is a regular monad it can be used with the regular do-notation. 8 | -- 9 | -- A good use case is when you have a linear resource, then you can use @UrT (`Linear.State` s) a@ 10 | -- to manipulate the resource linearly with regular do-notation. 11 | module Data.Unrestricted.Linear.Internal.UrT 12 | ( UrT (..), 13 | runUrT, 14 | liftUrT, 15 | evalUrT, 16 | ) 17 | where 18 | 19 | import qualified Control.Functor.Linear as Linear 20 | import Data.Unrestricted.Linear.Internal.Movable 21 | import Data.Unrestricted.Linear.Internal.Ur 22 | 23 | -- | @UrT@ transforms linear control monads to non-linear monads. 24 | -- 25 | -- * @UrT (`Linear.State` s) a@ is a non-linear monad with linear state. 26 | newtype UrT m a = UrT (m (Ur a)) 27 | 28 | -- | Linearly unwrap the @UrT@ newtype wrapper. 29 | runUrT :: UrT m a %1 -> m (Ur a) 30 | runUrT (UrT ma) = ma 31 | 32 | instance (Linear.Functor m) => Functor (UrT m) where 33 | fmap f (UrT ma) = UrT (Linear.fmap (\(Ur a) -> Ur (f a)) ma) 34 | 35 | instance (Linear.Applicative m) => Applicative (UrT m) where 36 | pure a = UrT (Linear.pure (Ur a)) 37 | UrT mf <*> UrT ma = UrT (Linear.liftA2 (\(Ur f) (Ur a) -> Ur (f a)) mf ma) 38 | 39 | instance (Linear.Monad m) => Monad (UrT m) where 40 | UrT ma >>= f = UrT (ma Linear.>>= (\(Ur a) -> case f a of (UrT mb) -> mb)) 41 | 42 | -- | Lift a computation to the @UrT@ monad, provided that the type @a@ can be used unrestricted. 43 | liftUrT :: (Movable a, Linear.Functor m) => m a %1 -> UrT m a 44 | liftUrT ma = UrT (Linear.fmap move ma) 45 | 46 | -- | Extract the inner computation linearly, the inverse of `liftUrT`. 47 | -- 48 | -- > evalUrT (liftUrT m) = m 49 | evalUrT :: (Linear.Functor m) => UrT m a %1 -> m a 50 | evalUrT u = Linear.fmap unur (runUrT u) 51 | -------------------------------------------------------------------------------- /src/System/IO/Resource/Linear.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines an IO monad for linearly working with system resources 2 | -- like files. It provides tools to take resources that are currently 3 | -- unsafely accessible from "System.IO" and use them in this monad. 4 | -- 5 | -- Import this module qualified to avoid name clashes. 6 | -- 7 | -- To use this RIO monad, create some @RIO@ computation, 8 | -- run it to get a "System.IO" computation. 9 | -- 10 | -- = A simple example 11 | -- >>> :set -XLinearTypes 12 | -- >>> :set -XQualifiedDo 13 | -- >>> :set -XNoImplicitPrelude 14 | -- >>> import qualified System.IO.Resource.Linear as Linear 15 | -- >>> import qualified Control.Functor.Linear as Control 16 | -- >>> import qualified Data.Text as Text 17 | -- >>> import Prelude.Linear 18 | -- >>> import qualified Prelude 19 | -- >>> :{ 20 | -- linearWriteToFile :: IO () 21 | -- linearWriteToFile = Linear.run $ Control.do 22 | -- handle1 <- Linear.openFile "/home/user/test.txt" Linear.WriteMode 23 | -- handle2 <- Linear.hPutStrLn handle1 (Text.pack "hello there") 24 | -- () <- Linear.hClose handle2 25 | -- Control.return (Ur ()) 26 | -- :} 27 | -- 28 | -- To enable do notation, `QualifiedDo` extension is used. But since QualifiedDo 29 | -- only modifies the desugaring of binds, we still need to qualify `Control.return`. 30 | module System.IO.Resource.Linear 31 | ( -- * The Resource I/O Monad 32 | RIO, 33 | run, 34 | 35 | -- * Using Resource Handles 36 | -- $monad 37 | -- $files 38 | Handle, 39 | 40 | -- ** File I/O 41 | openFile, 42 | openBinaryFile, 43 | System.IOMode (..), 44 | 45 | -- ** Working with Handles 46 | hClose, 47 | hIsEOF, 48 | hGetChar, 49 | hPutChar, 50 | hGetLine, 51 | hPutStr, 52 | hPutStrLn, 53 | hSeek, 54 | System.SeekMode (..), 55 | hTell, 56 | 57 | -- * Creating new types of resources 58 | -- $new-resources 59 | Resource, 60 | release, 61 | unsafeAcquire, 62 | unsafeFromSystemIOResource, 63 | unsafeFromSystemIOResource_, 64 | 65 | -- * Deprecated symbols 66 | UnsafeResource, 67 | unsafeRelease, 68 | ) 69 | where 70 | 71 | import qualified System.IO as System 72 | import System.IO.Resource.Linear.Internal 73 | -------------------------------------------------------------------------------- /test/Test/Data/Destination.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Test.Data.Destination (destArrayTests) where 5 | 6 | import qualified Data.Array.Destination as DArray 7 | import qualified Data.Vector as Vector 8 | import Hedgehog 9 | import qualified Hedgehog.Gen as Gen 10 | import qualified Hedgehog.Range as Range 11 | import Prelude.Linear 12 | import Test.Tasty 13 | import Test.Tasty.Hedgehog (testPropertyNamed) 14 | import qualified Prelude 15 | 16 | -- # Tests and Utlities 17 | ------------------------------------------------------------------------------- 18 | 19 | destArrayTests :: TestTree 20 | destArrayTests = 21 | testGroup 22 | "Destination array tests" 23 | [ testPropertyNamed "alloc . mirror = id" "roundTrip" roundTrip, 24 | testPropertyNamed "alloc . replicate = V.replicate" "replicateTest" replicateTest, 25 | testPropertyNamed "alloc . fill = V.singleton" "fillTest" fillTest, 26 | testPropertyNamed "alloc n . fromFunction (+s) = V.fromEnum n s" "fromFuncEnum" fromFuncEnum 27 | ] 28 | 29 | list :: Gen [Int] 30 | list = Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 100)) 31 | 32 | randInt :: Gen Int 33 | randInt = Gen.int (Range.linear (-500) 500) 34 | 35 | randNonnegInt :: Gen Int 36 | randNonnegInt = Gen.int (Range.linear 0 500) 37 | 38 | -- # Properties 39 | ------------------------------------------------------------------------------- 40 | 41 | roundTrip :: Property 42 | roundTrip = property Prelude.$ do 43 | xs <- forAll list 44 | let v = Vector.fromList xs 45 | let n = Vector.length v 46 | v === DArray.alloc n (DArray.mirror v id) 47 | 48 | replicateTest :: Property 49 | replicateTest = property Prelude.$ do 50 | n <- forAll randNonnegInt 51 | x <- forAll randInt 52 | let v = Vector.replicate n x 53 | v === DArray.alloc n (DArray.replicate x) 54 | 55 | fillTest :: Property 56 | fillTest = property Prelude.$ do 57 | x <- forAll randInt 58 | let v = Vector.singleton x 59 | v === DArray.alloc 1 (DArray.fill x) 60 | 61 | fromFuncEnum :: Property 62 | fromFuncEnum = property Prelude.$ do 63 | n <- forAll randNonnegInt 64 | start <- forAll randInt 65 | let v = Vector.enumFromN start n 66 | v === DArray.alloc n (DArray.fromFunction (Prelude.+ start)) 67 | -------------------------------------------------------------------------------- /src/Control/Optics/Linear/Prism.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides linear prisms. 2 | -- 3 | -- A @Prism s t a b@ is equivalent to @(s %1-> Either a t, b %1-> t)@ for some 4 | -- /sum type/ @s@. In the non-polymorphic version, this is a @(s %1-> Either a 5 | -- s, a %1-> s)@ which represents taking one case of a sum type and a way to 6 | -- build the sum-type given that one case. A prism is a traversal focusing on 7 | -- one branch or case that a sum type could be. 8 | -- 9 | -- = Example 10 | -- 11 | -- @ 12 | -- {-# LANGUAGE LinearTypes #-} 13 | -- {-# LANGUAGE LambdaCase #-} 14 | -- {-# LANGUAGE FlexibleContexts #-} 15 | -- {-# LANGUAGE NoImplicitPrelude #-} 16 | -- {-# LANGUAGE GADTs #-} 17 | -- 18 | -- import Control.Optics.Linear.Internal 19 | -- import Prelude.Linear 20 | -- import qualified Data.Functor.Linear as Data 21 | -- 22 | -- -- We can use a prism to do operations on one branch of a sum-type 23 | -- -- (This is a bit of a toy example since we could use @over@ for this.) 24 | -- formatLicenceName :: PersonId %1-> PersonId 25 | -- formatLicenceName personId = 26 | -- case Data.fmap modLisc (match pIdLiscPrism personId) of 27 | -- Left personId' -> personId' 28 | -- Right lisc -> build pIdLiscPrism lisc 29 | -- where 30 | -- modLisc :: Licence %1-> Licence 31 | -- modLisc (Licence nm x) = Licence (nm ++ "\n") x 32 | -- 33 | -- data PersonId where 34 | -- IdLicence :: Licence %1-> PersonId 35 | -- SSN :: Int %1-> PersonId 36 | -- BirthCertif :: String %1-> PersonId 37 | -- -- And there could be many more constructors ... 38 | -- 39 | -- -- A Licence is a name and number 40 | -- data Licence = Licence String Int 41 | -- 42 | -- pIdLiscPrism :: Prism' PersonId Licence 43 | -- pIdLiscPrism = prism IdLicence decompose where 44 | -- decompose :: PersonId %1-> Either PersonId Licence 45 | -- decompose (IdLicence l) = Right l 46 | -- decompose x = Left x 47 | -- @ 48 | module Control.Optics.Linear.Prism 49 | ( -- * Types 50 | Prism, 51 | Prism', 52 | 53 | -- * Composing optics 54 | (.>), 55 | 56 | -- * Common optics 57 | _Left, 58 | _Right, 59 | _Just, 60 | _Nothing, 61 | 62 | -- * Using optics 63 | match, 64 | build, 65 | withPrism, 66 | 67 | -- * Constructing optics 68 | prism, 69 | ) 70 | where 71 | 72 | import Control.Optics.Linear.Internal 73 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Linear/Internal/SymmetricMonoidal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# OPTIONS_HADDOCK hide #-} 7 | 8 | module Data.Bifunctor.Linear.Internal.SymmetricMonoidal 9 | ( SymmetricMonoidal (..), 10 | ) 11 | where 12 | 13 | import Data.Bifunctor.Linear.Internal.Bifunctor 14 | import Data.Kind (Type) 15 | import Data.Void 16 | import Prelude.Linear 17 | 18 | -- | A SymmetricMonoidal class 19 | -- 20 | -- This allows you to shuffle around a bifunctor nested in itself and swap the 21 | -- places of the two types held in the bifunctor. For instance, for tuples: 22 | -- 23 | -- * You can use @lassoc :: (a,(b,c)) %1-> ((a,b),c)@ and then use 'first' to access the @a@ 24 | -- * You can use the dual, i.e., @ rassoc :: ((a,b),c) %1-> (a,(b,c))@ and then 'second' 25 | -- * You can swap the first and second values with @swap :: (a,b) %1-> (b,a)@ 26 | -- 27 | -- == Laws 28 | -- 29 | -- * @swap . swap = id@ 30 | -- * @rassoc . lassoc = id@ 31 | -- * @lassoc . rassoc = id@ 32 | -- * @second swap . rassoc . first swap = rassoc . swap . rassoc@ 33 | class 34 | (Bifunctor m) => 35 | SymmetricMonoidal (m :: Type -> Type -> Type) (u :: Type) 36 | | m -> u, 37 | u -> m 38 | where 39 | {-# MINIMAL swap, (rassoc | lassoc) #-} 40 | rassoc :: (a `m` b) `m` c %1 -> a `m` (b `m` c) 41 | rassoc = swap . lassoc . swap . lassoc . swap 42 | lassoc :: a `m` (b `m` c) %1 -> (a `m` b) `m` c 43 | lassoc = swap . rassoc . swap . rassoc . swap 44 | swap :: a `m` b %1 -> b `m` a 45 | 46 | -- XXX: should unitors be added? 47 | -- XXX: Laws don't seem minimial 48 | 49 | -- # Instances 50 | ------------------------------------------------------------------------------- 51 | 52 | instance SymmetricMonoidal (,) () where 53 | swap (x, y) = (y, x) 54 | rassoc ((x, y), z) = (x, (y, z)) 55 | 56 | instance SymmetricMonoidal Either Void where 57 | swap = either Right Left 58 | rassoc (Left (Left x)) = Left x 59 | rassoc (Left (Right x)) = (Right :: a %1 -> Either b a) (Left x) 60 | rassoc (Right x) = (Right :: a %1 -> Either b a) (Right x) 61 | 62 | -- XXX: the above type signatures are necessary for certain older versions of 63 | -- the compiler, and as such are temporary 64 | -------------------------------------------------------------------------------- /src/Data/Either/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LinearTypes #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | 5 | -- | This module contains useful functions for working with 'Either's. 6 | module Data.Either.Linear 7 | ( Either (..), 8 | either, 9 | lefts, 10 | rights, 11 | fromLeft, 12 | fromRight, 13 | partitionEithers, 14 | ) 15 | where 16 | 17 | import Data.Unrestricted.Linear 18 | import Prelude (Either (..)) 19 | 20 | -- XXX Design Notes 21 | -- Functions like isLeft do not make sense in a linear program. 22 | -------------------------------------------------------------------------------- 23 | 24 | -- | Linearly consume an @Either@ by applying the first linear function on a 25 | -- value constructed with @Left@ and the second linear function on a value 26 | -- constructed with @Right@. 27 | either :: (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c 28 | either f _ (Left x) = f x 29 | either _ g (Right y) = g y 30 | 31 | -- | Get all the left elements in order, and consume the right ones. 32 | lefts :: (Consumable b) => [Either a b] %1 -> [a] 33 | lefts [] = [] 34 | lefts (Left a : xs) = a : lefts xs 35 | lefts (Right b : xs) = lseq b (lefts xs) 36 | 37 | -- | Get all the right elements in order, and consume the left ones. 38 | rights :: (Consumable a) => [Either a b] %1 -> [b] 39 | rights [] = [] 40 | rights (Left a : xs) = lseq a (rights xs) 41 | rights (Right b : xs) = b : rights xs 42 | 43 | -- | Get the left element of a consumable @Either@ with a default 44 | fromLeft :: (Consumable a, Consumable b) => a %1 -> Either a b %1 -> a 45 | fromLeft x (Left a) = lseq x a 46 | fromLeft x (Right b) = lseq b x 47 | 48 | -- | Get the right element of a consumable @Either@ with a default 49 | fromRight :: (Consumable a, Consumable b) => b %1 -> Either a b %1 -> b 50 | fromRight x (Left a) = lseq a x 51 | fromRight x (Right b) = lseq x b 52 | 53 | -- | Partition and consume a list of @Either@s into two lists with all the 54 | -- lefts in one and the rights in the second, in the order they appeared in the 55 | -- initial list. 56 | partitionEithers :: [Either a b] %1 -> ([a], [b]) 57 | partitionEithers [] = ([], []) 58 | partitionEithers (x : xs) = fromRecur x (partitionEithers xs) 59 | where 60 | fromRecur :: Either a b %1 -> ([a], [b]) %1 -> ([a], [b]) 61 | fromRecur (Left a) (as, bs) = (a : as, bs) 62 | fromRecur (Right b) (as, bs) = (as, b : bs) 63 | -------------------------------------------------------------------------------- /src/Data/Array/Polarized/Pull.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | This module provides pull arrays. 5 | -- 6 | -- These are part of a larger framework for controlling when memory is 7 | -- allocated for an array. See @Data.Array.Polarized@. 8 | module Data.Array.Polarized.Pull 9 | ( Array, 10 | 11 | -- * Construction 12 | fromFunction, 13 | fromVector, 14 | make, 15 | singleton, 16 | empty, 17 | 18 | -- * Consumption 19 | toVector, 20 | asList, 21 | 22 | -- * Operations 23 | zip, 24 | zipWith, 25 | append, 26 | foldr, 27 | foldMap, 28 | findLength, 29 | split, 30 | reverse, 31 | uncons, 32 | ) 33 | where 34 | 35 | import Data.Array.Polarized.Pull.Internal 36 | -- XXX: the data constructor Pull.Array could be used unsafely, so we don't 37 | -- export it, instead exporting a collection of functions to manipulate 38 | -- PullArrays 39 | -- (eg one could use an element multiple times, if the constructor was 40 | -- available) 41 | -- TODO: the current collection is almost certainly not complete: it would be 42 | -- nice if there was one (or a small number) of functions which characterise 43 | -- PullArrays, but I'm not sure what they are 44 | -- In particular, PullArrays are incredibly unfriendly in returned-value 45 | -- position at the moment, moreso than they should be 46 | import qualified Data.Functor.Linear as Data 47 | import Data.Vector (Vector) 48 | import qualified Data.Vector as Vector 49 | import Prelude.Linear hiding (foldMap, foldr, reverse, uncons, zip, zipWith) 50 | import qualified Unsafe.Linear as Unsafe 51 | 52 | -- | Convert a pull array into a list. 53 | asList :: Array a %1 -> [a] 54 | asList = foldr (\x xs -> x : xs) [] 55 | 56 | -- | @zipWith f [x1,x2,...,xn] [y1,y2,...,yn] = [f x1 y1, ..., f xn yn]@ 57 | -- __Partial:__ `zipWith f [x1,x2,...,xn] [y1,y2,...,yp]` is an error 58 | -- if @n ≠ p@. 59 | zipWith :: (a %1 -> b %1 -> c) -> Array a %1 -> Array b %1 -> Array c 60 | zipWith f x y = Data.fmap (uncurry f) (zip x y) 61 | 62 | -- | Fold a pull array using a monoid. 63 | foldMap :: (Monoid m) => (a %1 -> m) -> Array a %1 -> m 64 | foldMap f = foldr ((<>) . f) mempty 65 | 66 | -- I'm fairly sure this can be used safely 67 | 68 | -- | Convert a Vector to a pull array. 69 | fromVector :: Vector a %1 -> Array a 70 | fromVector = Unsafe.toLinear $ \v -> fromFunction (v Vector.!) (Vector.length v) 71 | -------------------------------------------------------------------------------- /test/Test/Data/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Test.Data.List (listTests) where 5 | 6 | import qualified Data.List.Linear as List 7 | import qualified Data.Num.Linear as Num 8 | import Hedgehog 9 | import qualified Hedgehog.Gen as Gen 10 | import qualified Hedgehog.Range as Range 11 | import Prelude.Linear 12 | import Test.Tasty 13 | import Test.Tasty.Hedgehog (testPropertyNamed) 14 | import qualified Prelude 15 | 16 | listTests :: TestTree 17 | listTests = 18 | testGroup 19 | "List tests" 20 | [ testPropertyNamed "take n ++ drop n = id" "take_drop" take_drop, 21 | testPropertyNamed "length . take n = const n" "take_length" take_length, 22 | testPropertyNamed "zipWith is lazy" "zipWith_lazy" zipWith_lazy, 23 | testPropertyNamed "zipWith3 is lazy" "zipWith3_lazy" zipWith3_lazy 24 | ] 25 | 26 | take_drop :: Property 27 | take_drop = property $ do 28 | n <- forAll $ Gen.int (Range.linear 0 50) 29 | classify "0" $ n == 0 30 | xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 40)) 31 | classify "length > n" $ Prelude.length xs > n 32 | List.take n xs ++ List.drop n xs === xs 33 | 34 | take_length :: Property 35 | take_length = property $ do 36 | n <- forAll $ Gen.int (Range.linear 0 50) 37 | classify "0" $ n == 0 38 | xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 40)) 39 | classify "length > n" $ Prelude.length xs > n 40 | case Prelude.length xs > n of 41 | True -> do 42 | annotate "Prelude.length xs > n" 43 | Prelude.length (List.take n xs) === n 44 | False -> do 45 | annotate "Prelude.length xs < n" 46 | Prelude.length (List.take n xs) === Prelude.length xs 47 | 48 | zipWith_lazy :: Property 49 | zipWith_lazy = property $ do 50 | lgth <- forAll $ Gen.word (Range.linear 0 50) 51 | _ <- eval $ Prelude.head (xs lgth) 52 | Prelude.return () 53 | where 54 | xs :: Word -> [Word] 55 | xs lgth = List.zipWith (Num.+) (0 : error "bottom") [0 .. lgth] 56 | 57 | zipWith3_lazy :: Property 58 | zipWith3_lazy = property $ do 59 | lgth1 <- forAll $ Gen.word (Range.linear 0 50) 60 | lgth2 <- forAll $ Gen.word (Range.linear 0 50) 61 | _ <- eval $ Prelude.head (xs lgth1 lgth2) 62 | Prelude.return () 63 | where 64 | xs :: Word -> Word -> [Word] 65 | xs lgth1 lgth2 = List.zipWith3 (\x y z -> x Num.+ y Num.+ z) (0 : error "bottom") [0 .. lgth1] [0 .. lgth2] 66 | -------------------------------------------------------------------------------- /src/Data/V/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | This module defines vectors of known length which can hold linear values. 5 | -- 6 | -- Having a known length matters with linear types, because many common vector 7 | -- operations (like zip) are not total with linear types. 8 | -- 9 | -- Make these vectors by giving any finite number of arguments to 'make' 10 | -- and use them with 'elim': 11 | -- 12 | -- >>> :set -XLinearTypes 13 | -- >>> :set -XTypeApplications 14 | -- >>> :set -XDataKinds 15 | -- >>> :set -XTypeFamilies 16 | -- >>> import Prelude.Linear 17 | -- >>> import qualified Data.V.Linear as V 18 | -- >>> :{ 19 | -- doSomething :: Int %1-> Int %1-> Bool 20 | -- doSomething x y = x + y > 0 21 | -- :} 22 | -- 23 | -- >>> :{ 24 | -- isTrue :: Bool 25 | -- isTrue = V.elim doSomething (build 4 9) 26 | -- where 27 | -- build :: Int %1-> Int %1-> V.V 2 Int 28 | -- build = V.make 29 | -- :} 30 | -- 31 | -- A much more expensive library of vectors of known size (including matrices 32 | -- and tensors of all dimensions) is the [@linear@ library on 33 | -- Hackage](https://hackage.haskell.org/package/linear) (that's /linear/ in the 34 | -- sense of [linear algebra](https://en.wikipedia.org/wiki/Linear_algebra), 35 | -- rather than linear types). 36 | module Data.V.Linear 37 | ( V, 38 | empty, 39 | consume, 40 | map, 41 | pure, 42 | (<*>), 43 | uncons#, 44 | uncons, 45 | Elim, 46 | elim, 47 | cons, 48 | fromReplicator, 49 | dupV, 50 | theLength, 51 | Make, 52 | make, 53 | 54 | -- * Type-level helpers for staging 55 | ArityV, 56 | ) 57 | where 58 | 59 | import Data.V.Linear.Internal 60 | import Data.V.Linear.Internal.Instances () 61 | 62 | {- Developers Note 63 | 64 | To avoid a common circular dependence, we moved the data type to 65 | Data.V.Internal.Linear.V and moved the instances here. The common import issue 66 | is as follows. Dupable depends on @V@ yet the instances of @V@ depend on 67 | a variety of things (data functors, control functors, traversable) which 68 | often end up depending on dupable. By moving the instances here, we 69 | can make sure that Data.Unrestricted.Linear.Internal.Dupable only depends on the data 70 | type defintion in Data.V.Linear.V and does not require any of the dependencies 71 | of the instances. 72 | 73 | Remark: ideally the instances below would be in an internal `Instances` 74 | module. But we haven't got around to it yet. 75 | -} 76 | -------------------------------------------------------------------------------- /src/Control/Optics/Linear/Traversal.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides linear traversals. 2 | -- 3 | -- Traversals provides a means of accessing several @a@s organized in some 4 | -- structural way in an @s@, and a means of changing them to @b@s to create a 5 | -- @t@. In very ordinary language, it's like walking or traversing the data 6 | -- structure, going across cases and inside definitions. In more imaginative 7 | -- language, it's like selecting some specific @a@s by looking at each 8 | -- constructor of a data definition and recursing on each non-basic type 9 | -- (where basic types are things like @Int@, @Bool@ or @Char@). 10 | -- 11 | -- = Example 12 | -- 13 | -- @ 14 | -- {-# LANGUAGE LinearTypes #-} 15 | -- {-# LANGUAGE NoImplicitPrelude #-} 16 | -- {-# LANGUAGE RankNTypes #-} 17 | -- {-# LANGUAGE GADTs #-} 18 | -- 19 | -- import Control.Optics.Linear.Internal 20 | -- import qualified Control.Functor.Linear as Control 21 | -- import Control.Functor.Linear ((<$>), (<*>), pure) 22 | -- import Prelude.Linear 23 | -- 24 | -- -- We can use a traversal to append a string only to the 25 | -- -- human names in a classroom struct 26 | -- appendToNames :: String -> Classroom %1-> Classroom 27 | -- appendToNames s = over classroomNamesTrav (\name -> name ++ s) 28 | -- 29 | -- data Classroom where 30 | -- Classroom :: 31 | -- { className :: String 32 | -- , teacherName :: String 33 | -- , classNum :: Int 34 | -- , students :: [Student] 35 | -- , textbooks :: [String] 36 | -- } %1-> Classroom 37 | -- 38 | -- -- A Student is a name and a student id number 39 | -- data Student = Student String Int 40 | -- 41 | -- classroomNamesTrav :: Traversal' Classroom String 42 | -- classroomNamesTrav = traversal traverseClassStr where 43 | -- traverseClassStr :: forall f. Control.Applicative f => 44 | -- (String %1-> f String) -> Classroom %1-> f Classroom 45 | -- traverseClassStr onName (Classroom cname teachname x students texts) = 46 | -- Classroom <$> 47 | -- pure cname <*> 48 | -- onName teachname <*> 49 | -- pure x <*> 50 | -- traverse' (\(Student s i) -> Student <$> onName s <*> pure i) students <*> 51 | -- pure texts 52 | -- @ 53 | module Control.Optics.Linear.Traversal 54 | ( -- * Types 55 | Traversal, 56 | Traversal', 57 | 58 | -- * Composing optics 59 | (.>), 60 | 61 | -- * Common optics 62 | traversed, 63 | 64 | -- * Using optics 65 | over, 66 | overU, 67 | traverseOf, 68 | traverseOfU, 69 | 70 | -- * Constructing optics 71 | traversal, 72 | ) 73 | where 74 | 75 | import Control.Optics.Linear.Internal 76 | -------------------------------------------------------------------------------- /src/Foreign/Marshal/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | -- | This module introduces primitives to /safely/ allocate and discard system 4 | -- heap memory (/not GC heap memory/) for storing values /explicitly/. 5 | -- (Basically, a haskell program has a GC that at runtime, manages its own heap 6 | -- by freeing and allocating space from the system heap.) Values discarded 7 | -- explicitly don't need to be managed by the garbage collector (GC), which 8 | -- therefore has less work to do. Less work for the GC can sometimes mean more 9 | -- predictable request latencies in multi-threaded and distributed 10 | -- applications. 11 | -- 12 | -- This module is meant to be imported qualified. 13 | -- 14 | -- == The Interface 15 | -- 16 | -- Run a computation that uses heap memory by passing a continuation to 17 | -- 'withPool' of type @Pool %1-> Ur b@. Allocate and free with 18 | -- 'alloc' and 'deconstruct'. Make as many or as few pools you need, by 19 | -- using the 'Dupable' and 'Consumable' instances of 'Pool'. 20 | -- 21 | -- A toy example: 22 | -- 23 | -- >>> :set -XLinearTypes 24 | -- >>> import Prelude 25 | -- >>> import Data.Unrestricted.Linear 26 | -- >>> import qualified Foreign.Marshal.Pure as Manual 27 | -- >>> :{ 28 | -- nothingWith3 :: Pool %1-> Ur Int 29 | -- nothingWith3 pool = move (Manual.deconstruct (Manual.alloc 3 pool)) 30 | -- :} 31 | -- 32 | -- >>> unur (Manual.withPool nothingWith3) 33 | -- 3 34 | -- 35 | -- 36 | -- === What are 'Pool's? 37 | -- 38 | -- 'Pool's are memory pools from which a user can safely allocate and use 39 | -- heap memory manually by passing 'withPool' a continuation. 40 | -- An alternative design would have allowed passing continuations to 41 | -- allocation functions but this could break tail-recursion in certain cases. 42 | -- 43 | -- Pools play another role: resilience to exceptions. If an exception is raised, 44 | -- all the data in the pool is deallocated. 45 | -- 46 | -- Note that data from one pool can refer to data in another pool and vice 47 | -- versa. 48 | -- 49 | -- == Large Examples 50 | -- 51 | -- You can find example data structure implementations in @Foreign.List@ and 52 | -- @Foreign.Heap@ [here](https://github.com/tweag/linear-base/tree/master/examples/Foreign). 53 | module Foreign.Marshal.Pure 54 | ( -- * Allocating and using values on the heap 55 | Pool, 56 | withPool, 57 | Box, 58 | alloc, 59 | deconstruct, 60 | 61 | -- * Typeclasses for values that can be allocated 62 | KnownRepresentable, 63 | Representable (..), 64 | MkRepresentable (..), 65 | ) 66 | where 67 | 68 | import Foreign.Marshal.Pure.Internal 69 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | # All built-in hints 9 | - warn: {name: "Use LANGUAGE pragmas"} 10 | - warn: {name: "Use fewer LANGUAGE pragmas"} 11 | - warn: {name: "Unused LANGUAGE pragma"} 12 | - warn: {name: "Missing NOINLINE pragma"} 13 | - warn: {name: "Fix pragma markup"} 14 | - warn: {name: "Use pragma syntax"} 15 | 16 | - ignore: {name: "Move guards forward"} 17 | - ignore: {name: "Move map inside list comprehension"} 18 | - ignore: {name: "Redundant True guards"} 19 | - ignore: {name: "Short-circuited list comprehension"} 20 | - ignore: {name: "Use :"} 21 | - ignore: {name: "Use String"} 22 | - ignore: {name: "Use list literal"} 23 | - ignore: {name: "Use list literal pattern"} 24 | - ignore: {name: "Use foldM"} 25 | - ignore: {name: "Use foldl"} 26 | - ignore: {name: "Use foldr"} 27 | - ignore: {name: "Use map"} 28 | - ignore: {name: "Redundant do"} 29 | - ignore: {name: "Redundant return"} 30 | - ignore: {name: "Redundant variable capture"} 31 | - ignore: {name: "Redundant void"} 32 | - ignore: {name: "Use <$>"} 33 | - ignore: {name: "Use foldM_"} 34 | - ignore: {name: "Use forM_"} 35 | - ignore: {name: "Use join"} 36 | - ignore: {name: "Use let"} 37 | - ignore: {name: "Use mapM_"} 38 | - ignore: {name: "Avoid lambda"} 39 | - ignore: {name: "Avoid lambda"} 40 | - ignore: {name: "Avoid lambda using `infix`"} 41 | - ignore: {name: "Collapse lambdas"} 42 | - ignore: {name: "Eta reduce"} 43 | - ignore: {name: "Redundant lambda"} 44 | - ignore: {name: "Use lambda"} 45 | - ignore: {name: "Use lambda-case"} 46 | - ignore: {name: "Use section"} 47 | - ignore: {name: "Use tuple-section"} 48 | - ignore: {name: "Redundant bracket due to operator fixities"} 49 | - ignore: {name: "Move brackets to avoid $"} 50 | - ignore: {name: "Redundant $"} 51 | - ignore: {name: "Redundant bracket"} 52 | - ignore: {name: "Redundant bracket"} 53 | - ignore: {name: "Redundant section"} 54 | - ignore: {name: "Use camelCase"} 55 | - ignore: {name: "Redundant as-pattern"} 56 | - ignore: {name: "Redundant bang pattern"} 57 | - ignore: {name: "Redundant case"} 58 | - ignore: {name: "Redundant guard"} 59 | - ignore: {name: "Redundant irrefutable pattern"} 60 | - ignore: {name: "Redundant where"} 61 | - ignore: {name: "Use guards"} 62 | - ignore: {name: "Use otherwise"} 63 | - ignore: {name: "Use record patterns"} 64 | - ignore: {name: "Used otherwise as a pattern"} 65 | - ignore: {name: "Redundant as"} 66 | - ignore: {name: "Use fewer imports"} 67 | - ignore: {name: "Use explicit module export list"} 68 | - ignore: {name: "Use module export list"} 69 | - ignore: {name: "Use DerivingStrategies"} 70 | - ignore: {name: "Use newtype instead of data"} 71 | - ignore: {name: "Use underscore"} 72 | -------------------------------------------------------------------------------- /src/Data/Unrestricted/Linear.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides essential tools for doing non-linear things 2 | -- in linear code. 3 | -- 4 | -- = /Critical/ Definition: Restricted 5 | -- 6 | -- In a linear function @f :: a %1-> b@, the argument @a@ must 7 | -- be used in a linear way. Its use is __restricted__. By contrast, 8 | -- an argument in a non-linear function is __unrestricted__. 9 | -- 10 | -- Hence, a linear function with an argument of @Ur a@ (@Ur@ is short for 11 | -- /unrestricted/) can use the @a@ in an unrestricted way. That is, we have 12 | -- the following equivalence: 13 | -- 14 | -- @ 15 | -- (Ur a %1-> b) ≌ (a -> b) 16 | -- @ 17 | -- 18 | -- = Consumable, Dupable, Moveable classes 19 | -- 20 | -- Use these classes to perform some non-linear action on linearly bound values. 21 | -- 22 | -- If a type is 'Consumable', you can __consume__ it in a linear function that 23 | -- doesn't need that value to produce it's result: 24 | -- 25 | -- > fst :: Consumable b => (a,b) %1-> a 26 | -- > fst (a,b) = withConsume (consume b) a 27 | -- > where 28 | -- > withConsume :: () %1-> a %1-> a 29 | -- > withConsume () x = x 30 | -- 31 | -- If a type is 'Dupable', you can __duplicate__ it as much as you like. 32 | -- 33 | -- > -- checkIndex ix size_of_array 34 | -- > checkIndex :: Int %1-> Int %1-> Bool 35 | -- > checkIndex ix size = withDuplicate (dup2 ix) size 36 | -- > where 37 | -- > withDuplicate :: (Int, Int) %1-> Int %1-> Bool 38 | -- > withDuplicate (ix,ix') size = (0 <= ix) && (ix < size) 39 | -- > (<) :: Int %1-> Int %1-> Bool 40 | -- > (<) = ... 41 | -- > 42 | -- > (<=) :: Int %1-> Int %1-> Bool 43 | -- > (<=) = ... 44 | -- > 45 | -- > (&&) :: Bool %1-> Bool %1-> Bool 46 | -- > (&&) = ... 47 | -- 48 | -- If a type is 'Moveable', you can __move__ it inside 'Ur' 49 | -- and use it in any non-linear way you would like. 50 | -- 51 | -- > diverge :: Int %1-> Bool 52 | -- > diverge ix = fromMove (move ix) 53 | -- > where 54 | -- > fromMove :: Ur Int %1-> Bool 55 | -- > fromMove (Ur 0) = True 56 | -- > fromMove (Ur 1) = True 57 | -- > fromMove (Ur x) = False 58 | module Data.Unrestricted.Linear 59 | ( -- * Unrestricted 60 | Ur (..), 61 | unur, 62 | lift, 63 | lift2, 64 | UrT (..), 65 | runUrT, 66 | liftUrT, 67 | evalUrT, 68 | 69 | -- * Performing non-linear actions on linearly bound values 70 | Consumable (..), 71 | Dupable (..), 72 | Movable (..), 73 | lseq, 74 | dup, 75 | dup3, 76 | dup4, 77 | dup5, 78 | dup6, 79 | dup7, 80 | module Data.Unrestricted.Linear.Internal.Instances, 81 | ) 82 | where 83 | 84 | import Data.Unrestricted.Linear.Internal.Consumable 85 | import Data.Unrestricted.Linear.Internal.Dupable 86 | import Data.Unrestricted.Linear.Internal.Instances 87 | import Data.Unrestricted.Linear.Internal.Movable 88 | import Data.Unrestricted.Linear.Internal.Ur 89 | import Data.Unrestricted.Linear.Internal.UrT 90 | -------------------------------------------------------------------------------- /examples/Simple/Quicksort.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- Uncomment the line below to observe the generated (optimised) Core. It will 5 | -- land in a file named “Quicksort.dump-simpl” 6 | -- {-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all -dsuppress-uniques #-} 7 | 8 | -- | This module implements quicksort with mutable arrays from linear-base 9 | module Simple.Quicksort where 10 | 11 | import Data.Array.Mutable.Linear (Array) 12 | import qualified Data.Array.Mutable.Linear as Array 13 | import Data.Unrestricted.Linear 14 | import GHC.Stack 15 | import Prelude.Linear hiding (partition) 16 | 17 | -- # Quicksort 18 | ------------------------------------------------------------------------------- 19 | 20 | quicksortUsingList :: (Ord a) => [a] -> [a] 21 | quicksortUsingList [] = [] 22 | quicksortUsingList (x : xs) = quicksortUsingList ltx ++ x : quicksortUsingList gex 23 | where 24 | ltx = [y | y <- xs, y < x] 25 | gex = [y | y <- xs, y >= x] 26 | 27 | quicksortUsingArray :: (Ord a) => [a] -> [a] 28 | quicksortUsingArray xs = unur $ Array.fromList xs $ Array.toList . quicksortArray 29 | 30 | quicksortArray :: (Ord a) => Array a %1 -> Array a 31 | quicksortArray arr = 32 | Array.size arr 33 | & \(Ur len, arr1) -> go 0 (len - 1) arr1 34 | 35 | go :: (Ord a) => Int -> Int -> Array a %1 -> Array a 36 | go lo hi arr 37 | | lo >= hi = arr 38 | | otherwise = 39 | Array.read arr lo 40 | & \(Ur pivot, arr1) -> 41 | partition arr1 pivot lo hi 42 | & \(arr2, Ur ix) -> 43 | swap arr2 lo ix 44 | & \arr3 -> 45 | go lo (ix - 1) arr3 46 | & \arr4 -> go (ix + 1) hi arr4 47 | 48 | -- | @partition arr pivot lo hi = (arr', Ur ix)@ such that 49 | -- @arr'[i] <= pivot@ for @lo <= i <= ix@, 50 | -- @arr'[j] > pivot@ for @ix < j <= hi@, 51 | -- @arr'[k] = arr[k]@ for @k < lo@ and @k > hi@, and 52 | -- @arr'@ is a permutation of @arr@. 53 | partition :: (Ord a) => Array a %1 -> a -> Int -> Int -> (Array a, Ur Int) 54 | partition arr pivot lo hi 55 | | (hi < lo) = (arr, Ur (lo - 1)) 56 | | otherwise = 57 | Array.read arr lo 58 | & \(Ur lVal, arr1) -> 59 | Array.read arr1 hi 60 | & \(Ur rVal, arr2) -> case (lVal <= pivot, pivot < rVal) of 61 | (True, True) -> partition arr2 pivot (lo + 1) (hi - 1) 62 | (True, False) -> partition arr2 pivot (lo + 1) hi 63 | (False, True) -> partition arr2 pivot lo (hi - 1) 64 | (False, False) -> 65 | swap arr2 lo hi 66 | & \arr3 -> partition arr3 pivot (lo + 1) (hi - 1) 67 | 68 | -- | @swap a i j@ exchanges the positions of values at @i@ and @j@ of @a@. 69 | swap :: (HasCallStack) => Array a %1 -> Int -> Int -> Array a 70 | swap arr i j = 71 | Array.read arr i 72 | & \(Ur ival, arr1) -> 73 | Array.read arr1 j 74 | & \(Ur jval, arr2) -> (Array.set i jval . Array.set j ival) arr2 75 | -------------------------------------------------------------------------------- /src/Prelude/Linear/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE NoImplicitPrelude #-} 8 | -- TODO: Disabled while we still support GHC 9.2 to enable 9 | -- the import of the empty TypeEq module there. 10 | {-# OPTIONS_GHC -Wno-dodgy-exports -Wno-unused-imports #-} 11 | {-# OPTIONS_HADDOCK hide #-} 12 | 13 | -- | This is a very very simple prelude, which doesn't depend on anything else 14 | -- in the linear-base library. 15 | module Prelude.Linear.Internal 16 | ( module Prelude.Linear.Internal, 17 | module Prelude.Linear.Internal.TypeEq, 18 | ) 19 | where 20 | 21 | import Data.Coerce 22 | import Data.Functor.Identity 23 | import GHC.Exts (TYPE) 24 | import Prelude.Linear.Internal.TypeEq 25 | 26 | -- A note on implementation: to avoid silly mistakes, very easy functions are 27 | -- simply reimplemented here. For harder function, we reuse the Prelude 28 | -- definition and make an unsafe cast. 29 | 30 | ($) :: forall {rep} a (b :: TYPE rep) p q. (a %p -> b) %q -> a %p -> b 31 | ($) f x = f x 32 | 33 | infixr 0 $ -- same fixity as base.$ 34 | 35 | (&) :: forall {rep} a (b :: TYPE rep) p q. a %p -> (a %p -> b) %q -> b 36 | x & f = f x 37 | 38 | infixl 1 & -- same fixity as base.& 39 | 40 | id :: a %q -> a 41 | id x = x 42 | 43 | const :: a %q -> b -> a 44 | const x _ = x 45 | 46 | -- | @seq x y@ only forces @x@ to head normal form, therefore is not guaranteed 47 | -- to consume @x@ when the resulting computation is consumed. Therefore, @seq@ 48 | -- cannot be linear in it's first argument. 49 | seq :: a -> b %q -> b 50 | seq !_ y = y 51 | 52 | infixr 0 `seq` -- same fixity as base.seq 53 | 54 | ($!) :: forall {rep} a (b :: TYPE rep) p q. (a %p -> b) %q -> a %p -> b 55 | ($!) f !a = f a 56 | 57 | infixr 0 $! -- same fixity as base.$! 58 | 59 | curry :: ((a, b) %p -> c) %q -> a %p -> b %p -> c 60 | curry f x y = f (x, y) 61 | 62 | uncurry :: (a %p -> b %p -> c) %q -> (a, b) %p -> c 63 | uncurry f (x, y) = f x y 64 | 65 | -- | Beware: @(.)@ is not compatible with the standard one because it is 66 | -- higher-order and we don't have sufficient multiplicity polymorphism yet. 67 | (.) :: forall {rep} b (c :: TYPE rep) a q m n. (b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c 68 | f . g = \x -> f (g x) 69 | 70 | infixr 9 . -- same fixity as base.. 71 | 72 | -- | Convenience operator when a higher-order function expects a non-linear 73 | -- arrow but we have a linear arrow. 74 | forget :: forall {rep} a (b :: TYPE rep). (a %1 -> b) %1 -> a -> b 75 | forget f a = f a 76 | 77 | -- XXX: Temporary, until newtype record projections are linear. 78 | runIdentity' :: Identity a %p -> a 79 | runIdentity' (Identity x) = x 80 | 81 | -- | A linear version of 'Data.Coerce.coerce' for types of kind 'Data.Kind.Type'. 82 | lcoerce :: forall a b. (Coercible a b) => a %1 -> b 83 | lcoerce = coerce ((\x -> x) :: a %1 -> a) 84 | {-# INLINE CONLIKE lcoerce #-} 85 | -------------------------------------------------------------------------------- /src/Data/Set/Mutable/Linear/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LinearTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE StrictData #-} 7 | {-# LANGUAGE TupleSections #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 10 | {-# OPTIONS_HADDOCK hide #-} 11 | 12 | module Data.Set.Mutable.Linear.Internal where 13 | 14 | import qualified Data.HashMap.Mutable.Linear as Linear 15 | import Data.Monoid.Linear 16 | import Data.Unrestricted.Linear 17 | import qualified Prelude.Linear as Linear hiding (insert) 18 | import Prelude (Bool, Int) 19 | import qualified Prelude 20 | 21 | -- # Data Definitions 22 | ------------------------------------------------------------------------------- 23 | 24 | -- XXX This representation could be improved on with AVL trees, for example 25 | newtype Set a = Set (Linear.HashMap a ()) 26 | 27 | type Keyed a = Linear.Keyed a 28 | 29 | -- # Constructors and Mutators 30 | ------------------------------------------------------------------------------- 31 | 32 | empty :: (Keyed a, Movable b) => Int -> (Set a %1 -> b) %1 -> b 33 | empty s (f :: Set a %1 -> b) = 34 | Linear.empty s (\hm -> f (Set hm)) 35 | 36 | toList :: (Keyed a) => Set a %1 -> Ur [a] 37 | toList (Set hm) = 38 | Linear.toList hm 39 | Linear.& \(Ur xs) -> Ur (Prelude.map Prelude.fst xs) 40 | 41 | insert :: (Keyed a) => a -> Set a %1 -> Set a 42 | insert a (Set hmap) = Set (Linear.insert a () hmap) 43 | 44 | delete :: (Keyed a) => a -> Set a %1 -> Set a 45 | delete a (Set hmap) = Set (Linear.delete a hmap) 46 | 47 | union :: (Keyed a) => Set a %1 -> Set a %1 -> Set a 48 | union (Set hm1) (Set hm2) = 49 | Set (Linear.unionWith (\_ _ -> ()) hm1 hm2) 50 | 51 | intersection :: (Keyed a) => Set a %1 -> Set a %1 -> Set a 52 | intersection (Set hm1) (Set hm2) = 53 | Set (Linear.intersectionWith (\_ _ -> ()) hm1 hm2) 54 | 55 | -- # Accessors 56 | ------------------------------------------------------------------------------- 57 | 58 | size :: (Keyed a) => Set a %1 -> (Ur Int, Set a) 59 | size (Set hm) = 60 | Linear.size hm Linear.& \(s, hm') -> (s, Set hm') 61 | 62 | member :: (Keyed a) => a -> Set a %1 -> (Ur Bool, Set a) 63 | member a (Set hm) = 64 | Linear.member a hm Linear.& \(b, hm') -> (b, Set hm') 65 | 66 | fromList :: (Keyed a, Movable b) => [a] -> (Set a %1 -> b) %1 -> b 67 | fromList xs f = 68 | Linear.fromList (Prelude.map (,()) xs) (\hm -> f (Set hm)) 69 | 70 | -- # Typeclass Instances 71 | ------------------------------------------------------------------------------- 72 | 73 | instance Prelude.Semigroup (Set a) where 74 | (<>) = Prelude.error "Prelude.(<>): invariant violation, unrestricted Set" 75 | 76 | instance (Keyed a) => Semigroup (Set a) where 77 | (<>) = union 78 | 79 | instance Consumable (Set a) where 80 | consume (Set hmap) = consume hmap 81 | 82 | instance Dupable (Set a) where 83 | dup2 (Set hm) = 84 | dup2 hm Linear.& \(hm1, hm2) -> 85 | (Set hm1, Set hm2) 86 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | Thank you very much for your interest in this project! We welcome contributions from anyone, given that they follow the few rules below. 4 | 5 | A great first step is to join our 6 | [![Discord](https://img.shields.io/badge/Discord-100000?style=flat&logo=Discord&logoColor=C3C3C3&labelColor=4179DA&color=010101)][discord] server 7 | 8 | ## Pull Request Process 9 | 10 | - Feel free to open a draft PR to first discuss the high level changes you intend to make before going deep into the implementation 11 | - Make focused changes on a dedicated branch. Smaller code diff are easier to review, and that way you will get earlier feedback from the maintainers. 12 | - Do not bother with the changelog and version number of this project. Both will be addressed in a final PR from the maintainers just before a release. 13 | - A PR can contain several commits; they don't need to be squashed, but they must have an expressive enough title and have a meaning on their own. 14 | - When you get an approval after a PR review: 15 | - If you are a Tweager, you can press the Green Button 16 | - Otherwise, the maintainers team will promptly merge the PR 17 | 18 | ## Changelog editing 19 | 20 | Just before a release, the changelog needs to be edited by the maintainer team. To make the process easier, it is recommended to use [github-changelog-generator](https://github.com/github-changelog-generator/github-changelog-generator) that is available in `nixpkgs`: 21 | 22 | ```bash 23 | $ nix-shell -p github-changelog-generator 24 | ``` 25 | 26 | Then go on [this page](https://github.com/settings/tokens) and generate a personal access token with the following permissions: 27 | 28 | + `public_repo` 29 | + `repo:status` 30 | + `repo_deployment` 31 | 32 | Then create a config file `.github_changelog_generator`: 33 | 34 | ```text 35 | issues=true 36 | future-release=v?.?.? # eg: v0.1.1 37 | since-tag=v?.?.? # eg: v0.1.0 38 | user=tweag 39 | project=linear-base 40 | token= 41 | output=CHANGELOG-gen.md 42 | ``` 43 | 44 | and run 45 | 46 | ```bash 47 | [nix-shell]$ github_changelog_generator 48 | ``` 49 | 50 | You'll end with a file named `CHANGELOG-gen.md` that will list all the PRs and issues merged/closed since the last release. You then need to sort these entries into the following categories (most recent PR at the top of each category): 51 | 52 | ```markdown 53 | ### Breaking changes 54 | 55 | ### New additions 56 | 57 | ### Code improvements / Bug fixing 58 | 59 | ### CI/Tooling improvements 60 | 61 | ### Documentation improvements 62 | ``` 63 | 64 | - Only the closed issues that does not match a PR 1:1 needs to appear on this listing (e.g. a `tag:bug` issue that has been fixed by an unrelated PR) 65 | - It is recommended to edit the PR titles in the listing, and add a concise description for the most important ones (or when a single line of text is not enough to describe the changes). 66 | - You might group PRs that are related to the same feature (or when one PR is overridden by a following one) 67 | - In case of doubt, use the changelog for `v0.2.0` as a reference of how to edit the changelog 68 | 69 | [discord]: https://discord.com/invite/7yg5GxzvDJ 70 | -------------------------------------------------------------------------------- /src/Control/Functor/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | = The control functor hierarchy 5 | -- 6 | -- The functors in this module are called control functors, which 7 | -- are different from the data functors in @Data.Functor.Linear@. 8 | -- 9 | -- This distinction and the use-cases of each group of functors is explained in 10 | -- [this blog post](https://tweag.io/posts/2020-01-16-data-vs-control.html). 11 | module Control.Functor.Linear 12 | ( -- * Control functor hierarchy 13 | Functor (..), 14 | (<$>), 15 | (<&>), 16 | (<$), 17 | void, 18 | dataFmapDefault, 19 | Applicative (..), 20 | dataPureDefault, 21 | Monad (..), 22 | return, 23 | join, 24 | ap, 25 | foldM, 26 | MonadFail (..), 27 | Data (..), 28 | 29 | -- * Monad transformers 30 | 31 | -- ** ReaderT monad transformer 32 | -- $readerT 33 | Reader, 34 | reader, 35 | runReader, 36 | mapReader, 37 | withReader, 38 | ReaderT (..), 39 | runReaderT, 40 | mapReaderT, 41 | withReaderT, 42 | ask, 43 | local, 44 | asks, 45 | 46 | -- ** StateT monad 47 | -- $stateT 48 | State, 49 | state, 50 | runState, 51 | evalState, 52 | execState, 53 | mapState, 54 | withState, 55 | StateT (..), 56 | runStateT, 57 | evalStateT, 58 | execStateT, 59 | mapStateT, 60 | withStateT, 61 | get, 62 | put, 63 | modify, 64 | gets, 65 | MonadTrans (..), 66 | module Control.Functor.Linear.Internal.Instances, 67 | ) 68 | where 69 | 70 | import Control.Functor.Linear.Internal.Class 71 | import Control.Functor.Linear.Internal.Instances 72 | import Control.Functor.Linear.Internal.MonadTrans 73 | import Control.Functor.Linear.Internal.Reader 74 | import Control.Functor.Linear.Internal.State 75 | 76 | -- $readerT 77 | -- See [here](https://mmhaskell.com/monads/reader-writer) to learn about 78 | -- the basics of reader monads. To know about the standard reader monad 79 | -- functions, see the documentation of the standard reader monad 80 | -- [here](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader.html). 81 | 82 | -- $stateT 83 | -- This is a linear version of the standard state monad. 84 | -- The linear arrows ensure that the state is threaded linearly through 85 | -- functions of the form @a %1-> StateT s m a@. That is, when sequencing 86 | -- @f :: a %1-> StateT s m b@ and @g :: b %1-> StateT s m c@, 87 | -- the type system enforces that state produced by $f$ is fed into @g@. 88 | -- 89 | -- For this reason, there is only one way to define '(>>=)': 90 | -- 91 | -- > instance Monad m => Applicative (StateT s m) where 92 | -- > StateT mx >>= f = StateT $ \s -> do 93 | -- > (x, s') <- mx s 94 | -- > runStateT (f x) s' 95 | -- 96 | -- To see examples and learn about all the standard state monad functions, see 97 | -- [here](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-State-Lazy.html). 98 | -- To learn the basics of the state monad, see 99 | -- [here](https://mmhaskell.com/monads/state). 100 | -------------------------------------------------------------------------------- /src/Data/Replicator/Linear/Internal/ReplicationStream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# OPTIONS_HADDOCK hide #-} 6 | 7 | module Data.Replicator.Linear.Internal.ReplicationStream 8 | ( ReplicationStream (..), 9 | consume, 10 | duplicate, 11 | map, 12 | pure, 13 | (<*>), 14 | liftA2, 15 | ) 16 | where 17 | 18 | import Data.Unrestricted.Linear.Internal.Ur 19 | import Prelude.Linear.Internal 20 | 21 | -- | @ReplicationStream s g dup2 c@ is the infinite linear stream 22 | -- @repeat (g s)@ where @dup2@ is used to make as many copies of @s@ as 23 | -- necessary, and @c@ is used to consume @s@ when consuming the stream. 24 | -- 25 | -- Although it isn't enforced at type level, @dup2@ should abide by the same 26 | -- laws as 'Data.Unrestricted.Linear.dup2': 27 | -- * @first c (dup2 a) ≃ a ≃ second c (dup2 a)@ (neutrality) 28 | -- * @first dup2 (dup2 a) ≃ (second dup2 (dup2 a))@ (associativity) 29 | -- 30 | -- This type is solely used to implement 'Data.Replicator.Linear' 31 | data ReplicationStream a where 32 | ReplicationStream :: 33 | s %1 -> 34 | (s %1 -> a) -> 35 | (s %1 -> (s, s)) -> 36 | (s %1 -> ()) -> 37 | ReplicationStream a 38 | 39 | consume :: ReplicationStream a %1 -> () 40 | consume (ReplicationStream s _ _ consumes) = consumes s 41 | {-# INLINEABLE consume #-} 42 | 43 | duplicate :: ReplicationStream a %1 -> ReplicationStream (ReplicationStream a) 44 | duplicate (ReplicationStream s give dups consumes) = 45 | ReplicationStream 46 | s 47 | (\s' -> ReplicationStream s' give dups consumes) 48 | dups 49 | consumes 50 | 51 | map :: (a %1 -> b) -> ReplicationStream a %1 -> ReplicationStream b 52 | map f (ReplicationStream s give dups consumes) = 53 | ReplicationStream s (f . give) dups consumes 54 | 55 | pure :: a -> ReplicationStream a 56 | pure x = 57 | ReplicationStream 58 | (Ur x) 59 | unur 60 | ( \case 61 | Ur x' -> (Ur x', Ur x') 62 | ) 63 | ( \case 64 | Ur _ -> () 65 | ) 66 | 67 | (<*>) :: ReplicationStream (a %1 -> b) %1 -> ReplicationStream a %1 -> ReplicationStream b 68 | (ReplicationStream sf givef dupsf consumesf) <*> (ReplicationStream sx givex dupsx consumesx) = 69 | ReplicationStream 70 | (sf, sx) 71 | (\(sf', sx') -> givef sf' (givex sx')) 72 | ( \(sf', sx') -> 73 | case (dupsf sf', dupsx sx') of 74 | ((sf1, sf2), (sx1, sx2)) -> ((sf1, sx1), (sf2, sx2)) 75 | ) 76 | ( \(sf', sx') -> 77 | case consumesf sf' of 78 | () -> consumesx sx' 79 | ) 80 | 81 | liftA2 :: (a %1 -> b %1 -> c) -> ReplicationStream a %1 -> ReplicationStream b %1 -> ReplicationStream c 82 | liftA2 f (ReplicationStream sa givea dupsa consumesa) (ReplicationStream sb giveb dupsb consumesb) = 83 | ReplicationStream 84 | (sa, sb) 85 | (\(sa', sb') -> f (givea sa') (giveb sb')) 86 | ( \(sa', sb') -> 87 | case (dupsa sa', dupsb sb') of 88 | ((sa1, sa2), (sb1, sb2)) -> ((sa1, sb1), (sa2, sb2)) 89 | ) 90 | ( \(sa', sb') -> 91 | case consumesa sa' of 92 | () -> consumesb sb' 93 | ) 94 | -- We need to inline this to get good results with generic deriving 95 | -- of Dupable. 96 | {-# INLINE liftA2 #-} 97 | 98 | infixl 4 <*> -- same fixity as base.<*> 99 | -------------------------------------------------------------------------------- /test-examples/Test/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE NoImplicitPrelude #-} 7 | 8 | module Test.Foreign (foreignGCTests) where 9 | 10 | import Control.Exception hiding (assert) 11 | import Control.Monad (void) 12 | import Data.Typeable 13 | import qualified Foreign.Heap as Heap 14 | import Foreign.List (List) 15 | import qualified Foreign.List as List 16 | import qualified Foreign.Marshal.Pure as Manual 17 | import Hedgehog 18 | import qualified Hedgehog.Gen as Gen 19 | import qualified Hedgehog.Range as Range 20 | import Prelude.Linear 21 | import Test.Tasty 22 | import Test.Tasty.Hedgehog (testPropertyNamed) 23 | import qualified Prelude 24 | 25 | -- # Organizing tests 26 | ------------------------------------------------------------------------------- 27 | 28 | foreignGCTests :: TestTree 29 | foreignGCTests = 30 | testGroup 31 | "foreignGCTests" 32 | [ listExampleTests, 33 | heapExampleTests 34 | ] 35 | 36 | listExampleTests :: TestTree 37 | listExampleTests = 38 | testGroup 39 | "list tests" 40 | [ testPropertyNamed "List.toList . List.fromList = id" "invertNonGCList" invertNonGCList, 41 | testPropertyNamed "map id = id" "mapIdNonGCList" mapIdNonGCList, 42 | testPropertyNamed "memory freed post-exception" "testExceptionOnMem" testExceptionOnMem 43 | ] 44 | 45 | heapExampleTests :: TestTree 46 | heapExampleTests = 47 | testGroup 48 | "heap tests" 49 | [testPropertyNamed "sort = heapsort" "nonGCHeapSort" nonGCHeapSort] 50 | 51 | -- # Internal library 52 | ------------------------------------------------------------------------------- 53 | 54 | list :: Gen [Int] 55 | list = Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 100)) 56 | 57 | eqList :: 58 | forall a. 59 | (Manual.Representable a, Movable a, Eq a) => 60 | List a %1 -> 61 | List a %1 -> 62 | Ur Bool 63 | eqList l1 l2 = move $ (List.toList l1) == (List.toList l2) 64 | 65 | data InjectedError = InjectedError 66 | deriving (Typeable, Show) 67 | 68 | instance Exception InjectedError 69 | 70 | -- # Properties 71 | ------------------------------------------------------------------------------- 72 | 73 | invertNonGCList :: Property 74 | invertNonGCList = property $ do 75 | xs <- forAll list 76 | let xs' = 77 | unur $ 78 | Manual.withPool (\p -> move $ List.toList $ List.ofList xs p) 79 | xs === xs' 80 | 81 | mapIdNonGCList :: Property 82 | mapIdNonGCList = property $ do 83 | xs <- forAll list 84 | let boolTest = unur $ 85 | Manual.withPool $ \p -> 86 | dup3 p & \(p0, p1, p2) -> 87 | eqList (List.ofList xs p0) (List.map id (List.ofList xs p1) p2) 88 | assert boolTest 89 | 90 | testExceptionOnMem :: Property 91 | testExceptionOnMem = property $ do 92 | xs <- forAll list 93 | let bs = xs ++ (throw InjectedError) 94 | let writeBadList = Manual.withPool (move . List.toList . List.ofRList bs) 95 | let ignoreCatch = \_ -> Prelude.return () 96 | evalIO (catch @InjectedError (void (evaluate writeBadList)) ignoreCatch) 97 | 98 | nonGCHeapSort :: Property 99 | nonGCHeapSort = property $ do 100 | xs <- forAll list 101 | let ys :: [(Int, ())] = zip xs $ Prelude.replicate (Prelude.length xs) () 102 | (Heap.sort ys) === (reverse $ sort ys) 103 | -------------------------------------------------------------------------------- /src/Debug/Trace/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | 5 | -- A thin wrapper on top of "Debug.Trace", providing linear versions of 6 | -- tracing functions. 7 | -- 8 | -- It only contains minimal amount of documentation; you should consult 9 | -- the original "Debug.Trace" module for more detailed information. 10 | module Debug.Trace.Linear 11 | ( -- * Tracing 12 | trace, 13 | traceShow, 14 | traceId, 15 | traceStack, 16 | traceIO, 17 | traceM, 18 | traceShowM, 19 | 20 | -- * Eventlog tracing 21 | traceEvent, 22 | traceEventIO, 23 | 24 | -- * Execution phase markers 25 | traceMarker, 26 | traceMarkerIO, 27 | ) 28 | where 29 | 30 | import Data.Functor.Linear 31 | import Data.Unrestricted.Linear 32 | import qualified Debug.Trace as NonLinear 33 | import Prelude.Linear.Internal 34 | import System.IO.Linear 35 | import qualified Unsafe.Linear as Unsafe 36 | import Prelude (Show (..), String) 37 | 38 | -- | The 'trace' function outputs the trace message given as its first 39 | -- argument, before returning the second argument as its result. 40 | trace :: String %1 -> a %1 -> a 41 | trace = Unsafe.toLinear2 NonLinear.trace 42 | 43 | -- | Like 'trace', but uses 'show' on the argument to convert it to 44 | -- a 'String'. 45 | traceShow :: (Show a) => a -> b %1 -> b 46 | traceShow a = Unsafe.toLinear (NonLinear.traceShow a) 47 | 48 | -- | Like 'trace' but returns the message instead of a third value. 49 | traceId :: String %1 -> String 50 | traceId s = dup s & \(s', s'') -> trace s' s'' 51 | 52 | -- | Like 'trace', but additionally prints a call stack if one is 53 | -- available. 54 | traceStack :: String %1 -> a %1 -> a 55 | traceStack = Unsafe.toLinear2 NonLinear.traceStack 56 | 57 | -- | The 'traceIO' function outputs the trace message from the IO monad. 58 | -- This sequences the output with respect to other IO actions. 59 | traceIO :: String %1 -> IO () 60 | traceIO s = fromSystemIO (Unsafe.toLinear NonLinear.traceIO s) 61 | 62 | -- | Like 'trace' but returning unit in an arbitrary 'Applicative' 63 | -- context. Allows for convenient use in do-notation. 64 | traceM :: (Applicative f) => String %1 -> f () 65 | traceM s = trace s $ pure () 66 | 67 | -- | Like 'traceM', but uses 'show' on the argument to convert it to a 68 | -- 'String'. 69 | traceShowM :: (Show a, Applicative f) => a -> f () 70 | traceShowM a = traceM (show a) 71 | 72 | -- | The 'traceEvent' function behaves like 'trace' with the difference 73 | -- that the message is emitted to the eventlog, if eventlog profiling is 74 | -- available and enabled at runtime. 75 | traceEvent :: String %1 -> a %1 -> a 76 | traceEvent = Unsafe.toLinear2 NonLinear.traceEvent 77 | 78 | -- | The 'traceEventIO' function emits a message to the eventlog, if 79 | -- eventlog profiling is available and enabled at runtime. 80 | traceEventIO :: String %1 -> IO () 81 | traceEventIO s = fromSystemIO (Unsafe.toLinear NonLinear.traceEventIO s) 82 | 83 | -- | The 'traceMarker' function emits a marker to the eventlog, if eventlog 84 | -- profiling is available and enabled at runtime. The @String@ is the name 85 | -- of the marker. The name is just used in the profiling tools to help you 86 | -- keep clear which marker is which. 87 | traceMarker :: String %1 -> a %1 -> a 88 | traceMarker = Unsafe.toLinear2 NonLinear.traceMarker 89 | 90 | -- | The 'traceMarkerIO' function emits a marker to the eventlog, if 91 | -- eventlog profiling is available and enabled at runtime. 92 | traceMarkerIO :: String %1 -> IO () 93 | traceMarkerIO s = fromSystemIO (Unsafe.toLinear NonLinear.traceMarkerIO s) 94 | -------------------------------------------------------------------------------- /src/Data/Ord/Linear/Internal/Eq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE LinearTypes #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# OPTIONS_HADDOCK hide #-} 6 | 7 | -- | This module provides a linear 'Eq' class for testing equality between 8 | -- values, along with standard instances. 9 | module Data.Ord.Linear.Internal.Eq 10 | ( Eq (..), 11 | ) 12 | where 13 | 14 | import Data.Bool.Linear 15 | import Data.Int (Int16, Int32, Int64, Int8) 16 | import Data.Unrestricted.Linear 17 | import Data.Word (Word16, Word32, Word64, Word8) 18 | import Prelude.Linear.Internal 19 | import qualified Prelude 20 | 21 | -- | Testing equality on values. 22 | -- 23 | -- The laws are that (==) and (/=) are compatible 24 | -- and (==) is an equivalence relation. So, for all @x@, @y@, @z@, 25 | -- 26 | -- * @x == x@ always 27 | -- * @x == y@ implies @y == x@ 28 | -- * @x == y@ and @y == z@ implies @x == z@ 29 | -- * @(x == y)@ ≌ @not (x /= y)@ 30 | class Eq a where 31 | {-# MINIMAL (==) | (/=) #-} 32 | (==) :: a %1 -> a %1 -> Bool 33 | x == y = not (x /= y) 34 | infix 4 == -- same fixity as base.== 35 | (/=) :: a %1 -> a %1 -> Bool 36 | x /= y = not (x == y) 37 | infix 4 /= -- same fixity as base./= 38 | 39 | -- * Instances 40 | 41 | instance (Prelude.Eq a) => Eq (Ur a) where 42 | Ur x == Ur y = x Prelude.== y 43 | Ur x /= Ur y = x Prelude./= y 44 | 45 | instance (Consumable a, Eq a) => Eq [a] where 46 | [] == [] = True 47 | (x : xs) == (y : ys) = x == y && xs == ys 48 | xs == ys = (xs, ys) `lseq` False 49 | 50 | instance (Consumable a, Eq a) => Eq (Prelude.Maybe a) where 51 | Prelude.Nothing == Prelude.Nothing = True 52 | Prelude.Just x == Prelude.Just y = x == y 53 | x == y = (x, y) `lseq` False 54 | 55 | instance 56 | (Consumable a, Consumable b, Eq a, Eq b) => 57 | Eq (Prelude.Either a b) 58 | where 59 | Prelude.Left x == Prelude.Left y = x == y 60 | Prelude.Right x == Prelude.Right y = x == y 61 | x == y = (x, y) `lseq` False 62 | 63 | instance (Eq a, Eq b) => Eq (a, b) where 64 | (a, b) == (a', b') = 65 | a == a' && b == b' 66 | 67 | instance (Eq a, Eq b, Eq c) => Eq (a, b, c) where 68 | (a, b, c) == (a', b', c') = 69 | a == a' && b == b' && c == c' 70 | 71 | instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) where 72 | (a, b, c, d) == (a', b', c', d') = 73 | a == a' && b == b' && c == c' && d == d' 74 | 75 | deriving via MovableEq () instance Eq () 76 | 77 | deriving via MovableEq Prelude.Int instance Eq Prelude.Int 78 | 79 | deriving via MovableEq Prelude.Double instance Eq Prelude.Double 80 | 81 | deriving via MovableEq Prelude.Bool instance Eq Prelude.Bool 82 | 83 | deriving via MovableEq Prelude.Char instance Eq Prelude.Char 84 | 85 | deriving via MovableEq Prelude.Ordering instance Eq Prelude.Ordering 86 | 87 | deriving via MovableEq Int16 instance Eq Int16 88 | 89 | deriving via MovableEq Int32 instance Eq Int32 90 | 91 | deriving via MovableEq Int64 instance Eq Int64 92 | 93 | deriving via MovableEq Int8 instance Eq Int8 94 | 95 | deriving via MovableEq Word16 instance Eq Word16 96 | 97 | deriving via MovableEq Word32 instance Eq Word32 98 | 99 | deriving via MovableEq Word64 instance Eq Word64 100 | 101 | deriving via MovableEq Word8 instance Eq Word8 102 | 103 | newtype MovableEq a = MovableEq a 104 | 105 | instance (Prelude.Eq a, Movable a) => Eq (MovableEq a) where 106 | MovableEq ar == MovableEq br = 107 | move (ar, br) & \(Ur (a, b)) -> 108 | a Prelude.== b 109 | 110 | MovableEq ar /= MovableEq br = 111 | move (ar, br) & \(Ur (a, b)) -> 112 | a Prelude./= b 113 | -------------------------------------------------------------------------------- /src/Data/Unrestricted/Linear/Internal/Ur.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE LinearTypes #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | -- for GHC.Types 8 | {-# LANGUAGE Trustworthy #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# OPTIONS_HADDOCK hide #-} 12 | 13 | module Data.Unrestricted.Linear.Internal.Ur 14 | ( Ur (..), 15 | unur, 16 | lift, 17 | lift2, 18 | ) 19 | where 20 | 21 | import qualified GHC.Generics as GHCGen 22 | import GHC.Types (Multiplicity (..)) 23 | import Generics.Linear 24 | import Prelude.Linear.GenericUtil 25 | import qualified Prelude 26 | 27 | -- | @Ur a@ represents unrestricted values of type @a@ in a linear 28 | -- context. The key idea is that because the contructor holds @a@ with a 29 | -- regular arrow, a function that uses @Ur a@ linearly can use @a@ 30 | -- however it likes. 31 | -- 32 | -- > someLinear :: Ur a %1-> (a,a) 33 | -- > someLinear (Ur a) = (a,a) 34 | data Ur a where 35 | Ur :: a -> Ur a 36 | 37 | deriving instance GHCGen.Generic (Ur a) 38 | 39 | deriving instance GHCGen.Generic1 Ur 40 | 41 | -- | Get an @a@ out of an @Ur a@. If you call this function on a 42 | -- linearly bound @Ur a@, then the @a@ you get out has to be used 43 | -- linearly, for example: 44 | -- 45 | -- > restricted :: Ur a %1-> b 46 | -- > restricted x = f (unur x) 47 | -- > where 48 | -- > -- f __must__ be linear 49 | -- > f :: a %1-> b 50 | -- > f x = ... 51 | unur :: Ur a %1 -> a 52 | unur (Ur a) = a 53 | 54 | -- | Lifts a function on a linear @Ur a@. 55 | lift :: (a -> b) -> Ur a %1 -> Ur b 56 | lift f (Ur a) = Ur (f a) 57 | 58 | -- | Lifts a function to work on two linear @Ur a@. 59 | lift2 :: (a -> b -> c) -> Ur a %1 -> Ur b %1 -> Ur c 60 | lift2 f (Ur a) (Ur b) = Ur (f a b) 61 | 62 | instance Prelude.Functor Ur where 63 | fmap f (Ur a) = Ur (f a) 64 | 65 | instance Prelude.Foldable Ur where 66 | foldMap f (Ur x) = f x 67 | 68 | instance Prelude.Traversable Ur where 69 | sequenceA (Ur x) = Prelude.fmap Ur x 70 | 71 | instance Prelude.Applicative Ur where 72 | pure = Ur 73 | Ur f <*> Ur x = Ur (f x) 74 | 75 | instance Prelude.Monad Ur where 76 | Ur a >>= f = f a 77 | 78 | -- ------------------- 79 | -- Generic and Generic1 instances 80 | 81 | instance Generic (Ur a) where 82 | type 83 | Rep (Ur a) = 84 | FixupMetaData 85 | (Ur a) 86 | ( D1 87 | Any 88 | ( C1 89 | Any 90 | ( S1 91 | Any 92 | (MP1 'Many (Rec0 a)) 93 | ) 94 | ) 95 | ) 96 | to rur = to' rur 97 | where 98 | to' :: Rep (Ur a) p %1 -> Ur a 99 | to' (M1 (M1 (M1 (MP1 (K1 a))))) = Ur a 100 | 101 | from ur = from' ur 102 | where 103 | from' :: Ur a %1 -> Rep (Ur a) p 104 | from' (Ur a) = M1 (M1 (M1 (MP1 (K1 a)))) 105 | 106 | instance Generic1 Ur where 107 | type 108 | Rep1 Ur = 109 | FixupMetaData1 110 | Ur 111 | ( D1 112 | Any 113 | ( C1 114 | Any 115 | ( S1 116 | Any 117 | (MP1 'Many Par1) 118 | ) 119 | ) 120 | ) 121 | 122 | to1 rur = to1' rur 123 | where 124 | to1' :: Rep1 Ur a %1 -> Ur a 125 | to1' (M1 (M1 (M1 (MP1 (Par1 a))))) = Ur a 126 | 127 | from1 ur = from1' ur 128 | where 129 | from1' :: Ur a %1 -> Rep1 Ur a 130 | from1' (Ur a) = M1 (M1 (M1 (MP1 (Par1 a)))) 131 | 132 | type family Any :: Meta 133 | -------------------------------------------------------------------------------- /src/Data/Array/Destination/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LinearTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# OPTIONS_HADDOCK hide #-} 6 | 7 | module Data.Array.Destination.Internal where 8 | 9 | import Data.Unrestricted.Linear 10 | import Data.Vector (Vector, (!)) 11 | import qualified Data.Vector as Vector 12 | import Data.Vector.Mutable (MVector) 13 | import qualified Data.Vector.Mutable as MVector 14 | import GHC.Exts (RealWorld) 15 | import GHC.Stack 16 | import Prelude.Linear hiding (replicate) 17 | import System.IO.Unsafe (unsafeDupablePerformIO) 18 | import qualified Unsafe.Linear as Unsafe 19 | import qualified Prelude as Prelude 20 | 21 | -- | A destination array, or @DArray@, is a write-only array that is filled 22 | -- by some computation which ultimately returns an array. 23 | data DArray a where 24 | DArray :: MVector RealWorld a -> DArray a 25 | 26 | -- XXX: use of Vector in types is temporary. I will probably move away from 27 | -- vectors and implement most stuff in terms of Array# and MutableArray# 28 | -- eventually, anyway. This would allow to move the MutableArray logic to 29 | -- linear IO, possibly, and segregate the unsafe casts to the Linear IO 30 | -- module. @`alloc` n k@ must be called with a non-negative value of @n@. 31 | alloc :: Int -> (DArray a %1 -> ()) %1 -> Vector a 32 | alloc n writer = (\(Ur dest, vec) -> writer (DArray dest) `lseq` vec) $ 33 | unsafeDupablePerformIO $ do 34 | destArray <- MVector.unsafeNew n 35 | vec <- Vector.unsafeFreeze destArray 36 | Prelude.return (Ur destArray, vec) 37 | 38 | -- | Get the size of a destination array. 39 | size :: DArray a %1 -> (Ur Int, DArray a) 40 | size (DArray mvec) = (Ur (MVector.length mvec), DArray mvec) 41 | 42 | -- | Fill a destination array with a constant 43 | replicate :: a -> DArray a %1 -> () 44 | replicate a = fromFunction (const a) 45 | 46 | -- | @fill a dest@ fills a singleton destination array. 47 | -- Caution, @'fill' a dest@ will fail is @dest@ isn't of length exactly one. 48 | fill :: (HasCallStack) => a %1 -> DArray a %1 -> () 49 | fill a (DArray mvec) = 50 | if MVector.length mvec /= 1 51 | then error "Destination.fill: requires a destination of size 1" $ a 52 | else 53 | a 54 | & Unsafe.toLinear (\x -> unsafeDupablePerformIO (MVector.write mvec 0 x)) 55 | 56 | -- | @dropEmpty dest@ consumes and empty array and fails otherwise. 57 | dropEmpty :: (HasCallStack) => DArray a %1 -> () 58 | dropEmpty (DArray mvec) 59 | | MVector.length mvec > 0 = error "Destination.dropEmpty on non-empty array." 60 | | otherwise = mvec `seq` () 61 | 62 | -- | @'split' n dest = (destl, destr)@ such as @destl@ has length @n@. 63 | -- 64 | -- 'split' is total: if @n@ is larger than the length of @dest@, then 65 | -- @destr@ is empty. 66 | split :: Int -> DArray a %1 -> (DArray a, DArray a) 67 | split n (DArray mvec) 68 | | (ml, mr) <- MVector.splitAt n mvec = 69 | (DArray ml, DArray mr) 70 | 71 | -- | Fills the destination array with the contents of given vector. 72 | -- 73 | -- Errors if the given vector is smaller than the destination array. 74 | mirror :: (HasCallStack) => Vector a -> (a %1 -> b) -> DArray b %1 -> () 75 | mirror v f arr = 76 | size arr & \(Ur sz, arr') -> 77 | if Vector.length v < sz 78 | then error "Destination.mirror: argument smaller than DArray" $ arr' 79 | else fromFunction (\t -> f (v ! t)) arr' 80 | 81 | -- | Fill a destination array using the given index-to-value function. 82 | fromFunction :: (Int -> b) -> DArray b %1 -> () 83 | fromFunction f (DArray mvec) = unsafeDupablePerformIO $ do 84 | let n = MVector.length mvec 85 | Prelude.sequence_ [MVector.unsafeWrite mvec m (f m) | m <- [0 .. n - 1]] 86 | 87 | -- The use of the mutable array is linear, since getting the length does not 88 | -- touch any elements, and each write fills in exactly one slot, so 89 | -- each slot of the destination array is filled. 90 | -------------------------------------------------------------------------------- /src/Data/Profunctor/Kleisli/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE LinearTypes #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE NoImplicitPrelude #-} 8 | 9 | -- | This module provides (linear) Kleisli and CoKleisli arrows 10 | -- 11 | -- This module is meant to be imported qualified, perhaps as below. 12 | -- 13 | -- > import qualified Data.Profunctor.Kleisli as Linear 14 | -- 15 | -- == What are Kleisli arrows? 16 | -- 17 | -- The basic idea is that a Kleisli arrow is like a function arrow 18 | -- and @Kleisli m a b@ is similar to a function from @a@ to @b@. Basically: 19 | -- 20 | -- > type Kleisli m a b = a %1-> m b 21 | -- 22 | -- == Why make this definition? 23 | -- 24 | -- It let's us view @Kleisli m@ for a certain @m@ as a certain kind of 25 | -- function arrow, give it instances, abstract over it an so on. 26 | -- 27 | -- For instance, if @m@ is any functor, @Kleisli m@ is a @Profunctor@. 28 | -- 29 | -- == CoKleisli 30 | -- 31 | -- A CoKleisli arrow is just one that represents a computation from 32 | -- a @m a@ to an @a@ via a linear arrow. (It's a Co-something because it 33 | -- reverses the order of the function arrows in the something.) 34 | module Data.Profunctor.Kleisli.Linear 35 | ( Kleisli (..), 36 | CoKleisli (..), 37 | ) 38 | where 39 | 40 | import qualified Control.Functor.Linear as Control 41 | import qualified Data.Functor.Linear as Data 42 | import Data.Profunctor.Linear 43 | import Data.Void 44 | import Prelude.Linear (Either (..), either) 45 | import Prelude.Linear.Internal 46 | 47 | -- Ideally, there would only be one Kleisli arrow, parametrised by 48 | -- a multiplicity parameter: 49 | -- newtype Kleisli p m a b = Kleisli { runKleisli :: a # p -> m b } 50 | -- 51 | -- Some instances would also still work, eg 52 | -- instance Functor p f => Profunctor (Kleisli p f) 53 | 54 | -- | Linear Kleisli arrows for the monad `m`. These arrows are still useful 55 | -- in the case where `m` is not a monad however, and some profunctorial 56 | -- properties still hold in this weaker setting. 57 | newtype Kleisli m a b = Kleisli {runKleisli :: a %1 -> m b} 58 | 59 | instance (Data.Functor f) => Profunctor (Kleisli f) where 60 | dimap f g (Kleisli h) = Kleisli (Data.fmap g . h . f) 61 | 62 | instance (Control.Functor f) => Strong (,) () (Kleisli f) where 63 | first (Kleisli f) = Kleisli (\(a, b) -> (,b) Control.<$> f a) 64 | second (Kleisli g) = Kleisli (\(a, b) -> (a,) Control.<$> g b) 65 | 66 | instance (Control.Applicative f) => Strong Either Void (Kleisli f) where 67 | first (Kleisli f) = Kleisli (either (Data.fmap Left . f) (Control.pure . Right)) 68 | second (Kleisli g) = Kleisli (either (Control.pure . Left) (Data.fmap Right . g)) 69 | 70 | instance (Data.Applicative f) => Monoidal (,) () (Kleisli f) where 71 | Kleisli f *** Kleisli g = Kleisli $ \(x, y) -> (,) Data.<$> f x Data.<*> g y 72 | unit = Kleisli $ \() -> Data.pure () 73 | 74 | instance (Data.Functor f) => Monoidal Either Void (Kleisli f) where 75 | Kleisli f *** Kleisli g = Kleisli $ \case 76 | Left a -> Left Data.<$> f a 77 | Right b -> Right Data.<$> g b 78 | unit = Kleisli $ \case {} 79 | 80 | instance (Control.Applicative f) => Wandering (Kleisli f) where 81 | wander traverse (Kleisli f) = Kleisli (traverse f) 82 | 83 | -- | Linear co-Kleisli arrows for the comonad `w`. These arrows are still 84 | -- useful in the case where `w` is not a comonad however, and some 85 | -- profunctorial properties still hold in this weaker setting. 86 | -- However stronger requirements on `f` are needed for profunctorial 87 | -- strength, so we have fewer instances. 88 | newtype CoKleisli w a b = CoKleisli {runCoKleisli :: w a %1 -> b} 89 | 90 | instance (Data.Functor f) => Profunctor (CoKleisli f) where 91 | dimap f g (CoKleisli h) = CoKleisli (g . h . Data.fmap f) 92 | 93 | instance Strong Either Void (CoKleisli (Data.Const x)) where 94 | first (CoKleisli f) = CoKleisli (\(Data.Const x) -> Left (f (Data.Const x))) 95 | -------------------------------------------------------------------------------- /src/Streaming/Prelude/Linear.hs: -------------------------------------------------------------------------------- 1 | -- | The names exported by this module are closely modeled on those in @Prelude@ and @Data.List@, 2 | -- but also on 3 | -- , 4 | -- 5 | -- and . 6 | -- The module may be said to give independent expression to the conception of 7 | -- Producer \/ Source \/ Generator manipulation 8 | -- articulated in the latter two modules. Because we dispense with piping and 9 | -- conduiting, the distinction between all of these modules collapses. Some things are 10 | -- lost but much is gained: on the one hand, everything comes much closer to ordinary 11 | -- beginning Haskell programming and, on the other, acquires the plasticity of programming 12 | -- directly with a general free monad type. The leading type, @Stream (Of a) m r@ is chosen to permit an api 13 | -- that is as close as possible to that of @Data.List@ and the @Prelude@. 14 | -- 15 | -- Import qualified thus: 16 | -- 17 | -- > import Streaming 18 | -- > import qualified Streaming.Prelude as S 19 | -- 20 | -- For the examples below, one sometimes needs 21 | -- 22 | -- > import Streaming.Prelude (each, yield, next, mapped, stdoutLn, stdinLn) 23 | -- > import Data.Function ((&)) 24 | -- 25 | -- Other libraries that come up in passing are 26 | -- 27 | -- > import qualified Control.Foldl as L -- cabal install foldl 28 | -- > import qualified Pipes as P 29 | -- > import qualified Pipes.Prelude as P 30 | -- > import qualified System.IO as IO 31 | -- 32 | -- Here are some correspondences between the types employed here and elsewhere: 33 | -- 34 | -- > streaming | pipes | conduit | io-streams 35 | -- > ------------------------------------------------------------------------------------------------------------------- 36 | -- > Stream (Of a) m () | Producer a m () | Source m a | InputStream a 37 | -- > | ListT m a | ConduitM () o m () | Generator r () 38 | -- > ------------------------------------------------------------------------------------------------------------------- 39 | -- > Stream (Of a) m r | Producer a m r | ConduitM () o m r | Generator a r 40 | -- > ------------------------------------------------------------------------------------------------------------------- 41 | -- > Stream (Of a) m (Stream (Of a) m r) | Producer a m (Producer a m r) | 42 | -- > -------------------------------------------------------------------------------------------------------------------- 43 | -- > Stream (Stream (Of a) m) r | FreeT (Producer a m) m r | 44 | -- > -------------------------------------------------------------------------------------------------------------------- 45 | -- > -------------------------------------------------------------------------------------------------------------------- 46 | -- > ByteString m () | Producer ByteString m () | Source m ByteString | InputStream ByteString 47 | -- > -------------------------------------------------------------------------------------------------------------------- 48 | -- > 49 | module Streaming.Prelude.Linear 50 | ( module Streaming.Linear.Internal.Type, 51 | module Streaming.Linear.Internal.Consume, 52 | module Streaming.Linear.Internal.Interop, 53 | module Streaming.Linear.Internal.Many, 54 | module Streaming.Linear.Internal.Process, 55 | module Streaming.Linear.Internal.Produce, 56 | ) 57 | where 58 | 59 | import Streaming.Linear.Internal.Consume 60 | import Streaming.Linear.Internal.Interop 61 | import Streaming.Linear.Internal.Many 62 | import Streaming.Linear.Internal.Process 63 | import Streaming.Linear.Internal.Produce 64 | import Streaming.Linear.Internal.Type 65 | -------------------------------------------------------------------------------- /examples/Simple/TopSort.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 6 | {-# OPTIONS_GHC -Wno-unused-matches #-} 7 | 8 | module Simple.TopSort where 9 | 10 | import Data.Bifunctor.Linear (second) 11 | import qualified Data.Functor.Linear as Data 12 | import Data.HashMap.Mutable.Linear (HashMap) 13 | import qualified Data.HashMap.Mutable.Linear as HMap 14 | import Data.Maybe.Linear (catMaybes) 15 | import Data.Unrestricted.Linear 16 | import qualified Prelude.Linear as Linear 17 | 18 | -- # The topological sort of a DAG 19 | ------------------------------------------------------------------------------- 20 | 21 | type Node = Int 22 | 23 | type InDegGraph = HashMap Node ([Node], Int) 24 | 25 | topsort :: [(Node, [Node])] -> [Node] 26 | topsort = reverse . postOrder . fmap (\(n, nbrs) -> (n, (nbrs, 0))) 27 | where 28 | postOrder :: [(Node, ([Node], Int))] -> [Node] 29 | postOrder [] = [] 30 | postOrder (xs) = 31 | let nodes = map fst xs 32 | in unur Linear.$ 33 | HMap.empty (length xs * 2) Linear.$ 34 | \hm -> postOrderHM nodes (HMap.insertAll xs hm) 35 | 36 | postOrderHM :: [Node] -> InDegGraph %1 -> Ur [Node] 37 | postOrderHM nodes dag = 38 | case findSources nodes (computeInDeg nodes dag) of 39 | (dag, Ur sources) -> pluckSources sources [] dag 40 | where 41 | -- O(V + N) 42 | computeInDeg :: [Node] -> InDegGraph %1 -> InDegGraph 43 | computeInDeg nodes dag = Linear.foldl incChildren dag (map Ur nodes) 44 | 45 | -- Increment in-degree of all neighbors 46 | incChildren :: InDegGraph %1 -> Ur Node %1 -> InDegGraph 47 | incChildren dag (Ur node) = 48 | case HMap.lookup node dag of 49 | (Ur Nothing, dag) -> dag 50 | (Ur (Just (xs, i)), dag) -> incNodes (move xs) dag 51 | where 52 | incNodes :: Ur [Node] %1 -> InDegGraph %1 -> InDegGraph 53 | incNodes (Ur ns) dag = Linear.foldl incNode dag (map Ur ns) 54 | 55 | incNode :: InDegGraph %1 -> Ur Node %1 -> InDegGraph 56 | incNode dag (Ur node) = 57 | case HMap.lookup node dag of 58 | (Ur Nothing, dag') -> dag' 59 | (Ur (Just (n, d)), dag') -> 60 | HMap.insert node (n, d + 1) dag' 61 | 62 | -- HMap.alter dag (\(Just (n,d)) -> Just (n,d+1)) node 63 | 64 | -- pluckSources sources postOrdSoFar dag 65 | pluckSources :: [Node] -> [Node] -> InDegGraph %1 -> Ur [Node] 66 | pluckSources [] postOrd dag = lseq dag (move postOrd) 67 | pluckSources (s : ss) postOrd dag = 68 | case HMap.lookup s dag of 69 | (Ur Nothing, dag) -> pluckSources ss (s : postOrd) dag 70 | (Ur (Just (xs, i)), dag) -> 71 | case walk xs dag of 72 | (dag', Ur newSrcs) -> 73 | pluckSources (newSrcs ++ ss) (s : postOrd) dag' 74 | where 75 | -- decrement degree of children, save newly made sources 76 | walk :: [Node] -> InDegGraph %1 -> (InDegGraph, Ur [Node]) 77 | walk children dag = 78 | second (Data.fmap catMaybes) (mapAccum decDegree children dag) 79 | 80 | -- Decrement the degree of a node, save it if it is now a source 81 | decDegree :: Node -> InDegGraph %1 -> (InDegGraph, Ur (Maybe Node)) 82 | decDegree node dag = 83 | case HMap.lookup node dag of 84 | (Ur Nothing, dag') -> (dag', Ur Nothing) 85 | (Ur (Just (n, d)), dag') -> 86 | checkSource node (HMap.insert node (n, d - 1) dag') 87 | 88 | -- Given a list of nodes, determines which are sources 89 | findSources :: [Node] -> InDegGraph %1 -> (InDegGraph, Ur [Node]) 90 | findSources nodes dag = 91 | second (Data.fmap catMaybes) (mapAccum checkSource nodes dag) 92 | 93 | -- | Check if a node is a source, and if so return it 94 | checkSource :: Node -> InDegGraph %1 -> (InDegGraph, Ur (Maybe Node)) 95 | checkSource node dag = 96 | case HMap.lookup node dag of 97 | (Ur Nothing, dag) -> (dag, Ur Nothing) 98 | (Ur (Just (xs, 0)), dag) -> (dag, Ur (Just node)) 99 | (Ur (Just (xs, n)), dag) -> (dag, Ur Nothing) 100 | 101 | mapAccum :: 102 | (a -> b %1 -> (b, Ur c)) -> [a] -> b %1 -> (b, Ur [c]) 103 | mapAccum f [] b = (b, Ur []) 104 | mapAccum f (x : xs) b = 105 | case mapAccum f xs b of 106 | (b, Ur cs) -> second (Data.fmap (: cs)) (f x b) 107 | -------------------------------------------------------------------------------- /docs/DESIGN.md: -------------------------------------------------------------------------------- 1 | # Design 2 | 3 | ## Overall architecture 4 | 5 | Linear base is more than a copy of things from [`base`] with some function 6 | arrows being replaced by linear arrows. Moreover, the goal is __not__ exact 7 | compliance with `base`. 8 | 9 | Linear base consists of the following: 10 | 11 | * fundamental data structures, functions and classes that arise 12 | naturally from wanting to do any linear development (e.g., 13 | `Ur` and `Consumable`), 14 | * tools ported from [`base`] and from other critical haskell 15 | libraries, like `lens`, 16 | * new APIs for using system resources, e.g., file I/O in 17 | [`System.IO.Resource.Linear`], 18 | * new abstractions made possible by linear types, like monad-free 19 | mutable arrays in ([`Data.Array.Mutable.Linear`]). 20 | 21 | There is a top-level `Prelude.Linear` that is meant to be imported _unqualified_. 22 | It does not include functors, monads, applicatives and so on because there are 23 | multiple sensible ways to give linear arrows to these things. See this [blog 24 | post] for details. This prelude includes: 25 | 26 | * linear variants of definitions in `Prelude`, 27 | * a few pervasive utility definitions when programming with linear 28 | types. 29 | 30 | ## Module structure 31 | 32 | * `Prelude.Linear` is public facing and meant for users of linear-base 33 | whereas `Prelude.Linear.Internal` is meant as an internal prelude for 34 | development in linear-base itself. It is down deep in the module 35 | hierarchy, used throughout linear-base while `Prelude.Linear` is at the top 36 | and no other modules import it. 37 | * Modules that have `Internal` in the name are not meant to be 38 | public and have their functionality used and/or re-exported in 39 | public-facing modules. 40 | 41 | ## General implementation strategy 42 | 43 | This is the strategy that we've followed so far for developing 44 | `linear-base`: 45 | 46 | 1. If the definition is simple enough that there's only one sensible 47 | place to replace a function arrow by a linear arrow, do that. 48 | Example: 49 | 50 | ```haskell 51 | foldr :: (a %1-> b %1-> b) -> b %1-> [a] %1-> b 52 | foldr f z = \case 53 | [] -> z 54 | x:xs -> f x (foldr f z xs) 55 | ``` 56 | 57 | Otherwise, implement each sensible variant of the definition in 58 | dedicated modules. For instance, this is the case with 59 | `Data.Functor`s and `Control.Functor`s (see this [blog post]). 60 | 61 | 2. The ideas behind new definitions that are just now possible with 62 | linear types vary and each have unique concepts that are not 63 | addressed by a general strategy. These should be documented below 64 | if one of the following is true: 65 | 66 | * there is an overarching concept that extends beyond a handful of 67 | modules. Or, 68 | * There is an explicit departure away from the direction of `base`. 69 | (E.g., we decide there should be different laws for some type 70 | class already in `base`.) 71 | 72 | ## Conventions 73 | 74 | We have established the following conventions in this project: 75 | 76 | * use full words for Qualified imports, not abbreviations. For 77 | instance, import `Data.Functor.Linear` as `Linear` and not as `F` 78 | for functor. 79 | * All public modules have an export list. 80 | * Pure functions which modify a container take the 81 | container as the last parameter (similar to functions in `Data.Map`). Monadic functions on containers 82 | take the containers as the first parameter 83 | (similar to functions in `Control.Concurrent.MVar`). See [issue #147][issue-147] for some 84 | more details. 85 | 86 | [functors]: https://www.tweag.io/posts/2020-01-16-data-vs-control.html 87 | [examples/Simple/FileIO.hs]: https://github.com/tweag/linear-base/tree/master/examples/Simple/FileIO.hs 88 | [`Data.Unrestricted.Linear`]: https://github.com/tweag/linear-base/tree/master/src/Data/Unrestricted/Linear.hs 89 | [`Num`]: https://github.com/tweag/linear-base/tree/master/src/Data/Num/Linear.hs 90 | [`base`]: https://hackage.haskell.org/package/base 91 | [`Data.Array.Mutable.Linear`]: https://github.com/tweag/linear-base/blob/master/src/Data/Array/Mutable/Linear.hs 92 | [blog post]: https://www.tweag.io/posts/2020-01-16-data-vs-control.html 93 | [contributor's guide]: ../CONTRIBUTING.md 94 | [`System.IO.Resource.Linear`]: https://github.com/tweag/linear-base/blob/master/src/System/IO/Resource/Linear.hs 95 | [issue-147]: https://github.com/tweag/linear-base/issues/147 96 | -------------------------------------------------------------------------------- /src/Data/Arity/Linear/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE StandaloneKindSignatures #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeFamilyDependencies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# OPTIONS_HADDOCK hide #-} 11 | 12 | module Data.Arity.Linear.Internal where 13 | 14 | import Data.Kind 15 | import GHC.TypeLits 16 | import GHC.Types 17 | 18 | data Peano = Z | S Peano 19 | 20 | -- | Converts a GHC type-level 'Nat' to a structural type-level natural ('Peano'). 21 | type NatToPeano :: Nat -> Peano 22 | type family NatToPeano n where 23 | NatToPeano 0 = 'Z 24 | NatToPeano n = 'S (NatToPeano (n - 1)) 25 | 26 | -- | Converts a structural type-level natural ('Peano') to a GHC type-level 'Nat'. 27 | type PeanoToNat :: Peano -> Nat 28 | type family PeanoToNat n where 29 | PeanoToNat 'Z = 0 30 | PeanoToNat ('S n) = 1 + PeanoToNat n 31 | 32 | -- | @'FunN' n a b@ represents a function taking @n@ linear arguments of 33 | -- type @a@ and returning a result of type @b@. 34 | type FunN :: Peano -> Type -> Type -> Type 35 | type family FunN n a b where 36 | FunN 'Z _ b = b 37 | FunN ('S n) a b = a %1 -> FunN n a b 38 | 39 | -- | The 'Arity' type family exists to help the type checker fill in 40 | -- blanks. Chances are that you can safely ignore 'Arity' completely if it's in 41 | -- the type of a function you care. But read on if you are curious. 42 | -- 43 | -- The idea is that in a function like 'Data.Replicator.Linear.elim' some of the 44 | -- type arguments are redundant. The function has an ambiguous type, so you will 45 | -- always have to help the compiler either with a type annotation or a type 46 | -- application. But there are several complete ways to do so. In 47 | -- 'Data.Replicator.Linear.elim', if you give the values of `n`, `a`, and `b`, 48 | -- then you can deduce the value of `f` (indeed, it's @'FunN' n a b@). With 49 | -- 'Arity' we can go in the other direction: if `b` and `f` are both known, then 50 | -- we know that `n` is @'Arity' b f@ 51 | -- 52 | -- 'Arity' returns a 'Nat' rather than a 'Peano' because the result is never 53 | -- consumed. It exists to infer arguments to functions such as 54 | -- 'Data.Replicator.Linear.elim' from the other arguments if they are known. 55 | -- 56 | -- 'Arity' could /theorically/ be an associated type family to the 'IsFunN' type 57 | -- class. But it's better to make it a closed type family (which can't be 58 | -- associated to a type class) because it lets us give a well-defined error 59 | -- case. In addition, GHC cannot see that @0 /= 1 + (? :: Nat)@ and as a result we get 60 | -- some overlap which is only allowed in (ordered) closed type families. 61 | type Arity :: Type -> Type -> Nat 62 | type family Arity b f where 63 | Arity b b = 0 64 | Arity b (a %1 -> f) = Arity b f + 1 65 | Arity b f = 66 | TypeError 67 | ( 'Text "Arity: " 68 | ':<>: 'ShowType f 69 | ':<>: 'Text " isn't a linear function with head " 70 | ':<>: 'ShowType b 71 | ':<>: 'Text "." 72 | ) 73 | 74 | -- | The 'IsFun' type class is meant to help the type checker fill in 75 | -- blanks. Chances are that you can safely ignore 'IsFun' completely if it's in 76 | -- the type of a function you care. But read on if you are curious. 77 | -- 78 | -- The type class 'IsFun' is a kind of inverse to 'FunN', it is meant to be 79 | -- read as @'IsFunN' a b f@ if and only if there exists @n@ such that @f = 80 | -- 'FunN' n a b@ (`n` can be retrieved as @'Arity' b f@ or 81 | -- @'Data.V.Linear.ArityV' f@). 82 | -- 83 | -- The reason why 'Arity' (read its documentation first) is not sufficient for 84 | -- our purpose, is that it can find @n@ /if/ @f@ is a linear function of the 85 | -- appropriate shape. But what if @f@ is partially undetermined? Then it is 86 | -- likely that 'Arity' will be stuck. But we know, for instance, that if @f = a1 87 | -- %1 -> a2 %1 -> c@ then we must have @a1 ~ a2@. The trick is that instance 88 | -- resolution of 'IsFun' will add unification constraints that the type checker 89 | -- has to solve. Look in particular at the instance @'IsFunN' a b (a\' %p -> 90 | -- f))@: it matches liberally, so triggers on quite underdetermined @f@, but has 91 | -- equality constraints in its context which will help the type checker. 92 | class IsFunN a b f 93 | 94 | instance IsFunN a b b 95 | 96 | instance (IsFunN a b f, a' ~ a, p ~ 'One) => IsFunN a b (a' %p -> f) 97 | -------------------------------------------------------------------------------- /test/Test/Data/Polarized.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Test.Data.Polarized (polarizedArrayTests) where 5 | 6 | import qualified Data.Array.Polarized as Polar 7 | import qualified Data.Array.Polarized.Pull as Pull 8 | import qualified Data.Array.Polarized.Push as Push 9 | import Data.Functor.Linear (fmap) 10 | import qualified Data.Vector as Vector 11 | import Hedgehog 12 | import qualified Hedgehog.Gen as Gen 13 | import qualified Hedgehog.Range as Range 14 | import Prelude.Linear 15 | import Test.Tasty 16 | import Test.Tasty.Hedgehog (testPropertyNamed) 17 | import qualified Prelude 18 | 19 | {- TODO: 20 | 21 | * test fmap on push arrays 22 | * test zip on different length pull arrays errors 23 | 24 | -} 25 | 26 | -- # Tests and Utlities 27 | ------------------------------------------------------------------------------- 28 | 29 | polarizedArrayTests :: TestTree 30 | polarizedArrayTests = 31 | testGroup 32 | "Polarized arrays" 33 | [ testPropertyNamed "Push.alloc . transfer . Pull.fromVector = id" "polarRoundTrip" polarRoundTrip, 34 | testPropertyNamed "Push.append ~ Vec.append" "pushAppend" pushAppend, 35 | testPropertyNamed "Push.make ~ Vec.replicate" "pushMake" pushMake, 36 | testPropertyNamed "Pull.append ~ Vec.append" "pullAppend" pullAppend, 37 | testPropertyNamed "Pull.asList . Pull.fromVector ~ id" "pullAsList" pullAsList, 38 | testPropertyNamed "Pull.empty = []" "pullEmpty" pullEmpty, 39 | testPropertyNamed "Pull.singleton x = [x]" "pullSingleton" pullSingleton, 40 | testPropertyNamed "Pull.splitAt ~ splitAt" "pullSplitAt" pullSplitAt, 41 | testPropertyNamed "Pull.make ~ Vec.replicate" "pullMake" pullMake, 42 | testPropertyNamed "Pull.zip ~ zip" "pullZip" pullZip, 43 | testPropertyNamed "Pull.uncons ~ uncons" "pullUncons" pullUncons 44 | ] 45 | 46 | list :: Gen [Int] 47 | list = Gen.list (Range.linear 0 1000) randInt 48 | 49 | randInt :: Gen Int 50 | randInt = Gen.int (Range.linear (-500) 500) 51 | 52 | randNonnegInt :: Gen Int 53 | randNonnegInt = Gen.int (Range.linear 0 500) 54 | 55 | -- # Properties 56 | ------------------------------------------------------------------------------- 57 | 58 | polarRoundTrip :: Property 59 | polarRoundTrip = property Prelude.$ do 60 | xs <- forAll list 61 | let v = Vector.fromList xs 62 | v === Push.alloc (Polar.transfer (Pull.fromVector v)) 63 | 64 | pushAppend :: Property 65 | pushAppend = property Prelude.$ do 66 | xs <- forAll list 67 | ys <- forAll list 68 | let v1 = Vector.fromList xs 69 | let v2 = Vector.fromList ys 70 | let sumVecs = v1 Vector.++ v2 71 | sumVecs === Push.alloc (Polar.walk v1 <> Polar.walk v2) 72 | 73 | pushMake :: Property 74 | pushMake = property Prelude.$ do 75 | n <- forAll randNonnegInt 76 | x <- forAll randInt 77 | let v = Vector.replicate n x 78 | v === Push.alloc (Push.make x n) 79 | 80 | pullAppend :: Property 81 | pullAppend = property Prelude.$ do 82 | xs <- forAll list 83 | ys <- forAll list 84 | let v1 = Vector.fromList xs 85 | let v2 = Vector.fromList ys 86 | let sumVecs = v1 Vector.++ v2 87 | sumVecs === Pull.toVector (Pull.fromVector v1 <> Pull.fromVector v2) 88 | 89 | pullAsList :: Property 90 | pullAsList = property Prelude.$ do 91 | xs <- forAll list 92 | xs === Pull.asList (Pull.fromVector (Vector.fromList xs)) 93 | 94 | pullEmpty :: Property 95 | pullEmpty = property Prelude.$ do 96 | ([] :: [Int]) === Pull.asList Pull.empty 97 | 98 | pullSingleton :: Property 99 | pullSingleton = property Prelude.$ do 100 | x <- forAll randInt 101 | [x] === Pull.asList (Pull.singleton x) 102 | 103 | pullSplitAt :: Property 104 | pullSplitAt = property Prelude.$ do 105 | xs <- forAll list 106 | n <- forAll randNonnegInt 107 | let v = Vector.fromList xs 108 | let (l, r) = Pull.split n (Pull.fromVector v) 109 | (Pull.asList l, Pull.asList r) === splitAt n xs 110 | 111 | pullMake :: Property 112 | pullMake = property Prelude.$ do 113 | x <- forAll randInt 114 | n <- forAll randNonnegInt 115 | replicate n x === Pull.asList (Pull.make x n) 116 | 117 | pullZip :: Property 118 | pullZip = property Prelude.$ do 119 | let genPairs = (,) Prelude.<$> randInt Prelude.<*> randInt 120 | as <- forAll (Gen.list (Range.linear 0 1000) genPairs) 121 | let (xs, ys) = unzip as 122 | let xs' = Pull.fromVector (Vector.fromList xs) 123 | let ys' = Pull.fromVector (Vector.fromList ys) 124 | zip xs ys === Pull.asList (Pull.zip xs' ys') 125 | 126 | pullUncons :: Property 127 | pullUncons = property Prelude.$ do 128 | xs <- forAll list 129 | uncons xs === fmap (fmap Pull.asList) (Pull.uncons (Pull.fromVector (Vector.fromList xs))) 130 | -------------------------------------------------------------------------------- /src/Control/Functor/Linear/Internal/Kan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LinearTypes #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# OPTIONS_HADDOCK hide #-} 7 | 8 | -- | A few things lifted from kan-extensions and lens for generic deriving of 9 | -- 'Data.Functor.Linear.Traversable' instances (see 10 | -- "Data.Functor.Linear.Internal.Traversable"). 11 | module Control.Functor.Linear.Internal.Kan where 12 | 13 | import Control.Functor.Linear 14 | import qualified Data.Functor.Linear.Internal.Applicative as Data 15 | import qualified Data.Functor.Linear.Internal.Functor as Data 16 | import Prelude.Linear.Internal 17 | 18 | -- | A linear version of @Data.Functor.Day.Curried.Curried@ in the 19 | -- @kan-extensions@ package. We use this for generic traversals. How 20 | -- does it help? Consider a type like 21 | -- 22 | -- @data Foo a = Foo a a a a@ 23 | -- 24 | -- The generic representation may look roughly like 25 | -- 26 | -- @D1 _ (C1 _ ((S1 _ Rec1 :*: S1 _ Rec1) :*: (S1 _ Rec1 :*: S1 _ Rec1)))@ 27 | -- 28 | -- Traversing this naively requires a bunch of @fmap@ applications. 29 | -- Most of them could be removed using 'Yoneda', but one aspect 30 | -- can't be. Let's simplify down to the hard bit: 31 | -- 32 | -- @m :*: (n :*: o)@ 33 | -- 34 | -- Traversing this looks like 35 | -- 36 | -- @((:*:) <$> m) <*> ((:*:) <$> n <*> o)@ 37 | -- 38 | -- We want to reassociate the applications so the whole reconstruction 39 | -- of the generic representation happens in one place, allowing inlining 40 | -- to (hopefully) erase them altogether. It will end up looking roughly like 41 | -- 42 | -- @(\x y z -> x :*: (y :*: z)) <$> m <*> n <*> o@ 43 | -- 44 | -- In our context, we always have the two functor 45 | -- arguments the same, so something like @Curried f f@. 46 | -- @Curried f f a@ is a lot like @f a@, as demonstrated directly by 47 | -- 'lowerCurriedC' and, in @kan-extensions@, @liftCurried@. 48 | -- It's a sort of "continuation passing style" version. If we have 49 | -- something like 50 | -- 51 | -- @ 52 | -- Con <$> m <*> n <*> o 53 | -- 54 | -- -- parenthesized 55 | -- 56 | -- ((Con <$> m) <*> n) <*> o 57 | -- @ 58 | -- 59 | -- we can look at what happens next to each field. So the next thing 60 | -- after performing @m@ is to map @Con@ over it. The next thing after 61 | -- performing @n@ is to apply @Con <$> m@ to it within the functor. 62 | newtype Curried g h a = Curried 63 | {runCurried :: forall r. g (a %1 -> r) %1 -> h r} 64 | 65 | instance (Data.Functor g) => Data.Functor (Curried g h) where 66 | fmap f (Curried g) = Curried (g . Data.fmap (. f)) 67 | {-# INLINE fmap #-} 68 | 69 | instance (Functor g) => Functor (Curried g h) where 70 | fmap f (Curried g) = Curried (\x -> g (fmap (\y -> y . f) x)) 71 | {-# INLINE fmap #-} 72 | 73 | instance (Data.Functor g, g ~ h) => Data.Applicative (Curried g h) where 74 | pure a = Curried (Data.fmap ($ a)) 75 | {-# INLINE pure #-} 76 | Curried mf <*> Curried ma = Curried (ma . mf . Data.fmap (.)) 77 | {-# INLINE (<*>) #-} 78 | 79 | instance (Functor g, g ~ h) => Applicative (Curried g h) where 80 | pure a = Curried (fmap ($ a)) 81 | {-# INLINE pure #-} 82 | Curried mf <*> Curried ma = Curried (ma . mf . fmap (.)) 83 | {-# INLINE (<*>) #-} 84 | 85 | lowerCurriedC :: (Applicative f) => Curried f g a %1 -> g a 86 | lowerCurriedC (Curried f) = f (pure id) 87 | {-# INLINE lowerCurriedC #-} 88 | 89 | newtype Yoneda f a = Yoneda {runYoneda :: forall b. (a %1 -> b) %1 -> f b} 90 | 91 | instance Data.Functor (Yoneda f) where 92 | fmap f (Yoneda m) = Yoneda (\k -> m (k . f)) 93 | {-# INLINE fmap #-} 94 | 95 | instance Functor (Yoneda f) where 96 | fmap f (Yoneda m) = Yoneda (\k -> m (k . f)) 97 | {-# INLINE fmap #-} 98 | 99 | instance (Applicative f) => Data.Applicative (Yoneda f) where 100 | pure a = Yoneda (\f -> pure (f a)) 101 | {-# INLINE pure #-} 102 | Yoneda m <*> Yoneda n = Yoneda (\f -> m (\g -> f . g) <*> n id) 103 | {-# INLINE (<*>) #-} 104 | 105 | instance (Applicative f) => Applicative (Yoneda f) where 106 | pure a = Yoneda (\f -> pure (f a)) 107 | {-# INLINE pure #-} 108 | Yoneda m <*> Yoneda n = Yoneda (\f -> m (\g -> f . g) <*> n id) 109 | {-# INLINE (<*>) #-} 110 | 111 | lowerYoneda :: Yoneda f a %1 -> f a 112 | lowerYoneda (Yoneda m) = m id 113 | {-# INLINE lowerYoneda #-} 114 | 115 | -- This bit comes from lens. 116 | liftCurriedYonedaC :: (Applicative f) => f a %1 -> Curried (Yoneda f) (Yoneda f) a 117 | liftCurriedYonedaC fa = Curried (`yap` fa) 118 | {-# INLINE liftCurriedYonedaC #-} 119 | 120 | yap :: (Applicative f) => Yoneda f (a %1 -> b) %1 -> f a %1 -> Yoneda f b 121 | yap (Yoneda k) fa = Yoneda (\ab_r -> k (\g -> ab_r . g) <*> fa) 122 | {-# INLINE yap #-} 123 | -------------------------------------------------------------------------------- /src/Prelude/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LinearTypes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | -- TODO: Disabled while we still support GHC 9.2 to enable 4 | -- the import of the empty TypeEq module there. 5 | {-# OPTIONS_GHC -Wno-dodgy-exports -Wno-unused-imports #-} 6 | 7 | -- | This module provides a replacement for 'Prelude' with 8 | -- support for linear programming via linear versions of 9 | -- standard data types, functions and type classes. 10 | -- 11 | -- A simple example: 12 | -- 13 | -- >>> :set -XLinearTypes 14 | -- >>> :set -XNoImplicitPrelude 15 | -- >>> import Prelude.Linear 16 | -- >>> :{ 17 | -- boolToInt :: Bool %1-> Int 18 | -- boolToInt False = 0 19 | -- boolToInt True = 1 20 | -- :} 21 | -- 22 | -- >>> :{ 23 | -- makeInt :: Either Int Bool %1-> Int 24 | -- makeInt = either id boolToInt 25 | -- :} 26 | -- 27 | -- This module is designed to be imported unqualifed. 28 | module Prelude.Linear 29 | ( -- * Standard Types, Classes and Related Functions 30 | 31 | -- ** Basic data types 32 | module Data.Bool.Linear, 33 | Prelude.Char, 34 | module Data.Maybe.Linear, 35 | module Data.Either.Linear, 36 | module Prelude.Linear.Internal.TypeEq, 37 | 38 | -- * Tuples 39 | Prelude.fst, 40 | Prelude.snd, 41 | curry, 42 | uncurry, 43 | 44 | -- ** Basic type classes 45 | module Data.Ord.Linear, 46 | Prelude.Enum (..), 47 | Prelude.Bounded (..), 48 | 49 | -- ** Numbers 50 | Prelude.Int, 51 | Prelude.Integer, 52 | Prelude.Float, 53 | Prelude.Double, 54 | Prelude.Rational, 55 | Prelude.Word, 56 | module Data.Num.Linear, 57 | Prelude.Real (..), 58 | Prelude.Integral (..), 59 | Prelude.Floating (..), 60 | Prelude.Fractional (..), 61 | Prelude.RealFrac (..), 62 | Prelude.RealFloat (..), 63 | 64 | -- *** Numeric functions 65 | Prelude.subtract, 66 | Prelude.even, 67 | Prelude.odd, 68 | Prelude.gcd, 69 | Prelude.lcm, 70 | (Prelude.^), 71 | (Prelude.^^), 72 | Prelude.fromIntegral, 73 | Prelude.realToFrac, 74 | 75 | -- ** Monads and functors 76 | (<*), 77 | 78 | -- ** Semigroups and monoids 79 | module Data.Monoid.Linear, 80 | 81 | -- ** Miscellaneous functions 82 | id, 83 | const, 84 | (.), 85 | flip, 86 | ($), 87 | (&), 88 | Prelude.until, 89 | Prelude.error, 90 | Prelude.errorWithoutStackTrace, 91 | Prelude.undefined, 92 | seq, 93 | ($!), 94 | 95 | -- * List operations 96 | module Data.List.Linear, 97 | 98 | -- * Functions on strings 99 | 100 | -- TODO: Implement a linear counterpart of this 101 | module Data.String, 102 | 103 | -- * Converting to and from String 104 | Prelude.ShowS, 105 | Prelude.Show (..), 106 | Prelude.shows, 107 | Prelude.showChar, 108 | Prelude.showString, 109 | Prelude.showParen, 110 | Prelude.ReadS, 111 | Prelude.Read (..), 112 | Prelude.reads, 113 | Prelude.readParen, 114 | Prelude.read, 115 | Prelude.lex, 116 | 117 | -- * Basic input and output 118 | Prelude.IO, 119 | Prelude.putChar, 120 | Prelude.putStr, 121 | Prelude.putStrLn, 122 | Prelude.print, 123 | Prelude.getChar, 124 | Prelude.getLine, 125 | Prelude.getContents, 126 | Prelude.interact, 127 | 128 | -- ** Files 129 | Prelude.FilePath, 130 | Prelude.readFile, 131 | Prelude.writeFile, 132 | Prelude.appendFile, 133 | Prelude.readIO, 134 | Prelude.readLn, 135 | 136 | -- * Using 'Ur' values in linear code 137 | -- $ 138 | Ur (..), 139 | unur, 140 | 141 | -- * Doing non-linear operations inside linear functions 142 | -- $ 143 | Consumable (..), 144 | Dupable (..), 145 | Movable (..), 146 | lseq, 147 | dup, 148 | dup3, 149 | forget, 150 | ) 151 | where 152 | 153 | import Data.Bool.Linear 154 | import Data.Either.Linear 155 | import qualified Data.Functor.Linear as Data 156 | import Data.List.Linear 157 | import Data.Maybe.Linear 158 | import Data.Monoid.Linear 159 | import Data.Num.Linear 160 | import Data.Ord.Linear 161 | import Data.String 162 | import Data.Tuple.Linear 163 | import Data.Unrestricted.Linear 164 | import Prelude.Linear.Internal 165 | import Prelude.Linear.Internal.TypeEq 166 | import qualified Prelude 167 | 168 | -- | Replacement for the flip function with generalized multiplicities. 169 | flip :: (a %p -> b %q -> c) %r -> b %q -> a %p -> c 170 | flip f b a = f a b 171 | 172 | -- | Linearly typed replacement for the standard '(Prelude.<*)' function. 173 | (<*) :: (Data.Applicative f, Consumable b) => f a %1 -> f b %1 -> f a 174 | fa <* fb = Data.fmap (flip lseq) fa Data.<*> fb 175 | 176 | infixl 4 <* -- same fixity as base.<* 177 | -------------------------------------------------------------------------------- /examples/Foreign/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | 10 | module Foreign.List where 11 | 12 | import qualified Data.List as List 13 | import Foreign.Marshal.Pure (Box, Pool) 14 | import qualified Foreign.Marshal.Pure as Manual 15 | import Prelude.Linear hiding (foldl, foldr, map) 16 | 17 | -- XXX: we keep the last Cons in Memory here. A better approach would be to 18 | -- always keep a Box instead. 19 | data List a 20 | = Nil 21 | | Cons !a !(Box (List a)) 22 | 23 | -- TODO: generating appropriate instances using the Generic framework 24 | instance 25 | (Manual.Representable a) => 26 | Manual.MkRepresentable (List a) (Maybe (a, Box (List a))) 27 | where 28 | toRepr Nil = Nothing 29 | toRepr (Cons a l) = Just (a, l) 30 | 31 | ofRepr Nothing = Nil 32 | ofRepr (Just (a, l)) = Cons a l 33 | 34 | instance (Manual.Representable a) => Manual.Representable (List a) where 35 | type AsKnown (List a) = Manual.AsKnown (Maybe (a, Box (List a))) 36 | 37 | -- Remark: this is a bit wasteful, we could implement an allocation-free map by 38 | -- reusing the old pointer with realloc. 39 | -- 40 | -- XXX: the mapped function should be of type (a %1-> Pool %1-> b) 41 | -- 42 | -- Remark: map could be tail-recursive in destination-passing style 43 | map :: forall a b. (Manual.Representable a, Manual.Representable b) => (a %1 -> b) -> List a %1 -> Pool %1 -> List b 44 | map _f Nil pool = pool `lseq` Nil 45 | map f (Cons a l) pool = 46 | withPools (dup pool) a (Manual.deconstruct l) 47 | where 48 | withPools :: (Pool, Pool) %1 -> a %1 -> List a %1 -> List b 49 | withPools (pool1, pool2) a' l' = 50 | Cons (f a') (Manual.alloc (map f l' pool1) pool2) 51 | 52 | foldr :: forall a b. (Manual.Representable a) => (a %1 -> b %1 -> b) -> b %1 -> List a %1 -> b 53 | foldr _f seed Nil = seed 54 | foldr f seed (Cons a l) = f a (foldr f seed (Manual.deconstruct l)) 55 | 56 | foldl :: forall a b. (Manual.Representable a) => (b %1 -> a %1 -> b) -> b %1 -> List a %1 -> b 57 | foldl _f seed Nil = seed 58 | foldl f seed (Cons a l) = foldl f (f seed a) (Manual.deconstruct l) 59 | 60 | -- Remark: could be tail-recursive with destination-passing style 61 | 62 | -- | Make a 'List' from a stream. 'List' is a type of strict lists, therefore 63 | -- the stream must terminate otherwise 'unfold' will loop. Not tail-recursive. 64 | unfold :: forall a s. (Manual.Representable a) => (s -> Maybe (a, s)) -> s -> Pool %1 -> List a 65 | unfold step state pool = dispatch (step state) (dup pool) 66 | where 67 | -- XXX: ^ The reason why we need to `dup` the pool before we know whether the 68 | -- next step is a `Nothing` (in which case we don't need the pool at all) or a 69 | -- `Just`, is because of the limitation of `case` to the unrestricted 70 | -- case. Will be fixed. 71 | 72 | dispatch :: Maybe (a, s) -> (Pool, Pool) %1 -> List a 73 | dispatch Nothing pools = pools `lseq` Nil 74 | dispatch (Just (a, next)) (pool1, pool2) = 75 | Cons a (Manual.alloc (unfold step next pool1) pool2) 76 | 77 | -- | Linear variant of 'unfold'. Note how they are implemented exactly 78 | -- identically. They could be merged if multiplicity polymorphism was supported. 79 | unfoldL :: forall a s. (Manual.Representable a) => (s %1 -> Maybe (a, s)) -> s %1 -> Pool %1 -> List a 80 | unfoldL step state pool = dispatch (step state) (dup pool) 81 | where 82 | dispatch :: Maybe (a, s) %1 -> (Pool, Pool) %1 -> List a 83 | dispatch Nothing pools = pools `lseq` Nil 84 | dispatch (Just (a, next)) (pool1, pool2) = 85 | Cons a (Manual.alloc (unfoldL step next pool1) pool2) 86 | 87 | ofList :: (Manual.Representable a) => [a] -> Pool %1 -> List a 88 | ofList l pool = unfold List.uncons l pool 89 | 90 | toList :: (Manual.Representable a) => List a %1 -> [a] 91 | toList l = foldr (:) [] l 92 | 93 | -- | Like unfold but builds the list in reverse, and tail recursive 94 | runfold :: forall a s. (Manual.Representable a) => (s -> Maybe (a, s)) -> s -> Pool %1 -> List a 95 | runfold step state pool = loop state Nil pool 96 | where 97 | loop :: s -> List a %1 -> Pool %1 -> List a 98 | loop state' acc pool' = dispatch (step state') acc (dup pool') 99 | 100 | dispatch :: Maybe (a, s) -> List a %1 -> (Pool, Pool) %1 -> List a 101 | dispatch Nothing !acc pools = pools `lseq` acc 102 | dispatch (Just (a, next)) !acc (pool1, pool2) = 103 | loop next (Cons a (Manual.alloc acc pool1)) pool2 104 | 105 | ofRList :: (Manual.Representable a) => [a] -> Pool %1 -> List a 106 | ofRList l pool = runfold List.uncons l pool 107 | -------------------------------------------------------------------------------- /src/Data/Array/Destination.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | -- | This module provides destination arrays 4 | -- 5 | -- == What are destination arrays? What are they good for? 6 | -- 7 | -- Destination arrays are write-only arrays that are only allocated once, 8 | -- thereby avoiding your reliance on GHC's fusion mechanisms to remove 9 | -- unneccessary allocations. 10 | -- 11 | -- The current status-quo for computations that have a write-only array 12 | -- threaded along is to rely on fusion. While the optimizations in say, 13 | -- `Data.Vector` are quite good at ensuring GHC fuses, they aren't 14 | -- foolproof and can sometimes break by simple refactorings. 15 | -- 16 | -- Avoiding extra allocations of a write-only array is easy in C, with 17 | -- something the functional programming world calls destination passing style, 18 | -- or DPS for short. 19 | -- 20 | -- Here is a C function that manipulates an array written in DPS style; it 21 | -- takes in the destiniation array @res@ and writes to it: 22 | -- 23 | -- @ 24 | -- // ((a + b) * c) for vectors a,b and scalar c 25 | -- void apbxc(int size, int *a, int *b, int c, int *res){ 26 | -- for (int i=0; i Vector Double -> Vector Double 44 | -- jacobi1d n oldA = case stepArr n oldA of 45 | -- newB -> stepArr n newB 46 | -- 47 | -- -- @jacobi1d N A[N] B[N] = (new_A[N], new_B[N])@. 48 | -- stepArr :: Int -> Vector Double -> Vector Double 49 | -- stepArr n oldArr = alloc n $ \newArr -> fillArr newArr oldArr 1 50 | -- where 51 | -- fillArr :: DArray Double %1-> Vector Double -> Int -> () 52 | -- fillArr newA oldA ix 53 | -- | ix == (n-1) = newA & 54 | -- fill (0.33 * ((oldA ! (ix-1)) + (oldA ! ix) + (oldA ! (ix+1)))) 55 | -- | True = split 1 newA & \(fst, rest) -> 56 | -- fill (0.33 * ((oldA ! (ix-1)) + (oldA ! ix) + (oldA ! (ix+1)))) fst & 57 | -- \() -> fillArr rest oldA (ix+1) 58 | -- @ 59 | -- 60 | -- We can be sure that @stepArr@ only allocates one array. In certain 61 | -- variations and implementations of the jacobi kernel or similar dense array 62 | -- computations, ensuring one allocation with @Data.Vector@'s fusion oriented 63 | -- implementation may not be trivial. 64 | -- 65 | -- For reference, the C equivalent of this code is the following: 66 | -- 67 | -- @ 68 | -- static void jacobi_1d_time_step(int n, int *A, int *B){ 69 | -- int t, i; 70 | -- for (i = 1; i < _PB_N - 1; i++) 71 | -- B[i] = 0.33333 * (A[i-1] + A[i] + A[i + 1]); 72 | -- for (i = 1; i < _PB_N - 1; i++) 73 | -- A[i] = 0.33333 * (B[i-1] + B[i] + B[i + 1]); 74 | -- } 75 | -- @ 76 | -- 77 | -- This example is taken from the 78 | -- [polybench test-suite](https://web.cse.ohio-state.edu/~pouchet.2/software/polybench/) 79 | -- of dense array codes. 80 | -- 81 | -- == Aside: Why do we need linear types? 82 | -- 83 | -- Linear types avoids ambiguous writes to the destination array. 84 | -- For example, this function could never be linear and hence we avoid 85 | -- ambiguity: 86 | -- 87 | -- @ 88 | -- nonLinearUse :: DArray Int -> () 89 | -- nonLinearUse arr = case (replicate 3 arr, replicate 4 arr) of 90 | -- ((),()) -> () 91 | -- @ 92 | -- 93 | -- Furthermore, this API is safely implemented by mutating an underlying array 94 | -- which is good for performance. The API is safe because linear types 95 | -- enforce the fact that each reference to an underlying mutable array 96 | -- (and there can be more than one by using @split@) is 97 | -- linearly threaded through functions and at the end consumed by one of our 98 | -- write functions. 99 | -- 100 | -- Lastly, linear types are used to ensure that each cell in the destination 101 | -- array is written to exactly once. This is because the only way to create and 102 | -- use a destination array is via 103 | -- 104 | -- @ 105 | -- alloc :: Int -> (DArray a %1-> ()) %1-> Vector a 106 | -- @ 107 | -- 108 | -- and the only way to really consume a @DArray@ is via our API 109 | -- which requires you to completely fill the array. 110 | module Data.Array.Destination 111 | ( -- * The Data Type 112 | DArray, 113 | 114 | -- * Create and use a @DArray@ 115 | alloc, 116 | size, 117 | 118 | -- * Ways to write to a @DArray@ 119 | replicate, 120 | split, 121 | mirror, 122 | fromFunction, 123 | fill, 124 | dropEmpty, 125 | ) 126 | where 127 | 128 | import Data.Array.Destination.Internal 129 | -------------------------------------------------------------------------------- /src/Data/Array/Polarized/Pull/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE PartialTypeSignatures #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} 7 | {-# OPTIONS_HADDOCK hide #-} 8 | 9 | module Data.Array.Polarized.Pull.Internal where 10 | 11 | import qualified Data.Functor.Linear as Data 12 | import Data.Vector (Vector) 13 | import qualified Data.Vector as Vector 14 | import Prelude.Linear 15 | import qualified Unsafe.Linear as Unsafe 16 | import qualified Prelude 17 | 18 | -- | A pull array is an array from which it is easy to extract elements, and 19 | -- this can be done in any order. The linear consumption of a pull array means 20 | -- each element is consumed exactly once, but the length can be accessed 21 | -- freely. 22 | data Array a where 23 | Array :: (Int -> a) -> Int -> Array a 24 | deriving (Prelude.Semigroup) via NonLinear (Array a) 25 | 26 | -- In the linear consumption of a pull array f n, (f i) should be consumed 27 | -- linearly for every 0 <= i < n. The exported functions (from non-internal 28 | -- modules) should enforce this invariant, but the current type of PullArray 29 | -- does not. 30 | 31 | instance Data.Functor Array where 32 | fmap f (Array g n) = fromFunction (\x -> f (g x)) n 33 | 34 | -- XXX: This should be well-typed without the unsafe, but it isn't accepted: 35 | -- the pull array type probably isn't the ideal choice (making Array linear in 36 | -- (Int -> a) would mean only one value could be taken out of the Array (which 37 | -- is interesting in and of itself: I think this is like an n-ary With), and 38 | -- changing the other arrows makes no difference) 39 | 40 | -- | Create an empty pull array 41 | empty :: Array a 42 | empty = fromFunction (\_ -> error "Data.Array.Polarized.Pull.Internal.empty: this should never be called") 0 43 | 44 | -- | Produce a pull array of lenght 1 consisting of solely the given element. 45 | singleton :: a %1 -> Array a 46 | singleton = Unsafe.toLinear (\x -> fromFunction (\_ -> x) 1) 47 | 48 | -- | @zip [x1, ..., xn] [y1, ..., yn] = [(x1,y1), ..., (xn,yn)]@ 49 | -- __Partial:__ `zip [x1,x2,...,xn] [y1,y2,...,yp]` is an error if @n ≠ p@. 50 | zip :: Array a %1 -> Array b %1 -> Array (a, b) 51 | zip (Array g n) (Array h m) 52 | | n /= m = error "Polarized.zip: size mismatch" 53 | | otherwise = fromFunction (\k -> (g k, h k)) n 54 | 55 | -- | Concatenate two pull arrays. 56 | append :: Array a %1 -> Array a %1 -> Array a 57 | append (Array f m) (Array g n) = Array h (m + n) 58 | where 59 | h k = 60 | if k < m 61 | then f k 62 | else g (k - m) 63 | 64 | -- | Creates a pull array of given size, filled with the given element. 65 | make :: a -> Int -> Array a 66 | make x n = fromFunction (const x) n 67 | 68 | instance Semigroup (Array a) where 69 | (<>) = append 70 | 71 | -- | A right-fold of a pull array. 72 | foldr :: (a %1 -> b %1 -> b) -> b %1 -> Array a %1 -> b 73 | foldr f z (Array g n) = go f z g n 74 | where 75 | go :: (_) => (_ %1 -> _ %1 -> _) -> _ %1 -> _ -> _ -> _ 76 | go _ z' _ 0 = z' 77 | go f' z' g' k = go f' (f' (g' (k - 1)) z') g' (k - 1) 78 | 79 | -- go is strict in its last argument 80 | 81 | -- | Extract the length of an array, and give back the original array. 82 | findLength :: Array a %1 -> (Int, Array a) 83 | findLength (Array f n) = (n, Array f n) 84 | 85 | -- | @'fromFunction' arrIndexer len@ constructs a pull array given a function 86 | -- @arrIndexer@ that goes from an array index to array values and a specified 87 | -- length @len@. 88 | fromFunction :: (Int -> a) -> Int -> Array a 89 | fromFunction f n = Array f' n 90 | where 91 | f' k 92 | | k < 0 = error "Pull.Array: negative index" 93 | | k >= n = error "Pull.Array: index too large" 94 | | otherwise = f k 95 | 96 | -- XXX: this is used internally to ensure out of bounds errors occur, but 97 | -- is unnecessary if the input function can be assumed to already have bounded 98 | -- domain, for instance in `append`. 99 | 100 | -- | This is a convenience function for @alloc . transfer@ 101 | toVector :: Array a %1 -> Vector a 102 | toVector (Array f n) = Vector.generate n f 103 | 104 | -- TODO: A test to make sure alloc . transfer == toVector 105 | 106 | -- | @'split' n v = (vl, vr)@ such that @vl@ has length @n@. 107 | -- 108 | -- 'split' is total: if @n@ is larger than the length of @v@, 109 | -- then @vr@ is empty. 110 | split :: Int -> Array a %1 -> (Array a, Array a) 111 | split k (Array f n) = (fromFunction f (min k n), fromFunction (\x -> f (x + k)) (max (n - k) 0)) 112 | 113 | -- | Reverse a pull array. 114 | reverse :: Array a %1 -> Array a 115 | reverse (Array f n) = Array (\x -> f (n + 1 - x)) n 116 | 117 | -- | Decompose an array into its head and tail, returns @Nothing@ if the array is empty. 118 | uncons :: Array a %1 -> Maybe (a, Array a) 119 | uncons (Array _ 0) = Nothing 120 | uncons (Array f n) = Just (f 0, fromFunction (\x -> f (x + 1)) (n - 1)) 121 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: Continuous integration 2 | on: [push, pull_request] 3 | env: 4 | # Bump this number to invalidate the Github-actions cache 5 | cache-invalidation-key: 0 6 | nixpkgs-url: https://github.com/NixOS/nixpkgs/archive/574d1eac1c200690e27b8eb4e24887f8df7ac27c.tar.gz 7 | 8 | jobs: 9 | cabal-test: 10 | name: cabal test - GHC ${{ matrix.ghc-version }} 11 | strategy: 12 | matrix: 13 | ghc-version: [96, 98, 910, 912] 14 | runs-on: ubuntu-latest 15 | steps: 16 | - uses: actions/checkout@v4 17 | - uses: cachix/install-nix-action@v15 18 | with: 19 | nix_path: "${{ env.nixpkgs-url }}" 20 | - name: Cache Cabal dependencies 21 | uses: actions/cache@v4 22 | with: 23 | path: | 24 | ~/.cabal/packages 25 | ~/.cabal/store 26 | dist-newstyle 27 | key: cabal-deps-${{ runner.os }}-${{ hashFiles('nix/sources.json') }}-${{ matrix.ghc-version }}-v${{ env.cache-invalidation-key }}-${{ hashFiles('linear-base.cabal') }}-${{ github.sha }} 28 | restore-keys: cabal-deps-${{ runner.os }}-${{ hashFiles('nix/sources.json') }}-${{ matrix.ghc-version }}-v${{ env.cache-invalidation-key }}-${{ hashFiles('linear-base.cabal') }}- 29 | - name: Build Nix dependencies 30 | run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "echo '=== Nix dependencies installed ==='" 31 | - name: Init Cabal's config file 32 | run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal --config-file=/home/runner/.cabal/config user-config -f init" 33 | - name: Update Cabal's database 34 | run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal update" 35 | - name: Build Cabal's dependencies 36 | run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build --dependencies-only" 37 | - name: Build 38 | run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build" 39 | - name: Haddock 40 | run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal haddock" 41 | - name: cabal-docspec 42 | run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal-docspec" 43 | - name: Build benchmarks 44 | run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build linear-base:bench:bench" 45 | - name: Run benchmarks 46 | run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal bench 2>&1 | tee benchmark_ghc${{ matrix.ghc-version }}.txt" 47 | - name: Upload benchmark results 48 | uses: actions/upload-artifact@v4 49 | with: 50 | name: linear-base_benchmarks_ghc${{ matrix.ghc-version }} 51 | path: | 52 | benchmark_ghc${{ matrix.ghc-version }}.txt 53 | retention-days: 90 54 | 55 | ormolu: 56 | name: check formatting with ormolu 57 | runs-on: ubuntu-latest 58 | steps: 59 | - uses: actions/checkout@v4 60 | - uses: cachix/install-nix-action@v15 61 | with: 62 | nix_path: "${{ env.nixpkgs-url }}" 63 | - name: Cache Stack dependencies 64 | uses: actions/cache@v4 65 | with: 66 | path: ~/.stack 67 | key: stack-deps-ormolu-${{ runner.os }}-${{ hashFiles('nix/sources.json') }}-v${{ env.cache-invalidation-key }}-${{ hashFiles('stack.yaml.lock') }}-${{ github.sha }} 68 | restore-keys: stack-deps-ormolu-${{ runner.os }}-${{ hashFiles('nix/sources.json') }}-v${{ env.cache-invalidation-key }}-${{ hashFiles('stack.yaml.lock') }}- 69 | - name: Build Nix dependencies 70 | run: nix-shell --arg installHls 'false' --pure --run "echo '=== Nix dependencies installed ==='" 71 | - name: check formatting 72 | run: nix-shell --arg installHls 'false' --pure --run 'stack build ormolu && stack exec ormolu -- -m check $(find . -type f -name "*.hs-boot" -o -name "*.hs")' 73 | 74 | stack-build: 75 | name: stack build 76 | runs-on: ubuntu-latest 77 | steps: 78 | - uses: actions/checkout@v4 79 | - uses: cachix/install-nix-action@v15 80 | with: 81 | nix_path: "${{ env.nixpkgs-url }}" 82 | - name: Cache Stack dependencies 83 | uses: actions/cache@v4 84 | with: 85 | path: ~/.stack 86 | key: stack-deps-${{ runner.os }}-${{ hashFiles('nix/sources.json') }}-v${{ env.cache-invalidation-key }}-${{ hashFiles('stack.yaml.lock', 'linear-base.cabal') }}-${{ github.sha }} 87 | restore-keys: stack-deps-${{ runner.os }}-${{ hashFiles('nix/sources.json') }}-v${{ env.cache-invalidation-key }}-${{ hashFiles('stack.yaml.lock', 'linear-base.cabal') }}- 88 | - name: Build Nix dependencies 89 | run: nix-shell --arg installHls 'false' --pure --run "echo '=== Nix dependencies installed ==='" 90 | - name: Build 91 | run: nix-shell --arg installHls 'false' --pure --run "stack build --pedantic --test --bench --no-run-benchmarks" 92 | -------------------------------------------------------------------------------- /src/Control/Functor/Linear/Internal/State.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wno-orphans #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE QuantifiedConstraints #-} 5 | {-# LANGUAGE RebindableSyntax #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TupleSections #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | {-# OPTIONS_HADDOCK hide #-} 10 | 11 | module Control.Functor.Linear.Internal.State 12 | ( StateT (..), 13 | State, 14 | state, 15 | get, 16 | put, 17 | gets, 18 | modify, 19 | replace, 20 | runStateT, 21 | runState, 22 | mapStateT, 23 | mapState, 24 | evalStateT, 25 | evalState, 26 | execStateT, 27 | execState, 28 | withStateT, 29 | withState, 30 | ) 31 | where 32 | 33 | import Control.Functor.Linear.Internal.Class 34 | import Control.Functor.Linear.Internal.Instances (Data (..)) 35 | import Control.Functor.Linear.Internal.MonadTrans 36 | import qualified Control.Monad as NonLinear () 37 | import qualified Control.Monad.Trans.State.Strict as NonLinear 38 | import Data.Functor.Identity 39 | import qualified Data.Functor.Linear.Internal.Applicative as Data 40 | import qualified Data.Functor.Linear.Internal.Functor as Data 41 | import qualified Data.Tuple.Linear as Linear 42 | import Data.Unrestricted.Linear.Internal.Consumable 43 | import Data.Unrestricted.Linear.Internal.Dupable 44 | import Prelude.Linear.Internal 45 | 46 | -- # StateT 47 | ------------------------------------------------------------------------------- 48 | 49 | -- | A (strict) linear state monad transformer. 50 | newtype StateT s m a = StateT (s %1 -> m (a, s)) 51 | deriving (Data.Applicative) via Data (StateT s m) 52 | 53 | -- We derive Data.Applicative and not Data.Functor since Data.Functor can use 54 | -- weaker constraints on m than Control.Functor, while 55 | -- Data.Applicative needs a Monad instance just like Control.Applicative. 56 | 57 | type State s = StateT s Identity 58 | 59 | get :: (Applicative m, Dupable s) => StateT s m s 60 | get = state dup 61 | 62 | put :: (Applicative m, Consumable s) => s %1 -> StateT s m () 63 | put = Data.void . replace 64 | 65 | gets :: (Applicative m, Dupable s) => (s %1 -> a) %1 -> StateT s m a 66 | gets f = state ((\(s1, s2) -> (f s1, s2)) . dup) 67 | 68 | runStateT :: StateT s m a %1 -> s %1 -> m (a, s) 69 | runStateT (StateT f) = f 70 | 71 | state :: (Applicative m) => (s %1 -> (a, s)) %1 -> StateT s m a 72 | state f = StateT (pure . f) 73 | 74 | runState :: State s a %1 -> s %1 -> (a, s) 75 | runState f = runIdentity' . runStateT f 76 | 77 | mapStateT :: (m (a, s) %1 -> n (b, s)) %1 -> StateT s m a %1 -> StateT s n b 78 | mapStateT r (StateT f) = StateT (r . f) 79 | 80 | withStateT :: (s %1 -> s) %1 -> StateT s m a %1 -> StateT s m a 81 | withStateT r (StateT f) = StateT (f . r) 82 | 83 | execStateT :: (Functor m) => StateT s m () %1 -> s %1 -> m s 84 | execStateT f = fmap (\((), s) -> s) . (runStateT f) 85 | 86 | -- | Use with care! 87 | -- This consumes the final state, so might be costly at runtime. 88 | evalStateT :: (Functor m, Consumable s) => StateT s m a %1 -> s %1 -> m a 89 | evalStateT f = fmap Linear.fst . runStateT f 90 | 91 | mapState :: ((a, s) %1 -> (b, s)) %1 -> State s a %1 -> State s b 92 | mapState f = mapStateT (Identity . f . runIdentity') 93 | 94 | withState :: (s %1 -> s) %1 -> State s a %1 -> State s a 95 | withState = withStateT 96 | 97 | execState :: State s () %1 -> s %1 -> s 98 | execState f = runIdentity' . execStateT f 99 | 100 | -- | Use with care! 101 | -- This consumes the final state, so might be costly at runtime. 102 | evalState :: (Consumable s) => State s a %1 -> s %1 -> a 103 | evalState f = runIdentity' . evalStateT f 104 | 105 | modify :: (Applicative m) => (s %1 -> s) %1 -> StateT s m () 106 | modify f = state $ \s -> ((), f s) 107 | 108 | -- TODO: add strict version of `modify` 109 | 110 | -- | @replace s@ will replace the current state with the new given state, and 111 | -- return the old state. 112 | replace :: (Applicative m) => s %1 -> StateT s m s 113 | replace s = state $ (\s' -> (s', s)) 114 | 115 | -- # Instances of StateT 116 | ------------------------------------------------------------------------------- 117 | 118 | instance (Functor m) => Functor (NonLinear.StateT s m) where 119 | fmap f (NonLinear.StateT x) = NonLinear.StateT $ \s -> fmap (\(a, s') -> (f a, s')) $ x s 120 | 121 | instance (Data.Functor m) => Data.Functor (StateT s m) where 122 | fmap f (StateT x) = StateT (\s -> Data.fmap (\(a, s') -> (f a, s')) (x s)) 123 | 124 | instance (Functor m) => Functor (StateT s m) where 125 | fmap f (StateT x) = StateT (\s -> fmap (\(a, s') -> (f a, s')) (x s)) 126 | 127 | instance (Monad m) => Applicative (StateT s m) where 128 | pure x = StateT (\s -> return (x, s)) 129 | StateT mf <*> StateT mx = StateT $ \s -> do 130 | (f, s') <- mf s 131 | (x, s'') <- mx s' 132 | return (f x, s'') 133 | 134 | instance (Monad m) => Monad (StateT s m) where 135 | StateT mx >>= f = StateT $ \s -> do 136 | (x, s') <- mx s 137 | runStateT (f x) s' 138 | 139 | instance MonadTrans (StateT s) where 140 | lift x = StateT (\s -> fmap (,s) x) 141 | -------------------------------------------------------------------------------- /src/Data/Array/Polarized/Push.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | 7 | -- | This module provides push arrays. 8 | -- 9 | -- These are part of a larger framework for controlling when memory is 10 | -- allocated for an array. See @Data.Array.Polarized@. 11 | -- 12 | -- This module is designed to be imported qualified as @Push@. 13 | module Data.Array.Polarized.Push 14 | ( -- * Construction 15 | Array (..), 16 | make, 17 | singleton, 18 | cons, 19 | snoc, 20 | 21 | -- * Operations 22 | alloc, 23 | foldMap, 24 | unzip, 25 | ) 26 | where 27 | 28 | import Data.Array.Destination (DArray) 29 | import qualified Data.Array.Destination as DArray 30 | import qualified Data.Functor.Linear as Data 31 | import Data.Vector (Vector) 32 | import GHC.Stack 33 | import Prelude.Linear hiding (foldMap, unzip) 34 | import qualified Prelude 35 | 36 | -- The Types 37 | ------------------------------------------------------------------------------- 38 | 39 | -- | Push arrays are un-allocated finished arrays. These are finished 40 | -- computations passed along or enlarged until we are ready to allocate. 41 | data Array a where 42 | Array :: (forall m. (Monoid m) => (a -> m) -> m) %1 -> Array a 43 | 44 | -- Developer notes: 45 | -- 46 | -- Think of @(a -> m)@ as something that writes an @a@ and think of 47 | -- @((a -> m) -> m)@ as something that takes a way to write a single element 48 | -- and writes and concatenates all elements. The @m@ is something that 49 | -- represents a writing of some elements to an array, a delayed write. 50 | -- 51 | -- Also, note that in this formulation we don't know the length beforehand. 52 | 53 | data ArrayWriter a where 54 | ArrayWriter :: (DArray a %1 -> ()) %1 -> !Int -> ArrayWriter a 55 | 56 | -- The second parameter is the length of the @DArray@ 57 | -- 58 | -- Developer notes: 59 | -- 60 | -- This is the linear monoid @m@ that we instantiate the above array with 61 | -- in order to allocate. An @ArrayWriter a@ is something that holds the 62 | -- ingredients to write some number of elements to an array, without 63 | -- holding the space to do so. 64 | 65 | -- API 66 | ------------------------------------------------------------------------------- 67 | 68 | -- | Convert a push array into a vector by allocating. This would be a common 69 | -- end to a computation using push and pull arrays. 70 | alloc :: Array a %1 -> Vector a 71 | alloc (Array k) = allocArrayWriter $ k singletonWriter 72 | where 73 | singletonWriter :: a -> ArrayWriter a 74 | singletonWriter a = ArrayWriter (DArray.fill a) 1 75 | 76 | allocArrayWriter :: ArrayWriter a %1 -> Vector a 77 | allocArrayWriter (ArrayWriter writer len) = DArray.alloc len writer 78 | 79 | -- | @`make` x n@ creates a constant push array of length @n@ in which every 80 | -- element is @x@. 81 | make :: (HasCallStack) => a -> Int -> Array a 82 | make x n 83 | | n < 0 = error "Making a negative length push array" 84 | | otherwise = Array (\makeA -> mconcat $ Prelude.replicate n (makeA x)) 85 | 86 | singleton :: a -> Array a 87 | singleton x = Array (\writeA -> writeA x) 88 | 89 | snoc :: a -> Array a %1 -> Array a 90 | snoc x (Array k) = Array (\writeA -> (k writeA) <> (writeA x)) 91 | 92 | cons :: a -> Array a %1 -> Array a 93 | cons x (Array k) = Array (\writeA -> (writeA x) <> (k writeA)) 94 | 95 | foldMap :: (Monoid b) => (a -> b) -> Array a %1 -> b 96 | foldMap f (Array k) = k f 97 | 98 | unzip :: Array (a, b) %1 -> (Array a, Array b) 99 | unzip (Array k) = k (\(a, b) -> (singleton a, singleton b)) 100 | 101 | -- # Instances 102 | ------------------------------------------------------------------------------- 103 | 104 | instance Data.Functor Array where 105 | fmap f (Array k) = Array (\g -> k (\x -> (g (f x)))) 106 | 107 | instance Prelude.Semigroup (Array a) where 108 | (<>) x y = append x y 109 | 110 | instance Semigroup (Array a) where 111 | (<>) = append 112 | 113 | instance Prelude.Monoid (Array a) where 114 | mempty = empty 115 | 116 | instance Monoid (Array a) where 117 | mempty = empty 118 | 119 | empty :: Array a 120 | empty = Array (\_ -> mempty) 121 | 122 | append :: Array a %1 -> Array a %1 -> Array a 123 | append (Array k1) (Array k2) = Array (\writeA -> k1 writeA <> k2 writeA) 124 | 125 | instance Prelude.Semigroup (ArrayWriter a) where 126 | (<>) x y = addWriters x y 127 | 128 | instance Prelude.Monoid (ArrayWriter a) where 129 | mempty = emptyWriter 130 | 131 | instance Semigroup (ArrayWriter a) where 132 | (<>) = addWriters 133 | 134 | instance Monoid (ArrayWriter a) where 135 | mempty = emptyWriter 136 | 137 | addWriters :: ArrayWriter a %1 -> ArrayWriter a %1 -> ArrayWriter a 138 | addWriters (ArrayWriter k1 l1) (ArrayWriter k2 l2) = 139 | ArrayWriter 140 | ( \darr -> 141 | (DArray.split l1 darr) & \(darr1, darr2) -> consume (k1 darr1, k2 darr2) 142 | ) 143 | (l1 + l2) 144 | 145 | emptyWriter :: ArrayWriter a 146 | emptyWriter = ArrayWriter DArray.dropEmpty 0 147 | 148 | -- Remark. @emptyWriter@ assumes we can split a destination array at 0. 149 | -------------------------------------------------------------------------------- /src/Control/Functor/Linear/Internal/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# OPTIONS -Wno-orphans #-} 5 | {-# LANGUAGE LinearTypes #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE NoImplicitPrelude #-} 8 | {-# OPTIONS_HADDOCK hide #-} 9 | 10 | module Control.Functor.Linear.Internal.Reader 11 | ( -- ReaderT monad transformer 12 | Reader, 13 | reader, 14 | runReader, 15 | mapReader, 16 | withReader, 17 | ReaderT (..), 18 | runReaderT, 19 | mapReaderT, 20 | withReaderT, 21 | ask, 22 | local, 23 | asks, 24 | ) 25 | where 26 | 27 | import Control.Functor.Linear.Internal.Class 28 | import Control.Functor.Linear.Internal.Instances () 29 | import Control.Functor.Linear.Internal.MonadTrans 30 | import qualified Control.Monad as NonLinear () 31 | import qualified Control.Monad.Trans.Reader as NonLinear 32 | import Data.Functor.Identity 33 | import qualified Data.Functor.Linear.Internal.Applicative as Data 34 | import qualified Data.Functor.Linear.Internal.Functor as Data 35 | import Data.Kind (FUN) 36 | import Data.Unrestricted.Linear.Internal.Consumable 37 | import Data.Unrestricted.Linear.Internal.Dupable 38 | import GHC.Exts (Multiplicity (..)) 39 | import Prelude.Linear.Internal (runIdentity', ($), (.)) 40 | 41 | -- # Linear ReaderT 42 | ------------------------------------------------------------------------------- 43 | 44 | -- | A linear reader monad transformer. 45 | -- This reader monad requires that use of the read-only state is explict. 46 | -- 47 | -- The monad instance requires that @r@ be 'Dupable'. This means that you 48 | -- should use the linear reader monad just like the non-linear monad, except 49 | -- that the type system ensures that you explicity use or discard the 50 | -- read-only state (with the 'Consumable' instance). 51 | newtype ReaderT r m a = ReaderT (r %1 -> m a) 52 | 53 | -- XXX: Replace with a newtype deconstructor once it can be inferred as linear. 54 | 55 | -- | Provide an intial read-only state and run the monadic computation in 56 | -- a reader monad transformer 57 | runReaderT :: ReaderT r m a %1 -> r %1 -> m a 58 | runReaderT (ReaderT f) = f 59 | 60 | instance (Data.Functor m) => Data.Functor (ReaderT r m) where 61 | fmap f = mapReaderT (Data.fmap f) 62 | 63 | instance (Functor m) => Functor (ReaderT r m) where 64 | fmap f = mapReaderT (fmap f) 65 | 66 | instance (Data.Applicative m, Dupable r) => Data.Applicative (ReaderT r m) where 67 | pure x = ReaderT $ \r -> lseq r (Data.pure x) 68 | ReaderT f <*> ReaderT x = ReaderT ((\(r1, r2) -> f r1 Data.<*> x r2) . dup) 69 | 70 | instance (Applicative m, Dupable r) => Applicative (ReaderT r m) where 71 | pure x = ReaderT $ \r -> lseq r (pure x) 72 | ReaderT f <*> ReaderT x = ReaderT ((\(r1, r2) -> f r1 Data.<*> x r2) . dup) 73 | 74 | instance (Monad m, Dupable r) => Monad (ReaderT r m) where 75 | ReaderT x >>= f = ReaderT ((\(r1, r2) -> x r1 >>= (\a -> runReaderT (f a) r2)) . dup) 76 | 77 | type Reader r = ReaderT r Identity 78 | 79 | ask :: (Applicative m) => ReaderT r m r 80 | ask = ReaderT pure 81 | 82 | withReaderT :: (r' %1 -> r) %1 -> ReaderT r m a %1 -> ReaderT r' m a 83 | withReaderT f m = ReaderT $ runReaderT m . f 84 | 85 | local :: (r %1 -> r) %1 -> ReaderT r m a %1 -> ReaderT r m a 86 | local = withReaderT 87 | 88 | reader :: (Monad m) => (r %1 -> a) %1 -> ReaderT r m a 89 | reader f = ReaderT (return . f) 90 | 91 | runReader :: Reader r a %1 -> r %1 -> a 92 | runReader m = runIdentity' . runReaderT m 93 | 94 | mapReader :: (a %1 -> b) %1 -> Reader r a %1 -> Reader r b 95 | mapReader f = mapReaderT (Identity . f . runIdentity') 96 | 97 | mapReaderT :: (m a %1 -> n b) %1 -> ReaderT r m a %1 -> ReaderT r n b 98 | mapReaderT f m = ReaderT (f . runReaderT m) 99 | 100 | withReader :: (r' %1 -> r) %1 -> Reader r a %1 -> Reader r' a 101 | withReader = withReaderT 102 | 103 | asks :: (Monad m) => (r %1 -> a) %1 -> ReaderT r m a 104 | asks f = ReaderT (return . f) 105 | 106 | instance (Dupable r) => MonadTrans (ReaderT r) where 107 | lift x = ReaderT (`lseq` x) 108 | 109 | -- # Instances for nonlinear ReaderT 110 | ------------------------------------------------------------------------------- 111 | 112 | instance (Functor m) => Functor (NonLinear.ReaderT r m) where 113 | fmap f (NonLinear.ReaderT g) = NonLinear.ReaderT $ \r -> fmap f (g r) 114 | 115 | instance (Applicative m) => Applicative (NonLinear.ReaderT r m) where 116 | pure x = NonLinear.ReaderT $ \_ -> pure x 117 | NonLinear.ReaderT f <*> NonLinear.ReaderT x = NonLinear.ReaderT $ \r -> f r <*> x r 118 | 119 | instance (Monad m) => Monad (NonLinear.ReaderT r m) where 120 | NonLinear.ReaderT x >>= f = NonLinear.ReaderT $ \r -> x r >>= (\a -> runReaderT' (f a) r) 121 | 122 | -- XXX: Temporary, until newtype record projections are linear. 123 | runReaderT' :: NonLinear.ReaderT r m a %1 -> r -> m a 124 | runReaderT' (NonLinear.ReaderT f) = f 125 | 126 | instance MonadTrans (NonLinear.ReaderT r) where 127 | lift x = NonLinear.ReaderT (\_ -> x) 128 | 129 | deriving via Reader r instance (Dupable r) => Data.Applicative (FUN 'One r) 130 | 131 | deriving via Reader r instance (Dupable r) => Applicative (FUN 'One r) 132 | 133 | deriving via Reader r instance (Dupable r) => Monad (FUN 'One r) 134 | -------------------------------------------------------------------------------- /src/Prelude/Linear/GenericUtil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | -- | @'FixupMetaData' a g@ copies the metadata from the 8 | -- @"GHC.Generics".'GHC.Generics.Generic'@ representation of @a@ to the 9 | -- representation @g@. 10 | -- 11 | -- @'FixupMetaData1' f g@ does something similar when @f 'Any'@ is an instance 12 | -- of @Generic@ and @g@ is a @Rep1@. See the individual type documentation 13 | -- for details. 14 | -- 15 | -- This is intended to help users instantiate 'Rep' and 'Rep1' for types with 16 | -- nonlinear or multiplicity-polymorphic fields. 17 | -- 18 | -- == Suggested use 19 | -- 20 | -- You will need to derive a @"GHC.Generics.Generic"@ instance for the 21 | -- type. This is used to obtain the correct metadata. 22 | -- 23 | -- Next you need to construct a @Rep@ and/or @Rep1@ for your type, ignoring the 24 | -- metadata. 25 | -- 26 | -- Constructing the actual representations can be a bit annoying, but GHC can 27 | -- help. 28 | -- 29 | -- === For 'Rep' 30 | -- 31 | -- Once you have derived @"GHC.Generics".'GHC.Generics.Generic'@ for your 32 | -- type, define a value like 33 | -- 34 | -- @ 35 | -- test :: Rep T a 36 | -- test = _ 37 | -- @ 38 | -- 39 | -- Then compile. The stripped representation you need will be in the error 40 | -- message. 41 | -- 42 | -- === For 'Rep1' 43 | -- 44 | -- Construct a type with the same shape as the one you wish to 45 | -- instantiate, but with only linear fields. Strictness annotations 46 | -- and @UNPACK@ pragmas are irrelevant here. 47 | -- 48 | -- Instantiate @"Generics.Linear".'Generic1'@ for the lookalike using 49 | -- 'Generics.Linear.TH.deriveGeneric1' and follow the same procedure 50 | -- as above (but with @'Rep1' T@, of course) to get a metadata-stripped 51 | -- representation. 52 | -- 53 | -- === For either 54 | -- 55 | -- To avoid confusion, replace at least the package and module names in the 56 | -- representation with 'Any'. Wrap @MP1@ around any nonlinear/representation 57 | -- polymorphic fields, just under the @S1@ type constructor. The first type 58 | -- argument of @MP1@ will indicate the multiplicity. 59 | module Prelude.Linear.GenericUtil 60 | ( FixupMetaData, 61 | FixupMetaData1, 62 | RemoveMetaData, 63 | ) 64 | where 65 | 66 | import Data.Kind (Type) 67 | import qualified GHC.Generics 68 | import GHC.TypeLits 69 | import Generics.Linear 70 | 71 | -- | @FixupMetaData a g@ copies the metadata from the 72 | -- @"GHC.Generics".'GHC.Generics.Generic'@ representation of @a@ to the 73 | -- representation @g@. It also checks that the structure of @Rep a@ is the 74 | -- same as @g@, except that @g@ may have @MP1@ applications under some @S1@ 75 | -- constructors. 76 | -- 77 | -- === Example 78 | -- 79 | -- @ 80 | -- instance 'Generic' ('Prelude.Linear.Ur' a) where 81 | -- type Rep (Ur a) = FixupMetaData (Ur a) 82 | -- (D1 Any 83 | -- (C1 Any 84 | -- (S1 Any 85 | -- (MP1 \'Many (Rec0 a))))) 86 | -- @ 87 | type FixupMetaData (a :: Type) (g :: Type -> Type) = 88 | Fixup (GHC.Generics.Rep a) g 89 | 90 | -- | @FixupMetaData1 f g@ copies the metadata from the 91 | -- @"GHC.Generics".'GHC.Generics.Generic'@ representation of @f 'Any'@ 92 | -- to the representation @g@. It also checks that the overall structure of 93 | -- @Rep (f 'Any')@ is the same as @g@, but does not check that their fields 94 | -- match. 95 | -- 96 | -- === Example 97 | -- 98 | -- @ 99 | -- instance 'Generic1' 'Prelude.Linear.Ur' where 100 | -- type Rep1 Ur = FixupMetaData1 Ur 101 | -- (D1 Any 102 | -- (C1 Any 103 | -- (S1 Any 104 | -- (MP1 \'Many Par1)))) 105 | -- @ 106 | type FixupMetaData1 (f :: k -> Type) (g :: k -> Type) = 107 | Fixup1 (GHC.Generics.Rep (f Any)) g 108 | 109 | type family Fixup (f :: Type -> Type) (g :: Type -> Type) :: Type -> Type where 110 | Fixup (D1 c f) (D1 _c g) = D1 c (Fixup f g) 111 | Fixup (C1 c f) (C1 _c g) = C1 c (Fixup f g) 112 | Fixup (S1 c f) (S1 _c (MP1 m f)) = S1 c (MP1 m f) 113 | Fixup (S1 c f) (S1 _c f) = S1 c f 114 | Fixup (f :*: g) (f' :*: g') = Fixup f f' :*: Fixup g g' 115 | Fixup (f :+: g) (f' :+: g') = Fixup f f' :+: Fixup g g' 116 | Fixup V1 V1 = V1 117 | Fixup _ _ = TypeError ('Text "FixupMetaData: representations do not match.") 118 | 119 | type family Fixup1 (f :: Type -> Type) (g :: k -> Type) :: k -> Type where 120 | Fixup1 (D1 c f) (D1 _c g) = D1 c (Fixup1 f g) 121 | Fixup1 (C1 c f) (C1 _c g) = C1 c (Fixup1 f g) 122 | Fixup1 (f :*: g) (f' :*: g') = Fixup1 f f' :*: Fixup1 g g' 123 | Fixup1 (f :+: g) (f' :+: g') = Fixup1 f f' :+: Fixup1 g g' 124 | Fixup1 (S1 c _f) (S1 _c g) = S1 c g 125 | Fixup1 V1 V1 = V1 126 | Fixup1 _ _ = TypeError ('Text "Fixup1MetaData1: representations do not match.") 127 | 128 | type family RemoveMetaData (f :: k -> Type) :: k -> Type where 129 | RemoveMetaData (D1 _c f) = D1 Any (RemoveMetaData f) 130 | RemoveMetaData (C1 _c f) = C1 Any (RemoveMetaData f) 131 | RemoveMetaData (S1 _c f) = S1 Any f 132 | RemoveMetaData (f :*: g) = RemoveMetaData f :*: RemoveMetaData g 133 | RemoveMetaData (f :+: g) = RemoveMetaData f :+: RemoveMetaData g 134 | RemoveMetaData x = x 135 | 136 | type family Any :: k 137 | -------------------------------------------------------------------------------- /src/Data/Monoid/Linear/Internal/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# OPTIONS_GHC -Wno-orphans #-} 7 | {-# OPTIONS_HADDOCK hide #-} 8 | 9 | -- | This module provides linear versions of 'Monoid'. 10 | -- 11 | -- To learn about how these classic monoids work, go to this school of haskell 12 | -- [post](https://www.schoolofhaskell.com/user/mgsloan/monoids-tour). 13 | module Data.Monoid.Linear.Internal.Monoid 14 | ( -- * Monoid operations 15 | Monoid (..), 16 | mconcat, 17 | mappend, 18 | -- Cannot export Data.Monoid.{First,Last} because of the name clash with Data.Semigroup.{First,Last} 19 | ) 20 | where 21 | 22 | import Data.Functor.Compose (Compose (Compose)) 23 | import qualified Data.Functor.Compose as Functor 24 | import Data.Functor.Const (Const) 25 | import Data.Functor.Identity (Identity (Identity)) 26 | import Data.Functor.Product (Product (Pair)) 27 | import qualified Data.Functor.Product as Functor 28 | import qualified Data.Monoid as Monoid 29 | import Data.Monoid.Linear.Internal.Semigroup 30 | import Data.Ord (Down (Down)) 31 | import Data.Proxy (Proxy (Proxy)) 32 | import Data.Unrestricted.Linear.Internal.Consumable (Consumable) 33 | import qualified Data.Unrestricted.Linear.Internal.Ur as Ur 34 | import GHC.Types hiding (Any) 35 | import Prelude.Linear.Internal 36 | import Prelude (Maybe (Nothing)) 37 | import qualified Prelude 38 | 39 | -- | A linear monoid is a linear semigroup with an identity on the binary 40 | -- operation. 41 | -- 42 | -- Laws (same as 'Data.Monoid.Monoid'): 43 | -- * ∀ x ∈ G, x <> mempty = mempty <> x = x 44 | class (Semigroup a) => Monoid a where 45 | {-# MINIMAL mempty #-} 46 | mempty :: a 47 | 48 | instance (Prelude.Semigroup a, Monoid a) => Prelude.Monoid (NonLinear a) where 49 | mempty = NonLinear mempty 50 | 51 | -- convenience redefine 52 | 53 | mconcat :: (Monoid a) => [a] %1 -> a 54 | mconcat (xs' :: [a]) = go mempty xs' 55 | where 56 | go :: a %1 -> [a] %1 -> a 57 | go acc [] = acc 58 | go acc (x : xs) = go (acc <> x) xs 59 | 60 | mappend :: (Monoid a) => a %1 -> a %1 -> a 61 | mappend = (<>) 62 | 63 | --------------- 64 | -- Instances -- 65 | --------------- 66 | 67 | instance Prelude.Monoid (Endo a) where 68 | mempty = Endo id 69 | 70 | -- Instances below are listed in the same order as in https://hackage.haskell.org/package/base-4.16.0.0/docs/Data-Monoid.html 71 | 72 | instance Monoid All where 73 | mempty = All True 74 | 75 | instance Monoid Any where 76 | mempty = Any False 77 | 78 | instance Monoid Ordering where 79 | mempty = EQ 80 | 81 | instance Monoid () where 82 | mempty = () 83 | 84 | instance (Monoid a) => Monoid (Identity a) where 85 | mempty = Identity mempty 86 | 87 | instance (Consumable a) => Monoid (Monoid.First a) where 88 | mempty = Monoid.First Nothing 89 | 90 | instance (Consumable a) => Monoid (Monoid.Last a) where 91 | mempty = Monoid.Last Nothing 92 | 93 | instance (Monoid a) => Monoid (Down a) where 94 | mempty = Down mempty 95 | 96 | -- Cannot add instance (Ord a, Bounded a) => Monoid (Max a); would require (NonLinear.Ord a, Consumable a) 97 | -- Cannot add instance (Ord a, Bounded a) => Monoid (Min a); would require (NonLinear.Ord a, Consumable a) 98 | 99 | instance (Monoid a) => Monoid (Dual a) where 100 | mempty = Dual mempty 101 | 102 | instance Monoid (Endo a) where 103 | mempty = Endo id 104 | 105 | -- See Data.Num.Linear for instance ... => Monoid (Product a) 106 | -- See Data.Num.Linear for instance ... => Monoid (Sum a) 107 | -- See System.IO.Linear for instance ... => Monoid (IO a) 108 | -- See System.IO.Resource.Internal for instance ... => Monoid (RIO a) 109 | 110 | instance (Semigroup a) => Monoid (Maybe a) where 111 | mempty = Nothing 112 | 113 | -- See Data.List.Linear for instance ... => Monoid [a] 114 | -- Cannot add instance Monoid a => Monoid (Op a b); would require Dupable b 115 | 116 | instance Monoid (Proxy a) where 117 | mempty = Proxy 118 | 119 | -- Cannot add instance Monoid a => Monoid (ST s a); I think that it would require a linear ST monad 120 | -- Cannot add instance Monoid b => Monoid (a -> b); would require Dupable a 121 | 122 | instance (Monoid a, Monoid b) => Monoid (a, b) where 123 | mempty = (mempty, mempty) 124 | 125 | instance (Monoid a) => Monoid (Const a b) where 126 | mempty = mempty 127 | 128 | -- See Data.Functor.Linear.Applicative for instance ... => Monoid (Ap f a) 129 | -- Cannot add instance Alternative f => Monoid (Alt f a); we don't have a linear Alternative 130 | 131 | instance (Monoid a, Monoid b, Monoid c) => Monoid (a, b, c) where 132 | mempty = (mempty, mempty, mempty) 133 | 134 | instance (Monoid (f a), Monoid (g a)) => Monoid (Functor.Product f g a) where 135 | mempty = Pair mempty mempty 136 | 137 | instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a, b, c, d) where 138 | mempty = (mempty, mempty, mempty, mempty) 139 | 140 | instance (Monoid (f (g a))) => Monoid (Functor.Compose f g a) where 141 | mempty = Compose mempty 142 | 143 | instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => Monoid (a, b, c, d, e) where 144 | mempty = (mempty, mempty, mempty, mempty, mempty) 145 | 146 | -- | Useful to treat /unrestricted/ monoids as linear ones. 147 | instance (Prelude.Monoid a) => Monoid (Ur.Ur a) where 148 | mempty = Ur.Ur Prelude.mempty 149 | {-# INLINE mempty #-} 150 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Linear base 2 | 3 | [![License MIT](https://img.shields.io/badge/license-MIT-brightgreen.svg)](https://github.com/tweag/linear-base/blob/master/LICENSE) 4 | [![Hackage](https://img.shields.io/hackage/v/linear-base.svg?style=flat&color=brightgreen)][hackage-pkg] 5 | [![Stackage](https://stackage.org/package/linear-base/badge/nightly)][stackage-pkg] 6 | [![Discord](https://img.shields.io/badge/Discord-100000?style=flat&logo=Discord&logoColor=C3C3C3&labelColor=4179DA&color=010101)][discord] 7 | 8 | Linear base is a standard library for developing applications with linear 9 | types. It is named `linear-base` to be an analog to the original [`base`] 10 | package that ships with GHC. 11 | 12 | The purpose of `linear-base` is to provide the minimal facilities you need to 13 | write _practical_ Linear Haskell code, i.e., Haskell code that uses the 14 | `-XLinearTypes` language extension. 15 | 16 | ## Motivation 17 | 18 | _Why do you need `linear-base` to write linear projects?_ 19 | 20 | 1. Data types, functions and classes in `base` are not linear types 21 | aware. For instance, if `n` is a linearly-bound `Int`, the RHS of 22 | a definition cannot write `n + 1` — this will not type check. We 23 | need linear variants of `Num`, `Functor`s, `Monad`s, `($)`, etc. 24 | 25 | 2. This library exports new abstractions that leverage linear types 26 | for resource safety or performance. For example, there are new APIs 27 | for file and socket I/O as well as for safe in-place mutation of 28 | arrays. 29 | 30 | ## Getting started 31 | 32 | `-XLinearTypes` is released with GHC 9, and `linear-base` is released 33 | on [Hackage][hackage-pkg] and [Stackage][stackage-pkg]. 34 | 35 | All source files with linear types need a language extension pragma at 36 | the top: 37 | 38 | ``` 39 | {-# LANGUAGE LinearTypes #-} 40 | ``` 41 | 42 | To get in touch, you can join our 43 | [![Discord](https://img.shields.io/badge/Discord-100000?style=flat&logo=Discord&logoColor=C3C3C3&labelColor=4179DA&color=010101)][discord] server 44 | 45 | 46 | ## User Guide 47 | 48 | If you already know what `-XLinearTypes` does and what the linear 49 | arrow `a %1-> b` means, then read the [User Guide] and explore the 50 | [`examples/`](https://github.com/tweag/linear-base/blob/master/examples) folder to know how to use `linear-base`. 51 | 52 | You can also find a table comparing `base` and `linear-base` typeclasses 53 | [here](https://github.com/tweag/linear-base/blob/master/docs/CLASS_TABLE.md). 54 | 55 | ## Learning about `-XLinearTypes` 56 | 57 | If you're a Haskeller who hasn't written any Linear Haskell code, don't fear! 58 | There are plenty of excellent resources and examples to help you. 59 | 60 | ### Tutorials and examples 61 | 62 | * See the [`examples/`](https://github.com/tweag/linear-base/blob/master/examples) folder. 63 | * [Linear examples on watertight 3D models](https://github.com/gelisam/linear-examples) 64 | 65 | ### Reading material 66 | 67 | * There is a [wiki page](https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types). 68 | * Key Blog posts 69 | * [Predictable performance](https://www.tweag.io/posts/2017-03-13-linear-types.html) (the first blog post from Tweag on this) 70 | * [IO State Transitions](https://www.tweag.io/posts/2017-08-03-linear-typestates.html) 71 | * [Streaming](https://www.tweag.io/posts/2018-06-21-linear-streams.html) 72 | * See [here](https://www.tweag.io/blog/tags/linear-types/) for all of Tweag's blog posts on linear types. 73 | * [Here is the paper](https://arxiv.org/pdf/1710.09756.pdf) behind `-XLinearTypes`. 74 | 75 | ### Talks 76 | – 77 | * [Distributed Programming with Linear Types – Haskell Exchange 2017](https://skillsmatter.com/skillscasts/10637-distributed-programming-with-linear-types) 78 | * [Practical Linearity in a higher-order polymorphic language – POPL 2018](https://www.youtube.com/watch?v=o0z-qlb5xbI) 79 | * [Practical Linearity in a higher-order polymorphic language – Curry on 2018](https://www.youtube.com/watch?v=t0mhvd3-60Y) 80 | * [Practical Linearity in a higher-order polymorphic language – Haskell Exchange 2018](https://skillsmatter.com/skillscasts/11067-keynote-linear-haskell-practical-linearity-in-a-higher-order-polymorphic-language) 81 | * [Implementing Linear Haskell](https://www.youtube.com/watch?v=uxv62QQajx8) 82 | * [In-place array update with linear types – ZuriHac 2020](https://www.youtube.com/watch?v=I7-JuVNvz78) 83 | * [Typecheck Your Memory Management with Linear Types – Haskell Exchange 2017](https://skillsmatter.com/skillscasts/14896-typecheck-your-memory-management-with-linear-types) 84 | 85 | ## Contributing 86 | 87 | Linear base is maintained by [Tweag]. 88 | 89 | To contribute please see the [Design Document] for instructions and advice on 90 | making pull requests. 91 | 92 | A great first step is to join our 93 | [![Discord](https://img.shields.io/badge/Discord-100000?style=flat&logo=Discord&logoColor=C3C3C3&labelColor=4179DA&color=010101)][discord] server 94 | 95 | ## Licence 96 | 97 | See the [Licence file](https://github.com/tweag/linear-base/blob/master/LICENSE). 98 | 99 | Copyright © Tweag Holding and its affiliates. 100 | 101 | [Tweag]: https://www.tweag.io/ 102 | [`base`]: https://hackage.haskell.org/package/base 103 | [User Guide]: https://github.com/tweag/linear-base/blob/master/docs/USER_GUIDE.md 104 | [Design Document]: https://github.com/tweag/linear-base/blob/master/docs/DESIGN.md 105 | [hackage-pkg]: https://hackage.haskell.org/package/linear-base 106 | [stackage-pkg]: https://www.stackage.org/nightly/package/linear-base 107 | [discord]: https://discord.com/invite/7yg5GxzvDJ 108 | -------------------------------------------------------------------------------- /docs/USER_GUIDE.md: -------------------------------------------------------------------------------- 1 | # User Guide 2 | 3 | This short guide assumes 4 | familiarity with linear types (see the [`README`] for resources about linear types 5 | if you are unfamiliar). 6 | 7 | #### Table of contents 8 | 9 | 1. [How to navigate the library](#navigating-the-library) 10 | 2. [Core concepts you need to know](#core-concepts) 11 | 3. [Current limitations](#temporary-limitations) 12 | 13 | ## Navigating the library 14 | 15 | * The [`Prelude.Linear`] module is a good place to start. It is a prelude for 16 | Haskell programs that use `-XLinearTypes` and is meant to replace the original 17 | prelude from `base`. 18 | * For mutable data with a pure API, 19 | consider looking at `Data.{Array, Hashmap, Vector, Set}.Mutable.Linear`. 20 | * A linear `IO` monad is in `System.IO.Linear`. 21 | * A variant of linear `IO` which lets you enforce resource safety 22 | can be found in `System.IO.Resource.Linear`. 23 | * Streams in the style of the [`streaming` 24 | library](https://hackage.haskell.org/package/streaming) is in 25 | `Streaming.Linear` and `Streaming.Prelude.Linear`. 26 | * How `Prelude.Linear` classes relate to their `base` (non-linear) counterpart is 27 | described in the [class comparison table](https://github.com/tweag/linear-base/blob/master/docs/CLASS_TABLE.md). 28 | 29 | There are many other modules of course but a lot of the ones not already listed 30 | are still experimental, such as system-heap memory management in `Foreign.Marshall.Pure`. 31 | 32 | ### Naming conventions & layout 33 | 34 | Typically, variants of common Haskell tools and facilities 35 | share the same name with a `Linear` postfix. For instance, 36 | `Data.Bool.Linear` provides the linear versions of `not` 37 | and `&&`. 38 | 39 | The module names follow the typical hierarchical module 40 | naming scheme with top-level names like `Control`, `Data`, `System` 41 | and so on. 42 | 43 | 44 | ## Core concepts 45 | 46 | ### Using values multiple times 47 | 48 | Frequently enough, you will want to consume a linear value, or maybe 49 | use it multiple time. The basic tools you need to do this are in 50 | [`Data.Unrestricted`] and are typically re-exported by 51 | [`Prelude.Linear`]. 52 | 53 | Interfacing linear code with regular Haskell is done, for instance, through the type `Ur`. 54 | The data type `Ur`, short for _unrestricted_ lets you store an 55 | unrestricted value inside a linear value. 56 | 57 | ### Import Conventions 58 | 59 | We've designed `linear-base` to work nicely with the following import conventions: 60 | 61 | - `import qualified Data.Functor.Linear as Data` 62 | - `import qualified Control.Functor.Linear as Control` 63 | 64 | ### Importing linear and non-linear code 65 | 66 | Most modules with `{-# LANGUAGE LinearHaskell #-}` will want to have a mix of 67 | linear and non-linear code and, for example, import linear modules like 68 | `Data.Functor.Linear` and unrestricted modules from `base` like `Data.List`. 69 | The pattern we've followed internally is to import the non-linear module 70 | qualified. For instance: 71 | 72 | ```haskell 73 | import Prelude.Linear 74 | import Data.Functor.Linear 75 | import qualified Prelude as NonLinear 76 | import Data.List as List 77 | ``` 78 | 79 | Sometimes it's easier to use `forget :: (a %1-> b) -> (a -> b)` from 80 | `Prelude.Linear` than to import the non-linear version of some function. 81 | This is useful in passing linear functions to higher order functions. 82 | For non HOF uses, we can use linear functions directly; given a linear function 83 | `f`, we can always write `g x = f x` for `g :: A -> B`. 84 | 85 | 86 | ### `f :: X -> (SomeType %1-> Ur b) %1-> Ur b` functions 87 | 88 | This style function is used throughout `linear-base`, particularly 89 | with mutable data structures. 90 | 91 | It serves to limit the **scope** of using `SomeType` by taking 92 | a function of type `(SomeType %1-> Ur b)` 93 | as its second argument and using it with a value of type `SomeType` to 94 | produce an `Ur b`. We call this function of type `(SomeType %1-> Ur b)`, 95 | a **scope function** or just **scope** for short. 96 | 97 | The `SomeType` cannot escape the scope function by being inside the type `b` 98 | in some way. This is because the `SomeType` is bound linearly in the scope 99 | function and `Ur` can only contain unrestricted (in particular not linear) 100 | values. At any nested level, the `SomeType` would have to be used in an 101 | unrestricted way. 102 | 103 | Now, if `f` is the only function that can make a `SomeType`, 104 | then we have an API that completely controls the creation-to-deletion 105 | lifetime (i.e, the scope) of `SomeType`. 106 | 107 | 108 | ## Temporary limitations 109 | 110 | ### `let` and `where` bindings are not linear 111 | 112 | The following will **fail** to type check: 113 | 114 | ```haskell 115 | idBad1 :: a %1-> a 116 | idBad1 x = y 117 | where 118 | y = x 119 | 120 | idBad2 :: a %1-> a 121 | idBad2 x = let y = x in y 122 | ``` 123 | 124 | This is because GHC assumes that anything used in a `where`-binding or 125 | `let`-binding is consumed with multiplicity `Many`. Workaround: inline 126 | these bindings or use sub-functions. 127 | 128 | ```haskell 129 | inlined1 :: a %1-> a 130 | inlined1 x = x 131 | 132 | useSubfunction :: Array a %1-> Array a 133 | useSubfunction arr = fromRead (read arr 0) 134 | where 135 | fromRead :: (Array a, Ur a) %1-> Array a 136 | fromRead = undefined 137 | ``` 138 | 139 | [`Data.Unrestricted`]: https://github.com/tweag/linear-base/blob/master/src/Data/Unrestricted/Linear.hs 140 | [`Prelude.Linear`]: https://github.com/tweag/linear-base/blob/master/src/Prelude/Linear.hs 141 | [`README`]: https://github.com/tweag/linear-base/blob/master/README.md 142 | -------------------------------------------------------------------------------- /examples/Simple/FileIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE QualifiedDo #-} 5 | {-# LANGUAGE RebindableSyntax #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 13 | 14 | -- | 15 | -- Module : FileIO 16 | -- Description : The Linear File IO example from the Linear Haskell paper. 17 | -- 18 | -- We implement a function that prints the first line of a file. 19 | -- 20 | -- We do this with the normal file IO interface in base and the linear file IO 21 | -- interface in linear-base. With the latter, the protocol for using files is 22 | -- enforced by the linear type system. For instance, forgetting to close the file 23 | -- will induce a type error at compile time. That is, typechecking proves that all 24 | -- opened files are closed at some later point in execution. With the former 25 | -- interface, we have code that type checks but will error or cause errors at 26 | -- runtime. 27 | module Simple.FileIO where 28 | 29 | -- Linear Base Imports 30 | import qualified Control.Functor.Linear as Control 31 | import Control.Monad () 32 | import Data.Text 33 | import Data.Unrestricted.Linear 34 | import qualified System.IO as System 35 | import qualified System.IO.Resource.Linear as Linear 36 | import Prelude 37 | 38 | -- * Non-linear first line printing 39 | 40 | -------------------------------------------- 41 | 42 | -- openFile :: FilePath -> IOMode -> IO Handle 43 | -- IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode 44 | -- hGetLine :: Handle -> IO String 45 | -- hPutStr :: Handle -> String -> IO () 46 | -- hClose :: Handle -> IO () 47 | 48 | printFirstLine :: FilePath -> System.IO () 49 | printFirstLine fpath = do 50 | fileHandle <- System.openFile fpath System.ReadMode 51 | firstLine <- System.hGetLine fileHandle 52 | System.putStrLn firstLine 53 | System.hClose fileHandle 54 | 55 | -- This compiles but can cause issues! 56 | -- The number of file handles you can have active is finite and after that 57 | -- openFile errors. This is especially critical on mobile devices or systems 58 | -- with limited resources. 59 | printFirstLineNoClose :: FilePath -> System.IO () 60 | printFirstLineNoClose fpath = do 61 | fileHandle <- System.openFile fpath System.ReadMode 62 | firstLine <- System.hGetLine fileHandle 63 | System.putStrLn firstLine 64 | 65 | -- This compiles, but will throw an error! 66 | printFirstLineAfterClose :: FilePath -> System.IO () 67 | printFirstLineAfterClose fpath = do 68 | fileHandle <- System.openFile fpath System.ReadMode 69 | System.hClose fileHandle 70 | firstLine <- System.hGetLine fileHandle 71 | System.putStrLn firstLine 72 | 73 | -- * Linear first line printing 74 | 75 | -------------------------------------------- 76 | 77 | linearGetFirstLine :: FilePath -> RIO (Ur Text) 78 | linearGetFirstLine fp = Control.do 79 | handle <- Linear.openFile fp System.ReadMode 80 | (t, handle') <- Linear.hGetLine handle 81 | Linear.hClose handle' 82 | Control.return t 83 | 84 | linearPrintFirstLine :: FilePath -> System.IO () 85 | linearPrintFirstLine fp = do 86 | text <- Linear.run (linearGetFirstLine fp) 87 | System.putStrLn (unpack text) 88 | 89 | {- 90 | For clarity, we show this function without do notation. 91 | 92 | Note that the current approach is limited. 93 | We have to make the continuation use the unit type. 94 | 95 | Enabling a more generic approach with a type index 96 | for the multiplicity, as descibed in the paper is a work in progress. 97 | This will hopefully result in using 98 | 99 | `(>>==) RIO 'Many a %1-> (a -> RIO p b) %1-> RIO p b` 100 | 101 | as the non-linear bind operation. 102 | See https://github.com/tweag/linear-base/issues/83. 103 | -} 104 | 105 | -- * Linear and non-linear combinators 106 | 107 | ------------------------------------------------- 108 | 109 | -- Some type synonyms 110 | type RIO = Linear.RIO 111 | 112 | type LinHandle = Linear.Handle 113 | 114 | -- | Linear bind 115 | -- Notice the continuation has a linear arrow, 116 | -- i.e., (a %1-> RIO b) 117 | (>>#=) :: RIO a %1 -> (a %1 -> RIO b) %1 -> RIO b 118 | (>>#=) = (Control.>>=) 119 | 120 | infixl 1 >>#= -- same fixity as base.>>= 121 | 122 | -- | Non-linear bind 123 | -- Notice the continuation has a non-linear arrow, 124 | -- i.e., (() -> RIO b). For simplicity, we don't use 125 | -- a more general type, like the following: 126 | -- (>>==) :: RIO (Ur a) %1-> (a -> RIO b) %1-> RIO b 127 | (>>==) :: RIO () %1 -> (() -> RIO b) %1 -> RIO b 128 | (>>==) ma f = ma Control.>>= (\() -> f ()) 129 | 130 | infixl 1 >>== -- same fixity as base.>>= 131 | 132 | -- | Inject 133 | -- provided just to make the type explicit 134 | inject :: a %1 -> RIO a 135 | inject = Control.return 136 | 137 | -- * The explicit example 138 | 139 | ------------------------------------------------- 140 | 141 | getFirstLineExplicit :: FilePath -> RIO (Ur Text) 142 | getFirstLineExplicit path = 143 | (openFileForReading path) 144 | >>#= readOneLine 145 | >>#= closeAndReturnLine -- Internally uses (>>==) 146 | where 147 | openFileForReading :: FilePath -> RIO LinHandle 148 | openFileForReading fp = Linear.openFile fp System.ReadMode 149 | readOneLine :: LinHandle %1 -> RIO (Ur Text, LinHandle) 150 | readOneLine = Linear.hGetLine 151 | closeAndReturnLine :: 152 | (Ur Text, LinHandle) %1 -> RIO (Ur Text) 153 | closeAndReturnLine (unrText, handle) = 154 | Linear.hClose handle >>#= (\() -> inject unrText) 155 | 156 | printFirstLineExplicit :: FilePath -> System.IO () 157 | printFirstLineExplicit fp = do 158 | firstLine <- Linear.run $ getFirstLineExplicit fp 159 | putStrLn $ unpack firstLine 160 | -------------------------------------------------------------------------------- /src/Data/Ord/Linear/Internal/Ord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE LinearTypes #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# OPTIONS_HADDOCK hide #-} 7 | 8 | module Data.Ord.Linear.Internal.Ord 9 | ( Ord (..), 10 | Ordering (..), 11 | min, 12 | max, 13 | ) 14 | where 15 | 16 | import Data.Bool.Linear (Bool (..), not) 17 | import Data.Int (Int16, Int32, Int64, Int8) 18 | import Data.Monoid.Linear 19 | import Data.Ord (Ordering (..)) 20 | import Data.Ord.Linear.Internal.Eq 21 | import Data.Unrestricted.Linear 22 | import Data.Word (Word16, Word32, Word64, Word8) 23 | import Prelude.Linear.Internal 24 | import qualified Prelude 25 | 26 | -- | Linear Orderings 27 | -- 28 | -- Linear orderings provide a strict order. The laws for @(<=)@ for 29 | -- all \(a,b,c\): 30 | -- 31 | -- * reflexivity: \(a \leq a \) 32 | -- * antisymmetry: \((a \leq b) \land (b \leq a) \rightarrow (a = b) \) 33 | -- * transitivity: \((a \leq b) \land (b \leq c) \rightarrow (a \leq c) \) 34 | -- 35 | -- and these \"agree\" with @<@: 36 | -- 37 | -- * @x <= y@ = @not (y > x)@ 38 | -- * @x >= y@ = @not (y < x)@ 39 | -- 40 | -- Unlike in the non-linear setting, a linear @compare@ doesn't follow from 41 | -- @<=@ since it requires calls: one to @<=@ and one to @==@. However, 42 | -- from a linear @compare@ it is easy to implement the others. Hence, the 43 | -- minimal complete definition only contains @compare@. 44 | class (Eq a) => Ord a where 45 | {-# MINIMAL compare #-} 46 | 47 | -- | @compare x y@ returns an @Ordering@ which is 48 | -- one of @GT@ (greater than), @EQ@ (equal), or @LT@ (less than) 49 | -- which should be understood as \"x is @(compare x y)@ y\". 50 | compare :: a %1 -> a %1 -> Ordering 51 | 52 | -- /!\ `compare` doesn't have a specified fixity in base 53 | -- but we chose infix 4 for consistency with `elem`, <, <=, ==, /= ... 54 | infix 4 `compare` 55 | 56 | (<=) :: a %1 -> a %1 -> Bool 57 | x <= y = not (x > y) 58 | infix 4 <= -- same fixity as base.<= 59 | 60 | (<) :: a %1 -> a %1 -> Bool 61 | x < y = compare x y == LT 62 | infix 4 < -- same fixity as base.< 63 | 64 | (>) :: a %1 -> a %1 -> Bool 65 | x > y = compare x y == GT 66 | infix 4 > -- same fixity as base.> 67 | 68 | (>=) :: a %1 -> a %1 -> Bool 69 | x >= y = not (x < y) 70 | infix 4 >= -- same fixity as base.>= 71 | 72 | -- | @max x y@ returns the larger input, or 'y' 73 | -- in case of a tie. 74 | max :: (Dupable a, Ord a) => a %1 -> a %1 -> a 75 | max x y = 76 | dup2 x & \(x', x'') -> 77 | dup2 y & \(y', y'') -> 78 | if x' <= y' 79 | then x'' `lseq` y'' 80 | else y'' `lseq` x'' 81 | 82 | -- | @min x y@ returns the smaller input, or 'y' 83 | -- in case of a tie. 84 | min :: (Dupable a, Ord a) => a %1 -> a %1 -> a 85 | min x y = 86 | dup2 x & \(x', x'') -> 87 | dup2 y & \(y', y'') -> 88 | if x' <= y' 89 | then y'' `lseq` x'' 90 | else x'' `lseq` y'' 91 | 92 | -- * Instances 93 | 94 | instance (Prelude.Ord a) => Ord (Ur a) where 95 | Ur x `compare` Ur y = x `Prelude.compare` y 96 | 97 | instance (Consumable a, Ord a) => Ord (Prelude.Maybe a) where 98 | Prelude.Nothing `compare` Prelude.Nothing = EQ 99 | Prelude.Nothing `compare` Prelude.Just y = y `lseq` LT 100 | Prelude.Just x `compare` Prelude.Nothing = x `lseq` GT 101 | Prelude.Just x `compare` Prelude.Just y = x `compare` y 102 | 103 | instance 104 | (Consumable a, Consumable b, Ord a, Ord b) => 105 | Ord (Prelude.Either a b) 106 | where 107 | Prelude.Left x `compare` Prelude.Right y = (x, y) `lseq` LT 108 | Prelude.Right x `compare` Prelude.Left y = (x, y) `lseq` GT 109 | Prelude.Left x `compare` Prelude.Left y = x `compare` y 110 | Prelude.Right x `compare` Prelude.Right y = x `compare` y 111 | 112 | instance (Consumable a, Ord a) => Ord [a] where 113 | {-# SPECIALIZE instance Ord [Prelude.Char] #-} 114 | compare [] [] = EQ 115 | compare xs [] = xs `lseq` GT 116 | compare [] ys = ys `lseq` LT 117 | compare (x : xs) (y : ys) = 118 | case compare x y of 119 | EQ -> compare xs ys 120 | res -> (xs, ys) `lseq` res 121 | 122 | instance (Ord a, Ord b) => Ord (a, b) where 123 | (a, b) `compare` (a', b') = 124 | compare a a' <> compare b b' 125 | 126 | instance (Ord a, Ord b, Ord c) => Ord (a, b, c) where 127 | (a, b, c) `compare` (a', b', c') = 128 | compare a a' <> compare b b' <> compare c c' 129 | 130 | instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) where 131 | (a, b, c, d) `compare` (a', b', c', d') = 132 | compare a a' <> compare b b' <> compare c c' <> compare d d' 133 | 134 | deriving via MovableOrd () instance Ord () 135 | 136 | deriving via MovableOrd Prelude.Int instance Ord Prelude.Int 137 | 138 | deriving via MovableOrd Prelude.Double instance Ord Prelude.Double 139 | 140 | deriving via MovableOrd Prelude.Bool instance Ord Prelude.Bool 141 | 142 | deriving via MovableOrd Prelude.Char instance Ord Prelude.Char 143 | 144 | deriving via MovableOrd Prelude.Ordering instance Ord Prelude.Ordering 145 | 146 | deriving via MovableOrd Int16 instance Ord Int16 147 | 148 | deriving via MovableOrd Int32 instance Ord Int32 149 | 150 | deriving via MovableOrd Int64 instance Ord Int64 151 | 152 | deriving via MovableOrd Int8 instance Ord Int8 153 | 154 | deriving via MovableOrd Word16 instance Ord Word16 155 | 156 | deriving via MovableOrd Word32 instance Ord Word32 157 | 158 | deriving via MovableOrd Word64 instance Ord Word64 159 | 160 | deriving via MovableOrd Word8 instance Ord Word8 161 | 162 | newtype MovableOrd a = MovableOrd a 163 | 164 | instance (Prelude.Eq a, Movable a) => Eq (MovableOrd a) where 165 | MovableOrd ar == MovableOrd br = 166 | move (ar, br) & \(Ur (a, b)) -> 167 | a Prelude.== b 168 | 169 | MovableOrd ar /= MovableOrd br = 170 | move (ar, br) & \(Ur (a, b)) -> 171 | a Prelude./= b 172 | 173 | instance (Prelude.Ord a, Movable a) => Ord (MovableOrd a) where 174 | MovableOrd ar `compare` MovableOrd br = 175 | move (ar, br) & \(Ur (a, b)) -> 176 | a `Prelude.compare` b 177 | --------------------------------------------------------------------------------