diff --git a/sdp.cabal b/sdp.cabal --- a/sdp.cabal +++ b/sdp.cabal @@ -1,5 +1,5 @@ name: sdp -version: 0.2.0.1 +version: 0.2.1 category: Data Structures synopsis: Simple Data Processing @@ -9,7 +9,7 @@ maintainer: work.a.mulik@gmail.com bug-reports: https://github.com/andreymulik/sdp/issues -copyright: 2019 Andrey Mulik +copyright: 2019-2021 Andrey Mulik license-file: LICENSE license: BSD3 @@ -45,14 +45,16 @@ default-language: Haskell2010 hs-source-dirs: src - ghc-options: -O2 -Wall -Wcompat -Wno-orphans + ghc-options: -O2 -Wall -Wcompat build-depends: base >= 4.9 && < 5, + fmr >= 0.2 && < 1, ghc-prim >= 0.5 && < 0.7, data-default-class >= 0.1 && < 0.2 exposed-modules: + -- Commons SDP.SafePrelude SDP.Comparing SDP.Estimate @@ -76,11 +78,12 @@ SDP.Shaped SDP.Linear SDP.MapM + SDP.ZipM SDP.Scan SDP.Sort SDP.Map - SDP.Set SDP.Zip + SDP.Set -- Templates SDP.Templates.AnyBorder @@ -114,6 +117,11 @@ SDP.ByteList.IOUblist -- STM arrays + Control.Concurrent.SDP.TArray + Control.Concurrent.SDP.TUnlist + Control.Concurrent.SDP.TUnrolled + + -- Deprecated Control.Concurent.SDP.TArray Control.Concurent.SDP.TUnlist Control.Concurent.SDP.TUnrolled @@ -126,5 +134,7 @@ Text.Show.SDP Text.Read.SDP + + diff --git a/src/Control/Concurent/SDP/TArray.hs b/src/Control/Concurent/SDP/TArray.hs --- a/src/Control/Concurent/SDP/TArray.hs +++ b/src/Control/Concurent/SDP/TArray.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE Safe, MagicHash #-} - {- | Module : Control.Concurent.SDP.TArray - Copyright : (c) Andrey Mulik 2020 + Copyright : (c) Andrey Mulik 2020-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : portable @@ -10,21 +8,13 @@ "Control.Concurent.SDP.TArray" provides lazy boxed array of @stm@ 'TVar's. -} module Control.Concurent.SDP.TArray +{-# WARNING "This module is the result of a typo in the word \ + \@concurrent@ and will be removed in sdp-0.3" #-} ( - -- * TArray - TArray, STM, TVar + module Control.Concurrent.SDP.TArray ) where -import SDP.Templates.AnyBorder -import SDP.Prim.TArray - -default () - --------------------------------------------------------------------------------- - --- | Lazy boxed array. -type TArray = AnyBorder TArray# - +import Control.Concurrent.SDP.TArray diff --git a/src/Control/Concurent/SDP/TUnlist.hs b/src/Control/Concurent/SDP/TUnlist.hs --- a/src/Control/Concurent/SDP/TUnlist.hs +++ b/src/Control/Concurent/SDP/TUnlist.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE Safe, MagicHash #-} - {- | Module : Control.Concurent.SDP.TUnlist - Copyright : (c) Andrey Mulik 2020 + Copyright : (c) Andrey Mulik 2020-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : portable @@ -11,20 +9,12 @@ @stm@ 'TVar's. -} module Control.Concurent.SDP.TUnlist +{-# WARNING "This module is the result of a typo in the word \ + \@concurrent@ and will be removed in sdp-0.3" #-} ( - -- * TUnlist - TUnlist, STM, TVar + module Control.Concurrent.SDP.TUnlist ) where -import SDP.Templates.AnyChunks -import SDP.Prim.TArray - -default () - --------------------------------------------------------------------------------- - --- | Lazy boxed unrolled linked list. -type TUnlist = AnyChunks TArray# - +import Control.Concurrent.SDP.TUnlist diff --git a/src/Control/Concurent/SDP/TUnrolled.hs b/src/Control/Concurent/SDP/TUnrolled.hs --- a/src/Control/Concurent/SDP/TUnrolled.hs +++ b/src/Control/Concurent/SDP/TUnrolled.hs @@ -1,30 +1,20 @@ -{-# LANGUAGE Safe #-} - {- | Module : Control.Concurent.SDP.TUnrolled - Copyright : (c) Andrey Mulik 2020 + Copyright : (c) Andrey Mulik 2020-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : portable - "Control.Concurent.SDP.TUnrolled" provides lazy boxed unrolled linked list - of @stm@ 'TVar's. + "Control.Concurent.SDP.TUnrolled" provides mutable lazy boxed bordered + unrolled linked list. -} module Control.Concurent.SDP.TUnrolled +{-# WARNING "This module is the result of a typo in the word \ + \@concurrent@ and will be removed in sdp-0.3" #-} ( - -- * TUnrolled - TUnrolled, STM, TVar + module Control.Concurrent.SDP.TUnrolled ) where -import Control.Concurent.SDP.TUnlist -import SDP.Templates.AnyBorder - -default () - --------------------------------------------------------------------------------- - --- | Lazy boxed unrolled libked list. -type TUnrolled = AnyBorder TUnlist - +import Control.Concurrent.SDP.TUnrolled diff --git a/src/Control/Concurrent/SDP/TArray.hs b/src/Control/Concurrent/SDP/TArray.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/SDP/TArray.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : Control.Concurrent.SDP.TArray + Copyright : (c) Andrey Mulik 2020-2021 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "Control.Concurrent.SDP.TArray" provides lazy boxed array of @stm@ 'TVar's. +-} +module Control.Concurrent.SDP.TArray +( + -- * TArray + TArray, STM, TVar +) +where + +import SDP.Templates.AnyBorder +import SDP.Prim.TArray + +default () + +-------------------------------------------------------------------------------- + +-- | Lazy boxed array. +type TArray = AnyBorder TArray# + + + diff --git a/src/Control/Concurrent/SDP/TUnlist.hs b/src/Control/Concurrent/SDP/TUnlist.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/SDP/TUnlist.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : Control.Concurrent.SDP.TUnlist + Copyright : (c) Andrey Mulik 2020-2021 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "Control.Concurrent.SDP.TUnlist" provides lazy boxed unrolled linked list of + @stm@ 'TVar's. +-} +module Control.Concurrent.SDP.TUnlist +( + -- * TUnlist + TUnlist, STM, TVar +) +where + +import SDP.Templates.AnyChunks +import SDP.Prim.TArray + +default () + +-------------------------------------------------------------------------------- + +-- | Lazy boxed unrolled linked list. +type TUnlist = AnyChunks TArray# + + diff --git a/src/Control/Concurrent/SDP/TUnrolled.hs b/src/Control/Concurrent/SDP/TUnrolled.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/SDP/TUnrolled.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : Control.Concurrent.SDP.TUnrolled + Copyright : (c) Andrey Mulik 2020-2021 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "Control.Concurrent.SDP.TUnrolled" provides lazy boxed unrolled linked list + of @stm@ 'TVar's. +-} +module Control.Concurrent.SDP.TUnrolled +( + -- * TUnrolled + TUnrolled, STM, TVar +) +where + +import Control.Concurrent.SDP.TUnlist +import SDP.Templates.AnyBorder + +default () + +-------------------------------------------------------------------------------- + +-- | Lazy boxed unrolled libked list. +type TUnrolled = AnyBorder TUnlist + + diff --git a/src/Control/Exception/SDP.hs b/src/Control/Exception/SDP.hs --- a/src/Control/Exception/SDP.hs +++ b/src/Control/Exception/SDP.hs @@ -2,7 +2,7 @@ {- | Module : Control.Exception.SDP - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : portable @@ -33,20 +33,26 @@ 'IndexException' replaces the less informative 'ArrayException' and has more neutral names. - * 'UnacceptableExpansion' - occurs if the desired range exceed the actual size - * 'UnexpectedRank' - occurs when trying to convert a list into a generalized - index of inappropriate dimension - * 'UndefinedValue' - occurs if the value is undefined - * 'EmptyRange' - occurs if range is empty - * 'IndexOverflow' - occurs if index overflows range - * 'IndexUnderflow' - occurs if index underflows range - - 'Exception' constructors are specified in the order of definition, this is the - recommended check order. + * 'UnacceptableExpansion' - occurs when performing the (safe) rebound + operation with unacceptable target range (example: an attempt to convert + structure with bounds @(2, 5)@ to structure with bounds @('\\0', '\\255')@ is + invalid because available size is smaller than required) + * 'UnexpectedRank' - occurs when trying to convert one representation of an + index to another, if their dimensions doesn't match (example: trying to + convert a list @[1, 2, 3]@ of type @[Int]@ to an index of type @(T4 Int)@) + * 'UndefinedValue' - occurs when referring to a non-existent or undefined + element; some unsafe structures and operations can lead to the possibility of + untracked reading of invalid or undefined values + * 'EmptyRange' - occurs when accessing the contents of an empty structure + * 'IndexOverflow' - occurs when going beyond the upper boundary of the + structure (overflow) + * 'IndexUnderflow' - occurs when going beyond the lower boundary of the + structure (underflow) If the error type may depend on the check order, it should be indicated in the documentation. For example: overflow is checked first, and then underflow. But - if an overflow is detected, underflow may not be noticed. + if an overflow is detected, underflow may not be noticed. 'IndexException' + constructor order is the recommended order. -} data IndexException = UnacceptableExpansion String | UndefinedValue String @@ -72,11 +78,11 @@ {- | A 'UnreachableException' is used as an exception that should never be thrown. - * 'ErrorCall' and 'AssertionFailed' means that the function is partially - defined or missused (if some arguments shouldn't be passed). - * 'UnreachableException' means that some expression, by definition, cannot be - reached (for example, a default value when initializing an array, if each - value is guaranteed to be overwritten before use). + Example: @newArray#@ requires a default value to fill the newly created array. + If the array is guaranteed to be filled with values (for example, in the + @replicate@ function), then this value will never be needed and, therefore, + calculated. 'UnreachableException' in this case will be a marker of + unreachability of this expression. -} data UnreachableException = UnreachableException String deriving (Eq, Typeable) diff --git a/src/SDP/Array/IO.hs b/src/SDP/Array/IO.hs --- a/src/SDP/Array/IO.hs +++ b/src/SDP/Array/IO.hs @@ -7,7 +7,7 @@ Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.Array.IO provides 'IOArray' - mutable lazy boxed array type. + "SDP.Array.IO" provides 'IOArray' - mutable lazy boxed array type. -} module SDP.Array.IO ( diff --git a/src/SDP/ByteList.hs b/src/SDP/ByteList.hs --- a/src/SDP/ByteList.hs +++ b/src/SDP/ByteList.hs @@ -7,7 +7,8 @@ Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.ByteList" provides 'ByteList' - strict unboxed unrolled linked list. + "SDP.ByteList" provides 'ByteList' - immutable strict bordered unboxed + unrolled linked list. -} module SDP.ByteList ( @@ -41,5 +42,4 @@ -- | 'ByteList' is bordered strict unboxed unrolled linked list. type ByteList = AnyBorder Ublist - diff --git a/src/SDP/ByteList/IO.hs b/src/SDP/ByteList/IO.hs --- a/src/SDP/ByteList/IO.hs +++ b/src/SDP/ByteList/IO.hs @@ -7,8 +7,8 @@ Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.ByteList.IO" provides 'IOByteList' - mutable strict unboxed unrolled - linked list type. + "SDP.ByteList.IO" provides 'IOByteList' - mutable strict unboxed bordered + unrolled linked list type. -} module SDP.ByteList.IO ( diff --git a/src/SDP/ByteList/ST.hs b/src/SDP/ByteList/ST.hs --- a/src/SDP/ByteList/ST.hs +++ b/src/SDP/ByteList/ST.hs @@ -7,8 +7,8 @@ Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.ByteList.ST" provides 'STByteList' - mutable unboxed strict unrolled - linked list. + "SDP.ByteList.ST" provides 'STByteList' - mutable unboxed strict bordered + unrolled linked list. -} module SDP.ByteList.ST ( diff --git a/src/SDP/Bytes/ST.hs b/src/SDP/Bytes/ST.hs --- a/src/SDP/Bytes/ST.hs +++ b/src/SDP/Bytes/ST.hs @@ -7,7 +7,7 @@ Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) - "SDP.Bytes.ST" provides 'STBytes' - mutable lazy boxed array type. + "SDP.Bytes.ST" provides 'STBytes' - mutable strict unboxed array type. -} module SDP.Bytes.ST ( diff --git a/src/SDP/Estimate.hs b/src/SDP/Estimate.hs --- a/src/SDP/Estimate.hs +++ b/src/SDP/Estimate.hs @@ -1,11 +1,15 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe, CPP, ConstraintKinds #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.Estimate - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com - Portability : portable + Portability : non-portable (GHC extensions) "SDP.Estimate" provides 'Estimate' class, type synonyms and some common comparators. This module is exported by "SDP.SafePrelude". @@ -16,7 +20,16 @@ module Data.Functor.Classes, -- * Estimate - Estimate (..), (<=.>), (<.), (>.), (<=.), (>=.), (==.), (/=.) + Estimate (..), Estimate1, Estimate2, + +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + Estimate', Estimate'', +#endif + + -- ** Right-side Estimate functions. + (<=.>), (<.), (>.), (<=.), (>=.), (==.), (/=.) ) where @@ -43,16 +56,16 @@ where {-# MINIMAL (<.=>), (<==>) #-} - -- | Left-side structure length with number comparison. + -- | Compare structure length with given number. (<.=>) :: e -> Int -> Ordering - -- | Two structures by length comparison. + -- | Compare pair of structures by length. (<==>) :: Compare e - -- | Left-side structure length with number comparison. + -- | Compare structure length with given number. (.==), (./=), (.<=), (.>=), (.<), (.>) :: e -> Int -> Bool - -- | Two structures comparison by length. + -- | Compare pair of structures by length. (.<.), (.>.), (.<=.), (.>=.), (.==.), (./=.) :: e -> e -> Bool e .< i = case e <.=> i of {LT -> True; _ -> False} @@ -69,11 +82,11 @@ e1 .==. e2 = case e1 <==> e2 of {EQ -> True; _ -> False} e1 ./=. e2 = case e1 <==> e2 of {EQ -> False; _ -> True} --- | Right-side number with structure length comparison. +-- | Compare given number with structure length. (<=.>) :: (Estimate e) => Int -> e -> Ordering i <=.> e = case e <.=> i of {LT -> GT; EQ -> EQ; GT -> LT} --- | Right-side number with structure length comparison. +-- | Compare given number with structure length. (==.), (/=.), (<=.), (>=.), (<.), (>.) :: (Estimate e) => Int -> e -> Bool (==.) = flip (.==) @@ -85,6 +98,22 @@ -------------------------------------------------------------------------------- +-- | @(Type -> Type)@ kind 'Estimate'. +type Estimate1 rep e = Estimate (rep e) + +-- | @(Type -> Type -> Type)@ kind 'Estimate'. +type Estimate2 rep i e = Estimate (rep i e) + +#if __GLASGOW_HASKELL__ >= 806 +-- | 'Estimate' quantified contraint for @(Type -> Type)@-kind types. +type Estimate' rep = forall e . Estimate (rep e) + +-- | 'Estimate' quantified contraint for @(Type -> Type -> Type)@-kind types. +type Estimate'' rep = forall i e . Estimate (rep i e) +#endif + +-------------------------------------------------------------------------------- + instance Estimate [a] where [] <==> [] = EQ @@ -96,5 +125,6 @@ es <.=> n = let go xs c | c == 0 = GT | null xs = 0 <=> c | True = tail xs `go` (c - 1) in if n < 0 then LT else go es n + diff --git a/src/SDP/Finite.hs b/src/SDP/Finite.hs --- a/src/SDP/Finite.hs +++ b/src/SDP/Finite.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-} -{-# LANGUAGE Trustworthy, TypeFamilies, TypeOperators, OverloadedLists #-} +{-# LANGUAGE Trustworthy, TypeFamilies, TypeOperators #-} +{-# LANGUAGE UndecidableInstances, FlexibleInstances #-} {- | Module : SDP.Finite - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com - Portability : non-portable (a lot of GHC extensions) - - "SDP.Finite" provide generalized finite-dimensional index type (':&') based on - @repa@ @(:.)@. - - Since @sdp-0.2@, for (':&') available @OverloadedLists@-based syntactic sugar. - For example, instead of the inconvenient @es!(ind4 0 1 2 3)@ or just awful - @es!(E:&0:&1:&1:&2:&3)@ you can write: @es![0, 1, 2, 3]@. - - Note that @OverloadedLists@ instances requires a strictly defined number of - subindexes. + Portability : non-portable (GHC extensions) + + "SDP.Finite" provide generalized finite-dimensional index type (':&') based + on @repa@ @(:.)@. + + Since @sdp-0.2@, for (':&') available @OverloadedLists@-based syntactic sugar. + For example, instead of the inconvenient @es!(ind4 0 1 2 3)@ or just awful + @es!(E:&0:&1:&1:&2:&3)@ you can write: @es![0, 1, 2, 3]@. + + Note that @OverloadedLists@ instances requires a strictly defined number of + subindexes. -} module SDP.Finite ( @@ -34,6 +34,7 @@ import Prelude ( (++) ) import SDP.SafePrelude +import SDP.Nullable import Data.Default.Class @@ -63,6 +64,9 @@ fromList = const E toList = const [] +-- | @since 0.2.1 +instance Nullable E where lzero = E; isNull = const True + -------------------------------------------------------------------------------- {- N-dimensional index type. -} @@ -75,16 +79,16 @@ instance (Enum i) => Enum (E :& i) where - succ = \ [e] -> [succ e] - pred = \ [e] -> [pred e] + fromEnum (E :& e) = fromEnum e + succ (E :& e) = E :& succ e + pred (E :& e) = E :& pred e - toEnum = \ n -> [toEnum n] - fromEnum = \ [e] -> fromEnum e + toEnum = (E :&) . toEnum - enumFrom = \ [f] -> [ [e] | e <- [f ..] ] - enumFromTo = \ [f] [l] -> [ [e] | e <- [f .. l] ] - enumFromThen = \ [f] [n] -> [ [e] | e <- [f, n ..] ] - enumFromThenTo = \ [f] [n] [l] -> [ [e] | e <- [f, n .. l] ] + enumFrom (E :& f) = (E :&) <$> [f ..] + enumFromTo (E :& f) (E :& l) = (E :&) <$> [f .. l] + enumFromThen (E :& f) (E :& n) = (E :&) <$> [f, n ..] + enumFromThenTo (E :& f) (E :& n) (E :& l) = (E :&) <$> [f, n .. l] instance (Default d, Default d') => Default (d :& d') where def = def :& def @@ -181,25 +185,26 @@ -- | 15-dimensional index constructor. ind15 :: i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> I15 i -ind2 a b = [a,b] -ind3 a b c = [a,b,c] -ind4 a b c d = [a,b,c,d] -ind5 a b c d e = [a,b,c,d,e] -ind6 a b c d e f = [a,b,c,d,e,f] -ind7 a b c d e f g = [a,b,c,d,e,f,g] -ind8 a b c d e f g h = [a,b,c,d,e,f,g,h] -ind9 a b c d e f g h i = [a,b,c,d,e,f,g,h,i] -ind10 a b c d e f g h i j = [a,b,c,d,e,f,g,h,i,j] -ind11 a b c d e f g h i j k = [a,b,c,d,e,f,g,h,i,j,k] -ind12 a b c d e f g h i j k l = [a,b,c,d,e,f,g,h,i,j,k,l] -ind13 a b c d e f g h i j k l m = [a,b,c,d,e,f,g,h,i,j,k,l,m] -ind14 a b c d e f g h i j k l m n = [a,b,c,d,e,f,g,h,i,j,k,l,m,n] -ind15 a b c d e f g h i j k l m n o = [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o] - --------------------------------------------------------------------------------- +ind2 a b = E:&a:&b +ind3 a b c = E:&a:&b:&c +ind4 a b c d = E:&a:&b:&c:&d +ind5 a b c d e = E:&a:&b:&c:&d:&e +ind6 a b c d e f = E:&a:&b:&c:&d:&e:&f +ind7 a b c d e f g = E:&a:&b:&c:&d:&e:&f:&g +ind8 a b c d e f g h = E:&a:&b:&c:&d:&e:&f:&g:&h +ind9 a b c d e f g h i = E:&a:&b:&c:&d:&e:&f:&g:&h:&i +ind10 a b c d e f g h i j = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j +ind11 a b c d e f g h i j k = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k +ind12 a b c d e f g h i j k l = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l +ind13 a b c d e f g h i j k l m = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l:&m +ind14 a b c d e f g h i j k l m n = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l:&m:&n +ind15 a b c d e f g h i j k l m n o = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l:&m:&n:&o unsnoc :: [i] -> ([i], i) unsnoc [i] = ([], i) unsnoc (i : is) = (i :) `first` unsnoc is unsnoc _ = throw $ UnexpectedRank "in SDP.Finite.fromList" + + + diff --git a/src/SDP/Index.hs b/src/SDP/Index.hs --- a/src/SDP/Index.hs +++ b/src/SDP/Index.hs @@ -1,23 +1,24 @@ -{-# LANGUAGE Trustworthy, OverloadedLists, ConstraintKinds, TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TypeFamilies, UndecidableInstances, DefaultSignatures, CPP #-} +{-# LANGUAGE Trustworthy, ConstraintKinds, TypeOperators #-} {- | Module : SDP.Index - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) - The 'Index' class is a fork of 'Data.Ix.Ix' with a richer interface, more - convenient function names and generalized indexes. + The 'Index' class is an alternative to 'Data.Ix.Ix' with a richer interface, + generalized indexes and more convenient function names. -} module SDP.Index ( - -- * Shapes + -- * Exports module SDP.Nullable, module SDP.Shape, + -- * Shapes (:|:), SubIndex, takeDim, dropDim, joinDim, splitDim, -- * Indices @@ -118,7 +119,7 @@ takeDim = takeDim . initDim -- | 'splitDim' returns pair of shape difference and subshape. -splitDim :: (SubIndex i j) => i -> (i :|: j, j) +splitDim :: (Sub i j) => i -> (i :|: j, j) splitDim i = let j = takeDim i in (dropDim i j, j) -------------------------------------------------------------------------------- @@ -164,8 +165,8 @@ -- | Returns the sizes of range dimensionwise. {-# INLINE sizes #-} sizes :: (i, i) -> [Int] - default sizes :: (Index (GIndex i)) => (i, i) -> [Int] sizes = sizes . toGBounds + default sizes :: (Index (GIndex i)) => (i, i) -> [Int] -- | Returns the index belonging to the given range. {-# INLINE safeElem #-} @@ -179,19 +180,19 @@ -- | Returns size of biggest range, that may be represented by this type. defLimit :: i -> Integer - default defLimit :: (Integral i, Bounded i) => i -> Integer defLimit i = toInteger (maxBound `asTypeOf` i) + 1 + default defLimit :: (Integral i, Bounded i) => i -> Integer -- | Returns default range by size. {-# INLINE defaultBounds #-} defaultBounds :: Int -> (i, i) - defaultBounds n = (unsafeIndex 0, unsafeIndex $ max 0 n - 1) + defaultBounds n = both unsafeIndex (0, max 0 n - 1) -- | Returns index by offset in default range. {-# INLINE unsafeIndex #-} unsafeIndex :: Int -> i - default unsafeIndex :: (Enum i) => Int -> i unsafeIndex = toEnum + default unsafeIndex :: (Enum i) => Int -> i {- Checkers -} @@ -223,17 +224,13 @@ -- | Returns previous index in 'range'. prev :: (i, i) -> i -> i - default prev :: (Enum i) => (i, i) -> i -> i - prev (l, u) i | isEmpty (l, u) = e | i <= l = l | i > u = u | True = pred i - where - e = emptyEx "prev {default}" + default prev :: (Enum i) => (i, i) -> i -> i + prev (l, u) i | isEmpty (l, u) = emptyEx "prev {default}" | i <= l = l | i > u = u | True = pred i -- | Returns next index in range. - default next :: (Enum i) => (i, i) -> i -> i next :: (i, i) -> i -> i - next (l, u) i | isEmpty (l, u) = e | i >= u = u | i < l = l | True = succ i - where - e = emptyEx "next {default}" + default next :: (Enum i) => (i, i) -> i -> i + next (l, u) i | isEmpty (l, u) = emptyEx "next {default}" | i >= u = u | i < l = l | True = succ i -- | Returns 'offset' (indent) of 'index' in 'range'. {-# INLINE offset #-} @@ -246,14 +243,14 @@ index :: (i, i) -> Int -> i default index :: (Enum i) => (i, i) -> Int -> i index bnds@(l, _) n = - let res = toEnum $ n + fromEnum l + let res = toEnum (n + fromEnum l) in checkBounds (0, size bnds - 1) n res "index {default}" -- | Returns the ordered list of indices in this range. {-# INLINE range #-} range :: (i, i) -> [i] - default range :: (Enum i) => (i, i) -> [i] range = uncurry enumFromTo + default range :: (Enum i) => (i, i) -> [i] {- | @subshape bnds ij@ returns subshape of @bnds@. @@ -266,7 +263,7 @@ (l', lj) = splitDim l (u', uj) = splitDim u - slice :: (Sub i j, ij ~ (i :|: j), Index j) => (i, i) -> ij -> ((ij, ij), (j, j)) + slice :: (Sub i j, ij ~~ (i :|: j), Index j) => (i, i) -> ij -> ((ij, ij), (j, j)) slice (l, u) ij = checkBounds (ls, us) ij ((ls, us), (lj, uj)) "slice {default}" where (ls, lj) = splitDim l @@ -283,15 +280,15 @@ (.<.) = on (<) size (<.=>) = (<=>) . size + (.<=) = (<=) . size + (.>=) = (>=) . size (.>) = (>) . size (.<) = (<) . size - (.>=) = (>=) . size - (.<=) = (<=) . size instance (Index i) => Nullable (i, i) where - isNull = isEmpty lzero = defaultBounds 0 + isNull = isEmpty -------------------------------------------------------------------------------- @@ -300,8 +297,7 @@ instance Index E where unsafeIndex = const (emptyEx "unsafeIndex {E}") - - defLimit = const (-1) + defLimit = const (-1) size = const 0 sizes = const [] @@ -309,14 +305,14 @@ next _ _ = E prev _ _ = E - offset _ _ = emptyEx "offset {E}" index _ _ = emptyEx "index {E}" + offset _ _ = emptyEx "offset {E}" - inBounds _ _ = ER - inRange _ _ = False - isEmpty _ = True - isOverflow _ _ = True isUnderflow _ _ = True + isOverflow _ _ = True + isEmpty _ = True + inRange _ _ = False + inBounds _ _ = ER instance Index () where @@ -408,27 +404,26 @@ where defLimit = (const . defLimit :: (Index i) => i -> (E :& i) -> Integer) undefined - size = \ ([l], [u]) -> size (l, u) - sizes = \ ([l], [u]) -> [size (l, u)] - range = \ ([l], [u]) -> [ [i] | i <- range (l, u) ] + size (E:&l, E:&u) = size (l, u) + sizes (E:&l, E:&u) = [size (l, u)] + range (E:&l, E:&u) = (E :&) <$> range (l, u) - next = \ ([l], [u]) [i] -> [next (l, u) i] - prev = \ ([l], [u]) [i] -> [prev (l, u) i] + next = \ (E:&l, E:&u) (E:&i) -> E :& next (l, u) i + prev = \ (E:&l, E:&u) (E:&i) -> E :& prev (l, u) i - inRange = \ ([l], [u]) [i] -> inRange (l, u) i - isOverflow = \ ([l], [u]) [i] -> isOverflow (l, u) i - isUnderflow = \ ([l], [u]) [i] -> isUnderflow (l, u) i - safeElem = \ ([l], [u]) [i] -> [safeElem (l, u) i] + inRange = \ (E:&l, E:&u) (E:&i) -> inRange (l, u) i + isOverflow = \ (E:&l, E:&u) (E:&i) -> isOverflow (l, u) i + isUnderflow = \ (E:&l, E:&u) (E:&i) -> isUnderflow (l, u) i + safeElem = \ (E:&l, E:&u) (E:&i) -> E :& safeElem (l, u) i - isEmpty = \ ([l], [u]) -> isEmpty (l, u) - ordBounds = \ ([l], [u]) -> let (l', u') = ordBounds (l, u) in ([l'], [u']) + isEmpty (E:&l, E:&u) = isEmpty (l, u) + ordBounds (E:&l, E:&u) = let (l', u') = ordBounds (l, u) in (E:&l', E:&u') - offset = \ ([l], [u]) [i] -> offset (l, u) i - index = \ ([l], [u]) n -> [index (l, u) n] + offset = \ (E:&l, E:&u) (E:&i) -> offset (l, u) i + index = \ (E:&l, E:&u) -> (E:&) . index (l, u) defaultBounds = both (E :&) . defaultBounds - - unsafeIndex = \ n -> [unsafeIndex n] + unsafeIndex = (E :&) . unsafeIndex -- [internal]: undecidable instance (Index i, Enum i, Bounded i, Index (i' :& i)) => Index (i' :& i :& i) @@ -555,11 +550,7 @@ UR -> throw . IndexUnderflow . showString "in SDP.Index." IN -> const res --------------------------------------------------------------------------------- - emptyEx :: String -> a emptyEx = throw . EmptyRange . showString "in SDP.Index." - - diff --git a/src/SDP/Indexed.hs b/src/SDP/Indexed.hs --- a/src/SDP/Indexed.hs +++ b/src/SDP/Indexed.hs @@ -1,9 +1,13 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -{-# LANGUAGE Safe, DefaultSignatures, ConstraintKinds #-} +{-# LANGUAGE Safe, CPP, ConstraintKinds, DefaultSignatures #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.Indexed - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -20,7 +24,13 @@ Indexed (..), Indexed1, Indexed2, binaryContain, -- * Freeze - Freeze (..), Freeze1 + Freeze (..), Freeze1, Freeze2, + +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + Indexed', Indexed'', Freeze', Freeze'' +#endif ) where @@ -35,6 +45,12 @@ -------------------------------------------------------------------------------- +{-# WARNING updates' "deprecated in favor of 'update', will be removed in sdp-0.3" #-} +{-# WARNING update' "will be moved to SDP.Map.Map class in sdp-0.3" #-} +{-# WARNING write' "will be moved to SDP.Map.Map class in sdp-0.3" #-} + +-------------------------------------------------------------------------------- + -- | 'Indexed' is class of ordered associative arrays with static bounds. class (Linear v e, Bordered v i, Map v i e) => Indexed v i e | v -> i, v -> e where @@ -64,6 +80,14 @@ write' :: v -> i -> e -> v write' es = write es . offsetOf es + -- | Update element by given function. + update' :: v -> (e -> e) -> i -> v + update' es f i = write' es i . f $ es!i + + -- | Create new structure from old by mapping with index. + updates' :: v -> (i -> e -> e) -> v + updates' es f = bounds es `assoc` [ (i, f i e) | (i, e) <- assocs es ] + {- | @'accum' f es ies@ create a new structure from @es@ elements selectively updated by function @f@ and @ies@ associations list. @@ -74,14 +98,6 @@ -- | 'imap' creates new indexed structure from old with reshaping. imap :: (Map m j e) => (i, i) -> m -> (i -> j) -> v imap bnds es f = assoc bnds [ (i, es!f i) | i <- range bnds ] - - -- | Update element by given function. - update' :: v -> (e -> e) -> i -> v - update' es f i = write' es i . f $ es!i - - -- | Create new structure from old by mapping with index. - updates' :: v -> (i -> e -> e) -> v - updates' es f = bounds es `assoc` [ (i, f i e) | (i, e) <- assocs es ] -------------------------------------------------------------------------------- @@ -105,15 +121,32 @@ -------------------------------------------------------------------------------- --- | Kind @(* -> *)@ 'Indexed' structure. +-- | 'Indexed' contraint for @(Type -> Type)@-kind types. type Indexed1 v i e = Indexed (v e) i e --- | Kind @(* -> * -> *)@ 'Indexed' structure. +-- | 'Indexed' contraint for @(Type -> Type -> Type)@-kind types. type Indexed2 v i e = Indexed (v i e) i e --- | Kind @(* -> *)@ 'Freeze'. +-- | 'Freeze' contraint for @(Type -> Type)@-kind types. type Freeze1 m v' v e = Freeze m (v' e) (v e) +-- | 'Freeze' contraint for @(Type -> Type -> Type)@-kind types. +type Freeze2 m v' v i e = Freeze m (v' i e) (v i e) + +#if __GLASGOW_HASKELL__ >= 806 +-- | 'Indexed' contraint for @(Type -> Type)@-kind types. +type Indexed' v i = forall e . Indexed (v e) i e + +-- | 'Indexed' contraint for @(Type -> Type -> Type)@-kind types. +type Indexed'' v = forall i e . Indexed (v i e) i e + +-- | 'Freeze' contraint for @(Type -> Type)@-kind types. +type Freeze' m v' v = forall e . Freeze m (v' e) (v e) + +-- | 'Freeze' contraint for @(Type -> Type -> Type)@-kind types. +type Freeze'' m v' v = forall i e . Freeze m (v' i e) (v i e) +#endif + -------------------------------------------------------------------------------- instance Indexed [e] Int e @@ -137,9 +170,6 @@ j = u - l `div` 2 + l in f e (head es) /= LT && f e (last es) /= GT && contain 0 (sizeOf es - 1) --------------------------------------------------------------------------------- - undEx :: String -> a undEx = throw . UndefinedValue . showString "in SDP.Indexed." - diff --git a/src/SDP/IndexedM.hs b/src/SDP/IndexedM.hs --- a/src/SDP/IndexedM.hs +++ b/src/SDP/IndexedM.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} -{-# LANGUAGE Safe, DefaultSignatures, ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DefaultSignatures #-} +{-# LANGUAGE Safe, CPP, ConstraintKinds #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.IndexedM - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -21,7 +25,13 @@ IndexedM (..), IndexedM1, IndexedM2, -- * Thaw - Thaw (..), Thaw1 + Thaw (..), Thaw1, Thaw2, + +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + IndexedM', IndexedM'', Thaw', Thaw'' +#endif ) where @@ -37,6 +47,11 @@ -------------------------------------------------------------------------------- +{-# WARNING updateM' "will be moved to SDP.MapM.MapM class in sdp-0.3" #-} +{-# WARNING writeM' "will be moved to SDP.MapM.MapM class in sdp-0.3" #-} + +-------------------------------------------------------------------------------- + -- | Class for work with mutable indexed structures. class (LinearM m v e, BorderedM m v i, MapM m v i e) => IndexedM m v i e where @@ -116,15 +131,30 @@ unsafeThaw :: v -> m v' unsafeThaw = thaw --------------------------------------------------------------------------------- - --- | Kind @(* -> *)@ 'IndexedM'. +-- | 'IndexedM' contraint for @(Type -> Type)@-kind types. type IndexedM1 m v i e = IndexedM m (v e) i e --- | Kind @(* -> * -> *)@ 'IndexedM'. +-- | 'IndexedM' contraint for @(Type -> Type -> Type)@-kind types. type IndexedM2 m v i e = IndexedM m (v i e) i e --- | Kind @(* -> *)@ 'Thaw'. +-- | 'Thaw' contraint for @(Type -> Type)@-kind types. type Thaw1 m v v' e = Thaw m (v e) (v' e) + +-- | 'Thaw' contraint for @(Type -> Type -> Type)@-kind types. +type Thaw2 m v v' i e = Thaw m (v i e) (v' i e) + +#if __GLASGOW_HASKELL__ >= 806 +-- | 'IndexedM' contraint for @(Type -> Type)@-kind types. +type IndexedM' m v i = forall e . IndexedM m (v e) i e + +-- | 'IndexedM' contraint for @(Type -> Type -> Type)@-kind types. +type IndexedM'' m v = forall i e . IndexedM m (v i e) i e + +-- | 'Thaw' contraint for @(Type -> Type)@-kind types. +type Thaw' m v v' = forall e . Thaw m (v e) (v' e) + +-- | 'Thaw' contraint for @(Type -> Type -> Type)@-kind types. +type Thaw'' m v v' = forall i e . Thaw m (v i e) (v' i e) +#endif diff --git a/src/SDP/Linear.hs b/src/SDP/Linear.hs --- a/src/SDP/Linear.hs +++ b/src/SDP/Linear.hs @@ -1,10 +1,14 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} {-# LANGUAGE PatternSynonyms, ViewPatterns, BangPatterns, DefaultSignatures #-} -{-# LANGUAGE Trustworthy, TypeOperators, TypeFamilies, ConstraintKinds, CPP #-} +{-# LANGUAGE Trustworthy, CPP, TypeFamilies, ConstraintKinds #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.Linear - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -24,21 +28,20 @@ Bordered (..), Bordered1, Bordered2, -- * Linear class - -- $linearDoc - Linear (..), Linear1, + Linear (..), Linear1, Linear2, pattern (:>), pattern (:<), - -- * Split class - -- $splitDoc - Split (..), Split1, +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + Bordered', Bordered'', Linear', Linear'', +#endif - -- * Patterns - -- $patternDoc - pattern (:>), pattern (:<), pattern Z, + -- ** Split class + Split (..), Split1, -- * Related functions - intercalate, tails, inits, ascending, - - stripPrefix, stripSuffix, stripPrefix', stripSuffix' + stripPrefix, stripSuffix, stripPrefix', stripSuffix', + intercalate, tails, inits, ascending ) where @@ -55,8 +58,7 @@ default () -infix 8 `filter`, `except` - +infix 8 `filter`, `except` infixr 5 :>, ++ infixl 5 :< infixl 9 !^ @@ -140,39 +142,20 @@ -------------------------------------------------------------------------------- -{- $linearDoc - Linear is a class for linear (list-like) data structures which supports - - * creation: 'single', 'replicate', 'fromFoldable', 'fromList', 'fromListN' - * deconstruction: 'head', 'tail', 'init', 'last', 'uncons', 'unsnoc' - * construction, concatenation: 'toHead', 'toLast', '++', 'concat', 'concatMap' - * left- and right-side view: 'listL', 'listR' - * filtering, separation and selection: 'filter', 'except', 'partition', - 'partitions', 'select', 'select'', 'extract', 'extract'', 'selects' and - 'selects'' - - Select and extract are needed to combine filtering and mapping, simplifying - lambdas and case-expressions in complex cases. - - > select' (p ?+ f) == fmap f . filter p - > select' (p ?- f) == fmap f . except p - - > fmap (\ (OneOfCons x y z) -> x + y * z) . filter (\ es -> case es of {(OneOfCons _ _ _) -> True; _ -> False}) - - is just - - > select (\ es -> case es of {(OneOfCons x y z) -> Just (x + y * z); _ -> Nothing}) - - The code is greatly simplified if there are more than one such constructor or - any additional conditions. --} - {-# RULES "select/Just" select Just = listL; "select'/Just" select' Just = id; #-} --- | Class of list-like data structures. +{- | + Class of list-like data structures, which + + * can be converted to and from list + * can be created from singleton or 'Foldable' stream + * support filter operations, separation, concatenation and selection + * It can be represented as 'head', 'tail', 'init' and 'last' elements and + constructed from 'head' and 'tail' or 'init' and 'last'. +-} class (Nullable l) => Linear l e | l -> e where {-# MINIMAL (listL|listR), (fromList|fromFoldable), (head,tail|uncons), (init,last|unsnoc) #-} @@ -352,11 +335,51 @@ reverse :: l -> l reverse = fromList . listR - -- | Create new line, equal to given. + -- | O(1) 'force', same as 'id'. force :: l -> l force = fromList . listL - -- | Generalized subsequences. + {- | + @since 0.2.1 + + @'before' es i e@ insert @e@ to @es@ before element with offset @i@. If + @i@ goes beyond the lower or upper bounds, @e@ is prepended or appended to + @es@ respectively. + + > before [0 .. 5] (-1) 7 == [7,0,1,2,3,4,5] + > before [0 .. 5] 0 7 == [7,0,1,2,3,4,5] + > before [0 .. 5] 3 7 == [0,1,2,7,3,4,5] + > before [0 .. 5] 5 7 == [0,1,2,3,4,7,5] + > before [0 .. 5] 19 7 == [0,1,2,3,4,5,7] + -} + before :: l -> Int -> e -> l + before es = fromList ... before (listL es) + + {- | + @since 0.2.1 + + @'after' es i e@ insert @e@ to @es@ after element with offset @i@. + + > after es i e == before es (i + 1) e + -} + after :: l -> Int -> e -> l + after es i e = before es (i + 1) e + + {- | + @since 0.2.1 + + @'remove' es i@ delete element with offset @i@ from @es@. + + > remove (-1) [0 .. 5] == [0 .. 5] + > remove 6 [0 .. 5] == [0 .. 5] + > remove 0 [0 .. 5] == [1,2,3,4,5] + > remove 3 [0 .. 5] == [0,1,2,4,5] + > remove 5 [0 .. 5] == [0,1,2,3,4] + -} + remove :: Int -> l -> l + remove n = fromList . remove n . listL + + -- | Generalized 'subsequences'. subsequences :: l -> [l] subsequences = (Z :) . go where @@ -414,25 +437,41 @@ -- | 'o_foldl'' is just 'foldl'' in 'Linear' context. o_foldl' :: (b -> e -> b) -> b -> l -> b o_foldl' = ofoldl' . const + + {- | + @since 0.2.1 + + 'o_foldr1' is just 'Data.Foldable.foldr1' in 'Linear' context. + -} + o_foldr1 :: (e -> e -> e) -> l -> e + o_foldr1 f = \ (es :< e) -> o_foldr f e es + + {- | + @since 0.2.1 + + 'o_foldl1' is just 'Data.Foldable.foldl1' in 'Linear' context. + -} + o_foldl1 :: (e -> e -> e) -> l -> e + o_foldl1 f = \ (e :> es) -> o_foldl f e es + + {- | + @since 0.2.1 + + 'o_foldr1'' is just strict 'Data.Foldable.foldr1' in 'Linear' context. + -} + o_foldr1' :: (e -> e -> e) -> l -> e + o_foldr1' f = \ (es :< e) -> o_foldr' f e es + + {- | + @since 0.2.1 + + 'o_foldl1'' is just 'Data.Foldable.foldl1'' in 'Linear' context. + -} + o_foldl1' :: (e -> e -> e) -> l -> e + o_foldl1' f = \ (e :> es) -> o_foldl' f e es -------------------------------------------------------------------------------- -{- $splitDoc - Split is class of structures that may be splitted by - - * length: 'take', 'drop', 'split', 'splits', 'keep', 'sans', 'divide', - 'divides', 'parts', 'chunks' - * content: 'splitBy', 'divideBy', 'splitsBy', 'splitsOn' - * predicate: 'takeWhile', 'dropWhile', 'spanl', 'breakl' (left to right), - 'takeEnd', 'dropEnd', 'spanr', 'breakr' (right to left) - * selector: 'selectWhile', 'selectEnd', 'extractWhile', 'extractEnd', - 'selectWhile'', 'selectEnd'', 'extractWhile'', 'extractEnd'', 'replaceBy', - 'removeAll', 'each', 'eachFrom'. - - Also Split provides some usefil predicates: 'isPrefixOf', 'isInfixOf', - 'isSuffixOf', 'prefix', 'suffix', 'infixes', 'combo'. --} - -- | Split - class of splittable data structures. class (Linear s e) => Split s e | s -> e where @@ -603,20 +642,24 @@ {- | @justifyL n e es@ appends @e@ elements if the @es@ is shorter than @n@, + @justifyL n e es@ prepends @(n - sizeOf es)@ elements @e@ to @es@ from the takes @n@ elements if longer. + left side if @(sizeOf es < n)@. Otherwise returns the first @n@ elements + of @es@, like @'take' n es@ do. -} justifyL :: Int -> e -> s -> s justifyL n e = take n . (++ replicate n e) {- | - @justifyR n e es@ prepends @e@ elements if the @es@ is shorter than @n@, - takes @n@ elements if longer. + @justifyR n e es@ appends @(n - sizeOf es)@ elements @e@ to @es@ from the + right side if @(sizeOf es < n)@. Otherwise returns the first @n@ elements + of @es@, like @'keep' n es@ do. -} justifyR :: Int -> e -> s -> s justifyR n e = keep n . (replicate n e ++) {- | - @each n es@ returns each nth element of structure. + @each n es@ returns each @n@-th element of structure. If @n == 1@, returns @es@. If @n < 1@, returns 'Z'. -} @@ -634,15 +677,15 @@ eachFrom :: Int -> Int -> s -> s eachFrom o n = each n . drop o - -- | isPrefixOf checks whether the first line is the beginning of the second + -- | @sub `'isPrefixOf'` es@ checks if @sub@ is beginning of @es@. isPrefixOf :: (Eq e) => s -> s -> Bool isPrefixOf (x :> xs) (y :> ys) = x == y && xs `isPrefixOf` ys - isPrefixOf xs _ = isNull xs + isPrefixOf xs ys = isNull xs && isNull ys - -- | isSuffixOf checks whether the first line is the ending of the second + -- | @sub `'isSuffixOf'` es@ checks if @sub@ is ending of @es@. isSuffixOf :: (Eq e) => s -> s -> Bool isSuffixOf (xs :< x) (ys :< y) = x == y && xs `isSuffixOf` ys - isSuffixOf xs _ = isNull xs + isSuffixOf xs ys = isNull xs && isNull ys -- | isInfixOf checks whether the first line is the substring of the second isInfixOf :: (Eq e) => s -> s -> Bool @@ -751,17 +794,6 @@ -------------------------------------------------------------------------------- -{- $patternDoc - "SDP.Linear" also provides three overloaded patterns: 'Z', (':>') and (':<'). --} - -{- | - 'Z' is overloaded empty ('lzero') value constant. Pattern 'Z' corresponds to - all empty ('isNull') values. --} -pattern Z :: (Nullable e) => e -pattern Z <- (isNull -> True) where Z = lzero - -- | Pattern @(':>')@ is left-size view of line. Same as 'uncons' and 'toHead'. pattern (:>) :: (Linear l e) => e -> l -> l pattern x :> xs <- (uncons' -> Just (x, xs)) where (:>) = toHead @@ -770,23 +802,37 @@ pattern (:<) :: (Linear l e) => l -> e -> l pattern xs :< x <- (unsnoc' -> Just (xs, x)) where (:<) = toLast --------------------------------------------------------------------------------- - --- | Kind @(* -> *)@ 'Linear' structure. +-- | 'Linear' contraint for @(Type -> Type)@-kind types. type Linear1 l e = Linear (l e) e --- | Kind @(* -> *)@ 'Split' structure. -type Split1 s e = Split (s e) e +-- | 'Linear' contraint for @(Type -> Type -> Type)@-kind types. +type Linear2 l i e = Linear (l i e) e --- | Kind @(* -> *)@ 'Bordered' structure. +-- | 'Bordered' contraint for @(Type -> Type)@-kind types. type Bordered1 l i e = Bordered (l e) i --- | Kind @(* -> * -> *)@ 'Bordered' structure. +-- | 'Bordered' contraint for @(Type -> Type -> Type)@-kind types. type Bordered2 l i e = Bordered (l i e) i +-- | Kind @(Type -> Type)@ 'Split' structure. +type Split1 s e = Split (s e) e + +#if __GLASGOW_HASKELL__ >= 806 +-- | 'Linear' contraint for @(Type -> Type)@-kind types. +type Linear' l = forall e . Linear (l e) e + +-- | 'Linear' contraint for @(Type -> Type -> Type)@-kind types. +type Linear'' l = forall i e . Linear (l i e) e + +-- | 'Bordered' contraint for @(Type -> Type)@-kind types. +type Bordered' l i = forall e . Bordered (l e) i + +-- | 'Bordered' contraint for @(Type -> Type -> Type)@-kind types. +type Bordered'' l = forall i e . Bordered (l i e) i +#endif + -------------------------------------------------------------------------------- -{-# COMPLETE Z, (:) #-} {-# COMPLETE [], (:>) #-} {-# COMPLETE [], (:<) #-} @@ -829,6 +875,18 @@ intersperse = L.intersperse isSubseqOf = L.isSubsequenceOf + before es i e = go (max 0 i) es + where + go 0 xs = e : xs + go n (x : xs) = x : go (n - 1) xs + go _ [] = [e] + + remove i es = i < 0 ? es $ go i es + where + go 0 (_ : xs) = xs + go n (x : xs) = x : go (n - 1) xs + go _ [] = [] + iterate n f e = n < 1 ? [] $ e : iterate (n - 1) f (f e) ofoldr f base = @@ -919,12 +977,9 @@ inits es = es : inits (init es) {- | - @ascending es lens@ checks if the subsequences of @es@ of lengths @lens@ is - sorted. + @ascending es lengths@ checks if the subsequences of @es@ of lengths @lengths@ + is sorted. -} ascending :: (Split s e, Sort s e, Ord e) => s -> [Int] -> Bool ascending = all sorted ... flip splits - - - diff --git a/src/SDP/LinearM.hs b/src/SDP/LinearM.hs --- a/src/SDP/LinearM.hs +++ b/src/SDP/LinearM.hs @@ -1,9 +1,14 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, BangPatterns #-} -{-# LANGUAGE Safe, ConstraintKinds, DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE Safe, CPP, BangPatterns, GADTs, ViewPatterns, PatternSynonyms #-} +{-# LANGUAGE ConstraintKinds, DefaultSignatures #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.LinearM - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -19,9 +24,15 @@ BorderedM (..), BorderedM1, BorderedM2, -- * LinearM class - LinearM (..), LinearM1, + LinearM (..), LinearM1, LinearM2, pattern (:+=), pattern (:=+), pattern (:~=), - -- * SplitM class +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + BorderedM', BorderedM'', LinearM', LinearM'', +#endif + + -- ** SplitM class SplitM (..), SplitM1 ) where @@ -31,6 +42,9 @@ import SDP.Linear import SDP.Map +import Data.Property hiding ( set ) +import Data.Typeable + default () infixl 5 !#> @@ -172,10 +186,18 @@ copied' :: l -> Int -> Int -> m l copied' es l n = getLeft es >>= newLinearN n . drop l - -- | Monadic 'reverse'. + -- | Monadic 'reverse', returns new structure. {-# INLINE reversed #-} reversed :: l -> m l reversed = newLinear <=< getRight + + {- | + @since 0.2.1 + + Monadic in-place 'reverse', reverse elements of given structure. + -} + reversed' :: l -> m () + reversed' es = mapM_ (uncurry $ writeM es) . assocs =<< getRight es -- | Monadic 'concat'. merged :: (Foldable f) => f l -> m l @@ -187,6 +209,26 @@ filled n = newLinearN n . replicate n {- | + @since 0.2.1 + @'removed' n es@ removes element with offset @n@ from @es@. + -} + removed :: Int -> l -> m l + removed n es = newLinear . remove n =<< getLeft es + + {- | + @since 0.2.1 + + @'lshiftM' es i j@ cyclically shifts the elements with offsets between @i@ + and @j@ @(i < j)@ one position to the left (the @j@-th element is in the + @i@-th position, the @i@-th in the @(i+1)@th, etc.) If @i >= j@, does + nothing. + -} + lshiftM :: l -> Int -> Int -> m () + lshiftM es i j = + let go k ej = when (k <= j) $ do ek <- es !#> k; writeM es k ej; go (k + 1) ek + in when (i < j) $ go i =<< (es !#> j) + + {- | @copyTo source soff target toff count@ writes @count@ elements of @source@ from @soff@ to @target@ starting with @toff@. -} @@ -198,7 +240,8 @@ -- | 'ofoldlM' is left monadic fold with offset. ofoldlM :: (Int -> r -> e -> m r) -> r -> l -> m r - ofoldlM f base es = foldl (flip $ uncurry ((=<<) ... flip . f)) (pure base) . assocs =<< getLeft es + ofoldlM f base es = foldl (flip $ uncurry ((=<<) ... flip . f)) (pure base) + . assocs =<< getLeft es -- | 'ofoldrM'' is strict version of 'ofoldrM'. ofoldrM' :: (Int -> e -> r -> m r) -> r -> l -> m r @@ -224,6 +267,20 @@ foldlM' :: (r -> e -> m r) -> r -> l -> m r foldlM' f = foldlM (\ !r e -> f r e) + {- | + @since 0.2.1 + 'foldrM1' is 'foldrM' version with 'last' element as base. + -} + foldrM1 :: (e -> e -> m e) -> l -> m e + foldrM1 f = getLeft >=> \ (es :< e) -> foldr ((=<<) . f) (pure e) es + + {- | + @since 0.2.1 + 'foldlM1' is 'foldlM' version with 'head' element as base. + -} + foldlM1 :: (e -> e -> m e) -> l -> m e + foldlM1 f = getLeft >=> \ (e :> es) -> foldl (flip $ (=<<) . flip f) (pure e) es + -- | Just swap two elements. swapM :: l -> Int -> Int -> m () swapM es i j = do ei <- es !#> i; writeM es i =<< es !#> j; writeM es j ei @@ -292,16 +349,18 @@ @n <- ns@. Changes in the source and results must be synchronous. -} splitsM :: (Foldable f) => f Int -> s -> m [s] - splitsM ns es = reverse <$> foldl (\ ds' n -> do ds <- ds'; (d, d') <- splitM n (head ds); pure (d' : d : ds)) (pure [es]) ns + splitsM ns es = + let f ds' n = do ds <- ds'; (d,d') <- splitM n (head ds); pure (d':d:ds) + in reverse <$> foldl f (pure [es]) ns {- | @dividesM ns es@ returns the sequence of @es@ suffix references of length @n <- ns@. Changes in the source and results must be synchronous. -} dividesM :: (Foldable f) => f Int -> s -> m [s] - dividesM ns es = foldr (\ n ds' -> do ds <- ds'; (d, d') <- divideM n (head ds); pure (d' : d : ds)) (pure [es]) ns - - -- TODO: comboM :: (e -> e -> Bool) -> s -> m Int + dividesM ns es = + let f n ds' = do ds <- ds'; (d, d') <- divideM n (head ds); pure (d':d:ds) + in foldr f (pure [es]) ns {- | @partsM n es@ returns the sequence of @es@ prefix references, splitted by @@ -342,19 +401,100 @@ -------------------------------------------------------------------------------- --- | Kind @(* -> *)@ 'SplitM' structure. -type SplitM1 m l e = SplitM m (l e) e +{- fmr-0.2 append, prepend and delete fields. -} --- | Kind @(* -> *)@ 'LinearM' structure. -type LinearM1 m l e = LinearM m (l e) e +-- | 'FieldLinearM' is a service type used to prepend, append or remove element. +data FieldLinearM l e m field record + where + Prepend :: (LinearM m l e, FieldGet field, FieldSet field) + => e -> field m record l -> FieldLinearM l e m field record + Append :: (LinearM m l e, FieldGet field, FieldSet field) + => field m record l -> e -> FieldLinearM l e m field record + Delete :: (LinearM m l e, FieldGet field, FieldSet field) + => Int -> field m record l -> FieldLinearM l e m field record + deriving ( Typeable ) --- | Kind @(* -> *)@ 'BorderedM' structure. +instance IsProp (FieldLinearM l e) + where + performProp record (Append field e) = setRecord field record =<< + flip append e =<< getRecord field record + + performProp record (Delete n field) = setRecord field record =<< + removed n =<< getRecord field record + + performProp record (Prepend e field) = setRecord field record =<< + prepend e =<< getRecord field record + +{- | + @since 0.2.1 + @(':+=')@ is @fmr@-compatible 'prepend' element pattern for 'LinearM' fields. +-} +pattern (:+=) :: + ( + Typeable record, Typeable field, Typeable m, Typeable l, Typeable e, + LinearM m l e, FieldGet field, FieldSet field + ) => e -> field m record l -> Prop m field record +pattern e :+= field <- (cast' -> Just (Prepend e field)) where (:+=) = Prop ... Prepend + +{- | + @since 0.2.1 + @(':=+')@ is @fmr@-compatible 'append' element pattern for 'LinearM' fields. +-} +pattern (:=+) :: + ( + Typeable record, Typeable field, Typeable m, Typeable l, Typeable e, + LinearM m l e, FieldGet field, FieldSet field + ) => field m record l -> e -> Prop m field record +pattern field :=+ e <- (cast' -> Just (Append field e)) where (:=+) = Prop ... Append + +{- | + @since 0.2.1 + @(':~=')@ is @fmr@-compatible delete element pattern for 'LinearM' fields, see + 'removed'. +-} +pattern (:~=) :: + ( + Typeable record, Typeable field, Typeable m, Typeable l, Typeable e, + LinearM m l e, FieldGet field, FieldSet field + ) => Int -> field m record l -> Prop m field record +pattern n :~= field <- (cast' -> Just (Delete n field)) where (:~=) = Prop ... Delete + +-- | 'cast'' is just service function for 'Prop' data extraction. +cast' :: + ( + Typeable record, Typeable field, Typeable m, Typeable l, Typeable e, + LinearM m l e, FieldGet field, FieldSet field + ) => Prop m field record -> Maybe (FieldLinearM l e m field record) +cast' = cast + +-------------------------------------------------------------------------------- + +-- | 'BorderedM' contraint for @(Type -> Type)@-kind types. type BorderedM1 m l i e = BorderedM m (l e) i --- | Kind @(* -> * -> *)@ 'BorderedM' structure. +-- | 'BorderedM' contraint for @(Type -> Type -> Type)@-kind types. type BorderedM2 m l i e = BorderedM m (l i e) i +-- | 'LinearM' contraint for @(Type -> Type)@-kind types. +type LinearM1 m l e = LinearM m (l e) e +-- | 'LinearM' contraint for @(Type -> Type -> Type)@-kind types. +type LinearM2 m l i e = LinearM m (l i e) e +-- | Kind @(Type -> Type)@ 'SplitM' structure. +type SplitM1 m l e = SplitM m (l e) e +#if __GLASGOW_HASKELL__ >= 806 +-- | 'BorderedM' contraint for @(Type -> Type)@-kind types. +type BorderedM' m l i = forall e . BorderedM m (l e) i + +-- | 'BorderedM' contraint for @(Type -> Type -> Type)@-kind types. +type BorderedM'' m l = forall i e . BorderedM m (l i e) i + +-- | 'LinearM' contraint for @(Type -> Type)@-kind types. +type LinearM' m l = forall e . LinearM m (l e) e + +-- | 'LinearM' contraint for @(Type -> Type -> Type)@-kind types. +type LinearM'' m l = forall i e . LinearM m (l i e) e +#endif diff --git a/src/SDP/Map.hs b/src/SDP/Map.hs --- a/src/SDP/Map.hs +++ b/src/SDP/Map.hs @@ -1,9 +1,13 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -{-# LANGUAGE Safe, DefaultSignatures, ConstraintKinds, BangPatterns #-} +{-# LANGUAGE Safe, CPP, BangPatterns, ConstraintKinds, DefaultSignatures #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.Map - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -16,7 +20,13 @@ module SDP.Set, -- * Map - Map (..), Map1, Map2 + Map (..), Map1, Map2, + +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + Map', Map'' +#endif ) where @@ -36,13 +46,13 @@ -------------------------------------------------------------------------------- {- | - 'Map' is a class of dictionaries, simple associative arrays with an arbitrary - (implementation-dependent) key. + @since 0.2 - In the current implementation, 'Map' (since @sdp-0.2@) is a superclass of - 'SDP.Indexed.Indexed'. 'Map' provides a set of operations on associative - arrays that aren't specific to 'Linear' data structures and aren't limited by - the 'Bordered' context (doesn't restrict key type). + 'Map' is a class of dictionaries (associative arrays). + + 'Map' provides a set of operations on associative arrays that aren't specific + to 'Linear' data structures and aren't limited by the 'Bordered' context + (doesn't restrict key type). -} class (Nullable map) => Map map key e | map -> key, map -> e where @@ -80,7 +90,6 @@ If @map@ doesn't allow gaps, then the missing elements should be filled with default values. -} - default insert' :: (Bordered map key) => key -> e -> map -> map insert' :: key -> e -> map -> map insert' k e es = toMap $ assocs es :< (k, e) @@ -175,7 +184,7 @@ EQ -> (i, f x y) : go xs ys go _ _ = [] - -- | Update function, by default uses ('!') and may throw 'IndexException'. + -- | Update function, by default uses ('//'). update :: map -> (key -> e -> e) -> map update es f = es // [ (i, f i e) | (i, e) <- assocs es ] @@ -239,12 +248,20 @@ -------------------------------------------------------------------------------- --- | Kind @(* -> *)@ 'Map' structure. +-- | 'Map' contraint for @(Type -> Type)@-kind types. type Map1 map key e = Map (map e) key e --- | Kind @(* -> * -> *)@ 'Map' structure. +-- | 'Map' contraint for @(Type -> Type -> Type)@-kind types. type Map2 map key e = Map (map key e) key e +#if __GLASGOW_HASKELL__ >= 806 +-- | 'Map' contraint for @(Type -> Type)@-kind types. +type Map' map key = forall e . Map (map e) key e + +-- | 'Map' contraint for @(Type -> Type -> Type)@-kind types. +type Map'' map = forall key e . Map (map key e) key e +#endif + -------------------------------------------------------------------------------- instance Map [e] Int e @@ -310,6 +327,4 @@ unreachEx :: String -> a unreachEx = throw . UnreachableException . showString "in SDP.Map." - - diff --git a/src/SDP/MapM.hs b/src/SDP/MapM.hs --- a/src/SDP/MapM.hs +++ b/src/SDP/MapM.hs @@ -1,9 +1,13 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -{-# LANGUAGE Safe, DefaultSignatures, ConstraintKinds, BangPatterns #-} +{-# LANGUAGE Safe, CPP, BangPatterns, ConstraintKinds, DefaultSignatures #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.MapM - Copyright : (c) Andrey Mulik 2020 + Copyright : (c) Andrey Mulik 2020-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : portable @@ -13,7 +17,13 @@ module SDP.MapM ( -- * Mutable maps - MapM (..), MapM1, MapM2 + MapM (..), MapM1, MapM2, + +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + MapM', MapM'' +#endif ) where @@ -133,12 +143,20 @@ -------------------------------------------------------------------------------- --- | Rank @(* -> *)@ 'MapM'. +-- | 'MapM' contraint for @(Type -> Type)@-kind types. type MapM1 m map key e = MapM m (map e) key e --- | Rank @(* -> * -> *)@ 'MapM'. +-- | 'MapM' contraint for @(Type -> Type -> Type)@-kind types. type MapM2 m map key e = MapM m (map key e) key e +#if __GLASGOW_HASKELL__ >= 806 +-- | 'MapM' contraint for @(Type -> Type)@-kind types. +type MapM' m map key = forall e . MapM m (map e) key e + +-- | 'MapM' contraint for @(Type -> Type -> Type)@-kind types. +type MapM'' m map = forall key e . MapM m (map key e) key e +#endif + -------------------------------------------------------------------------------- empEx :: String -> a @@ -152,4 +170,6 @@ underEx :: String -> a underEx = throw . IndexUnderflow . showString "in SDP.MapM." + + diff --git a/src/SDP/Nullable.hs b/src/SDP/Nullable.hs --- a/src/SDP/Nullable.hs +++ b/src/SDP/Nullable.hs @@ -1,8 +1,13 @@ -{-# LANGUAGE CPP, Trustworthy, PatternSynonyms, ViewPatterns, MagicHash #-} +{-# LANGUAGE CPP, MagicHash, PatternSynonyms, ViewPatterns, DefaultSignatures #-} +{-# LANGUAGE Trustworthy, ConstraintKinds #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.Nullable - Copyright : (c) Andrey Mulik 2020 + Copyright : (c) Andrey Mulik 2020-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -12,7 +17,16 @@ module SDP.Nullable ( -- * Nullable - Nullable (..), pattern NULL + Nullable (..), Nullable1, Nullable2, + +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + Nullable', Nullable'', +#endif + + -- ** Patterns + pattern NULL, pattern Z ) where @@ -23,53 +37,124 @@ import GHC.Base import GHC.Exts +import Control.Exception.SDP + default () -------------------------------------------------------------------------------- --- | 'Nullable' is class of types which value may be empty. +{- | + 'Nullable' is class of types which have empty values. + + Nullable instances must follow some rules: + + @ + isNull Z === True + x == Z ==> isNull x == True + x == y === isNull x == isNull y + + -- For 'Foldable' instances + toList Z === [] + fold Z === mempty + isNull x === null x + isNull x === length x == 0 + + sum Z === 0 + product Z === 1 + elem x Z === False + foldr f Z === foldl f Z === id + foldr1 f Z === foldl1 f Z === undefined + @ +-} class Nullable e where -- | Empty value. lzero :: e + lzero = mempty + default lzero :: (Monoid e) => e -- | Is value empty? isNull :: e -> Bool + isNull = (== lzero) + default isNull :: (Eq e) => e -> Bool +-------------------------------------------------------------------------------- + -- | Originally defined in @sdp-ctypes@ (now @sdp-foreign@), same as @Z@ now. pattern NULL :: (Nullable e) => e pattern NULL <- (isNull -> True) where NULL = lzero +{- | + Other empty value pattern: @Z === NULL@. + + Defined in "SDP.Nullable" since @sdp-0.2.1@, earlier - in "SDP.Linear". +-} +pattern Z :: (Nullable e) => e +pattern Z = NULL + -------------------------------------------------------------------------------- +{- | + @since 0.2.1 + 'Nullable' contraint for @(Type -> Type)@-kind types. +-} +type Nullable1 rep e = Nullable (rep e) + +{- | + @since 0.2.1 + 'Nullable' contraint for @(Type -> Type -> Type)@-kind types. +-} +type Nullable2 rep i e = Nullable (rep i e) + +#if __GLASGOW_HASKELL__ >= 806 +{- | + @since 0.2.1 + 'Nullable' contraint for @(Type -> Type)@-kind types. +-} +type Nullable' rep = forall e . Nullable (rep e) + +{- | + @since 0.2.1 + 'Nullable' contraint for @(Type -> Type -> Type)@-kind types. +-} +type Nullable'' rep = forall i e . Nullable (rep i e) +#endif + +-------------------------------------------------------------------------------- + +{-# COMPLETE Z, Just #-} +{-# COMPLETE NULL, Just #-} + instance Nullable (Maybe e) where isNull = \ mx -> case mx of {Nothing -> True; _ -> False} lzero = Nothing -instance Nullable [e] - where - isNull = null - lzero = [] +{-# COMPLETE Z, (:) #-} +{-# COMPLETE NULL, (:) #-} -instance Nullable (Ptr e) - where - isNull = (== nullPtr) - lzero = nullPtr +instance Nullable [e] where isNull = null +instance Nullable (Ptr e) where lzero = nullPtr + -- Stolen from @bytestring@ package. instance Nullable (ForeignPtr e) where -#if __GLASGOW_HASKELL__ >= 811 +#if MIN_VERSION_base(4,15,0) lzero = ForeignPtr nullAddr# FinalPtr #else - lzero = ForeignPtr nullAddr# (error "nullForeignPtr in SDP.Nullable.lzero") + lzero = + let err = throw $ UnreachableException "in SDP.Nullable.lzero :: ForeignPtr e" + in ForeignPtr nullAddr# err #endif isNull (ForeignPtr addr# _) = Ptr addr# == nullPtr -instance Nullable (StablePtr e) - where - lzero = StablePtr (unsafeCoerce# 0#) - isNull = (== lzero) +instance Nullable (StablePtr e) where lzero = StablePtr (unsafeCoerce# 0#) + +-- | @since 0.2.1 +instance Nullable (FunPtr e) where lzero = nullFunPtr + + + diff --git a/src/SDP/Prim/SArray.hs b/src/SDP/Prim/SArray.hs --- a/src/SDP/Prim/SArray.hs +++ b/src/SDP/Prim/SArray.hs @@ -3,7 +3,7 @@ {- | Module : SDP.Prim.SArray - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -152,10 +152,10 @@ instance Estimate (SArray# e) where (<==>) = on (<=>) sizeOf - (.<=.) = on (<=) sizeOf - (.>=.) = on (>=) sizeOf - (.>.) = on (>) sizeOf - (.<.) = on (<) sizeOf + (.<=.) = on (<=) sizeOf + (.>=.) = on (>=) sizeOf + (.>.) = on (>) sizeOf + (.<.) = on (<) sizeOf (<.=>) = (<=>) . sizeOf (.>=) = (>=) . sizeOf @@ -179,70 +179,70 @@ instance Zip SArray# where - all2 f as bs = go (minimum [sizeOf as, sizeOf bs]) + all2 f as bs = go (sizeOf as bs) where apply i = f (as!^i) (bs!^i) go 0 = True go i = let i' = i - 1 in apply i' && go i' - all3 f as bs cs = go (minimum [sizeOf as, sizeOf bs, sizeOf cs]) + all3 f as bs cs = go (sizeOf as bs cs) where apply i = f (as!^i) (bs!^i) (cs!^i) go 0 = True go i = let i' = i - 1 in apply i' && go i' - all4 f as bs cs ds = go (minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds]) + all4 f as bs cs ds = go (sizeOf as bs cs ds) where apply i = f (as!^i) (bs!^i) (cs!^i) (ds!^i) - + go 0 = True go i = let i' = i - 1 in apply i' && go i' - all5 f as bs cs ds es = go (minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds, sizeOf es]) + all5 f as bs cs ds es = go (sizeOf as bs cs ds es) where apply i = f (as!^i) (bs!^i) (cs!^i) (ds!^i) (es!^i) go 0 = True go i = let i' = i - 1 in apply i' && go i' - all6 f as bs cs ds es fs = go (minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds, sizeOf es, sizeOf fs]) + all6 f as bs cs ds es fs = go (sizeOf as bs cs ds es fs) where apply i = f (as!^i) (bs!^i) (cs!^i) (ds!^i) (es!^i) (fs!^i) go 0 = True go i = let i' = i - 1 in apply i' && go i' - any2 f as bs = go (minimum [sizeOf as, sizeOf bs]) + any2 f as bs = go (sizeOf as bs) where apply i = f (as!^i) (bs!^i) go 0 = False go i = let i' = i - 1 in apply i' || go i' - any3 f as bs cs = go (minimum [sizeOf as, sizeOf bs, sizeOf cs]) + any3 f as bs cs = go (sizeOf as bs cs) where apply i = f (as!^i) (bs!^i) (cs!^i) go 0 = False go i = let i' = i - 1 in apply i' || go i' - any4 f as bs cs ds = go (minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds]) + any4 f as bs cs ds = go (sizeOf as bs cs ds) where apply i = f (as!^i) (bs!^i) (cs!^i) (ds!^i) go 0 = False go i = let i' = i - 1 in apply i' || go i' - any5 f as bs cs ds es = go (minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds, sizeOf es]) + any5 f as bs cs ds es = go (sizeOf as bs cs ds es) where apply i = f (as!^i) (bs!^i) (cs!^i) (ds!^i) (es!^i) go 0 = False go i = let i' = i - 1 in apply i' || go i' - any6 f as bs cs ds es fs = go (minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds, sizeOf es, sizeOf fs]) + any6 f as bs cs ds es fs = go (sizeOf as bs cs ds es fs) where apply i = f (as!^i) (bs!^i) (cs!^i) (ds!^i) (es!^i) (fs!^i) @@ -277,7 +277,17 @@ instance Applicative SArray# where pure = single - fs <*> es = concatMap (<$> es) fs + + fs@(SArray# fn _ _) <*> es@(SArray# en _ _) = runST $ do + xs <- filled (fn * en) $ unreachEx "in SDP.Prim.SArray.(<*>) :: SArray# e" + + let + go (-1) _ _ = return () + go i (-1) k = go (i - 1) (en - 1) k + go i j k = writeM xs k (fs!^i $ es!^j) >> go i (j - 1) (k - 1) + + go (fn - 1) (en - 1) (upper xs) + done xs -------------------------------------------------------------------------------- @@ -314,7 +324,7 @@ instance Traversable SArray# where - traverse f = fmap fromList . foldr (liftA2 (:) . f) (pure []) + traverse f es = fromListN (sizeOf es) <$> foldr (liftA2 (:) . f) (pure Z) es -------------------------------------------------------------------------------- @@ -374,7 +384,7 @@ writeM es' n e done es' - reverse es = runST $ fromIndexed' es >>= reversed >>= done + reverse es = runST $ do es' <- fromIndexed' es; reversed' es'; done es' -- [internal]: always return new array, even if only one is nonempty concat ess = runST $ do @@ -382,13 +392,28 @@ marr@(STArray# _ _ marr#) <- filled n (unreachEx "concat") let - write# (SArray# c@(I# c#) (I# o#) arr#) i@(I# i#) = ST $ - \ s2# -> case copyArray# arr# o# marr# i# c# s2# of - s3# -> (# s3#, i + c #) + writeBlock# (SArray# (I# c#) (I# o#) arr#) (I# i#) = ST $ + \ s1# -> (# copyArray# arr# o# marr# i# c# s1#, I# (i# +# c#) #) - void $ foldl (\ b a -> write# a =<< b) (return 0) ess + void $ foldl (\ b a -> writeBlock# a =<< b) (return 0) ess done marr + before es@(SArray# c@(I# c#) (I# o#) arr#) n@(I# n#) e + | n >= c = es :< e + | n <= 0 = e :> es + | True = runST $ ST $ \ s1# -> case newArray# (c# +# 1#) e s1# of + (# s2#, marr# #) -> case copyArray# arr# o# marr# 0# n# s2# of + s3# -> case copyArray# arr# (o# +# n#) marr# (n# +# 1#) (c# -# n#) s3# of + s4# -> case unsafeFreezeArray# marr# s4# of + (# s5#, res# #) -> (# s5#, SArray# (c + 1) 0 res# #) + + remove n@(I# n#) es@(SArray# c@(I# c#) (I# o#) arr#) = n < 0 || n >= c ? es $ + runST $ ST $ \ s1# -> case newArray# (c# -# 1#) (unreachEx "remove") s1# of + (# s2#, marr# #) -> case copyArray# arr# o# marr# 0# n# s2# of + s3# -> case copyArray# arr# (o# +# n# +# 1#) marr# n# (c# -# n# -# 1#) s3# of + s4# -> case unsafeFreezeArray# marr# s4# of + (# s5#, res# #) -> (# s5#, SArray# (c - 1) 0 res# #) + select f = foldr (\ o es -> case f o of {Just e -> e : es; _ -> es}) [] extract f = @@ -512,8 +537,8 @@ setWith f = nubSorted f . sortBy f insertWith f e es = case (\ x -> x `f` e /= LT) .$ es of - Just i -> e `f` (es!^i) == EQ ? es $ before i e es - Nothing -> es :< e + Just i -> e `f` (es!^i) == EQ ? es $ before es i e + _ -> es :< e deleteWith f e es = memberWith f e es ? except (\ x -> f e x == EQ) es $ es @@ -674,8 +699,7 @@ fromIndexed es = runST $ do let n = sizeOf es copy <- filled n (unreachEx "fromIndexed") - forM_ [0 .. n - 1] $ \ i -> writeM copy i (es !^ i) - done copy + updateM copy (\ i _ -> es!^i) >>= done -------------------------------------------------------------------------------- @@ -794,19 +818,20 @@ writeM = writeM' - copied es@(STArray# n _ _) = do - copy <- filled n $ unreachEx "copied" - forM_ [0 .. n - 1] $ \ i -> es !#> i >>= writeM copy i - return copy + copied (STArray# n@(I# n#) (I# o#) marr#) = ST $ + \ s1# -> case cloneMutableArray# marr# o# n# s1# of + (# s2#, copy# #) -> (# s2#, STArray# n 0 copy# #) - copied' es l n = do - copy <- n `filled` unreachEx "copied'" - forM_ [0 .. n - 1] $ \ i -> es !#> (l + i) >>= writeM copy i - return copy + copied' (STArray# c (I# o#) marr#) l@(I# l#) n@(I# n#) + | l >= 0 && n >= 0 && c >= l + n = ST $ + \ s1# -> case cloneMutableArray# marr# (o# +# l#) n# s1# of + (# s2#, copy# #) -> (# s2#, STArray# n 0 copy# #) + | True = unreachEx "copied'" - reversed es = + reversed es = do es' <- copied es; reversed' es'; return es' + reversed' es = let go i j = when (i < j) $ go (i + 1) (j - 1) >> swapM es i j - in go 0 (sizeOf es - 1) >> return es + in go 0 (sizeOf es - 1) filled n e = let !n'@(I# n#) = max 0 n in ST $ \ s1# -> case newArray# n# e s1# of @@ -1017,10 +1042,11 @@ writeM = writeM' (!#>) = stToMIO ... (!#>) . unpack - copied = pack . copied . unpack - reversed = pack . reversed . unpack - getLeft = stToMIO . getLeft . unpack - getRight = stToMIO . getRight . unpack + copied = pack . copied . unpack + reversed = pack . reversed . unpack + getLeft = stToMIO . getLeft . unpack + getRight = stToMIO . getRight . unpack + reversed' = stToMIO . reversed' . unpack copied' es = pack ... copied' (unpack es) @@ -1074,9 +1100,8 @@ (>!) = (!#>) overwrite = pack ... overwrite . unpack - - kfoldrM = ofoldrM - kfoldlM = ofoldlM + kfoldrM = ofoldrM + kfoldlM = ofoldlM instance (MonadIO io) => IndexedM io (MIOArray# io e) Int e where @@ -1192,23 +1217,15 @@ where fun = \ e ls -> e `f` head ls == EQ ? ls $ e : ls -before :: Int -> e -> SArray# e -> SArray# e -before n@(I# n#) e es@(SArray# c@(I# c#) (I# o#) arr#) - | n >= c = es :< e - | n <= 0 = e :> es - | True = runST $ ST $ \ s1# -> case newArray# (c# +# 1#) e s1# of - (# s2#, marr# #) -> case copyArray# arr# o# marr# 0# n# s2# of - s3# -> case copyArray# arr# (o# +# n#) marr# (n# +# 1#) (c# -# n#) s3# of - s4# -> case unsafeFreezeArray# marr# s4# of - (# s5#, res# #) -> (# s5#, SArray# (c + 1) 0 res# #) - ascsBounds :: (Ord a) => [(a, b)] -> (a, a) ascsBounds = \ ((x, _) : xs) -> foldr (\ (e, _) (mn, mx) -> (min mn e, max mx e)) (x, x) xs --- | In base-4.9 'asProxyTypeOf' has less general type @a -> Proxy a -> a@. asProxyTypeOf :: a -> proxy a -> a asProxyTypeOf = const +() :: (Bordered b i) => Int -> b -> Int +() = (. sizeOf) . min + -------------------------------------------------------------------------------- undEx :: String -> a @@ -1225,6 +1242,4 @@ unreachEx :: String -> a unreachEx = throw . UnreachableException . showString "in SDP.Prim.SArray." - - diff --git a/src/SDP/Prim/SBytes.hs b/src/SDP/Prim/SBytes.hs --- a/src/SDP/Prim/SBytes.hs +++ b/src/SDP/Prim/SBytes.hs @@ -3,7 +3,7 @@ {- | Module : SDP.Prim.SBytes - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -50,12 +50,12 @@ import qualified GHC.Exts as E import GHC.Exts ( - ByteArray#, MutableByteArray#, State#, Int#, (+#), (-#), (==#), + ByteArray#, MutableByteArray#, State#, Int#, (+#), (-#), newByteArray#, unsafeFreezeByteArray#, sameMutableByteArray# ) import GHC.Types -import GHC.ST ( ST (..), STRep ) +import GHC.ST ( ST (..) ) import Data.Default.Class import Data.Typeable @@ -85,7 +85,7 @@ data SBytes# e = SBytes# {-# UNPACK #-} !Int -- ^ Element count (not a real size) {-# UNPACK #-} !Int -- ^ Offset (in elements) - !(ByteArray#) -- ^ Real primitive byte array + !ByteArray# -- ^ Real primitive byte array deriving ( Typeable ) type role SBytes# representational @@ -139,18 +139,13 @@ instance Nullable (SBytes# e) where - lzero = runST $ (done =<<) $ ST $ \ s1# -> case newByteArray# 0# s1# of - (# s2#, marr# #) -> (# s2#, STBytes# 0 0 marr# #) - isNull es = case es of {(SBytes# 0 _ _) -> True; _ -> False} + lzero = def instance (Unboxed e) => Semigroup (SBytes# e) where (<>) = (++) instance (Unboxed e) => Monoid (SBytes# e) where mempty = Z; mappend = (<>) -instance Default (SBytes# e) - where - def = runST $ (done =<<) $ ST $ \ s1# -> case newByteArray# 0# s1# of - (# s2#, marr# #) -> (# s2#, STBytes# 0 0 marr# #) +instance Default (SBytes# e) where def = SBytes# 0 0 (unwrap lzero#) instance Estimate (SBytes# e) where @@ -195,7 +190,7 @@ fromListN n es = runST $ newLinearN n es >>= done fromFoldable es = runST $ fromFoldableM es >>= done - single e = runST $ filled 1 e >>= done + single e = SBytes# 1 0 (single# e) xs@(SBytes# (I# n1#) (I# o1#) arr1#) ++ SBytes# (I# n2#) (I# o2#) arr2# = let n# = n1# +# n2# in runST $ ST $ \ s1# -> case pnewUnboxed xs n# s1# of @@ -225,14 +220,30 @@ marr@(STBytes# _ _ marr#) <- alloc n let - write# (SBytes# c@(I# c#) (I# o#) arr#) i@(I# i#) = ST $ + writeBlock# (SBytes# c@(I# c#) (I# o#) arr#) i@(I# i#) = ST $ \ s2# -> case pcopyUnboxed1 ess arr# o# marr# i# c# s2# of s3# -> (# s3#, i + c #) - foldl (flip $ (=<<) . write#) (return 0) ess >> done marr + foldl (flip $ (=<<) . writeBlock#) (return 0) ess >> done marr - reverse es = runST $ fromIndexed' es >>= reversed >>= done + reverse es = runST $ do es' <- fromIndexed' es; reversed' es'; done es' + before es@(SBytes# c@(I# c#) (I# o#) arr#) n@(I# n#) e + | n >= c = es :< e + | n <= 0 = e :> es + | True = runST $ ST $ \ s1# -> case newUnboxed' e (c# +# 1#) s1# of + (# s2#, marr# #) -> case copyUnboxed# e arr# o# marr# 0# n# s2# of + s3# -> case copyUnboxed# e arr# (o# +# n#) marr# (n# +# 1#) (c# -# n#) s3# of + s4# -> case unsafeFreezeByteArray# marr# s4# of + (# s5#, res# #) -> (# s5#, SBytes# (c + 1) 0 res# #) + + remove n@(I# n#) es@(SBytes# c@(I# c#) (I# o#) arr#) = n < 0 || n >= c ? es $ + runST $ ST $ \ s1# -> case pnewUnboxed es (c# -# 1#) s1# of + (# s2#, marr# #) -> case pcopyUnboxed es arr# o# marr# 0# n# s2# of + s3# -> case pcopyUnboxed es arr# (o# +# n# +# 1#) marr# n# (c# -# n# -# 1#) s3# of + s4# -> case unsafeFreezeByteArray# marr# s4# of + (# s5#, res# #) -> (# s5#, SBytes# (c - 1) 0 res# #) + select f = o_foldr (\ o es -> case f o of {Just e -> e : es; _ -> es}) [] extract f = let g o = second (o :) `maybe` (first . (:)) $ f o @@ -360,7 +371,7 @@ setWith f = nubSorted f . sortBy f insertWith f e es = case (\ x -> x `f` e /= LT) .$ es of - Just i -> e `f` (es!^i) == EQ ? es $ before i e es + Just i -> e `f` (es!^i) == EQ ? es $ before es i e _ -> es :< e deleteWith f e es = memberWith f e es ? except (\ x -> f e x == EQ) es $ es @@ -535,8 +546,7 @@ where thaw es@(SBytes# c@(I# c#) (I# o#) arr#) = do marr@(STBytes# _ _ marr#) <- alloc c - ST $ \ s1# -> case pcopyUnboxed es arr# o# marr# 0# c# s1# of - s2# -> (# s2#, () #) + ST $ \ s1# -> (# pcopyUnboxed es arr# o# marr# 0# c# s1#, () #) return marr instance (Unboxed e) => Freeze (ST s) (STBytes# s e) (SBytes# e) @@ -606,29 +616,18 @@ nowNull es = return (sizeOf es == 0) newLinear = fromFoldableM - newLinearN c es = ST $ \ s1# -> case pnewUnboxed es n# s1# of - (# s2#, marr# #) -> - let - go y r = \ i# s3# -> case writeByteArray# marr# i# y s3# of - s4# -> if isTrue# (i# ==# n# -# 1#) then s4# else r (i# +# 1#) s4# - in done' n marr# (if n == 0 then s2# else foldr go (\ _ s# -> s#) es 0# s2#) - where - !n@(I# n#) = max 0 c + newLinearN c es = let !n@(I# n#) = max 0 c in ST $ + \ s1# -> case newLinearN# n# es s1# of + (# s2#, marr# #) -> (# s2#, STBytes# n 0 marr# #) - fromFoldableM es = ST $ \ s1# -> case pnewUnboxed es n# s1# of - (# s2#, marr# #) -> - let - go y r = \ i# s3# -> case writeByteArray# marr# i# y s3# of - s4# -> if isTrue# (i# ==# n# -# 1#) then s4# else r (i# +# 1#) s4# - in done' n marr# (if n == 0 then s2# else foldr go (\ _ s# -> s#) es 0# s2#) - where - !n@(I# n#) = length es + fromFoldableM es = ST $ \ s1# -> case fromFoldableM# es s1# of + (# s2#, n, marr# #) -> (# s2#, STBytes# n 0 marr# #) getLeft es@(STBytes# n _ _) = (es !#>) `mapM` [0 .. n - 1] getRight es@(STBytes# n _ _) = (es !#>) `mapM` [n - 1, n - 2 .. 0] {-# INLINE (!#>) #-} - (!#>) (STBytes# _ (I# o#) marr#) = \ (I# i#) -> ST $ marr# !># (o# +# i#) + STBytes# _ (I# o#) marr# !#> I# i# = ST $ marr# !># (o# +# i#) writeM = writeM' @@ -642,9 +641,11 @@ forM_ [0 .. n - 1] $ \ i -> es !#> (l + i) >>= writeM copy i return copy - reversed es@(STBytes# n _ _) = + reversed es = do es' <- copied es; reversed' es'; return es' + + reversed' es@(STBytes# n _ _) = let go i j = when (i < j) $ go (i + 1) (j - 1) >> swapM es i j - in go 0 (n - 1) >> return es + in go 0 (n - 1) filled n e = ST $ \ s1# -> case newUnboxed' e n# s1# of (# s2#, marr# #) -> (# s2#, STBytes# n' 0 marr# #) @@ -861,8 +862,8 @@ writeM es = stToMIO ... writeM (unpack es) copied = pack . copied . unpack - getLeft = stToMIO . getLeft . unpack reversed = pack . reversed . unpack + getLeft = stToMIO . getLeft . unpack getRight = stToMIO . getRight . unpack copied' es = pack ... copied' (unpack es) @@ -927,8 +928,7 @@ fromAssocs bnds = pack . fromAssocs bnds fromAssocs' bnds = pack ... fromAssocs' bnds - writeM' es = stToMIO ... writeM' (unpack es) - + writeM' es = stToMIO ... writeM' (unpack es) fromIndexed' = pack . fromIndexed' fromIndexedM es = do @@ -1084,10 +1084,6 @@ done (STBytes# n o marr#) = ST $ \ s1# -> case unsafeFreezeByteArray# marr# s1# of (# s2#, arr# #) -> (# s2#, SBytes# n o arr# #) -{-# INLINE done' #-} -done' :: Int -> MutableByteArray# s -> STRep s (STBytes# s e) -done' n marr# = \ s1# -> (# s1#, STBytes# n 0 marr# #) - -- | alloc creates filled by default value pseudo-primitive. alloc :: (Unboxed e) => Int -> ST s (STBytes# s e) alloc c@(I# c#) = @@ -1098,19 +1094,8 @@ cloneSTBytes# :: (Unboxed e) => STBytes# s e -> ST s (STBytes# s e) cloneSTBytes# es@(STBytes# c@(I# c#) (I# o#) marr#) = do copy@(STBytes# _ _ copy#) <- alloc c - ST $ \ s1# -> case pcopyUnboxedM es marr# o# copy# 0# c# s1# of - s2# -> (# s2#, () #) + ST $ \ s1# -> (# pcopyUnboxedM es marr# o# copy# 0# c# s1#, () #) return copy - -before :: (Unboxed e) => Int -> e -> SBytes# e -> SBytes# e -before n@(I# n#) e es@(SBytes# c@(I# c#) (I# o#) arr#) - | n >= c = es :< e - | n <= 0 = e :> es - | True = runST $ ST $ \ s1# -> case newUnboxed' e (c# +# 1#) s1# of - (# s2#, marr# #) -> case copyUnboxed# e arr# o# marr# 0# n# s2# of - s3# -> case copyUnboxed# e arr# (o# +# n#) marr# (n# +# 1#) (c# -# n#) s3# of - s4# -> case unsafeFreezeByteArray# marr# s4# of - (# s5#, res# #) -> (# s5#, SBytes# (c + 1) 0 res# #) {-# INLINE nubSorted #-} nubSorted :: (Unboxed e) => Compare e -> SBytes# e -> SBytes# e diff --git a/src/SDP/SafePrelude.hs b/src/SDP/SafePrelude.hs --- a/src/SDP/SafePrelude.hs +++ b/src/SDP/SafePrelude.hs @@ -3,7 +3,7 @@ {- | Module : SDP.SafePrelude - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : portable @@ -12,17 +12,15 @@ those overridden in this library and its extensions (e.g. @sdp-io@). In addition, this module re-exports the most common definitions from other - @base@ and @sdp@ modules ("Control.Applicative", "Data.Bufunctor", + @base@ and @sdp@ modules ("Control.Applicative", "Data.Bifunctor", "SDP.Estimate", etc.) and some useful combinators that were used in this library and may be useful to its users. Import "Prelude" without conflicting functions, may require additional imports for functions overridden in other modules: - @ - import Prelude () - import SDP.SafePrelude - @ + > import Prelude () + > import SDP.SafePrelude -} module SDP.SafePrelude ( @@ -47,12 +45,15 @@ #endif -- * Combinators - on, (?), (?+), (?-), (?^), (?:), (+?), (...), (<=<<), (>>=>), (>>=<<) + (.), id, on, (?), (?+), (?-), (?^), (?:), (+?), (...), (<=<<), (>>=>), (>>=<<) ) where import Prelude hiding ( + -- defined in Control.Category + (.), id, + -- defined in SDP.Zip and Data.List zip, zip3, zipWith, zipWith3, @@ -76,15 +77,17 @@ #endif import Data.Functor.Classes + import Data.Bifunctor import Data.Foldable hiding ( foldrM, foldlM, concat, concatMap ) import Data.Function ( on ) import Control.Applicative +import Control.Category import Control.Monad.IO.Class import Control.Monad.ST -import Control.Monad +import Control.Monad hiding ( zipWithM ) infixl 8 ?+, ?- infixr 1 ?, ?^ -- Lowest priority, compatible with infixr 0 $ @@ -121,8 +124,8 @@ -- | Short version of 'Data.Maybe.fromMaybe'. {-# INLINE (+?) #-} (+?) :: a -> Maybe a -> a -_ +? Just x = x -x +? Nothing = x +_ +? Just x = x +x +? _ = x -- | @(...) = (.) . (.)@. {-# INLINE (...) #-} @@ -172,4 +175,6 @@ -- | 'stToMIO' is just @'liftIO' . 'stToIO'@. stToMIO :: (MonadIO io) => ST RealWorld e -> io e stToMIO = liftIO . stToIO + + diff --git a/src/SDP/Set.hs b/src/SDP/Set.hs --- a/src/SDP/Set.hs +++ b/src/SDP/Set.hs @@ -1,10 +1,14 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -{-# LANGUAGE TypeOperators, TypeFamilies, ConstraintKinds, DefaultSignatures #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Trustworthy, CPP, TypeOperators, TypeFamilies, DefaultSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.Set - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC Extensions) @@ -14,10 +18,16 @@ module SDP.Set ( -- * SetWith - SetWith (..), SetWith1, + SetWith (..), SetWith1, SetWith2, -- * Set - Set (..), Set1 + Set (..), Set1, Set2, + +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + SetWith', SetWith'', Set', Set'' +#endif ) where @@ -44,9 +54,9 @@ simplicity, openness and a lot of non-set functions without extra conversions, then you are at the right place. - Note that function of type @Compare o@ must follow total order laws - (antisymmetry, transitivity and connexity). If you use the wrong comparator, - the result may become implementation-dependent. + Note that function of type @Compare o@ must follow basic order laws + (comparability, transitivity, reflexivity and antisymmetry). With wrong + comparator, the result may become implementation-dependent. -} class (Nullable s) => SetWith s o | s -> o where @@ -260,11 +270,31 @@ -------------------------------------------------------------------------------- --- | Kind @(* -> *)@ 'Set'. +-- | 'Set' contraint for @(Type -> Type)@-kind types. type Set1 s o = Set (s o) o --- | Kind @(* -> *)@ 'SetWith'. +-- | 'SetWith' contraint for @(Type -> Type)@-kind types. type SetWith1 s o = SetWith (s o) o + +-- | 'Set' contraint for @(Type -> Type -> Type)@-kind types. +type Set2 s i o = Set (s i o) o + +-- | 'SetWith' contraint for @(Type -> Type -> Type)@-kind types. +type SetWith2 s i o = SetWith (s i o) o + +#if __GLASGOW_HASKELL__ >= 806 +-- | 'Set' quantified contraint for @(Type -> Type)@-kind types. +type Set' s = forall o . Set (s o) o + +-- | 'SetWith' quantified contraint for @(Type -> Type)@-kind types. +type SetWith' s = forall o . SetWith (s o) o + +-- | 'Set' quantified contraint for @(Type -> Type -> Type)@-kind types. +type Set'' s = forall i o . Set (s i o) o + +-- | 'SetWith' quantified contraint for @(Type -> Type -> Type)@-kind types. +type SetWith'' s = forall i o . SetWith (s i o) o +#endif -------------------------------------------------------------------------------- diff --git a/src/SDP/Shape.hs b/src/SDP/Shape.hs --- a/src/SDP/Shape.hs +++ b/src/SDP/Shape.hs @@ -1,10 +1,9 @@ {-# LANGUAGE TypeFamilies, TypeOperators, DefaultSignatures, ConstraintKinds #-} -{-# LANGUAGE CPP, FlexibleInstances, UndecidableInstances, OverloadedLists #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, FlexibleInstances, UndecidableInstances, Trustworthy #-} {- | Module : SDP.Shape - Copyright : (c) Andrey Mulik 2020 + Copyright : (c) Andrey Mulik 2020-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -87,13 +86,13 @@ {-# INLINE fromGIndex #-} default fromGIndex :: (RANK1 i) => GIndex i -> i fromGIndex :: GIndex i -> i - fromGIndex = \ [i] -> i + fromGIndex = \ (E :& i) -> i -- | Create generalized index from index. {-# INLINE toGIndex #-} default toGIndex :: (RANK1 i) => i -> GIndex i toGIndex :: i -> GIndex i - toGIndex = \ i -> [i] + toGIndex = (E :&) -- | Count of dimensions in represented space (must be finite and constant). {-# INLINE rank #-} @@ -204,7 +203,7 @@ instance Shape CSize #if MIN_VERSION_base(4,10,0) --- | @since base-4.10.0.0 +-- | since @base-4.10.0.0@ instance Shape CBool #endif @@ -251,120 +250,121 @@ instance (Shape i, Enum i, Bounded i) => Shape (Type i)\ where\ {\ -type DimInit (Type i) = Last i;\ type DimLast (Type i) = i;\ +type DimInit (Type i) = Last i;\ rank = const RANK;\ initDim = fst . unconsDim;\ lastDim = snd . unconsDim; SHAPE_INSTANCE(T2, I1, 2) -fromGIndex = \ [a,b] -> (a,b); -consDim = \ [a] b -> (a,b); -toGIndex (a,b) = [a,b]; -unconsDim (a,b) = ([a],b); +fromGIndex = \ (E:&a:&b) -> (a,b); +consDim = \ (E:&a) b -> (a,b); +unconsDim (a,b) = (E:&a,b); +toGIndex (a,b) = E:&a:&b; } SHAPE_INSTANCE(T3, T2, 3) -fromGIndex = \ [a,b,c] -> (a,b,c); -toGIndex (a,b,c) = [a,b,c]; -consDim (a,b) c = (a,b,c); -unconsDim (a,b,c) = ((a,b),c); +fromGIndex = \ (E:&a:&b:&c) -> (a,b,c); +toGIndex (a,b,c) = E:&a:&b:&c; +unconsDim (a,b,c) = ((a,b),c); +consDim (a,b) c = (a,b,c); } SHAPE_INSTANCE(T4, T3, 4) -fromGIndex = \ [a,b,c,d] -> (a,b,c,d); -toGIndex (a,b,c,d) = [a,b,c,d]; -consDim (a,b,c) d = (a,b,c,d); -unconsDim (a,b,c,d) = ((a,b,c),d); +fromGIndex = \ (E:&a:&b:&c:&d) -> (a,b,c,d); +toGIndex (a,b,c,d) = E:&a:&b:&c:&d; +unconsDim (a,b,c,d) = ((a,b,c),d); +consDim (a,b,c) d = (a,b,c,d); } SHAPE_INSTANCE(T5, T4, 5) -fromGIndex = \ [a,b,c,d,e] -> (a,b,c,d,e); -toGIndex (a,b,c,d,e) = [a,b,c,d,e]; -consDim (a,b,c,d) e = (a,b,c,d,e); -unconsDim (a,b,c,d,e) = ((a,b,c,d),e); +fromGIndex = \ (E:&a:&b:&c:&d:&e) -> (a,b,c,d,e); +toGIndex (a,b,c,d,e) = E:&a:&b:&c:&d:&e; +unconsDim (a,b,c,d,e) = ((a,b,c,d),e); +consDim (a,b,c,d) e = (a,b,c,d,e); } SHAPE_INSTANCE(T6, T5, 6) -fromGIndex = \ [a,b,c,d,e,f] -> (a,b,c,d,e,f); -toGIndex (a,b,c,d,e,f) = [a,b,c,d,e,f]; -consDim (a,b,c,d,e) f = (a,b,c,d,e,f); -unconsDim (a,b,c,d,e,f) = ((a,b,c,d,e),f); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f) -> (a,b,c,d,e,f); +toGIndex (a,b,c,d,e,f) = E:&a:&b:&c:&d:&e:&f; +unconsDim (a,b,c,d,e,f) = ((a,b,c,d,e),f); +consDim (a,b,c,d,e) f = (a,b,c,d,e,f); } SHAPE_INSTANCE(T7, T6, 7) -fromGIndex = \ [a,b,c,d,e,f,g] -> (a,b,c,d,e,f,g); -toGIndex (a,b,c,d,e,f,g) = [a,b,c,d,e,f,g]; -consDim (a,b,c,d,e,f) g = (a,b,c,d,e,f,g); -unconsDim (a,b,c,d,e,f,g) = ((a,b,c,d,e,f),g); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f:&g) -> (a,b,c,d,e,f,g); +toGIndex (a,b,c,d,e,f,g) = E:&a:&b:&c:&d:&e:&f:&g; +unconsDim (a,b,c,d,e,f,g) = ((a,b,c,d,e,f),g); +consDim (a,b,c,d,e,f) g = (a,b,c,d,e,f,g); } SHAPE_INSTANCE(T8, T7, 8) -fromGIndex = \ [a,b,c,d,e,f,g,h] -> (a,b,c,d,e,f,g,h); -toGIndex (a,b,c,d,e,f,g,h) = [a,b,c,d,e,f,g,h]; -consDim (a,b,c,d,e,f,g) h = (a,b,c,d,e,f,g,h); -unconsDim (a,b,c,d,e,f,g,h) = ((a,b,c,d,e,f,g),h); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f:&g:&h) -> (a,b,c,d,e,f,g,h); +toGIndex (a,b,c,d,e,f,g,h) = E:&a:&b:&c:&d:&e:&f:&g:&h; +unconsDim (a,b,c,d,e,f,g,h) = ((a,b,c,d,e,f,g),h); +consDim (a,b,c,d,e,f,g) h = (a,b,c,d,e,f,g,h); } SHAPE_INSTANCE(T9, T8, 9) -fromGIndex = \ [a,b,c,d,e,f,g,h,i] -> (a,b,c,d,e,f,g,h,i); -toGIndex (a,b,c,d,e,f,g,h,i) = [a,b,c,d,e,f,g,h,i]; -consDim (a,b,c,d,e,f,g,h) i = (a,b,c,d,e,f,g,h,i); -unconsDim (a,b,c,d,e,f,g,h,i) = ((a,b,c,d,e,f,g,h),i); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f:&g:&h:&i) -> (a,b,c,d,e,f,g,h,i); +toGIndex (a,b,c,d,e,f,g,h,i) = E:&a:&b:&c:&d:&e:&f:&g:&h:&i; +unconsDim (a,b,c,d,e,f,g,h,i) = ((a,b,c,d,e,f,g,h),i); +consDim (a,b,c,d,e,f,g,h) i = (a,b,c,d,e,f,g,h,i); } SHAPE_INSTANCE(T10, T9, 10) -fromGIndex = \ [a,b,c,d,e,f,g,h,i,j] -> (a,b,c,d,e,f,g,h,i,j); -toGIndex (a,b,c,d,e,f,g,h,i,j) = [a,b,c,d,e,f,g,h,i,j]; -consDim (a,b,c,d,e,f,g,h,i) j = (a,b,c,d,e,f,g,h,i,j); -unconsDim (a,b,c,d,e,f,g,h,i,j) = ((a,b,c,d,e,f,g,h,i),j); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j) -> (a,b,c,d,e,f,g,h,i,j); +toGIndex (a,b,c,d,e,f,g,h,i,j) = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j; +unconsDim (a,b,c,d,e,f,g,h,i,j) = ((a,b,c,d,e,f,g,h,i),j); +consDim (a,b,c,d,e,f,g,h,i) j = (a,b,c,d,e,f,g,h,i,j); } SHAPE_INSTANCE(T11, T10, 11) -fromGIndex = \ [a,b,c,d,e,f,g,h,i,j,k] -> (a,b,c,d,e,f,g,h,i,j,k); -toGIndex (a,b,c,d,e,f,g,h,i,j,k) = [a,b,c,d,e,f,g,h,i,j,k]; -consDim (a,b,c,d,e,f,g,h,i,j) k = (a,b,c,d,e,f,g,h,i,j,k); -unconsDim (a,b,c,d,e,f,g,h,i,j,k) = ((a,b,c,d,e,f,g,h,i,j),k); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k) -> (a,b,c,d,e,f,g,h,i,j,k); +toGIndex (a,b,c,d,e,f,g,h,i,j,k) = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k; +unconsDim (a,b,c,d,e,f,g,h,i,j,k) = ((a,b,c,d,e,f,g,h,i,j),k); +consDim (a,b,c,d,e,f,g,h,i,j) k = (a,b,c,d,e,f,g,h,i,j,k); } SHAPE_INSTANCE(T12, T11, 12) -fromGIndex = \ [a,b,c,d,e,f,g,h,i,j,k,l] -> (a,b,c,d,e,f,g,h,i,j,k,l); -toGIndex (a,b,c,d,e,f,g,h,i,j,k,l) = [a,b,c,d,e,f,g,h,i,j,k,l]; -consDim (a,b,c,d,e,f,g,h,i,j,k) l = (a,b,c,d,e,f,g,h,i,j,k,l); -unconsDim (a,b,c,d,e,f,g,h,i,j,k,l) = ((a,b,c,d,e,f,g,h,i,j,k),l); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l) -> (a,b,c,d,e,f,g,h,i,j,k,l); +toGIndex (a,b,c,d,e,f,g,h,i,j,k,l) = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l; +unconsDim (a,b,c,d,e,f,g,h,i,j,k,l) = ((a,b,c,d,e,f,g,h,i,j,k),l); +consDim (a,b,c,d,e,f,g,h,i,j,k) l = (a,b,c,d,e,f,g,h,i,j,k,l); } SHAPE_INSTANCE(T13, T12, 13) -fromGIndex = \ [a,b,c,d,e,f,g,h,i,j,k,l,m] -> (a,b,c,d,e,f,g,h,i,j,k,l,m); -toGIndex (a,b,c,d,e,f,g,h,i,j,k,l,m) = [a,b,c,d,e,f,g,h,i,j,k,l,m]; -consDim (a,b,c,d,e,f,g,h,i,j,k,l) m = (a,b,c,d,e,f,g,h,i,j,k,l,m); -unconsDim (a,b,c,d,e,f,g,h,i,j,k,l,m) = ((a,b,c,d,e,f,g,h,i,j,k,l),m); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l:&m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m); +toGIndex (a,b,c,d,e,f,g,h,i,j,k,l,m) = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l:&m; +unconsDim (a,b,c,d,e,f,g,h,i,j,k,l,m) = ((a,b,c,d,e,f,g,h,i,j,k,l),m); +consDim (a,b,c,d,e,f,g,h,i,j,k,l) m = (a,b,c,d,e,f,g,h,i,j,k,l,m); } SHAPE_INSTANCE(T14, T13, 14) -fromGIndex = \ [a,b,c,d,e,f,g,h,i,j,k,l,m,n] -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n); -toGIndex (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = [a,b,c,d,e,f,g,h,i,j,k,l,m,n]; -consDim (a,b,c,d,e,f,g,h,i,j,k,l,m) n = (a,b,c,d,e,f,g,h,i,j,k,l,m,n); -unconsDim (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = ((a,b,c,d,e,f,g,h,i,j,k,l,m),n); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l:&m:&n) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n); +toGIndex (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l:&m:&n; +unconsDim (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = ((a,b,c,d,e,f,g,h,i,j,k,l,m),n); +consDim (a,b,c,d,e,f,g,h,i,j,k,l,m) n = (a,b,c,d,e,f,g,h,i,j,k,l,m,n); } SHAPE_INSTANCE(T15, T14, 15) -fromGIndex = \ [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o] -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o); -toGIndex (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o]; -consDim (a,b,c,d,e,f,g,h,i,j,k,l,m,n) o = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o); -unconsDim (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = ((a,b,c,d,e,f,g,h,i,j,k,l,m,n),o); +fromGIndex = \ (E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l:&m:&n:&o) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o); +toGIndex (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = E:&a:&b:&c:&d:&e:&f:&g:&h:&i:&j:&k:&l:&m:&n:&o; +unconsDim (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = ((a,b,c,d,e,f,g,h,i,j,k,l,m,n),o); +consDim (a,b,c,d,e,f,g,h,i,j,k,l,m,n) o = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o); } #undef SHAPE_INSTANCE -------------------------------------------------------------------------------- -- | Convert any index type bounds to generalized index bounds. -{-# INLINE toGBounds #-} toGBounds :: (Shape i) => (i, i) -> (GIndex i, GIndex i) toGBounds = both toGIndex -- | Convert generalized index bounds to any index type bounds. -{-# INLINE fromGBounds #-} fromGBounds :: (Shape i) => (GIndex i, GIndex i) -> (i, i) fromGBounds = both fromGIndex + + + diff --git a/src/SDP/Sort.hs b/src/SDP/Sort.hs --- a/src/SDP/Sort.hs +++ b/src/SDP/Sort.hs @@ -1,9 +1,13 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe, CPP, ConstraintKinds #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.Index - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : portable @@ -13,7 +17,16 @@ module SDP.Sort ( -- * Sort - Sort (..), sort, sortOn, sorted, sortedOn + Sort (..), Sort1, Sort2, + +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + Sort', Sort'', +#endif + + -- * Helpers + sort, sortOn, sorted, sortedOn ) where @@ -50,6 +63,22 @@ -------------------------------------------------------------------------------- +-- | 'Sort' contraint for @(Type -> Type)@-kind types. +type Sort1 rep e = Sort (rep e) + +-- | 'Sort' contraint for @(Type -> Type -> Type)@-kind types. +type Sort2 rep i e = Sort (rep i e) + +#if __GLASGOW_HASKELL__ >= 806 +-- | 'Sort' quantified contraint for @(Type -> Type)@-kind types. +type Sort' rep = forall e . Sort (rep e) + +-- | 'Sort' quantified contraint for @(Type -> Type -> Type)@-kind types. +type Sort'' rep = forall i e . Sort (rep i e) +#endif + +-------------------------------------------------------------------------------- + -- | Checks if the structure is 'sorted'. sorted :: (Sort s e, Ord e) => s -> Bool sorted = sortedBy (<=) @@ -65,6 +94,7 @@ -- | Sort by comparing the results of a given function applied to each element. sortOn :: (Sort s e, Ord o) => (e -> o) -> s -> s sortOn = sortBy . comparing + diff --git a/src/SDP/SortM.hs b/src/SDP/SortM.hs --- a/src/SDP/SortM.hs +++ b/src/SDP/SortM.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, ConstraintKinds #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe, CPP, MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE ConstraintKinds #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints, RankNTypes #-} +#endif + {- | Module : SDP.SortM - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -11,10 +15,19 @@ "SDP.SortM" provides 'SortM' - class of sortable mutable structures. -} module SDP.SortM - ( - -- * SortM - SortM (..), SortM1, sortM, sortMOn, sortedM, sortedMOn - ) +( + -- * SortM + SortM (..), SortM1, SortM2, + +#if __GLASGOW_HASKELL__ >= 806 + -- ** Rank 2 quantified constraints + -- | GHC 8.6.1+ only + SortM', SortM'', +#endif + + -- * Helpers + sortM, sortMOn, sortedM, sortedMOn +) where import Prelude () @@ -40,9 +53,20 @@ -------------------------------------------------------------------------------- --- | Kind (* -> *) version of 'SortM'. +-- | 'SortM' contraint for @(Type -> Type)@-kind types. type SortM1 m s e = SortM m (s e) e +-- | 'SortM' contraint for @(Type -> Type -> Type)@-kind types. +type SortM2 m s i e = SortM m (s i e) + +#if __GLASGOW_HASKELL__ >= 806 +-- | 'SortM' quantified contraint for @(Type -> Type)@-kind types. +type SortM' m s = forall e . SortM m (s e) e + +-- | 'SortM' quantified contraint for @(Type -> Type -> Type)@-kind types. +type SortM'' m s = forall i e . SortM m (s i e) +#endif + -------------------------------------------------------------------------------- -- | Checks if the structure is sorted. @@ -60,6 +84,7 @@ -- | Sort by comparing the results of a key function applied to each element. sortMOn :: (SortM m s e, Ord o) => (e -> o) -> s -> m () sortMOn = sortMBy . comparing + diff --git a/src/SDP/SortM/Insertion.hs b/src/SDP/SortM/Insertion.hs --- a/src/SDP/SortM/Insertion.hs +++ b/src/SDP/SortM/Insertion.hs @@ -2,7 +2,7 @@ {- | Module : SDP.SortM.Insertion - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : portable @@ -48,7 +48,7 @@ -------------------------------------------------------------------------------- {- | - unsafeInsertionSort cmp es b s e is internal sorting procedure, where + @unsafeInsertionSort cmp es b s e@ is internal sorting procedure, where @cmp@ - compare function, @es@ - data structure, @[b .. s]@ - sorted range, @[b .. e]@ - sortable range. -} @@ -64,7 +64,7 @@ LT -> next' l (c - 1) c EQ -> return (c + 1) p <- next' b (i - 1) i - mapM_ (swapM es i) [p .. i - 1] + lshiftM es p i diff --git a/src/SDP/Templates/AnyBorder.hs b/src/SDP/Templates/AnyBorder.hs --- a/src/SDP/Templates/AnyBorder.hs +++ b/src/SDP/Templates/AnyBorder.hs @@ -4,7 +4,7 @@ {- | Module : SDP.Templates.AnyBorder - Copyright : (c) Andrey Mulik 2020 + Copyright : (c) Andrey Mulik 2020-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -265,7 +265,9 @@ partitions f = fmap fromList . partitions f . listL intersperse e = withBounds . intersperse e . unpack - filter f = withBounds . filter f . unpack + filter f = withBounds . filter f . unpack + remove n = withBounds . remove n . unpack + before es = withBounds ... before (unpack es) reverse (AnyBorder l u rep) = AnyBorder l u (reverse rep) force (AnyBorder l u rep) = AnyBorder l u (force rep) @@ -602,4 +604,7 @@ {-# INLINE withBounds' #-} withBounds' :: (Index i, BorderedM1 m rep Int e) => rep e -> m (AnyBorder rep i e) withBounds' rep = (\ n -> uncurry AnyBorder (defaultBounds n) rep) <$> getSizeOf rep + + + diff --git a/src/SDP/Templates/AnyChunks.hs b/src/SDP/Templates/AnyChunks.hs --- a/src/SDP/Templates/AnyChunks.hs +++ b/src/SDP/Templates/AnyChunks.hs @@ -4,7 +4,7 @@ {- | Module : SDP.Templates.AnyChunks - Copyright : (c) Andrey Mulik 2020 + Copyright : (c) Andrey Mulik 2020-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) @@ -268,6 +268,23 @@ select f (AnyChunks es) = concatMap (select f) es extract f (AnyChunks es) = bimap concat AnyChunks . unzip $ extract f <$> es + before (AnyChunks ess) i e = AnyChunks $ go (max 0 i) ess + where + go n (xs : xss) = + let c = sizeOf xs + in n < c ? before xs n e : xss $ xs : go (n - c) xss + go _ [] = [single e] + + remove i es@(AnyChunks ess) = i < 0 ? es $ AnyChunks (go i ess) + where + go n (xs : xss) + | c == 1 = xss -- singleton chunk + | n >= c = xs : go (n - c) xss + | True = remove n xs : xss + where + c = sizeOf xs + go _ [] = [] + selects fs = second fromList . selects fs . listL ofoldr f' base' = go 0 f' base' . toChunks @@ -357,7 +374,6 @@ where (d, n) = c `divMod` lim - -- TODO: rewrite without SplitM copyTo src os trg ot c = when (c > 0) $ do when (os < 0 || ot < 0) $ underEx "copyTo" src' <- dropM os src @@ -572,7 +588,7 @@ -------------------------------------------------------------------------------- --- | Creates new local immutable structure and thaw it as fast, as possible. +-- | Creates new local immutable structure and thaw it unsafely. instance {-# OVERLAPPABLE #-} (Linear1 imm e, Thaw1 m imm mut e) => Thaw m (AnyChunks imm e) (mut e) where -- @concat [e]@ may return e @@ -626,5 +642,4 @@ lim :: Int lim = 1024 - diff --git a/src/SDP/Unboxed.hs b/src/SDP/Unboxed.hs --- a/src/SDP/Unboxed.hs +++ b/src/SDP/Unboxed.hs @@ -1,675 +1,1485 @@ {-# LANGUAGE Trustworthy, CPP, MagicHash, UnboxedTuples, BangPatterns #-} - -{- | - Module : SDP.Unboxed - Copyright : (c) Andrey Mulik 2019 - License : BSD-style - Maintainer : work.a.mulik@gmail.com - Portability : portable - - "SDP.Unboxed" provide service class 'Unboxed', that needed for - "SDP.Prim.SBytes"-based structures. --} -module SDP.Unboxed -( - -- * Unboxed - Unboxed (..), cloneUnboxed#, cloneUnboxed1#, - - -- ** Proxy - psizeof, pnewUnboxed, pcopyUnboxed, pcopyUnboxedM, fromProxy, - pnewUnboxed1, pcopyUnboxed1, pcopyUnboxedM1, fromProxy1 -) -where - -import Prelude () -import SDP.SafePrelude -import SDP.Ratio - -import GHC.Stable -import GHC.Base -import GHC.Word -import GHC.Int -import GHC.Ptr -import GHC.ST - -import Data.Complex - -import Foreign.C.Types - -#include "MachDeps.h" - -default () - --------------------------------------------------------------------------------- - -{- | - 'Unboxed' is a layer between untyped raw data and parameterized unboxed data - structures. Also it prevents direct interaction with primitives. --} -class (Eq e) => Unboxed e - where - {-# MINIMAL (sizeof#|sizeof), (!#), (!>#), writeByteArray#, newUnboxed #-} - - {- | - @sizeof e n@ returns the length (in bytes) of primitive, where @n@ - count - of elements, @e@ - type parameter. - -} - {-# INLINE sizeof #-} - sizeof :: e -> Int -> Int - sizeof e (I# c#) = I# (sizeof# e c#) - - -- | 'sizeof#' is unboxed 'sizeof'. - {-# INLINE sizeof# #-} - sizeof# :: e -> Int# -> Int# - sizeof# e c# = case sizeof e (I# c#) of I# n# -> n# - - -- | Unsafe 'ByteArray#' reader with overloaded result type. - (!#) :: ByteArray# -> Int# -> e - - -- | Unsafe 'MutableByteArray#' reader with overloaded result type. - (!>#) :: MutableByteArray# s -> Int# -> State# s -> (# State# s, e #) - - -- | Unsafe 'MutableByteArray#' writer. - writeByteArray# :: MutableByteArray# s -> Int# -> e -> State# s -> State# s - - {-# INLINE fillByteArray# #-} - -- | Procedure for filling the array with the default value (like calloc). - fillByteArray# :: MutableByteArray# s -> Int# -> e -> State# s -> State# s - fillByteArray# mbytes# n# e = I# n# > 0 ? go (n# -# 1#) $ \ s1# -> s1# - where - go 0# s2# = writeByteArray# mbytes# 0# e s2# - go c# s2# = go (c# -# 1#) (writeByteArray# mbytes# c# e s2#) - - {- | - 'newUnboxed' creates new 'MutableByteArray#' of given count of elements. - First argument used as type variable. - -} - newUnboxed :: e -> Int# -> State# s -> (# State# s, MutableByteArray# s #) - - {-# INLINE newUnboxed' #-} - {- | - 'newUnboxed'' is version of 'newUnboxed', that use first argument as - initial value. May fail when trying to write 'error' or 'undefined'. - -} - newUnboxed' :: e -> Int# -> State# s -> (# State# s, MutableByteArray# s #) - newUnboxed' e n# = \ s1# -> case newUnboxed e n# s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# e s2# of - s3# -> (# s3#, mbytes# #) - - {- | - @'copyUnboxed#' e bytes\# o1\# mbytes\# o2\# n\#@ unsafely writes elements - from @bytes\#@ to @mbytes\#@, where o1\# and o2\# - offsets (element - count), @n\#@ - count of elements to copy. - -} - copyUnboxed# :: e -> ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - copyUnboxed# e bytes# o1# mbytes# o2# n# = copyByteArray# bytes# (sizeof# e o1#) mbytes# (sizeof# e o2#) (sizeof# e n#) - - {- | - @'copyUnboxedM#' e msrc\# o1\# mbytes\# o2\# n\#@ unsafely writes elements - from @msrc\#@ to @mbytes\#@, where o1\# and o2\# - offsets (element - count), @n\#@ - count of elements to copy. - -} - copyUnboxedM# :: e -> MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - copyUnboxedM# e msrc# o1# mbytes# o2# n# = copyMutableByteArray# msrc# (sizeof# e o1#) mbytes# (sizeof# e o2#) (sizeof# e n#) - - {- | - @'hashUnboxedWith' e len# off# bytes# salt@ returns @bytes#@ @FNV-1@ hash, - where @off#@ and @len#@ is offset and length (in elements). - - Note: the standard definition of this function is written in Haskell using - low-level functions, but this implementation mayn't be as efficient as the - foreign procedure in the @hashable@ package. - -} - hashUnboxedWith :: e -> Int# -> Int# -> ByteArray# -> Int# -> Int# - hashUnboxedWith e len# off# bytes# = go (sizeof# e off#) (sizeof# e len#) - where - go _ 0# salt# = salt# - go o# n# salt# = go (o# +# 1#) (n# -# 1#) (word2Int# hash#) - where - prod# = int2Word# (salt# *# 16777619#) - elem# = indexWord8Array# bytes# o# - hash# = prod# `xor#` elem# - --------------------------------------------------------------------------------- - --- | 'psizeof' is @Proxy 'sizeof'@. -psizeof :: (Unboxed e) => proxy e -> Int -> Int -psizeof = sizeof . fromProxy - --- | @(* -> *)@ kind proxy version of 'newUnboxed'. -pnewUnboxed :: (Unboxed e) => proxy e -> Int# -> State# s -> (# State# s, MutableByteArray# s #) -pnewUnboxed = newUnboxed . fromProxy - --- | @(* -> *)@ kind proxy version if 'copyUnboxed#'. -pcopyUnboxed :: (Unboxed e) => proxy e -> ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -pcopyUnboxed = copyUnboxed# . fromProxy - --- | Proxy version if 'copyUnboxedM#'. -pcopyUnboxedM :: (Unboxed e) => proxy e -> MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -pcopyUnboxedM = copyUnboxedM# . fromProxy - --- | Returns 'undefined' of suitable type. -fromProxy :: proxy e -> e -fromProxy = const undefined - --- | @(* -> * -> *)@ kind proxy version of 'newUnboxed'. -pnewUnboxed1 :: (Unboxed e) => m (proxy e) -> Int# -> State# s -> (# State# s, MutableByteArray# s #) -pnewUnboxed1 = newUnboxed . fromProxy1 - --- | @(* -> * -> *)@ kind proxy version if 'copyUnboxed#'. -pcopyUnboxed1 :: (Unboxed e) => m (proxy e) -> ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -pcopyUnboxed1 = copyUnboxed# . fromProxy1 - --- | @(* -> * -> *)@ kind proxy version if 'copyUnboxedM#'. -pcopyUnboxedM1 :: (Unboxed e) => m (proxy e) -> MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -pcopyUnboxedM1 = copyUnboxedM# . fromProxy1 - --- | Returns 'undefined' of suitable type. -fromProxy1 :: m (proxy e) -> e -fromProxy1 = const undefined - --------------------------------------------------------------------------------- - -{- Int instances. -} - -instance Unboxed Int - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * SIZEOF_HSWORD - - {-# INLINE (!#) #-} - bytes# !# i# = I# (indexIntArray# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readIntArray# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, I# e# #) - - writeByteArray# mbytes# n# (I# e#) = writeIntArray# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Int) s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Int8 - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n - - {-# INLINE (!#) #-} - bytes# !# i# = I8# (indexInt8Array# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readInt8Array# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, I8# e# #) - - writeByteArray# mbytes# n# (I8# e#) = writeInt8Array# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Int8) s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Int16 - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * 2 - - {-# INLINE (!#) #-} - bytes# !# i# = I16# (indexInt16Array# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readInt16Array# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, I16# e# #) - - writeByteArray# mbytes# n# (I16# e#) = writeInt16Array# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Int16) s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Int32 - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * 4 - - {-# INLINE (!#) #-} - bytes# !# i# = I32# (indexInt32Array# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readInt32Array# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, I32# e# #) - - writeByteArray# mbytes# n# (I32# e#) = writeInt32Array# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Int32) s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Int64 - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * 8 - - {-# INLINE (!#) #-} - bytes# !# i# = I64# (indexInt64Array# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readInt64Array# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, I64# e# #) - - writeByteArray# mbytes# n# (I64# e#) = writeInt64Array# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Int64) s2# of - s3# -> (# s3#, mbytes# #) - --------------------------------------------------------------------------------- - -{- Word instances. -} - -instance Unboxed Word - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * SIZEOF_HSWORD - - {-# INLINE (!#) #-} - bytes# !# i# = W# (indexWordArray# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readWordArray# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, W# e# #) - - writeByteArray# mbytes# n# (W# e#) = writeWordArray# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Word) s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Word8 - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n - - {-# INLINE (!#) #-} - bytes# !# i# = W8# (indexWord8Array# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readWord8Array# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, W8# e# #) - - writeByteArray# mbytes# n# (W8# e#) = writeWord8Array# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Word8) s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Word16 - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * 2 - - {-# INLINE (!#) #-} - bytes# !# i# = W16# (indexWord16Array# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readWord16Array# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, W16# e# #) - - writeByteArray# mbytes# n# (W16# e#) = writeWord16Array# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Word16) s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Word32 - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * 4 - - {-# INLINE (!#) #-} - bytes# !# i# = W32# (indexWord32Array# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readWord32Array# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, W32# e# #) - - writeByteArray# mbytes# n# (W32# e#) = writeWord32Array# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Word32) s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Word64 - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * 8 - - {-# INLINE (!#) #-} - bytes# !# i# = W64# (indexWord64Array# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readWord64Array# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, W64# e# #) - - writeByteArray# mbytes# n# (W64# e#) = writeWord64Array# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Word64) s2# of - s3# -> (# s3#, mbytes# #) - --------------------------------------------------------------------------------- - -{- Pointer instances. -} - -instance Unboxed (Ptr a) - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * SIZEOF_HSWORD - - {-# INLINE (!#) #-} - bytes# !# i# = Ptr (indexAddrArray# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readAddrArray# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, Ptr e# #) - - writeByteArray# mbytes# n# (Ptr e) = writeAddrArray# mbytes# n# e - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# nullPtr s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed (FunPtr a) - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * SIZEOF_HSWORD - - {-# INLINE (!#) #-} - bytes# !# i# = FunPtr (indexAddrArray# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readAddrArray# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, FunPtr e# #) - - writeByteArray# mbytes# n# (FunPtr e) = writeAddrArray# mbytes# n# e - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# nullFunPtr s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed (StablePtr a) - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * SIZEOF_HSWORD - - {-# INLINE (!#) #-} - bytes# !# i# = StablePtr (indexStablePtrArray# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readStablePtrArray# mbytes# i# s1# of - (# s2#, e# #) -> (# s2#, StablePtr e# #) - - writeByteArray# mbytes# n# (StablePtr e) = writeStablePtrArray# mbytes# n# e - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# nullStablePtr s2# of - s3# -> (# s3#, mbytes# #) - -nullStablePtr :: StablePtr a -nullStablePtr = StablePtr (unsafeCoerce# 0#) - --------------------------------------------------------------------------------- - -{- Foreign C instances. -} - -#define SDP_DERIVE_FOREIGN_UNBOXED(Type)\ -instance Unboxed Type where\ -{\ - sizeof e = sizeof (consSizeof Type e);\ - arr# !# i# = Type ( arr# !# i# );\ - marr# !># i# = \ s1# -> case (!>#) marr# i# s1# of {(# s2#, e #) -> (# s2#, Type e #)};\ - writeByteArray# marr# i# (Type e) = writeByteArray# marr# i# e;\ - fillByteArray# marr# i# (Type e) = fillByteArray# marr# i# e;\ - newUnboxed (Type e) = newUnboxed e;\ - newUnboxed' (Type e) = newUnboxed' e;\ -} - -SDP_DERIVE_FOREIGN_UNBOXED(CChar) -SDP_DERIVE_FOREIGN_UNBOXED(CSChar) -SDP_DERIVE_FOREIGN_UNBOXED(CWchar) -SDP_DERIVE_FOREIGN_UNBOXED(CShort) -SDP_DERIVE_FOREIGN_UNBOXED(CUShort) - -SDP_DERIVE_FOREIGN_UNBOXED(CInt) -SDP_DERIVE_FOREIGN_UNBOXED(CUInt) -SDP_DERIVE_FOREIGN_UNBOXED(CLong) -SDP_DERIVE_FOREIGN_UNBOXED(CULong) -SDP_DERIVE_FOREIGN_UNBOXED(CLLong) -SDP_DERIVE_FOREIGN_UNBOXED(CULLong) -SDP_DERIVE_FOREIGN_UNBOXED(CIntPtr) -SDP_DERIVE_FOREIGN_UNBOXED(CUIntPtr) -SDP_DERIVE_FOREIGN_UNBOXED(CIntMax) -SDP_DERIVE_FOREIGN_UNBOXED(CUIntMax) -SDP_DERIVE_FOREIGN_UNBOXED(CPtrdiff) - -SDP_DERIVE_FOREIGN_UNBOXED(CTime) -SDP_DERIVE_FOREIGN_UNBOXED(CClock) -SDP_DERIVE_FOREIGN_UNBOXED(CUSeconds) -SDP_DERIVE_FOREIGN_UNBOXED(CSUSeconds) - -SDP_DERIVE_FOREIGN_UNBOXED(CSize) - -#if MIN_VERSION_base(4,10,0) --- | @since base-4.10.0.0 -SDP_DERIVE_FOREIGN_UNBOXED(CBool) -#endif - -SDP_DERIVE_FOREIGN_UNBOXED(CFloat) -SDP_DERIVE_FOREIGN_UNBOXED(CDouble) -SDP_DERIVE_FOREIGN_UNBOXED(CSigAtomic) - -#undef SDP_DERIVE_FOREIGN_UNBOXED - --------------------------------------------------------------------------------- - -{- Other instances. -} - -instance Unboxed () - where - {-# INLINE sizeof #-} - sizeof _ _ = 0 - - {-# INLINE (!#) #-} - (!>#) = \ _ _ s# -> (# s#, () #) - (!#) = \ _ _ -> () - - newUnboxed _ _ = newByteArray# 0# - newUnboxed' _ _ = newByteArray# 0# - - writeByteArray# _ _ = \ _ s# -> s# - fillByteArray# _ _ = \ _ s# -> s# - -instance Unboxed Bool - where - {-# INLINE sizeof #-} - sizeof _ c = d == 0 ? n $ n + 1 where (n, d) = max 0 c `divMod` 8 - - {-# INLINE (!#) #-} - bytes# !# i# = isTrue# ((indexWordArray# bytes# (bool_index i#) `and#` bool_bit i#) `neWord#` int2Word# 0#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readWordArray# mbytes# (bool_index i#) s1# of - (# s2#, e# #) -> (# s2#, isTrue# ((e# `and#` bool_bit i#) `neWord#` int2Word# 0#) #) - - writeByteArray# mbytes# n# e = \ s1# -> case readWordArray# mbytes# i# s1# of - (# s2#, old_byte# #) -> writeWordArray# mbytes# i# (bitWrite old_byte#) s2# - where - bitWrite old_byte# = if e then old_byte# `or#` bool_bit n# else old_byte# `and#` bool_not_bit n# - i# = bool_index n# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# False s2# of - s3# -> (# s3#, mbytes# #) - - fillByteArray# mbytes# n# e = - setByteArray# mbytes# 0# (bool_scale n#) (if e then 0xff# else 0#) - - copyUnboxed# e bytes# o1# mbytes# o2# c# = isTrue# (c# <# 1#) ? (\ s1# -> s1#) $ - \ s1# -> case writeByteArray# mbytes# o2# ((bytes# !# o1#) `asTypeOf` e) s1# of - s2# -> copyUnboxed# e bytes# (o1# +# 1#) mbytes# (o2# +# 1#) (c# -# 1#) s2# - - copyUnboxedM# e src# o1# mbytes# o2# n# = \ s1# -> case (!>#) src# o1# s1# of - (# s2#, x #) -> case writeByteArray# mbytes# o2# (x `asTypeOf` e) s2# of - s3# -> copyUnboxedM# e src# (o1# +# 1#) mbytes# (o2# +# 1#) (n# -# 1#) s3# - - hashUnboxedWith e len# off# bytes# - | isTrue# (len# <# 1#) = \ salt# -> salt# - | isTrue# (off# <# 0#) = hashUnboxedWith e len# 0# bytes# - | isTrue# (bit_off# ==# 0#) = go0 byte_cnt# byte_off# - | True = goo byte_cnt# (byte_off# +# 1#) (indexWord8Array# bytes# byte_off#) - where - go0 0# _ salt# = salt# - go0 1# o# salt# = hash# salt# (indexWord8Array# bytes# o# `and#` mask#) - go0 n# o# salt# = go0 (n# -# 1#) (o# +# 1#) (salt# `hash#` indexWord8Array# bytes# o#) - - goo 0# _ _ salt# = salt# - goo 1# _ temp# salt# = hash# salt# (shiftRL# temp# bit_off# `and#` mask#) - goo n# o# temp# salt# = goo (n# -# 1#) (o# +# 1#) byte# (hash# salt# curr#) - where - curr# = shiftRL# temp# bit_off# `or#` shiftL# byte# (8# -# bit_off#) - byte# = indexWord8Array# bytes# o# - - hash# = \ s# v# -> word2Int# (int2Word# (s# *# 16777619#) `xor#` v#) - mask# = int2Word# 0xff# `shiftRL#` bit_rest# - - !(I# byte_off#, I# bit_off#) = I# off# `divMod` 8 - !(I# bit_len#) = I# len# `mod` 8 - - bit_rest# = if isTrue# (bit_len# ==# 0#) then 0# else 8# -# bit_len# - byte_cnt# = sizeof# e len# - -instance Unboxed Char - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * 4 - - {-# INLINE (!#) #-} - bytes# !# i# = C# (indexWideCharArray# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readWideCharArray# mbytes# i# s1# of - (# s2#, c# #) -> (# s2#, C# c# #) - - writeByteArray# mbytes# n# (C# e#) = writeWideCharArray# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# '\0' s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Float - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * SIZEOF_HSFLOAT - - {-# INLINE (!#) #-} - bytes# !# i# = F# (indexFloatArray# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readFloatArray# mbytes# i# s1# of - (# s2#, f# #) -> (# s2#, F# f# #) - - writeByteArray# mbytes# n# (F# e#) = writeFloatArray# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Float) s2# of - s3# -> (# s3#, mbytes# #) - -instance Unboxed Double - where - {-# INLINE sizeof #-} - sizeof _ n = max 0 n * SIZEOF_HSDOUBLE - - {-# INLINE (!#) #-} - bytes# !# i# = D# (indexDoubleArray# bytes# i#) - - {-# INLINE (!>#) #-} - mbytes# !># i# = \ s1# -> case readDoubleArray# mbytes# i# s1# of - (# s2#, d# #) -> (# s2#, D# d# #) - - writeByteArray# mbytes# n# (D# e#) = writeDoubleArray# mbytes# n# e# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: Double) s2# of - s3# -> (# s3#, mbytes# #) - -instance (Unboxed a, Integral a) => Unboxed (Ratio a) - where - sizeof e n = 2 * psizeof e n - - bytes# !# i# = bytes# !# i2# :% (bytes# !# (i2# +# 1#)) where i2# = 2# *# i# - - mbytes# !># i# = let i2# = 2# *# i# in \ s1# -> case (!>#) mbytes# i2# s1# of - (# s2#, n #) -> case (!>#) mbytes# (i2# +# 1#) s2# of - (# s3#, d #) -> (# s3#, n :% d #) - - writeByteArray# mbytes# i# (n :% d) = let i2# = 2# *# i# in - \ s1# -> case writeByteArray# mbytes# i2# n s1# of - s2# -> writeByteArray# mbytes# (i2# +# 1#) d s2# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# ((0 :% 0) `asTypeOf` e) s2# of - s3# -> (# s3#, mbytes# #) - -instance (Unboxed a, Num a) => Unboxed (Complex a) - where - sizeof e n = 2 * psizeof e n - - bytes# !# i# = bytes# !# i2# :+ (bytes# !# (i2# +# 1#)) where i2# = 2# *# i# - - mbytes# !># i# = let i2# = 2# *# i# in \ s1# -> case (!>#) mbytes# i2# s1# of - (# s2#, n #) -> case (!>#) mbytes# (i2# +# 1#) s2# of - (# s3#, d #) -> (# s3#, n :+ d #) - - writeByteArray# mbytes# i# (n :+ d) = let i2# = 2# *# i# in - \ s1# -> case writeByteArray# mbytes# i2# n s1# of - s2# -> writeByteArray# mbytes# (i2# +# 1#) d s2# - - newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of - (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# ((0 :+ 0) `asTypeOf` e) s2# of - s3# -> (# s3#, mbytes# #) - --------------------------------------------------------------------------------- - --- Just a wrapper, used once to lift ByteArray# from ST. -data Wrap = Wrap { unwrap :: ByteArray# } - -{- | - @cloneUnboxed\# e o\# c\#@ creates byte array with @c\#@ elements of same type - as @e@ beginning from @o\#@ elements. --} -cloneUnboxed# :: (Unboxed e) => e -> ByteArray# -> Int# -> Int# -> ByteArray# -cloneUnboxed# e bytes# o# c# = unwrap $ runST $ ST $ - \ s1# -> case newUnboxed e c# s1# of - (# s2#, mbytes# #) -> case copyUnboxed# e bytes# o# mbytes# 0# c# s2# of - s3# -> case unsafeFreezeByteArray# mbytes# s3# of - (# s4#, bytes'# #) -> (# s4#, (Wrap bytes'#) #) - --- | @(* -> *)@ kind proxy version if 'cloneUnboxed#'. -cloneUnboxed1# :: (Unboxed e) => proxy e -> ByteArray# -> Int# -> Int# -> ByteArray# -cloneUnboxed1# proxy = cloneUnboxed# (fromProxy proxy) - --------------------------------------------------------------------------------- - -{-# INLINE bool_scale #-} -bool_scale :: Int# -> Int# -bool_scale n# = (n# +# 7#) `uncheckedIShiftRA#` 3# - -{-# INLINE bool_bit #-} -bool_bit :: Int# -> Word# -bool_bit n# = case (SIZEOF_HSWORD * 8 - 1) of !(W# mask#) -> int2Word# 1# `uncheckedShiftL#` word2Int# (int2Word# n# `and#` mask#) - -{-# INLINE bool_not_bit #-} -bool_not_bit :: Int# -> Word# -bool_not_bit n# = case maxBound of !(W# mb#) -> bool_bit n# `xor#` mb# +{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators #-} + +{- | + Module : SDP.Unboxed + Copyright : (c) Andrey Mulik 2019-2021 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Unboxed" provide service class 'Unboxed', that needed for + "SDP.Prim.SBytes"-based structures. +-} +module SDP.Unboxed +( + -- * Unboxed + Unboxed (..), cloneUnboxed#, cloneUnboxedM#, thawUnboxed#, freezeUnboxed#, + + -- ** Kind @(Type -> Type)@ proxies + fromProxy, psizeof#, psizeof, pnewUnboxed, pcopyUnboxed, pcopyUnboxedM, + pcloneUnboxed, pcloneUnboxedM, pthawUnboxed, pfreezeUnboxed, + + -- ** Kind @(Type -> Type -> Type)@ proxies + fromProxy1, pnewUnboxed1, pcloneUnboxed1, pcopyUnboxed1, pcopyUnboxedM1, + cloneUnboxed1#, pcloneUnboxedM1, + + -- Wrap helper + Wrap (..), lzero#, single#, fromList#, fromFoldable#, fromListN#, + newLinear#, newLinearN#, fromFoldableM#, concat#, pconcat +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Nullable +import SDP.Finite +import SDP.Shape +import SDP.Ratio + +import GHC.Stable +import GHC.Base hiding ( (.), foldr ) +import GHC.Word +import GHC.Int +import GHC.Ptr +import GHC.ST + +import Data.Complex + +import Foreign.C.Types + +#include "MachDeps.h" + +default () + +-------------------------------------------------------------------------------- + +{- | + 'Unboxed' is a layer between untyped raw data and parameterized unboxed data + structures. Also it prevents direct interaction with primitives. +-} +class (Eq e) => Unboxed e + where + {-# MINIMAL (sizeof#|sizeof), (!#), (!>#), writeByteArray#, newUnboxed #-} + + {- | + @sizeof e n@ returns the length (in bytes) of primitive, where @n@ - count + of elements, @e@ - type parameter. + -} + {-# INLINE sizeof #-} + sizeof :: e -> Int -> Int + sizeof e (I# c#) = I# (sizeof# e c#) + + -- | 'sizeof#' is unboxed 'sizeof'. + {-# INLINE sizeof# #-} + sizeof# :: e -> Int# -> Int# + sizeof# e c# = case sizeof e (I# c#) of I# n# -> n# + + -- | Unsafe 'ByteArray#' reader with overloaded result type. + (!#) :: ByteArray# -> Int# -> e + + -- | Unsafe 'MutableByteArray#' reader with overloaded result type. + (!>#) :: MutableByteArray# s -> Int# -> State# s -> (# State# s, e #) + + -- | Unsafe 'MutableByteArray#' writer. + writeByteArray# :: MutableByteArray# s -> Int# -> e -> State# s -> State# s + + {-# INLINE fillByteArray# #-} + -- | Procedure for filling the array with the default value (like calloc). + fillByteArray# :: MutableByteArray# s -> Int# -> e -> State# s -> State# s + fillByteArray# mbytes# n# e = I# n# > 0 ? go (n# -# 1#) $ \ s1# -> s1# + where + go 0# s2# = writeByteArray# mbytes# 0# e s2# + go c# s2# = go (c# -# 1#) (writeByteArray# mbytes# c# e s2#) + + {- | + 'newUnboxed' creates new 'MutableByteArray#' of given count of elements. + First argument used as type variable. + -} + newUnboxed :: e -> Int# -> State# s -> (# State# s, MutableByteArray# s #) + + {-# INLINE newUnboxed' #-} + {- | + 'newUnboxed'' is version of 'newUnboxed', that use first argument as + initial value. May fail when trying to write 'error' or 'undefined'. + -} + newUnboxed' :: e -> Int# -> State# s -> (# State# s, MutableByteArray# s #) + newUnboxed' e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# e s2# of + s3# -> (# s3#, mbytes# #) + + {- | + @'copyUnboxed#' e bytes\# o1\# mbytes\# o2\# n\#@ unsafely writes elements + from @bytes\#@ to @mbytes\#@, where o1\# and o2\# - offsets (element + count), @n\#@ - count of elements to copy. + -} + copyUnboxed# :: e -> ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + copyUnboxed# e bytes# o1# mbytes# o2# n# = copyByteArray# bytes# (sizeof# e o1#) mbytes# (sizeof# e o2#) (sizeof# e n#) + + {- | + @'copyUnboxedM#' e msrc\# o1\# mbytes\# o2\# n\#@ unsafely writes elements + from @msrc\#@ to @mbytes\#@, where o1\# and o2\# - offsets (element + count), @n\#@ - count of elements to copy. + -} + copyUnboxedM# :: e -> MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + copyUnboxedM# e msrc# o1# mbytes# o2# n# = copyMutableByteArray# msrc# (sizeof# e o1#) mbytes# (sizeof# e o2#) (sizeof# e n#) + + {- | + @'hashUnboxedWith' e len# off# bytes# salt@ returns @bytes#@ @FNV-1@ hash, + where @off#@ and @len#@ is offset and length (in elements). + + Note: the standard definition of this function is written in Haskell using + low-level functions, but this implementation mayn't be as efficient as the + foreign procedure in the @hashable@ package. + -} + hashUnboxedWith :: e -> Int# -> Int# -> ByteArray# -> Int# -> Int# + hashUnboxedWith e len# off# bytes# = go (sizeof# e off#) (sizeof# e len#) + where + go _ 0# salt# = salt# + go o# n# salt# = go (o# +# 1#) (n# -# 1#) (word2Int# hash#) + where + prod# = int2Word# (salt# *# 16777619#) + elem# = indexWord8Array# bytes# o# + hash# = prod# `xor#` elem# + +-------------------------------------------------------------------------------- + +{- Unboxed helpers. -} + +{- | + @since 0.2 + @cloneUnboxed# e bytes# o# c#@ creates new @c#@-element length immutable slice + of @bytes#@ beginning from @o#@-th element. +-} +cloneUnboxed# :: (Unboxed e) => e -> ByteArray# -> Int# -> Int# -> ByteArray# +cloneUnboxed# e bytes# o# c# = unwrap $ runST $ ST $ + \ s1# -> case newUnboxed e c# s1# of + (# s2#, mbytes# #) -> case copyUnboxed# e bytes# o# mbytes# 0# c# s2# of + s3# -> case unsafeFreezeByteArray# mbytes# s3# of + (# s4#, bytes'# #) -> (# s4#, (Wrap bytes'#) #) + +{- | + @since 0.2.1 + @cloneUnboxedM# e mbytes# o# c#@ creates new @c#@-element length mutable slice + of @bytes#@ beginning from @o#@-th element. +-} +cloneUnboxedM# :: (Unboxed e) => e -> MutableByteArray# s -> Int# -> Int# -> + State# s -> (# State# s, MutableByteArray# s #) +cloneUnboxedM# e mbytes# o# n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, copy# #) -> case copyUnboxedM# e mbytes# o# copy# 0# n# s2# of + s3# -> (# s3#, copy# #) + +{- | + @since 0.2.1 + @'thawUnboxed#' e bytes# c#@ creates new @sizeof# e c#@ bytes length + 'MutableByteArray#' and copy @bytes#@ to it. +-} +thawUnboxed# :: (Unboxed e) => e -> ByteArray# -> Int# -> + State# s -> (# State# s, MutableByteArray# s #) +thawUnboxed# e bytes# c# = \ s1# -> case newByteArray# n# s1# of + (# s2#, mbytes# #) -> case copyByteArray# bytes# 0# mbytes# 0# n# s2# of + s3# -> (# s3#, mbytes# #) + where + n# = sizeof# e c# + +{- | + @since 0.2.1 + @'freezeUnboxed#' e mbytes# c#@ creates new @sizeof# e c#@ bytes length + 'ByteArray#' and copy @mbytes#@ to it. +-} +freezeUnboxed# :: (Unboxed e) => e -> MutableByteArray# s -> Int# -> + State# s -> (# State# s, ByteArray# #) +freezeUnboxed# e mbytes# n# = \ s1# -> case cloneUnboxedM# e mbytes# 0# n# s1# of + (# s2#, copy# #) -> unsafeFreezeByteArray# copy# s2# + +-------------------------------------------------------------------------------- + +{- Rank 1 Unboxed proxies. -} + +-- | Returns 'undefined' of suitable type. +fromProxy :: proxy e -> e +fromProxy = const undefined + +{- | + @since 0.2.1 + 'psizeof#' is proxy version of 'sizeof#'. +-} +psizeof# :: (Unboxed e) => proxy e -> Int# -> Int# +psizeof# = sizeof# . fromProxy + +{- | + @since 0.2 + 'psizeof' is proxy version of 'sizeof'. +-} +psizeof :: (Unboxed e) => proxy e -> Int -> Int +psizeof = sizeof . fromProxy + +{- | + @since 0.2 + Kind @(Type -> Type)@ proxy version of 'newUnboxed'. +-} +pnewUnboxed :: (Unboxed e) => proxy e -> Int# -> + State# s -> (# State# s, MutableByteArray# s #) +pnewUnboxed = newUnboxed . fromProxy + +{- | + @since 0.2 + Kind @(Type -> Type)@ proxy version if 'copyUnboxed#'. +-} +pcopyUnboxed :: (Unboxed e) => proxy e -> ByteArray# -> Int# -> + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +pcopyUnboxed = copyUnboxed# . fromProxy + +{- | + @since 0.2 + Kind @(Type -> Type)@ proxy version if 'copyUnboxedM#'. +-} +pcopyUnboxedM :: (Unboxed e) => proxy e -> MutableByteArray# s -> Int# -> + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +pcopyUnboxedM = copyUnboxedM# . fromProxy + +{- | + @since 0.2 + Kind @(Type -> Type)@ proxy version of 'cloneUnboxed#'. +-} +cloneUnboxed1# :: (Unboxed e) => proxy e -> ByteArray# -> Int# -> Int# -> ByteArray# +cloneUnboxed1# = cloneUnboxed# . fromProxy + +{- | + @since 0.2.1 + Same as @sdp-0.2@ 'cloneUnboxed1#'. Use only if you don't need @sdp-0.2@ + compatibility. +-} +pcloneUnboxed :: (Unboxed e) => proxy e -> ByteArray# -> Int# -> Int# -> ByteArray# +pcloneUnboxed = cloneUnboxed1# + +{- | + @since 0.2.1 + Kind @(Type -> Type)@ proxy version of 'cloneUnboxed#'. +-} +pcloneUnboxedM :: (Unboxed e) => proxy e -> MutableByteArray# s -> Int# -> Int# -> + State# s -> (# State# s, MutableByteArray# s #) +pcloneUnboxedM = cloneUnboxedM# . fromProxy + +{- | + @since 0.2.1 + Kind @(Type -> Type)@ proxy version of 'thawUnboxed#'. +-} +pthawUnboxed :: (Unboxed e) => proxy e -> ByteArray# -> Int# -> + State# s -> (# State# s, MutableByteArray# s #) +pthawUnboxed = thawUnboxed# . fromProxy + +{- | + @since 0.2.1 + Kind @(Type -> Type)@ proxy version of 'pfreezeUnboxed'. +-} +pfreezeUnboxed :: (Unboxed e) => proxy e -> MutableByteArray# s -> Int# -> + State# s -> (# State# s, ByteArray# #) +pfreezeUnboxed = freezeUnboxed# . fromProxy + +-------------------------------------------------------------------------------- + +{- (Type -> Type -> Type)-kind Unboxed proxies. -} + +-- | Returns 'undefined' of suitable type. +fromProxy1 :: m (proxy e) -> e +fromProxy1 = const undefined + +{- | + @since 0.2 + Kind @(Type -> Type -> Type)@ proxy version of 'newUnboxed'. +-} +pnewUnboxed1 :: (Unboxed e) => p (proxy e) -> Int# -> + State# s -> (# State# s, MutableByteArray# s #) +pnewUnboxed1 = newUnboxed . fromProxy1 + +{- | + @since 0.2 + Kind @(Type -> Type -> Type)@ proxy version of 'copyUnboxed#'. +-} +pcopyUnboxed1 :: (Unboxed e) => p (proxy e) -> ByteArray# -> Int# -> + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +pcopyUnboxed1 = copyUnboxed# . fromProxy1 + +{- | + @since 0.2.1 + Kind @(Type -> Type -> Type)@ proxy version of 'copyUnboxedM#'. +-} +pcopyUnboxedM1 :: (Unboxed e) => p (proxy e) -> MutableByteArray# s -> Int# -> + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +pcopyUnboxedM1 = copyUnboxedM# . fromProxy1 + +{- | + @since 0.2.1 + Kind @(Type -> Type -> Type)@ proxy version of 'cloneUnboxed#'. +-} +pcloneUnboxed1 :: (Unboxed e) => p (proxy e) -> ByteArray# -> Int# -> Int# -> ByteArray# +pcloneUnboxed1 = cloneUnboxed# . fromProxy1 + +{- | + @since 0.2.1 + Kind @(Type -> Type -> Type)@ proxy version of 'cloneUnboxed#'. +-} +pcloneUnboxedM1 :: (Unboxed e) => p (proxy e) -> MutableByteArray# s -> Int# -> Int# -> + State# s -> (# State# s, MutableByteArray# s #) +pcloneUnboxedM1 = cloneUnboxedM# . fromProxy1 + +-------------------------------------------------------------------------------- + +{- Numeric instances. -} + +instance Unboxed Int + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * SIZEOF_HSWORD + + {-# INLINE (!#) #-} + bytes# !# i# = I# (indexIntArray# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readIntArray# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, I# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (I# e#) = writeIntArray# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Int) + +instance Unboxed Int8 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n + + {-# INLINE (!#) #-} + bytes# !# i# = I8# (indexInt8Array# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readInt8Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, I8# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (I8# e#) = writeInt8Array# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Int8) + +instance Unboxed Int16 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 2 + + {-# INLINE (!#) #-} + bytes# !# i# = I16# (indexInt16Array# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readInt16Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, I16# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (I16# e#) = writeInt16Array# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Int16) + +instance Unboxed Int32 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 4 + + {-# INLINE (!#) #-} + bytes# !# i# = I32# (indexInt32Array# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readInt32Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, I32# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (I32# e#) = writeInt32Array# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Int32) + +instance Unboxed Int64 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 8 + + {-# INLINE (!#) #-} + bytes# !# i# = I64# (indexInt64Array# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readInt64Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, I64# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (I64# e#) = writeInt64Array# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Int64) + +instance Unboxed Word + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * SIZEOF_HSWORD + + {-# INLINE (!#) #-} + bytes# !# i# = W# (indexWordArray# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWordArray# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, W# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (W# e#) = writeWordArray# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Word) + +instance Unboxed Word8 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n + + {-# INLINE (!#) #-} + bytes# !# i# = W8# (indexWord8Array# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWord8Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, W8# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (W8# e#) = writeWord8Array# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Word8) + +instance Unboxed Word16 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 2 + + {-# INLINE (!#) #-} + bytes# !# i# = W16# (indexWord16Array# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWord16Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, W16# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (W16# e#) = writeWord16Array# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Word16) + +instance Unboxed Word32 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 4 + + {-# INLINE (!#) #-} + bytes# !# i# = W32# (indexWord32Array# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWord32Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, W32# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (W32# e#) = writeWord32Array# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Word32) + +instance Unboxed Word64 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 8 + + {-# INLINE (!#) #-} + bytes# !# i# = W64# (indexWord64Array# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWord64Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, W64# e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (W64# e#) = writeWord64Array# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Word64) + +instance Unboxed Float + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * SIZEOF_HSFLOAT + + {-# INLINE (!#) #-} + bytes# !# i# = F# (indexFloatArray# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readFloatArray# mbytes# i# s1# of + (# s2#, f# #) -> (# s2#, F# f# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (F# e#) = writeFloatArray# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Float) + +instance Unboxed Double + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * SIZEOF_HSDOUBLE + + {-# INLINE (!#) #-} + bytes# !# i# = D# (indexDoubleArray# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readDoubleArray# mbytes# i# s1# of + (# s2#, d# #) -> (# s2#, D# d# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (D# e#) = writeDoubleArray# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' (0 :: Double) + +instance (Unboxed a, Integral a) => Unboxed (Ratio a) + where + sizeof e n = 2 * psizeof e n + + bytes# !# i# = bytes# !# i2# :% (bytes# !# (i2# +# 1#)) where i2# = 2# *# i# + + mbytes# !># i# = let i2# = 2# *# i# in \ s1# -> case (!>#) mbytes# i2# s1# of + (# s2#, n #) -> case (!>#) mbytes# (i2# +# 1#) s2# of + (# s3#, d #) -> (# s3#, n :% d #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# i# (n :% d) = let i2# = 2# *# i# in + \ s1# -> case writeByteArray# mbytes# i2# n s1# of + s2# -> writeByteArray# mbytes# (i2# +# 1#) d s2# + + {-# INLINE newUnboxed #-} + newUnboxed e n# = pnewUnboxed e (2# *# n#) + +instance (Unboxed a, Num a) => Unboxed (Complex a) + where + sizeof e n = 2 * psizeof e n + + bytes# !# i# = bytes# !# i2# :+ (bytes# !# (i2# +# 1#)) where i2# = 2# *# i# + mbytes# !># i# = let i2# = 2# *# i# in \ s1# -> case (!>#) mbytes# i2# s1# of + (# s2#, n #) -> case (!>#) mbytes# (i2# +# 1#) s2# of + (# s3#, d #) -> (# s3#, n :+ d #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# i# (n :+ d) = let i2# = 2# *# i# in + \ s1# -> case writeByteArray# mbytes# i2# n s1# of + s2# -> writeByteArray# mbytes# (i2# +# 1#) d s2# + + {-# INLINE newUnboxed #-} + newUnboxed e n# = pnewUnboxed e (2# *# n#) + +-------------------------------------------------------------------------------- + +{- Pointer instances. -} + +instance Unboxed (Ptr a) + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * SIZEOF_HSWORD + + {-# INLINE (!#) #-} + bytes# !# i# = Ptr (indexAddrArray# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readAddrArray# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, Ptr e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (Ptr e) = writeAddrArray# mbytes# n# e + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' nullPtr + +instance Unboxed (FunPtr a) + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * SIZEOF_HSWORD + + {-# INLINE (!#) #-} + bytes# !# i# = FunPtr (indexAddrArray# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readAddrArray# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, FunPtr e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (FunPtr e) = writeAddrArray# mbytes# n# e + + {-# INLINE newUnboxed #-} + newUnboxed e = newUnboxed' (NULL `asTypeOf` e) + +instance Unboxed (StablePtr a) + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * SIZEOF_HSWORD + + {-# INLINE (!#) #-} + bytes# !# i# = StablePtr (indexStablePtrArray# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readStablePtrArray# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, StablePtr e# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (StablePtr e) = writeStablePtrArray# mbytes# n# e + + {-# INLINE newUnboxed #-} + newUnboxed e = newUnboxed' (NULL `asTypeOf` e) + +-------------------------------------------------------------------------------- + +{- Foreign C instances. -} + +#define deriving_instance_Unboxed(Type)\ +instance Unboxed Type where\ +{\ + sizeof e = sizeof (consSizeof Type e);\ + arr# !# i# = Type ( arr# !# i# );\ + marr# !># i# = \ s1# -> case (!>#) marr# i# s1# of {(# s2#, e #) -> (# s2#, Type e #)};\ + writeByteArray# marr# i# (Type e) = writeByteArray# marr# i# e;\ + fillByteArray# marr# i# (Type e) = fillByteArray# marr# i# e;\ + newUnboxed (Type e) = newUnboxed e;\ + newUnboxed' (Type e) = newUnboxed' e;\ +} + +deriving_instance_Unboxed(CChar) +deriving_instance_Unboxed(CSChar) +deriving_instance_Unboxed(CWchar) +deriving_instance_Unboxed(CShort) +deriving_instance_Unboxed(CUShort) + +deriving_instance_Unboxed(CInt) +deriving_instance_Unboxed(CUInt) +deriving_instance_Unboxed(CLong) +deriving_instance_Unboxed(CULong) +deriving_instance_Unboxed(CLLong) +deriving_instance_Unboxed(CULLong) +deriving_instance_Unboxed(CIntPtr) +deriving_instance_Unboxed(CUIntPtr) +deriving_instance_Unboxed(CIntMax) +deriving_instance_Unboxed(CUIntMax) +deriving_instance_Unboxed(CPtrdiff) + +deriving_instance_Unboxed(CTime) +deriving_instance_Unboxed(CClock) +deriving_instance_Unboxed(CUSeconds) +deriving_instance_Unboxed(CSUSeconds) + +deriving_instance_Unboxed(CSize) + +#if MIN_VERSION_base(4,10,0) +-- | @since base-4.10.0.0 +deriving_instance_Unboxed(CBool) +#endif + +deriving_instance_Unboxed(CFloat) +deriving_instance_Unboxed(CDouble) +deriving_instance_Unboxed(CSigAtomic) + +#undef deriving_instance_Unboxed + +-------------------------------------------------------------------------------- + +{- Other instances. -} + +instance Unboxed Bool + where + {-# INLINE sizeof #-} + sizeof _ c = d == 0 ? n $ n + 1 where (n, d) = max 0 c `divMod` 8 + + {-# INLINE (!#) #-} + bytes# !# i# = isTrue# ((indexWordArray# bytes# (bool_index i#) `and#` bool_bit i#) `neWord#` int2Word# 0#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWordArray# mbytes# (bool_index i#) s1# of + (# s2#, e# #) -> (# s2#, isTrue# ((e# `and#` bool_bit i#) `neWord#` int2Word# 0#) #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# e = \ s1# -> case readWordArray# mbytes# i# s1# of + (# s2#, old_byte# #) -> writeWordArray# mbytes# i# (bitWrite old_byte#) s2# + where + bitWrite old_byte# = if e then old_byte# `or#` bool_bit n# else old_byte# `and#` bool_not_bit n# + i# = bool_index n# + + {-# INLINE newUnboxed #-} + newUnboxed _ = newUnboxed' False + + fillByteArray# mbytes# n# e = + setByteArray# mbytes# 0# (bool_scale n#) (if e then 0xff# else 0#) + + copyUnboxed# e bytes# o1# mbytes# o2# c# = isTrue# (c# <# 1#) ? (\ s1# -> s1#) $ + \ s1# -> case writeByteArray# mbytes# o2# ((bytes# !# o1#) `asTypeOf` e) s1# of + s2# -> copyUnboxed# e bytes# (o1# +# 1#) mbytes# (o2# +# 1#) (c# -# 1#) s2# + + copyUnboxedM# e src# o1# mbytes# o2# n# = \ s1# -> case (!>#) src# o1# s1# of + (# s2#, x #) -> case writeByteArray# mbytes# o2# (x `asTypeOf` e) s2# of + s3# -> copyUnboxedM# e src# (o1# +# 1#) mbytes# (o2# +# 1#) (n# -# 1#) s3# + + hashUnboxedWith e len# off# bytes# + | isTrue# (len# <# 1#) = \ salt# -> salt# + | isTrue# (off# <# 0#) = hashUnboxedWith e len# 0# bytes# + | isTrue# (bit_off# ==# 0#) = go0 byte_cnt# byte_off# + | True = goo byte_cnt# (byte_off# +# 1#) (indexWord8Array# bytes# byte_off#) + where + go0 0# _ salt# = salt# + go0 1# o# salt# = hash# salt# (indexWord8Array# bytes# o# `and#` mask#) + go0 n# o# salt# = go0 (n# -# 1#) (o# +# 1#) (salt# `hash#` indexWord8Array# bytes# o#) + + goo 0# _ _ salt# = salt# + goo 1# _ temp# salt# = hash# salt# (shiftRL# temp# bit_off# `and#` mask#) + goo n# o# temp# salt# = goo (n# -# 1#) (o# +# 1#) byte# (hash# salt# curr#) + where + curr# = shiftRL# temp# bit_off# `or#` shiftL# byte# (8# -# bit_off#) + byte# = indexWord8Array# bytes# o# + + hash# = \ s# v# -> word2Int# (int2Word# (s# *# 16777619#) `xor#` v#) + mask# = int2Word# 0xff# `shiftRL#` bit_rest# + + !(I# byte_off#, I# bit_off#) = I# off# `divMod` 8 + !(I# bit_len#) = I# len# `mod` 8 + + bit_rest# = if isTrue# (bit_len# ==# 0#) then 0# else 8# -# bit_len# + byte_cnt# = sizeof# e len# + +instance Unboxed Char + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 4 + + {-# INLINE (!#) #-} + bytes# !# i# = C# (indexWideCharArray# bytes# i#) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWideCharArray# mbytes# i# s1# of + (# s2#, c# #) -> (# s2#, C# c# #) + + {-# INLINE writeByteArray# #-} + writeByteArray# mbytes# n# (C# e#) = writeWideCharArray# mbytes# n# e# + + {-# INLINE newUnboxed #-} + newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# '\0' s2# of + s3# -> (# s3#, mbytes# #) + +instance Unboxed E + where + {-# INLINE sizeof #-} + sizeof _ _ = 0 + + {-# INLINE (!#) #-} + (!>#) = \ _ _ s# -> (# s#, E #) + (!#) = \ _ _ -> E + + newUnboxed _ _ = newByteArray# 0# + newUnboxed' _ _ = newByteArray# 0# + + writeByteArray# _ _ = \ _ s# -> s# + fillByteArray# _ _ = \ _ s# -> s# + +instance (Unboxed e) => Unboxed (I1 e) + where + sizeof# = psizeof# + sizeof = psizeof + + bytes# !# i# = E :& (bytes# !# i#) + bytes# !># i# = \ s1# -> case (!>#) bytes# i# s1# of + (# s2#, e #) -> (# s2#, E :& e #) + + writeByteArray# bytes# n# (E :& e) = writeByteArray# bytes# n# e + fillByteArray# bytes# n# (E :& e) = fillByteArray# bytes# n# e + + newUnboxed' = \ (E :& i) -> newUnboxed i + newUnboxed = pnewUnboxed + +instance (Enum e, Shape e, Bounded e, Unboxed e, Shape (e' :& e), Unboxed (e' :& e)) => Unboxed (e' :& e :& e) + where + sizeof# e n# = psizeof# e (rank# e *# n#) + sizeof e n = psizeof e (rank e * n) + + bytes# !# i# = go undefined + where + go t = + let r# = rank# t; o# = i#*#r# +# i# + in ((bytes# !# o#) `asTypeOf` t) :& (bytes# !# (o# +# r#)) + + bytes# !># i# = go undefined + where + go t = let r# = rank# t; o# = i#*#r# +# i# in + \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, es #) -> case (!>#) bytes# (o# +# r#) s2# of + (# s3#, e #) -> (# s3#, (es `asTypeOf` t) :& e #) + + writeByteArray# bytes# i# (es :& e) = let r# = rank# es; o# = i#*#r# +# i# in + \ s1# -> case writeByteArray# bytes# o# es s1# of + s2# -> writeByteArray# bytes# (o# +# r#) e s2# + + newUnboxed e n# = pnewUnboxed e (rank# e *# n#) + +-------------------------------------------------------------------------------- + +{- Tuple instances. -} + +instance Unboxed () + where + {-# INLINE sizeof #-} + sizeof _ _ = 0 + + {-# INLINE (!#) #-} + (!>#) = \ _ _ s# -> (# s#, () #) + (!#) = \ _ _ -> () + + newUnboxed _ _ = newByteArray# 0# + newUnboxed' _ _ = newByteArray# 0# + + writeByteArray# _ _ = \ _ s# -> s# + fillByteArray# _ _ = \ _ s# -> s# + +instance (Unboxed e) => Unboxed (T2 e) + where + sizeof e2 n = psizeof e2 (2 * n) + sizeof# e2 n# = psizeof# e2 (2# *# n#) + + bytes# !# n# = let o# = 2# *# n# in (bytes# !# o#, bytes# !# (o#+#1#)) + bytes# !># n# = let o# = 2# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> (# s3#, (e1,e2) #) + + writeByteArray# mbytes# n# (e1,e2) = let o# = 2# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> writeByteArray# mbytes# (o# +# 1#) e2 s2# + + newUnboxed e n# = pnewUnboxed e (2# *# n#) + +instance (Unboxed e) => Unboxed (T3 e) + where + sizeof e2 n = psizeof e2 (3 * n) + sizeof# e2 n# = psizeof# e2 (3# *# n#) + + bytes# !# n# = + let o# = 3# *# n# + in (bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#)) + + bytes# !># n# = let o# = 3# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> (# s4#, (e1,e2,e3) #) + + writeByteArray# mbytes# n# (e1,e2,e3) = let o# = 3# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> writeByteArray# mbytes# (o# +# 2#) e3 s3# + + newUnboxed e n# = pnewUnboxed e (3# *# n#) + +instance (Unboxed e) => Unboxed (T4 e) + where + sizeof e2 n = psizeof e2 (4 * n) + sizeof# e2 n# = psizeof# e2 (4# *# n#) + + bytes# !# n# = + let o# = 4# *# n# + in (bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), bytes# !# (o#+#3#)) + + bytes# !># n# = let o# = 4# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> (# s5#, (e1,e2,e3,e4) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4) = let o# = 4# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> writeByteArray# mbytes# (o# +# 3#) e4 s4# + + newUnboxed e n# = pnewUnboxed e (4# *# n#) + +instance (Unboxed e) => Unboxed (T5 e) + where + sizeof e2 n = psizeof e2 (5 * n) + sizeof# e2 n# = psizeof# e2 (5# *# n#) + + bytes# !# n# = + let o# = 5# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#) + ) + + bytes# !># n# = let o# = 5# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> (# s6#, (e1,e2,e3,e4,e5) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5) = let o# = 5# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> writeByteArray# mbytes# (o# +# 4#) e5 s5# + + newUnboxed e n# = pnewUnboxed e (5# *# n#) + +instance (Unboxed e) => Unboxed (T6 e) + where + sizeof e2 n = psizeof e2 (6 * n) + sizeof# e2 n# = psizeof# e2 (6# *# n#) + + bytes# !# n# = + let o# = 6# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#) + ) + + bytes# !># n# = let o# = 6# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> (# s7#, (e1,e2,e3,e4,e5,e6) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6) = let o# = 6# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> writeByteArray# mbytes# (o# +# 5#) e6 s6# + + newUnboxed e n# = pnewUnboxed e (6# *# n#) + +instance (Unboxed e) => Unboxed (T7 e) + where + sizeof e2 n = psizeof e2 (7 * n) + sizeof# e2 n# = psizeof# e2 (7# *# n#) + + bytes# !# n# = + let o# = 7# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#), + bytes# !# (o#+#6#) + ) + + bytes# !># n# = let o# = 7# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> case (!>#) bytes# (o# +# 6#) s7# of + (# s8#, e7 #) -> (# s8#, (e1,e2,e3,e4,e5,e6,e7) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6,e7) = let o# = 7# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> case writeByteArray# mbytes# (o# +# 5#) e6 s6# of + s7# -> writeByteArray# mbytes# (o# +# 6#) e7 s7# + + newUnboxed e n# = pnewUnboxed e (7# *# n#) + +instance (Unboxed e) => Unboxed (T8 e) + where + sizeof e2 n = psizeof e2 (8 * n) + sizeof# e2 n# = psizeof# e2 (8# *# n#) + + bytes# !# n# = + let o# = 8# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#), + bytes# !# (o#+#6#), bytes# !# (o#+#7#) + ) + + bytes# !># n# = let o# = 8# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> case (!>#) bytes# (o# +# 6#) s7# of + (# s8#, e7 #) -> case (!>#) bytes# (o# +# 7#) s8# of + (# s9#, e8 #) -> (# s9#, (e1,e2,e3,e4,e5,e6,e7,e8) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6,e7,e8) = let o# = 8# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> case writeByteArray# mbytes# (o# +# 5#) e6 s6# of + s7# -> case writeByteArray# mbytes# (o# +# 6#) e7 s7# of + s8# -> writeByteArray# mbytes# (o# +# 7#) e8 s8# + + newUnboxed e n# = pnewUnboxed e (8# *# n#) + +instance (Unboxed e) => Unboxed (T9 e) + where + sizeof e2 n = psizeof e2 (9 * n) + sizeof# e2 n# = psizeof# e2 (9# *# n#) + + bytes# !# n# = + let o# = 9# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#), + bytes# !# (o#+#6#), bytes# !# (o#+#7#), bytes# !# (o#+#8#) + ) + + bytes# !># n# = let o# = 9# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> case (!>#) bytes# (o# +# 6#) s7# of + (# s8#, e7 #) -> case (!>#) bytes# (o# +# 7#) s8# of + (# s9#, e8 #) -> case (!>#) bytes# (o# +# 8#) s9# of + (# s10#, e9 #) -> (# s10#, (e1,e2,e3,e4,e5,e6,e7,e8,e9) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6,e7,e8,e9) = let o# = 9# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> case writeByteArray# mbytes# (o# +# 5#) e6 s6# of + s7# -> case writeByteArray# mbytes# (o# +# 6#) e7 s7# of + s8# -> case writeByteArray# mbytes# (o# +# 7#) e8 s8# of + s9# -> writeByteArray# mbytes# (o# +# 8#) e9 s9# + + newUnboxed e n# = pnewUnboxed e (9# *# n#) + +instance (Unboxed e) => Unboxed (T10 e) + where + sizeof e2 n = psizeof e2 (10 * n) + sizeof# e2 n# = psizeof# e2 (10# *# n#) + + bytes# !# n# = + let o# = 10# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#), + bytes# !# (o#+#6#), bytes# !# (o#+#7#), bytes# !# (o#+#8#), + bytes# !# (o#+#9#) + ) + + bytes# !># n# = let o# = 10# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> case (!>#) bytes# (o# +# 6#) s7# of + (# s8#, e7 #) -> case (!>#) bytes# (o# +# 7#) s8# of + (# s9#, e8 #) -> case (!>#) bytes# (o# +# 8#) s9# of + (# s10#, e9 #) -> case (!>#) bytes# (o# +# 9#) s10# of + (# s11#, e10 #) -> (# s11#, (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10) = let o# = 10# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> case writeByteArray# mbytes# (o# +# 5#) e6 s6# of + s7# -> case writeByteArray# mbytes# (o# +# 6#) e7 s7# of + s8# -> case writeByteArray# mbytes# (o# +# 7#) e8 s8# of + s9# -> case writeByteArray# mbytes# (o# +# 8#) e9 s9# of + s10# -> writeByteArray# mbytes# (o# +# 9#) e10 s10# + + newUnboxed e n# = pnewUnboxed e (10# *# n#) + +instance (Unboxed e) => Unboxed (T11 e) + where + sizeof e2 n = psizeof e2 (11 * n) + sizeof# e2 n# = psizeof# e2 (11# *# n#) + + bytes# !# n# = + let o# = 11# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#), + bytes# !# (o#+#6#), bytes# !# (o#+#7#), bytes# !# (o#+#8#), + bytes# !# (o#+#9#), bytes# !# (o#+#10#) + ) + + bytes# !># n# = let o# = 11# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> case (!>#) bytes# (o# +# 6#) s7# of + (# s8#, e7 #) -> case (!>#) bytes# (o# +# 7#) s8# of + (# s9#, e8 #) -> case (!>#) bytes# (o# +# 8#) s9# of + (# s10#, e9 #) -> case (!>#) bytes# (o# +# 9#) s10# of + (# s11#, e10 #) -> case (!>#) bytes# (o# +# 10#) s11# of + (# s12#, e11 #) -> (# s12#, (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11) = let o# = 11# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> case writeByteArray# mbytes# (o# +# 5#) e6 s6# of + s7# -> case writeByteArray# mbytes# (o# +# 6#) e7 s7# of + s8# -> case writeByteArray# mbytes# (o# +# 7#) e8 s8# of + s9# -> case writeByteArray# mbytes# (o# +# 8#) e9 s9# of + s10# -> case writeByteArray# mbytes# (o# +# 9#) e10 s10# of + s11# -> writeByteArray# mbytes# (o# +# 10#) e11 s11# + + newUnboxed e n# = pnewUnboxed e (11# *# n#) + +instance (Unboxed e) => Unboxed (T12 e) + where + sizeof e2 n = psizeof e2 (12 * n) + sizeof# e2 n# = psizeof# e2 (12# *# n#) + + bytes# !# n# = + let o# = 12# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#), + bytes# !# (o#+#6#), bytes# !# (o#+#7#), bytes# !# (o#+#8#), + bytes# !# (o#+#9#), bytes# !# (o#+#10#), bytes# !# (o#+#11#) + ) + + bytes# !># n# = let o# = 12# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> case (!>#) bytes# (o# +# 6#) s7# of + (# s8#, e7 #) -> case (!>#) bytes# (o# +# 7#) s8# of + (# s9#, e8 #) -> case (!>#) bytes# (o# +# 8#) s9# of + (# s10#, e9 #) -> case (!>#) bytes# (o# +# 9#) s10# of + (# s11#, e10 #) -> case (!>#) bytes# (o# +# 10#) s11# of + (# s12#, e11 #) -> case (!>#) bytes# (o# +# 11#) s12# of + (# s13#, e12 #) -> (# s13#, (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12) = let o# = 12# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> case writeByteArray# mbytes# (o# +# 5#) e6 s6# of + s7# -> case writeByteArray# mbytes# (o# +# 6#) e7 s7# of + s8# -> case writeByteArray# mbytes# (o# +# 7#) e8 s8# of + s9# -> case writeByteArray# mbytes# (o# +# 8#) e9 s9# of + s10# -> case writeByteArray# mbytes# (o# +# 9#) e10 s10# of + s11# -> case writeByteArray# mbytes# (o# +# 10#) e11 s11# of + s12# -> writeByteArray# mbytes# (o# +# 11#) e12 s12# + + newUnboxed e n# = pnewUnboxed e (12# *# n#) + +instance (Unboxed e) => Unboxed (T13 e) + where + sizeof e2 n = psizeof e2 (13 * n) + sizeof# e2 n# = psizeof# e2 (13# *# n#) + + bytes# !# n# = + let o# = 13# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#), + bytes# !# (o#+#6#), bytes# !# (o#+#7#), bytes# !# (o#+#8#), + bytes# !# (o#+#9#), bytes# !# (o#+#10#), bytes# !# (o#+#11#), + bytes# !# (o#+#12#) + ) + + bytes# !># n# = let o# = 13# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> case (!>#) bytes# (o# +# 6#) s7# of + (# s8#, e7 #) -> case (!>#) bytes# (o# +# 7#) s8# of + (# s9#, e8 #) -> case (!>#) bytes# (o# +# 8#) s9# of + (# s10#, e9 #) -> case (!>#) bytes# (o# +# 9#) s10# of + (# s11#, e10 #) -> case (!>#) bytes# (o# +# 10#) s11# of + (# s12#, e11 #) -> case (!>#) bytes# (o# +# 11#) s12# of + (# s13#, e12 #) -> case (!>#) bytes# (o# +# 12#) s13# of + (# s14#, e13 #) -> (# s14#, (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12,e13) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12,e13) = let o# = 13# *# n# in + \ s1# -> case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> case writeByteArray# mbytes# (o# +# 5#) e6 s6# of + s7# -> case writeByteArray# mbytes# (o# +# 6#) e7 s7# of + s8# -> case writeByteArray# mbytes# (o# +# 7#) e8 s8# of + s9# -> case writeByteArray# mbytes# (o# +# 8#) e9 s9# of + s10# -> case writeByteArray# mbytes# (o# +# 9#) e10 s10# of + s11# -> case writeByteArray# mbytes# (o# +# 10#) e11 s11# of + s12# -> case writeByteArray# mbytes# (o# +# 11#) e12 s12# of + s13# -> writeByteArray# mbytes# (o# +# 12#) e13 s13# + + newUnboxed e n# = pnewUnboxed e (13# *# n#) + +instance (Unboxed e) => Unboxed (T14 e) + where + sizeof e2 n = psizeof e2 (14 * n) + sizeof# e2 n# = psizeof# e2 (14# *# n#) + + bytes# !# n# = + let o# = 14# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#), + bytes# !# (o#+#6#), bytes# !# (o#+#7#), bytes# !# (o#+#8#), + bytes# !# (o#+#9#), bytes# !# (o#+#10#), bytes# !# (o#+#11#), + bytes# !# (o#+#12#), bytes# !# (o#+#13#) + ) + + bytes# !># n# = let o# = 14# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> case (!>#) bytes# (o# +# 6#) s7# of + (# s8#, e7 #) -> case (!>#) bytes# (o# +# 7#) s8# of + (# s9#, e8 #) -> case (!>#) bytes# (o# +# 8#) s9# of + (# s10#, e9 #) -> case (!>#) bytes# (o# +# 9#) s10# of + (# s11#, e10 #) -> case (!>#) bytes# (o# +# 10#) s11# of + (# s12#, e11 #) -> case (!>#) bytes# (o# +# 11#) s12# of + (# s13#, e12 #) -> case (!>#) bytes# (o# +# 12#) s13# of + (# s14#, e13 #) -> case (!>#) bytes# (o# +# 13#) s14# of + (# s15#, e14 #) -> (# s15#, (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12,e13,e14) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12,e13,e14) = + \ s1# -> let o# = 14# *# n# in case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> case writeByteArray# mbytes# (o# +# 5#) e6 s6# of + s7# -> case writeByteArray# mbytes# (o# +# 6#) e7 s7# of + s8# -> case writeByteArray# mbytes# (o# +# 7#) e8 s8# of + s9# -> case writeByteArray# mbytes# (o# +# 8#) e9 s9# of + s10# -> case writeByteArray# mbytes# (o# +# 9#) e10 s10# of + s11# -> case writeByteArray# mbytes# (o# +# 10#) e11 s11# of + s12# -> case writeByteArray# mbytes# (o# +# 11#) e12 s12# of + s13# -> case writeByteArray# mbytes# (o# +# 12#) e13 s13# of + s14# -> writeByteArray# mbytes# (o# +# 13#) e14 s14# + + newUnboxed e n# = pnewUnboxed e (14# *# n#) + +instance (Unboxed e) => Unboxed (T15 e) + where + sizeof e2 n = psizeof e2 (15 * n) + sizeof# e2 n# = psizeof# e2 (15# *# n#) + + bytes# !# n# = + let o# = 15# *# n# + in + ( + bytes# !# o#, bytes# !# (o#+#1#), bytes# !# (o#+#2#), + bytes# !# (o#+#3#), bytes# !# (o#+#4#), bytes# !# (o#+#5#), + bytes# !# (o#+#6#), bytes# !# (o#+#7#), bytes# !# (o#+#8#), + bytes# !# (o#+#9#), bytes# !# (o#+#10#), bytes# !# (o#+#11#), + bytes# !# (o#+#12#), bytes# !# (o#+#13#), bytes# !# (o#+#14#) + ) + + bytes# !># n# = let o# = 15# *# n# in \ s1# -> case (!>#) bytes# o# s1# of + (# s2#, e1 #) -> case (!>#) bytes# (o# +# 1#) s2# of + (# s3#, e2 #) -> case (!>#) bytes# (o# +# 2#) s3# of + (# s4#, e3 #) -> case (!>#) bytes# (o# +# 3#) s4# of + (# s5#, e4 #) -> case (!>#) bytes# (o# +# 4#) s5# of + (# s6#, e5 #) -> case (!>#) bytes# (o# +# 5#) s6# of + (# s7#, e6 #) -> case (!>#) bytes# (o# +# 6#) s7# of + (# s8#, e7 #) -> case (!>#) bytes# (o# +# 7#) s8# of + (# s9#, e8 #) -> case (!>#) bytes# (o# +# 8#) s9# of + (# s10#, e9 #) -> case (!>#) bytes# (o# +# 9#) s10# of + (# s11#, e10 #) -> case (!>#) bytes# (o# +# 10#) s11# of + (# s12#, e11 #) -> case (!>#) bytes# (o# +# 11#) s12# of + (# s13#, e12 #) -> case (!>#) bytes# (o# +# 12#) s13# of + (# s14#, e13 #) -> case (!>#) bytes# (o# +# 13#) s14# of + (# s15#, e14 #) -> case (!>#) bytes# (o# +# 14#) s15# of + (# s16#, e15 #) -> (# s16#, (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12,e13,e14,e15) #) + + writeByteArray# mbytes# n# (e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12,e13,e14,e15) = + \ s1# -> let o# = 15# *# n# in case writeByteArray# mbytes# o# e1 s1# of + s2# -> case writeByteArray# mbytes# (o# +# 1#) e2 s2# of + s3# -> case writeByteArray# mbytes# (o# +# 2#) e3 s3# of + s4# -> case writeByteArray# mbytes# (o# +# 3#) e4 s4# of + s5# -> case writeByteArray# mbytes# (o# +# 4#) e5 s5# of + s6# -> case writeByteArray# mbytes# (o# +# 5#) e6 s6# of + s7# -> case writeByteArray# mbytes# (o# +# 6#) e7 s7# of + s8# -> case writeByteArray# mbytes# (o# +# 7#) e8 s8# of + s9# -> case writeByteArray# mbytes# (o# +# 8#) e9 s9# of + s10# -> case writeByteArray# mbytes# (o# +# 9#) e10 s10# of + s11# -> case writeByteArray# mbytes# (o# +# 10#) e11 s11# of + s12# -> case writeByteArray# mbytes# (o# +# 11#) e12 s12# of + s13# -> case writeByteArray# mbytes# (o# +# 12#) e13 s13# of + s14# -> case writeByteArray# mbytes# (o# +# 13#) e14 s14# of + s15# -> writeByteArray# mbytes# (o# +# 14#) e15 s15# + + newUnboxed e n# = pnewUnboxed e (15# *# n#) + +-------------------------------------------------------------------------------- + +-- | 'ByteArray#' wrapper. +data Wrap = Wrap {unwrap :: ByteArray#} + +{- | + @since 0.2.1 + Wrapped empty 'ByteArray#'. +-} +lzero# :: Wrap +lzero# = runST $ ST $ \ s1# -> case newByteArray# 0# s1# of + (# s2#, marr# #) -> case unsafeFreezeByteArray# marr# s2# of + (# s3#, arr# #) -> (# s3#, Wrap arr# #) + +{- | + @since 0.2.1 + 'ByteArray#' singleton. +-} +single# :: (Unboxed e) => e -> ByteArray# +single# e = unwrap $ runST $ ST $ \ s1# -> case newUnboxed' e 1# s1# of + (# s2#, marr# #) -> case unsafeFreezeByteArray# marr# s2# of + (# s3#, arr# #) -> (# s3#, Wrap arr# #) + +{- | + @since 0.2.1 + Create immutable 'Unboxed' array from given list. +-} +fromList# :: (Unboxed e) => [e] -> ByteArray# +fromList# es = let !(I# n#) = length es in fromListN# n# es + +{- | + @since 0.2.1 + Create immutable 'Unboxed' array from 'Foldable' stream. +-} +fromFoldable# :: (Foldable f, Unboxed e) => f e -> (# Int, ByteArray# #) +fromFoldable# es = unpack' $ runST $ ST $ \ s1# -> case fromFoldableM# es s1# of + (# s2#, n, marr# #) -> case unsafeFreezeByteArray# marr# s2# of + (# s3#, arr# #) -> (# s3#, (n, Wrap arr#) #) + where + unpack' (i, Wrap arr#) = (# i, arr# #) + +{- | + @since 0.2.1 + Create immutable 'Unboxed' array from known size list. +-} +fromListN# :: (Unboxed e) => Int# -> [e] -> ByteArray# +fromListN# n# es = unwrap $ runST $ ST $ \ s1# -> case newLinearN# n# es s1# of + (# s2#, marr# #) -> case unsafeFreezeByteArray# marr# s2# of + (# s3#, arr# #) -> (# s3#, Wrap arr# #) + +{- | + @since 0.2.1 + Create mutable 'Unboxed' array from given list. +-} +newLinear# :: (Unboxed e) => [e] -> State# s -> + (# State# s, MutableByteArray# s #) +newLinear# es = let !(I# n#) = length es in newLinearN# n# es + +{- | + @since 0.2.1 + Create mutable 'Unboxed' array from known size list. +-} +newLinearN# :: (Unboxed e) => Int# -> [e] -> State# s -> + (# State# s, MutableByteArray# s #) +newLinearN# c# es = \ s1# -> case pnewUnboxed es n# s1# of + (# s2#, marr# #) -> + let + go y r = \ i# s4# -> case writeByteArray# marr# i# y s4# of + s5# -> if isTrue# (i# ==# n# -# 1#) then s5# else r (i# +# 1#) s5# + in case if n == 0 then s2# else foldr go (\ _ s# -> s#) es 0# s2# of + s3# -> (# s3#, marr# #) + where + !n@(I# n#) = max 0 (I# c#) + +{- | + @since 0.2.1 + Create mutable 'Unboxed' array from 'Foldable' stream. +-} +fromFoldableM# :: (Foldable f, Unboxed e) => f e -> State# s -> + (# State# s, Int, MutableByteArray# s #) +fromFoldableM# es = \ s1# -> case pnewUnboxed es n# s1# of + (# s2#, marr# #) -> + let + go y r = \ i# s4# -> case writeByteArray# marr# i# y s4# of + s5# -> if isTrue# (i# ==# n# -# 1#) then s5# else r (i# +# 1#) s5# + in case if n == 0 then s2# else foldr go (\ _ s# -> s#) es 0# s2# of + s3# -> (# s3#, n, marr# #) + where + !n@(I# n#) = length es + +{- | + @since 0.2.1 + Concatenation of two 'Unboxed' arrays. +-} +concat# :: (Unboxed e) => e -> + ByteArray# -> Int# -> Int# -> + ByteArray# -> Int# -> Int# -> State# s -> + (# State# s, Int#, MutableByteArray# s #) +concat# e arr1# n1# o1# arr2# n2# o2# = \ s1# -> case newUnboxed e n# s1# of + (# s2#, marr# #) -> case copyUnboxed# e arr1# o1# marr# 0# n1# s2# of + s3# -> case copyUnboxed# e arr2# o2# marr# n1# n2# s3# of + s4# -> (# s4#, n#, marr# #) + where + n# = n1# +# n2# + +-- | Proxy concatenation of two byte arrays representing 'Unboxed' structures. +pconcat :: (Unboxed e) => proxy e -> + ByteArray# -> Int# -> Int# -> ByteArray# -> Int# -> Int# -> + State# s -> (# State# s, Int#, MutableByteArray# s #) +pconcat = concat# . fromProxy + +-------------------------------------------------------------------------------- + +rank# :: (Shape i) => i -> Int# +rank# i = case rank i of I# r# -> r# + +{-# INLINE bool_scale #-} +bool_scale :: Int# -> Int# +bool_scale n# = (n# +# 7#) `uncheckedIShiftRA#` 3# + +{-# INLINE bool_bit #-} +bool_bit :: Int# -> Word# +bool_bit n# = case (SIZEOF_HSWORD * 8 - 1) of + W# mask# -> int2Word# 1# `uncheckedShiftL#` word2Int# (int2Word# n# `and#` mask#) + +{-# INLINE bool_not_bit #-} +bool_not_bit :: Int# -> Word# +bool_not_bit n# = case maxBound of W# mb# -> bool_bit n# `xor#` mb# {-# INLINE bool_index #-} bool_index :: Int# -> Int# diff --git a/src/SDP/Unrolled.hs b/src/SDP/Unrolled.hs --- a/src/SDP/Unrolled.hs +++ b/src/SDP/Unrolled.hs @@ -7,7 +7,8 @@ Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.Unrolled" provides 'Unrolled' - lazy boxed unrolled linked list. + "SDP.Unrolled" provides 'Unrolled' - immutable lazy boxed bordered unrolled + linked list. -} module SDP.Unrolled ( @@ -39,7 +40,6 @@ -- | 'Unrolled' is bordered unrolled linked list. type Unrolled = AnyBorder Unlist - diff --git a/src/SDP/Unrolled/IO.hs b/src/SDP/Unrolled/IO.hs --- a/src/SDP/Unrolled/IO.hs +++ b/src/SDP/Unrolled/IO.hs @@ -7,8 +7,8 @@ Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.Unrolled.IO" provides 'IOUnrolled' - mutable lazy boxed unrolled linked - list type. + "SDP.Unrolled.IO" provides 'IOUnrolled' - mutable lazy boxed bordered + unrolled linked list type. -} module SDP.Unrolled.IO ( diff --git a/src/SDP/Unrolled/ST.hs b/src/SDP/Unrolled/ST.hs --- a/src/SDP/Unrolled/ST.hs +++ b/src/SDP/Unrolled/ST.hs @@ -7,8 +7,8 @@ Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.Unrolled.ST" provides 'STUnrolled' - mutable boxed lazy unrolled linked - list. + "SDP.Unrolled.ST" provides 'STUnrolled' - mutable boxed lazy bordered + unrolled linked list. -} module SDP.Unrolled.ST ( diff --git a/src/SDP/Unrolled/STUnlist.hs b/src/SDP/Unrolled/STUnlist.hs --- a/src/SDP/Unrolled/STUnlist.hs +++ b/src/SDP/Unrolled/STUnlist.hs @@ -7,8 +7,8 @@ Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.Unrolled.STUnlist" provides 'STUnlist' - mutable boxed lazy unrolled - linked list. + "SDP.Unrolled.STUnlist" provides 'STUnlist' - mutable boxed lazy bordered + unrolled linked list. -} module SDP.Unrolled.STUnlist ( diff --git a/src/SDP/Unrolled/Unlist.hs b/src/SDP/Unrolled/Unlist.hs --- a/src/SDP/Unrolled/Unlist.hs +++ b/src/SDP/Unrolled/Unlist.hs @@ -7,7 +7,8 @@ Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.Unrolled.Unlist" provides 'Unlist' - lazy boxed unrolled linked list. + "SDP.Unrolled.Unlist" provides 'Unlist' - immutable lazy boxed unrolled + linked list. -} module SDP.Unrolled.Unlist ( @@ -90,8 +91,7 @@ instance Sort (Unlist e) e where sortBy cmp es = runST $ do es' <- thaw es; timSortBy cmp es'; done es' - - sortedBy f = go . toChunks + sortedBy f = go . toChunks where go (x1 : x2 : xs) = sortedBy f x1 && last x1 `f` head x2 && go (x2 : xs) go [x1] = sortedBy f x1 diff --git a/src/SDP/Zip.hs b/src/SDP/Zip.hs --- a/src/SDP/Zip.hs +++ b/src/SDP/Zip.hs @@ -2,12 +2,12 @@ {- | Module : SDP.Zip - Copyright : (c) Andrey Mulik 2019 + Copyright : (c) Andrey Mulik 2019-2021 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : portable - "SDP.Zip" provides 'Zip' - class of 'Control.Applicative.ZipList"-like + "SDP.Zip" provides 'Zip' - class of "Control.Applicative.ZipList"-like structures. -} module SDP.Zip ( Zip (..) ) where @@ -19,12 +19,12 @@ -------------------------------------------------------------------------------- --- | Zip is generalization of ZipList applicative semantics (but without pure). +-- | Zip is generalization of ZipList applicative semantics (but without 'pure'). class (Functor z) => Zip z where {-# MINIMAL (zap | zipWith), all2, any2 #-} - -- | ZipList-like '<*>' + -- | ZipList-like @('<*>')@. zap :: z (a -> b) -> z a -> z b zap = zipWith ($) diff --git a/src/SDP/ZipM.hs b/src/SDP/ZipM.hs new file mode 100644 --- /dev/null +++ b/src/SDP/ZipM.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE Safe, MultiParamTypeClasses, FunctionalDependencies #-} + +{- | + Module : SDP.ZipM + Copyright : (c) Andrey Mulik 2021 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.ZipM" provides 'ZipM' - class of monadic zips. +-} +module SDP.ZipM +( + -- * Export + module SDP.Zip, + + -- * ZipM + ZipM (..) +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Zip + +default () + +-------------------------------------------------------------------------------- + +-- | 'ZipM' is monadic version of 'SDP.Zip.Zip'. +class (Monad m) => ZipM m z | z -> m + where + {-# MINIMAL zipWithM #-} + + -- | Monadic 'zip'. + zipM :: z a -> z b -> m (z (a, b)) + zipM = mzipWith (,) + + -- | Monadic 'zip3'. + zipM3 :: z a -> z b -> z c -> m (z (a, b, c)) + zipM3 = mzipWith3 (,,) + + -- | Monadic 'zip4'. + zipM4 :: z a -> z b -> z c -> z d -> m (z (a, b, c, d)) + zipM4 = mzipWith4 (,,,) + + -- | Monadic 'zip5'. + zipM5 :: z a -> z b -> z c -> z d -> z e -> m (z (a, b, c, d, e)) + zipM5 = mzipWith5 (,,,,) + + -- | Monadic 'zip6'. + zipM6 :: z a -> z b -> z c -> z d -> z e -> z f -> m (z (a, b, c, d, e, f)) + zipM6 = mzipWith6 (,,,,,) + + -- | Pure to monadic lifted 'zipWith'. + mzipWith :: (a -> b -> r) -> z a -> z b -> m (z r) + mzipWith g = zipWithM (\ a b -> return (g a b)) + + -- | Pure to monadic lifted 'zipWith3'. + mzipWith3 :: (a -> b -> c -> r) -> z a -> z b -> z c -> m (z r) + mzipWith3 g = zipWithM3 (\ a b c -> return (g a b c)) + + -- | Pure to monadic lifted 'zipWith4'. + mzipWith4 :: (a -> b -> c -> d -> r) -> z a -> z b -> z c -> z d -> m (z r) + mzipWith4 g = zipWithM4 (\ a b c d -> return (g a b c d)) + + -- | Pure to monadic lifted 'zipWith5'. + mzipWith5 :: (a -> b -> c -> d -> e -> r) -> z a -> z b -> z c -> z d -> z e -> m (z r) + mzipWith5 g = zipWithM5 (\ a b c d e -> return (g a b c d e)) + + -- | Pure to monadic lifted 'zipWith6'. + mzipWith6 :: (a -> b -> c -> d -> e -> f -> r) -> z a -> z b -> z c -> z d -> z e -> z f -> m (z r) + mzipWith6 g = zipWithM6 (\ a b c d e f -> return (g a b c d e f)) + + -- | Monadic 'zipWith'. + zipWithM :: (a -> b -> m r) -> z a -> z b -> m (z r) + + -- | Monadic 'zipWith3'. + zipWithM3 :: (a -> b -> c -> m r) -> z a -> z b -> z c -> m (z r) + zipWithM3 f za zb zc = zipWithM ($) `flip` zc =<< mzipWith f za zb + + -- | Monadic 'zipWith4'. + zipWithM4 :: (a -> b -> c -> d -> m r) -> z a -> z b -> z c -> z d -> m (z r) + zipWithM4 f za zb zc zd = zipWithM ($) `flip` zd =<< mzipWith3 f za zb zc + + -- | Monadic 'zipWith5'. + zipWithM5 :: (a -> b -> c -> d -> e -> m r) -> z a -> z b -> z c -> z d -> z e -> m (z r) + zipWithM5 f za zb zc zd ze = zipWithM ($) `flip` ze =<< mzipWith4 f za zb zc zd + + -- | Monadic 'zipWith6'. + zipWithM6 :: (a -> b -> c -> d -> e -> f -> m r) -> z a -> z b -> z c -> z d -> z e -> z f -> m (z r) + zipWithM6 f za zb zc zd ze zf = zipWithM ($) `flip` zf =<< mzipWith5 f za zb zc zd ze + + +