diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Andrey Mulik (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrey Mulik nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sdp.cabal b/sdp.cabal new file mode 100644 --- /dev/null +++ b/sdp.cabal @@ -0,0 +1,115 @@ +name: sdp +version: 0.2 +category: Data Structures + +synopsis: Simple Data Processing +description: SDP provides generalized interface for simple data operations. + +author: Andrey Mulik +maintainer: work.a.mulik@gmail.com +bug-reports: https://github.com/andreymulik/sdp/issues + +copyright: 2019 Andrey Mulik +license-file: LICENSE +license: BSD3 + +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/andreymulik/sdp + +--- _ _____ ______ ______ ___ ______ __ __ --- +--- | | |_ _|| ___ \| ___ \ / _ \ | ___ \\ \ / / --- +--- | | | | | |_/ /| |_/ // /_\ \| |_/ / \ V / --- +--- | | | | | ___ \| / | _ || / \ / --- +--- | |____ _| |_ | |_/ /| |\ \ | | | || |\ \ | | --- +--- \_____/ \___/ \____/ \_| \_|\_| |_/\_| \_| \_/ --- + +Library + default-language: Haskell2010 + hs-source-dirs: src + + ghc-options: -O2 -Wall -Wcompat -Wno-orphans + + build-depends: + base >= 4.9 && < 5, + ghc-prim >= 0.5.3 && < 0.7, + data-default-class >= 0.1 && < 0.2 + + exposed-modules: + SDP.SafePrelude + SDP.Comparing + SDP.Estimate + SDP.Nullable + SDP.Unboxed + SDP.Finite + SDP.Tuple + SDP.Shape + SDP.Index + SDP.Ratio + + -- Sorting + SDP.SortM.Insertion + SDP.SortM.Tim + SDP.SortM + + -- Classes + SDP.IndexedM + SDP.LinearM + SDP.Indexed + SDP.Shaped + SDP.Linear + SDP.MapM + SDP.Scan + SDP.Sort + SDP.Map + SDP.Set + SDP.Zip + + -- Templates + SDP.Templates.AnyBorder + SDP.Templates.AnyChunks + + -- Primitives + SDP.Prim.SArray + SDP.Prim.SBytes + SDP.Prim.TArray + + -- Boxed arrays + SDP.Array + SDP.Array.ST + SDP.Array.IO + SDP.Unrolled + SDP.Unrolled.ST + SDP.Unrolled.IO + SDP.Unrolled.Unlist + SDP.Unrolled.STUnlist + SDP.Unrolled.IOUnlist + + -- Unboxed arrays + SDP.Bytes + SDP.Bytes.ST + SDP.Bytes.IO + SDP.ByteList + SDP.ByteList.ST + SDP.ByteList.IO + SDP.ByteList.Ublist + SDP.ByteList.STUblist + SDP.ByteList.IOUblist + + -- STM arrays + Control.Concurent.SDP.TArray + Control.Concurent.SDP.TUnlist + Control.Concurent.SDP.TUnrolled + + -- Service definitions + Control.Exception.SDP + + SDP.Unboxed.WordAs + SDP.Unboxed.IntAs + + Text.Show.SDP + Text.Read.SDP + diff --git a/src/Control/Concurent/SDP/TArray.hs b/src/Control/Concurent/SDP/TArray.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurent/SDP/TArray.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : Control.Concurent.SDP.TArray + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "Control.Concurent.SDP.TArray" provides lazy boxed array of @stm@ 'TVar's. +-} +module Control.Concurent.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/Concurent/SDP/TUnlist.hs b/src/Control/Concurent/SDP/TUnlist.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurent/SDP/TUnlist.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : Control.Concurent.SDP.TUnlist + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "Control.Concurent.SDP.TUnlist" provides lazy boxed unrolled linked list of + @stm@ 'TVar's. +-} +module Control.Concurent.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/Concurent/SDP/TUnrolled.hs b/src/Control/Concurent/SDP/TUnrolled.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurent/SDP/TUnrolled.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : Control.Concurent.SDP.TUnrolled + Copyright : (c) Andrey Mulik 2020 + 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. +-} +module Control.Concurent.SDP.TUnrolled +( + -- * TUnrolled + TUnrolled, STM, TVar +) +where + +import Control.Concurent.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 new file mode 100644 --- /dev/null +++ b/src/Control/Exception/SDP.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : Control.Exception.SDP + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "Control.Exception.SDP" - service module that provide some useful exceptions. + Note that "SDP.SafePrelude" doesn't export this module. +-} +module Control.Exception.SDP +( + -- * Exports + module Control.Exception, + + -- * Exceptions + UnreachableException (..), IndexException (..) +) +where + +import Prelude ( Eq (..), Show (..), String, (++) ) + +import Control.Exception +import Data.Typeable + +default () + +-------------------------------------------------------------------------------- + +{- | + '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. + + 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. +-} +data IndexException = UnacceptableExpansion String + | UndefinedValue String + | UnexpectedRank String + | IndexUnderflow String + | IndexOverflow String + | EmptyRange String + deriving ( Eq, Typeable ) + +instance Show IndexException + where + show (UnacceptableExpansion s) = "unacceptable expansion " ++ s + show (UndefinedValue s) = "undefined element " ++ s + show (UnexpectedRank s) = "unexpected rank " ++ s + show (IndexUnderflow s) = "index out of lower bound " ++ s + show (IndexOverflow s) = "index out of upper bound " ++ s + show (EmptyRange s) = "empty range " ++ s + +instance Exception IndexException + +-------------------------------------------------------------------------------- + +{- | + 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). +-} +data UnreachableException = UnreachableException String deriving (Eq, Typeable) + +instance Show UnreachableException + where + show (UnreachableException s) = "unreachable exception " ++ s + +instance Exception UnreachableException + + + diff --git a/src/SDP/Array.hs b/src/SDP/Array.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Array.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.Array + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Array" provides 'Array' - immutable lazy boxed array type. +-} +module SDP.Array +( + -- * Exports + module SDP.Indexed, + module SDP.Sort, + module SDP.Scan, + module SDP.Set, + + -- * Array + Array +) +where + +import SDP.Indexed +import SDP.Sort +import SDP.Scan +import SDP.Set + +import SDP.Templates.AnyBorder +import SDP.Prim.SArray + +default () + +-------------------------------------------------------------------------------- + +-- | 'Array' - lazy boxed array. +type Array = AnyBorder SArray# + + diff --git a/src/SDP/Array/IO.hs b/src/SDP/Array/IO.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Array/IO.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.Array.IO + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Array.IO provides 'IOArray' - mutable lazy boxed array type. +-} +module SDP.Array.IO +( + -- * Exports + module SDP.IndexedM, + module SDP.SortM, + + -- * MonadIO and IO Array + MIOArray, IOArray +) +where + +import SDP.Templates.AnyBorder +import SDP.Prim.SArray +import SDP.IndexedM +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'MIOArray' is mutable version of 'SDP.Array.Array'. +type MIOArray io = AnyBorder (MIOArray# io) + +-- | 'IOArray' is mutable version of 'SDP.Array.Array'. +type IOArray = AnyBorder IOArray# + + + + diff --git a/src/SDP/Array/ST.hs b/src/SDP/Array/ST.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Array/ST.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.Array.ST + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Array.ST" provides 'STArray' - mutable lazy boxed array type. +-} +module SDP.Array.ST +( + -- * Exports + module SDP.IndexedM, + module SDP.SortM, + + -- * STArray + STArray +) +where + +import SDP.Templates.AnyBorder +import SDP.Prim.SArray +import SDP.IndexedM +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'STArray' is mutable version of 'SDP.Array.Array'. +type STArray s = AnyBorder (STArray# s) + + diff --git a/src/SDP/ByteList.hs b/src/SDP/ByteList.hs new file mode 100644 --- /dev/null +++ b/src/SDP/ByteList.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.ByteList + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.ByteList" provides 'ByteList' - strict unboxed unrolled linked list. +-} +module SDP.ByteList +( + -- * Exports + module SDP.Indexed, + module SDP.Unboxed, + module SDP.Sort, + module SDP.Scan, + module SDP.Set, + + -- * ByteList + ByteList, + + -- * Ublist + Ublist +) +where + +import SDP.Indexed +import SDP.Unboxed +import SDP.Sort +import SDP.Scan +import SDP.Set + +import SDP.Templates.AnyBorder +import SDP.ByteList.Ublist + +default () + +-------------------------------------------------------------------------------- + +-- | '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 new file mode 100644 --- /dev/null +++ b/src/SDP/ByteList/IO.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.ByteList.IO + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.ByteList.IO" provides 'IOByteList' - mutable strict unboxed unrolled + linked list type. +-} +module SDP.ByteList.IO +( + -- * Exports + module SDP.IndexedM, + module SDP.Unboxed, + module SDP.SortM, + + -- * MonadIO and IO ByteLists + MIOByteList, IOByteList +) +where + +import SDP.Templates.AnyBorder +import SDP.ByteList.IOUblist +import SDP.IndexedM +import SDP.Unboxed +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'MIOByteList' is mutable version of 'SDP.ByteList.ByteList'. +type MIOByteList io = AnyBorder (MIOUblist io) + +-- | 'IOByteList' is mutable version of 'SDP.ByteList.ByteList'. +type IOByteList = AnyBorder IOUblist + diff --git a/src/SDP/ByteList/IOUblist.hs b/src/SDP/ByteList/IOUblist.hs new file mode 100644 --- /dev/null +++ b/src/SDP/ByteList/IOUblist.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.ByteList.IOUblist + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC Extensions) + + "SDP.ByteList.IOUblist" provides 'IOUblist' - mutable strict unboxed + unrolled linked list. +-} +module SDP.ByteList.IOUblist +( + -- * Exports + module SDP.IndexedM, + module SDP.Unboxed, + module SDP.SortM, + + -- * MonadIO and IO Ublists + MIOUblist, IOUblist +) +where + +import SDP.Templates.AnyChunks +import SDP.Prim.SBytes +import SDP.IndexedM +import SDP.Unboxed +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'MIOUblist' is mutable version of 'SDP.ByteList.Ublist.Ublist'. +type MIOUblist io = AnyChunks (MIOBytes# io) + +-- | 'IOUblist' is mutable version of 'SDP.ByteList.Ublist.Ublist'. +type IOUblist = AnyChunks IOBytes# + diff --git a/src/SDP/ByteList/ST.hs b/src/SDP/ByteList/ST.hs new file mode 100644 --- /dev/null +++ b/src/SDP/ByteList/ST.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.ByteList.ST + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.ByteList.ST" provides 'STByteList' - mutable unboxed strict unrolled + linked list. +-} +module SDP.ByteList.ST +( + -- * Exports + module SDP.IndexedM, + module SDP.Unboxed, + module SDP.SortM, + + -- * STByteList + STByteList +) +where + +import SDP.Templates.AnyBorder +import SDP.ByteList.STUblist +import SDP.IndexedM +import SDP.Unboxed +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'STByteList' is mutable version of 'SDP.ByteList.ByteList'. +type STByteList s = AnyBorder (STUblist s) + + + + diff --git a/src/SDP/ByteList/STUblist.hs b/src/SDP/ByteList/STUblist.hs new file mode 100644 --- /dev/null +++ b/src/SDP/ByteList/STUblist.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.ByteList.STUblist + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.ByteList.STUblist" provides 'STUblist' - mutable unboxed strict + unrolled linked list. +-} +module SDP.ByteList.STUblist +( + -- * Exports + module SDP.IndexedM, + module SDP.Unboxed, + module SDP.SortM, + + -- * STUblist + STUblist +) +where + +import SDP.Templates.AnyChunks +import SDP.Prim.SBytes +import SDP.IndexedM +import SDP.Unboxed +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | This 'STUblist' is mutable version of 'SDP.ByteList.Ublist.Ublist'. +type STUblist s = AnyChunks (STBytes# s) + + + + diff --git a/src/SDP/ByteList/Ublist.hs b/src/SDP/ByteList/Ublist.hs new file mode 100644 --- /dev/null +++ b/src/SDP/ByteList/Ublist.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE Safe, MagicHash, MultiParamTypeClasses, FlexibleInstances #-} + +{- | + Module : SDP.ByteList.Ublist + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.ByteList.Ublist" provides 'Ublist' - strict boxed unrolled linked list. +-} +module SDP.ByteList.Ublist +( + -- * Exports + module SDP.Indexed, + module SDP.Unboxed, + module SDP.Sort, + module SDP.Scan, + module SDP.Set, + + -- * Ublist + Ublist +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Indexed +import SDP.Unboxed +import SDP.Sort +import SDP.Scan +import SDP.Set + +import SDP.Templates.AnyChunks +import SDP.Prim.SBytes +import SDP.SortM.Tim + +default () + +-------------------------------------------------------------------------------- + +-- | 'Ublist' is unrolled linked list of unboxed values. +type Ublist = AnyChunks SBytes# + +-------------------------------------------------------------------------------- + +instance (Unboxed e) => Sort (Ublist e) e + where + sortBy cmp es = runST $ do es' <- thaw es; timSortBy cmp es'; done es' + + 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 + go [] = True + +-------------------------------------------------------------------------------- + +{-# INLINE done #-} +done :: (Unboxed e) => STBytes# s e -> ST s (Ublist e) +done = unsafeFreeze + + + + diff --git a/src/SDP/Bytes.hs b/src/SDP/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Bytes.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.Bytes + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Bytes" provides 'Bytes' - immutable strict unboxed array type. +-} +module SDP.Bytes +( + -- * Exports + module SDP.Unboxed, + module SDP.Indexed, + module SDP.Sort, + module SDP.Scan, + module SDP.Set, + + -- * Bytes + Bytes +) +where + +import SDP.Indexed +import SDP.Unboxed +import SDP.Sort +import SDP.Scan +import SDP.Set + +import SDP.Templates.AnyBorder +import SDP.Prim.SBytes + +default () + +-------------------------------------------------------------------------------- + +-- | 'Bytes' - unboxed array. +type Bytes = AnyBorder SBytes# + + + + + diff --git a/src/SDP/Bytes/IO.hs b/src/SDP/Bytes/IO.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Bytes/IO.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.Bytes.IO + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Bytes.IO" provides 'IOBytes' - mutable strict unboxed array type. +-} +module SDP.Bytes.IO +( + -- * Exports + module SDP.IndexedM, + module SDP.Unboxed, + module SDP.SortM, + + -- * MonadIO and IO Bytes + MIOBytes, IOBytes +) +where + +import SDP.Templates.AnyBorder +import SDP.Prim.SBytes +import SDP.IndexedM +import SDP.Unboxed +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'MIOBytes' is mutable version of 'SDP.Bytes.Bytes'. +type MIOBytes io = AnyBorder (MIOBytes# io) + +-- | 'IOBytes' is mutable version of 'SDP.Bytes.Bytes'. +type IOBytes = AnyBorder IOBytes# + + diff --git a/src/SDP/Bytes/ST.hs b/src/SDP/Bytes/ST.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Bytes/ST.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.Bytes.ST + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Bytes.ST" provides 'STBytes' - mutable lazy boxed array type. +-} +module SDP.Bytes.ST +( + -- * Exports + module SDP.IndexedM, + module SDP.SortM, + + -- * STBytes + STBytes +) +where + +import SDP.Templates.AnyBorder +import SDP.Prim.SBytes +import SDP.IndexedM +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'STBytes' is mutable version of 'SDP.Bytes.Bytes'. +type STBytes s = AnyBorder (STBytes# s) + + diff --git a/src/SDP/Comparing.hs b/src/SDP/Comparing.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Comparing.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.Comparing + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Comparing" provide common comparators and combinators. +-} +module SDP.Comparing +( + -- * Exports + module Data.Ord, + module Data.Eq, + + -- * Type synonyms + Equal, Compare, + + -- * Common comparators + (<=>), eqfst, eqsnd, cmpfst, cmpsnd, invertcmp +) +where + +import Data.Function +import Data.Ord +import Data.Eq + +default () + +infixl 4 <=> + +-------------------------------------------------------------------------------- + +{- Type synonyms. -} + +-- | 'Equal' is just synonym of @(e -> e -> Bool)@. +type Equal e = e -> e -> Bool + +-- | 'Compare' is just synonym of @(e -> e -> Ordering)@. +type Compare e = e -> e -> Ordering + +-------------------------------------------------------------------------------- + +-- | Spaceship operator - infix version of compare. +(<=>) :: (Ord o) => Compare o +(<=>) = compare + +-- | Compare tuples by first elements. +eqfst :: (Eq e) => Equal (e, s) +eqfst = (==) `on` fst + +-- | Compare tuples by second elements. +eqsnd :: (Eq e) => Equal (f, e) +eqsnd = (==) `on` snd + +-- | Compare tuples by first elements. +cmpfst :: (Ord o) => Compare (o, s) +cmpfst = comparing fst + +-- | Compare tuples by second elements. +cmpsnd :: (Ord o) => Compare (f, o) +cmpsnd = comparing snd + +-- | Common compare combinator +invertcmp :: Compare e -> Compare e +invertcmp = flip + + diff --git a/src/SDP/Estimate.hs b/src/SDP/Estimate.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Estimate.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.Estimate + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Estimate" provides 'Estimate' class, type synonyms and some common + comparators. This module is exported by "SDP.SafePrelude". +-} +module SDP.Estimate +( + -- * Exports + module Data.Functor.Classes, + + -- * Estimate + Estimate (..), (<=.>), (<.), (>.), (<=.), (>=.), (==.), (/=.) +) +where + +import Data.Functor.Classes + +import SDP.Comparing + +default () + +infixl 4 <==>, .<., .>., .<=., .>=., .==., ./=. + +infixl 4 <.=>, .<, .>, .<=, .>=, .==, ./= +infixl 4 <=.>, <., >., <=., >=., ==., /=. + +-------------------------------------------------------------------------------- + +{- | + 'Estimate' class provides the lazy comparsion structures by length. + + For some types (e.g., lists), this allows you to speed up the comparison or + make it finite. For others (e.g., arrays), it may be convenient abbreviation. +-} +class Estimate e + where + {-# MINIMAL (<.=>), (<==>) #-} + + -- | Left-side structure length with number comparison. + (<.=>) :: e -> Int -> Ordering + + -- | Two structures by length comparison. + (<==>) :: Compare e + + -- | Left-side structure length with number comparison. + (.==), (./=), (.<=), (.>=), (.<), (.>) :: e -> Int -> Bool + + -- | Two structures comparison by length. + (.<.), (.>.), (.<=.), (.>=.), (.==.), (./=.) :: e -> e -> Bool + + e .< i = case e <.=> i of {LT -> True; _ -> False} + e .> i = case e <.=> i of {GT -> True; _ -> False} + e .<= i = case e <.=> i of {GT -> False; _ -> True} + e .>= i = case e <.=> i of {LT -> False; _ -> True} + e .== i = case e <.=> i of {EQ -> True; _ -> False} + e ./= i = case e <.=> i of {EQ -> False; _ -> True} + + e1 .<. e2 = case e1 <==> e2 of {LT -> True; _ -> False} + e1 .>. e2 = case e1 <==> e2 of {GT -> True; _ -> False} + e1 .<=. e2 = case e1 <==> e2 of {GT -> False; _ -> True} + e1 .>=. e2 = case e1 <==> e2 of {LT -> False; _ -> True} + 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. +(<=.>) :: (Estimate e) => Int -> e -> Ordering +i <=.> e = case e <.=> i of {LT -> GT; EQ -> EQ; GT -> LT} + +-- | Right-side number with structure length comparison. +(==.), (/=.), (<=.), (>=.), (<.), (>.) :: (Estimate e) => Int -> e -> Bool + +(==.) = flip (.==) +(/=.) = flip (./=) +(<=.) = flip (.>=) +(>=.) = flip (.<=) +(<.) = flip (.>) +(>.) = flip (.<) + +-------------------------------------------------------------------------------- + +instance Estimate [a] + where + [] <==> [] = EQ + [] <==> _ = LT + _ <==> [] = GT + xs <==> ys = tail xs <==> tail ys + + [] <.=> n = 0 <=> n + 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 new file mode 100644 --- /dev/null +++ b/src/SDP/Finite.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE Trustworthy, TypeFamilies, TypeOperators, OverloadedLists #-} + +{- | + Module : SDP.Finite + Copyright : (c) Andrey Mulik 2019 + 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. +-} +module SDP.Finite +( + -- * Generalized index + E (..), (:&) (..), + + -- * Type synonyms + I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, I11, I12, I13, I14, I15, + + -- * Old constructors + ind2, ind3, ind4, ind5, ind6, ind7, ind8, ind9, + ind10, ind11, ind12, ind13, ind14, ind15 +) +where + +import Prelude ( (++) ) +import SDP.SafePrelude + +import Data.Default.Class + +import GHC.Types +import GHC.Read + +import qualified GHC.Exts as E +import GHC.Exts ( IsList ) + +import Control.Exception.SDP + +default () + +-------------------------------------------------------------------------------- + +{- Zero-dimensional type. -} + +-- | Service type, that represents zero-dimensional index. +data E = E deriving ( Eq, Ord, Show, Read ) + +instance Default E where def = E + +instance IsList E + where + type Item E = E + + fromList = const E + toList = const [] + +-------------------------------------------------------------------------------- + +{- N-dimensional index type. -} + +{- | + N-dimensional index type. The type (head :& tail) allows working with any + finite dimension number. +-} +data tail :& head = !tail :& !head deriving ( Eq, Ord ) + +instance (Enum i) => Enum (E :& i) + where + succ = \ [e] -> [succ e] + pred = \ [e] -> [pred e] + + toEnum = \ n -> [toEnum n] + fromEnum = \ [e] -> fromEnum e + + 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] ] + +instance (Default d, Default d') => Default (d :& d') where def = def :& def + +-------------------------------------------------------------------------------- + +{- Overloaded indices. -} + +instance (IsList (i' :& i), E.Item (i' :& i) ~~ i, Show i) => Show (i' :& i) + where + showsPrec p = showsPrec p . E.toList + +instance (IsList (i' :& i), E.Item (i' :& i) ~~ i, Read i) => Read (i' :& i) + where + readPrec = E.fromList <$> readPrec + +instance IsList (E :& i) + where + type Item (E :& i) = i + + fromList [i] = E :& i + fromList _ = throw $ UnexpectedRank "in SDP.Finite.fromList" + + toList (E :& i) = [i] + +instance (E.Item (i' :& i) ~~ i, IsList (i' :& i)) => IsList (i' :& i :& i) + where + type Item (i' :& i :& i) = i + + toList (i' :& i) = E.toList i' ++ [i] + + fromList = (uncurry $ (:&) . E.fromList) . unsnoc + +-------------------------------------------------------------------------------- + +{- Type synonyms are declared up to 15 dimensions. -} + +-- | 1-dimensional index (@(E :& i)@ without @TypeOperators@). +type I1 i = E :& i +-- | 2-dimensional index +type I2 i = E :& i :& i +-- | 3-dimensional index +type I3 i = (I2 i) :& i +-- | 4-dimensional index +type I4 i = (I3 i) :& i +-- | 5-dimensional index +type I5 i = (I4 i) :& i +-- | 6-dimensional index +type I6 i = (I5 i) :& i +-- | 7-dimensional index +type I7 i = (I6 i) :& i +-- | 8-dimensional index +type I8 i = (I7 i) :& i +-- | 9-dimensional index +type I9 i = (I8 i) :& i +-- | 10-dimensional index +type I10 i = (I9 i) :& i +-- | 11-dimensional index +type I11 i = (I10 i) :& i +-- | 12-dimensional index +type I12 i = (I11 i) :& i +-- | 13-dimensional index +type I13 i = (I12 i) :& i +-- | 14-dimensional index +type I14 i = (I13 i) :& i +-- | 15-dimensional index +type I15 i = (I14 i) :& i + +-- | 2-dimensional index constructor. +ind2 :: i -> i -> I2 i +-- | 3-dimensional index constructor. +ind3 :: i -> i -> i -> I3 i +-- | 4-dimensional index constructor. +ind4 :: i -> i -> i -> i -> I4 i +-- | 5-dimensional index constructor. +ind5 :: i -> i -> i -> i -> i -> I5 i +-- | 6-dimensional index constructor. +ind6 :: i -> i -> i -> i -> i -> i -> I6 i +-- | 7-dimensional index constructor. +ind7 :: i -> i -> i -> i -> i -> i -> i -> I7 i +-- | 8-dimensional index constructor. +ind8 :: i -> i -> i -> i -> i -> i -> i -> i -> I8 i +-- | 9-dimensional index constructor. +ind9 :: i -> i -> i -> i -> i -> i -> i -> i -> i -> I9 i +-- | 10-dimensional index constructor. +ind10 :: i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> I10 i +-- | 11-dimensional index constructor. +ind11 :: i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> I11 i +-- | 12-dimensional index constructor. +ind12 :: i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> I12 i +-- | 13-dimensional index constructor. +ind13 :: i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> I13 i +-- | 14-dimensional index constructor. +ind14 :: i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> i -> I14 i +-- | 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] + +-------------------------------------------------------------------------------- + +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 new file mode 100644 --- /dev/null +++ b/src/SDP/Index.hs @@ -0,0 +1,560 @@ +{-# LANGUAGE Trustworthy, OverloadedLists, ConstraintKinds, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, DefaultSignatures, CPP #-} + +{- | + Module : SDP.Index + Copyright : (c) Andrey Mulik 2019 + 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. +-} +module SDP.Index +( + -- * Shapes + module SDP.Nullable, + module SDP.Shape, + + (:|:), SubIndex, takeDim, dropDim, joinDim, splitDim, + + -- * Indices + Index (..), + + -- ** Helpers + InBounds (..), offsetIntegral, defaultBoundsUnsign +) +where + +import Prelude ( (++) ) +import SDP.SafePrelude +import SDP.Nullable +import SDP.Shape + +import Data.Tuple +import Data.Char ( ord ) + +import GHC.Types + +import Foreign.C.Types + +import Control.Exception.SDP + +default () + +-------------------------------------------------------------------------------- + +-- | InBounds - service type that specifies index and bounds status. +data InBounds = ER -- ^ Empty range + | UR -- ^ Underflow range + | IN -- ^ Index in range + | OR -- ^ Overflow range + deriving ( Eq, Show, Read, Enum ) + +-------------------------------------------------------------------------------- + +-- | @(':|:')@ is closed type family of shape differences. +type family i :|: j + where + i :|: E = i + i :|: j = DimInit i :|: DimInit j + +{- | + 'SubIndex' is service constraint that corresponds closed (internal) class + @Sub@. @'SubIndex' i j @ matches if 'Index' type @i@ is subspace of 'Index' + type @j@. +-} +type SubIndex = Sub + +-- Internal class of shape differences. +class (Index i, Index j, Index (i :|: j)) => Sub i j + where + {- | + Drop some dimensions (second argument used as type variable). + + >>> dropDim ([1, 2, 3, 4] :: I4 Int) ([] :: E) + [1, 2, 3, 4] + >>> dropDim ([1, 2, 3, 4] :: I4 Int) ([1, 2] :: I2 Int) + [3, 4] + -} + dropDim :: i -> j -> i :|: j + + {- | + Join some dimensions. + + >>> joinDim ([1, 2] :: I2 Int) [3] :: I3 Int + [1, 2, 3] + >>> joinDim ([1, 2] :: I2 Int) [3, 4] :: I4 Int + [1, 2, 3, 4] + -} + joinDim :: j -> i :|: j -> i + + {- | + Take some dimensions. + + >>> takeDim ([1, 2, 3, 4] :: I4 Int) :: I1 Int + [1] + >>> takeDim ([1, 2, 3, 4] :: I4 Int) :: E + E + -} + takeDim :: i -> j + +instance {-# OVERLAPS #-} (Index i, E ~~ (i :|: i)) => Sub i i + where + dropDim = \ _ _ -> E + joinDim = const + takeDim = id + +instance + ( + ij ~~ (i :|: j), DimInit ij ~~ (DimInit i :|: j), DimLast ij ~~ DimLast i, + Index i, Index j, Index ij, Sub (DimInit i) j + ) => Sub i j + where + dropDim i' j' = let (is, i) = unconsDim i' in consDim (dropDim is j') i + joinDim j' ij = let (is, i) = unconsDim ij in consDim (joinDim j' is) i + takeDim = takeDim . initDim + +-- | 'splitDim' returns pair of shape difference and subshape. +splitDim :: (SubIndex i j) => i -> (i :|: j, j) +splitDim i = let j = takeDim i in (dropDim i j, j) + +-------------------------------------------------------------------------------- + +{- | + Index is service class based on @base@ Ix and @repa@ Shape. + + Basic rules: + + > size bnds >= 0 + > size bnds == product (sizes bnds) + + > isEmpty bnds == (size bnds == 0) + > isEmpty bnds == inRange bnds (safeElem bnds i) + + > isEmpty bnds => isOverflow bnds i + > isEmpty bnds => isUnderflow bnds i + + > inRange bnds i /= isEmpty bnds + > inRange bnds i /= isOverflow bnds i + > inRange bnds i /= isUnderflow bnds i + > inRange bnds i == (safeElem bnds i == i) + + Note: + + * 'E' is (and should remain) the one and only one index of @rank 0@. + * 'Index' is a generalization of 'Enum', so all @rank 1@ indices must satisfy + 'Enum' laws. + * The cardinality of the set of permissible values for indices mustn't + exceed 1 (cardinality of a series of natural numbers), so 'Fractional' types + cannot be indices. +-} +class (Ord i, Shape i, Shape (DimLast i), Shape (DimInit i), Shape (GIndex i)) => Index i + where + {- Basic functions. -} + + -- | Returns the size of range. + {-# INLINE size #-} + size :: (i, i) -> Int + default size :: (Enum i) => (i, i) -> Int + size bnds@(l, u) = isEmpty bnds ? 0 $ u -. l + 1 + + -- | Returns the sizes of range dimensionwise. + {-# INLINE sizes #-} + sizes :: (i, i) -> [Int] + default sizes :: (Index (GIndex i)) => (i, i) -> [Int] + sizes = sizes . toGBounds + + -- | Returns the index belonging to the given range. + {-# INLINE safeElem #-} + safeElem :: (i, i) -> i -> i + safeElem (l, u) = min u . max l + + -- | Returns bounds of nonempty range (swaps bounds in each empty subshape). + {-# INLINE ordBounds #-} + ordBounds :: (i, i) -> (i, i) + ordBounds = \ bs -> isEmpty bs ? swap bs $ bs + + -- | 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 + + -- | Returns default range by size. + {-# INLINE defaultBounds #-} + defaultBounds :: Int -> (i, i) + defaultBounds n = (unsafeIndex 0, unsafeIndex $ max 0 n - 1) + + -- | Returns index by offset in default range. + {-# INLINE unsafeIndex #-} + unsafeIndex :: Int -> i + default unsafeIndex :: (Enum i) => Int -> i + unsafeIndex = toEnum + + {- Checkers -} + + -- | Checks if the bounds is empty. + {-# INLINE isEmpty #-} + isEmpty :: (i, i) -> Bool + isEmpty = uncurry (>) + + -- | Checks the index status in bounds. + inBounds :: (i, i) -> i -> InBounds + inBounds (l, u) i | l > u = ER | i > u = OR | i < l = UR | True = IN + + -- | Checks if the index is overflow. + {-# INLINE isOverflow #-} + isOverflow :: (i, i) -> i -> Bool + isOverflow (l, u) i = i > u || l > u + + -- | Checks if the index is underflow. + {-# INLINE isUnderflow #-} + isUnderflow :: (i, i) -> i -> Bool + isUnderflow (l, u) i = i < l || l > u + + -- | Checks if the index is in 'range'. + {-# INLINE inRange #-} + inRange :: (i, i) -> i -> Bool + inRange (l, u) i = l <= i && i <= u + + {- Enum-like operations -} + + -- | 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}" + + -- | 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}" + + -- | Returns 'offset' (indent) of 'index' in 'range'. + {-# INLINE offset #-} + offset :: (i, i) -> i -> Int + default offset :: (Enum i) => (i, i) -> i -> Int + offset bnds@(l, _) i = checkBounds bnds i (i -. l) "offset {default}" + + -- | Returns 'index' by this 'offset' (indent) in 'range'. + {-# INLINE index #-} + index :: (i, i) -> Int -> i + default index :: (Enum i) => (i, i) -> Int -> i + index bnds@(l, _) n = + 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 + + {- | + @subshape bnds ij@ returns subshape of @bnds@. + + Checks if @ij@ in @bnds@ subshape, may 'throw' 'IndexException'. + -} + subshape :: (Sub i j, Index (i :|: j)) => (i, i) -> i :|: j -> (j, j) + subshape (l, u) ij = checkBounds (l', u') ij (lj, uj) "subshape {default}" + where + (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 (l, u) ij = checkBounds (ls, us) ij ((ls, us), (lj, uj)) "slice {default}" + where + (ls, lj) = splitDim l + (us, uj) = splitDim u + +-------------------------------------------------------------------------------- + +instance (Index i) => Estimate (i, i) + where + (<==>) = on (<=>) size + (.<=.) = on (<=) size + (.>=.) = on (>=) size + (.>.) = on (>) size + (.<.) = on (<) size + + (<.=>) = (<=>) . size + (.>) = (>) . size + (.<) = (<) . size + (.>=) = (>=) . size + (.<=) = (<=) . size + +instance (Index i) => Nullable (i, i) + where + isNull = isEmpty + lzero = defaultBounds 0 + +-------------------------------------------------------------------------------- + +{- Basic instances. -} + +instance Index E + where + unsafeIndex = const (emptyEx "unsafeIndex {E}") + + defLimit = const (-1) + + size = const 0 + sizes = const [] + range = const [] + + next _ _ = E + prev _ _ = E + offset _ _ = emptyEx "offset {E}" + index _ _ = emptyEx "index {E}" + + inBounds _ _ = ER + inRange _ _ = False + isEmpty _ = True + isOverflow _ _ = True + isUnderflow _ _ = True + +instance Index () + where + size = const 1 + sizes = const [1] + range = const [()] + + defLimit = const 0 + next _ _ = () + prev _ _ = () + + inBounds _ _ = IN + isEmpty _ = False + inRange _ _ = True + isOverflow _ _ = False + isUnderflow _ _ = False + + defaultBounds = const ((), ()) + index = const unsafeIndex + offset _ _ = 0 + + unsafeIndex 0 = () + unsafeIndex _ = emptyEx "unsafeIndex ()" + +instance Index Char + where + defaultBounds = defaultBoundsUnsign + defLimit = const $ toInteger (ord maxBound) + +{- | + Note that 'Integer' isn't 'Bounded', so it can't be used in multidimensional + indices. +-} +instance Index Integer + where + -- | Undefined. + defLimit = error "in SDP.Index.defLimit: Integer has no upper bound" + offset = offsetIntegral + +instance Index Int where offset = offsetIntegral +instance Index Int8 where offset = offsetIntegral +instance Index Int16 where offset = offsetIntegral +instance Index Int32 where offset = offsetIntegral +instance Index Int64 where offset = offsetIntegral + +instance Index Word where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index Word8 where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index Word16 where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index Word32 where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index Word64 where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign + +-------------------------------------------------------------------------------- + +{- Foreign C instances. -} + +instance Index CChar where offset = offsetIntegral +instance Index CSChar where offset = offsetIntegral +instance Index CWchar where offset = offsetIntegral +instance Index CShort where offset = offsetIntegral + +instance Index CInt where offset = offsetIntegral +instance Index CLong where offset = offsetIntegral +instance Index CLLong where offset = offsetIntegral +instance Index CIntPtr where offset = offsetIntegral +instance Index CIntMax where offset = offsetIntegral +instance Index CPtrdiff where offset = offsetIntegral +instance Index CSigAtomic where offset = offsetIntegral + +instance Index CSize where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index CBool where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index CUChar where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index CUShort where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign + +instance Index CUInt where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index CULong where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index CULLong where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index CUIntPtr where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index CUIntMax where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign + +-------------------------------------------------------------------------------- + +{- N-dimensional index instances. -} + +instance (Index i) => Index (E :& i) + 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) ] + + next = \ ([l], [u]) [i] -> [next (l, u) i] + prev = \ ([l], [u]) [i] -> [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] + + isEmpty = \ ([l], [u]) -> isEmpty (l, u) + ordBounds = \ ([l], [u]) -> let (l', u') = ordBounds (l, u) in ([l'], [u']) + + offset = \ ([l], [u]) [i] -> offset (l, u) i + index = \ ([l], [u]) n -> [index (l, u) n] + + defaultBounds = both (E :&) . defaultBounds + + unsafeIndex = \ n -> [unsafeIndex n] + +-- [internal]: undecidable +instance (Index i, Enum i, Bounded i, Index (i' :& i)) => Index (i' :& i :& i) + where + defLimit i = lim (error "in defLimit {i' :& i :& i}") (rank i) i + where + lim :: (Index i) => i -> Int -> (i' :& i) -> Integer + lim = const ... (^) . defLimit + + size (ls :& l, us :& u) = size (l, u) * size (ls, us) + sizes (ls :& l, us :& u) = sizes (ls, us) ++ sizes (l, u) + range (ls :& l, us :& u) = liftA2 (:&) (range (ls, us)) (range (l, u)) + + prev bs@(ls :& l, us :& u) ix + | isEmpty bs = emptyEx "prev {i' :& i :& i}" + | i /= l = is :& pred i + | is /= ls = prev (ls, us) is :& u + | True = ls :& l + where + (is :& i) = safeElem bs ix + + next bs@(ls :& l, us :& u) ix + | isEmpty bs = emptyEx "next {i' :& i :& i}" + | i /= u = is :& succ i + | is /= us = prev (ls, us) is :& u + | True = ls :& l + where + (is :& i) = safeElem bs ix + + inBounds bs i + | isEmpty bs = ER + | isUnderflow bs i = UR + | isOverflow bs i = OR + | True = IN + + inRange (ls :& l, us :& u) (is :& i) = inRange (l, u) i && inRange (ls, us) is + isOverflow (ls :& l, us :& u) (is :& i) = isOverflow (l, u) i || isOverflow (ls, us) is + isUnderflow (ls :& l, us :& u) (is :& i) = isUnderflow (l, u) i || isUnderflow (ls, us) is + + safeElem (ls :& l, us :& u) (is :& i) = safeElem (ls, us) is :& safeElem (l, u) i + isEmpty (ls :& l, us :& u) = isEmpty (l, u) || isEmpty (ls, us) + ordBounds (ls :& l, us :& u) = (ls' :& l', us' :& u') + where + (ls', us') = ordBounds (ls, us) + (l', u') = ordBounds (l, u) + + index bnds@(ls :& l, us :& u) c = checkBounds (0, size bnds - 1) c res err + where + (cs, i) = c `divMod` size (l, u) + res = index (ls, us) cs :& unsafeIndex i + err = "index {i' :& i :& i}" + + offset bnds ix@(is :& i) = checkBounds bnds ix res "offset {i' :& i :& i}" + where + res = offset (ls, us) is * size (l, u) + offset (l, u) i + (ls :& l, us :& u) = bnds + + unsafeIndex c = unsafeIndex d :& i + where + (d, m) = defLimit c <= lim ? (0, c) $ c `divMod` fromInteger lim + i = unsafeIndex m + lim = defLimit i + +-------------------------------------------------------------------------------- + +{- Tuple instances. -} + +#define INDEX_INSTANCE(Type) instance (Ord i, Index i, Enum i, Bounded i) => Index (Type i) where\ +{\ +size = size . toGBounds;\ +sizes = sizes . toGBounds;\ +isEmpty = isEmpty . toGBounds;\ +defLimit = defLimit . toGIndex;\ +unsafeIndex = fromGIndex . unsafeIndex;\ +index = fromGIndex ... index . toGBounds;\ +range = fmap fromGIndex . range . toGBounds;\ +ordBounds = fromGBounds . ordBounds . toGBounds;\ +offset = \ bs -> offset (toGBounds bs) . toGIndex;\ +inRange = \ bs -> inRange (toGBounds bs) . toGIndex;\ +isOverflow = \ bs -> isOverflow (toGBounds bs) . toGIndex;\ +isUnderflow = \ bs -> isUnderflow (toGBounds bs) . toGIndex;\ +next = \ bs -> fromGIndex . next (toGBounds bs) . toGIndex;\ +prev = \ bs -> fromGIndex . prev (toGBounds bs) . toGIndex;\ +safeElem = \ bs -> fromGIndex . safeElem (toGBounds bs) . toGIndex;\ +} + +INDEX_INSTANCE(T2) +INDEX_INSTANCE(T3) +INDEX_INSTANCE(T4) +INDEX_INSTANCE(T5) +INDEX_INSTANCE(T6) +INDEX_INSTANCE(T7) +INDEX_INSTANCE(T8) +INDEX_INSTANCE(T9) +INDEX_INSTANCE(T10) +INDEX_INSTANCE(T11) +INDEX_INSTANCE(T12) +INDEX_INSTANCE(T13) +INDEX_INSTANCE(T14) +INDEX_INSTANCE(T15) + +#undef INDEX_INSTANCE + +-------------------------------------------------------------------------------- + +(-.) :: (Enum i) => i -> i -> Int +(-.) = on (-) fromEnum + +-- | Default 'offset' for 'Integral' types. +{-# INLINE offsetIntegral #-} +offsetIntegral :: (Index i, Integral i) => (i, i) -> i -> Int +offsetIntegral bnds@(l, _) i = checkBounds bnds i (i -. l) "offset {default}" + +-- | Default 'defaultBounds' for unsigned types. +{-# INLINE defaultBoundsUnsign #-} +defaultBoundsUnsign :: (Index i, Bounded i) => Int -> (i, i) +defaultBoundsUnsign n = n < 1 ? ub 1 0 $ ub 0 (n - 1) where ub = on (,) unsafeIndex + +-- | Check bounds and 'throw' 'IndexException' if needed. +checkBounds :: (Index i) => (i, i) -> i -> res -> String -> res +checkBounds bnds i res = case inBounds bnds i of + ER -> throw . EmptyRange . showString "in SDP.Index." + OR -> throw . IndexOverflow . showString "in SDP.Index." + 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 new file mode 100644 --- /dev/null +++ b/src/SDP/Indexed.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE Safe, DefaultSignatures, ConstraintKinds #-} + +{- | + Module : SDP.Indexed + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Indexed" provides 'Indexed' and 'Freeze' classes. +-} +module SDP.Indexed +( + -- * Exports + module SDP.Linear, + module SDP.Map, + + -- * Indexed + Indexed (..), Indexed1, Indexed2, binaryContain, + + -- * Freeze + Freeze (..), Freeze1 +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Linear +import SDP.Map + +import Control.Exception.SDP + +default () + +-------------------------------------------------------------------------------- + +-- | '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 + {-# MINIMAL fromIndexed #-} + + {- | + @assoc bnds ascs@ create new structure from list of associations, without + default element. Note that @bnds@ is @ascs@ bounds and may not match with + the result bounds (not always possible). + -} + assoc :: (i, i) -> [(i, e)] -> v + assoc = flip assoc' (undEx "assoc {default}") + + {- | + @assoc' bnds def ascs@ creates new structure from list of associations + with default element. Note that @bnds@ is @ascs@ bounds and may not match + with the result bounds (not always possible). + -} + assoc' :: (i, i) -> e -> [(i, e)] -> v + assoc' bnds defvalue = toMap' defvalue . filter (inRange bnds . fst) + + -- | 'fromIndexed' converts this indexed structure to another one. + fromIndexed :: (Indexed m j e) => m -> v + + -- | Safe index-based immutable writer. + {-# INLINE write' #-} + write' :: v -> i -> e -> v + write' es = write es . offsetOf es + + {- | + @'accum' f es ies@ create a new structure from @es@ elements selectively + updated by function @f@ and @ies@ associations list. + -} + accum :: (e -> e' -> e) -> v -> [(i, e')] -> v + accum f es ies = bounds es `assoc` [ (i, es!i `f` e') | (i, e') <- ies ] + + -- | '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 ] + +-------------------------------------------------------------------------------- + +-- | Service class of mutable to immutable conversions. +class (Monad m) => Freeze m v' v | v' -> m + where + {- | + @freeze@ is a safe way to convert a mutable structure to a immutable. + @freeze@ should copy the old structure or ensure that it will not be used + after calling the procedure. + -} + freeze :: v' -> m v + + {- | + @unsafeFreeze@ is unsafe version of 'freeze'. @unsafeFreeze@ doesn't + guarantee that the structure will be copied or locked. It only guarantees + that if the old structure isn't used, no error will occur. + -} + unsafeFreeze :: v' -> m v + unsafeFreeze = freeze + +-------------------------------------------------------------------------------- + +-- | Kind @(* -> *)@ 'Indexed' structure. +type Indexed1 v i e = Indexed (v e) i e + +-- | Kind @(* -> * -> *)@ 'Indexed' structure. +type Indexed2 v i e = Indexed (v i e) i e + +-- | Kind @(* -> *)@ 'Freeze'. +type Freeze1 m v' v e = Freeze m (v' e) (v e) + +-------------------------------------------------------------------------------- + +instance Indexed [e] Int e + where + assoc' bnds e = toMap' e . filter (inRange bnds . fst) + + fromIndexed es = (es !) <$> indices es + +-------------------------------------------------------------------------------- + +-- | binaryContain checks that sorted structure has equal element. +binaryContain :: (Linear v e, Bordered v i) => Compare e -> e -> v -> Bool +binaryContain _ _ Z = False +binaryContain f e es = + let + contain l u = not (l > u) && case f e (es !^ j) of + LT -> contain l (j - 1) + EQ -> True + GT -> contain (j + 1) u + where + 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 new file mode 100644 --- /dev/null +++ b/src/SDP/IndexedM.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE Safe, DefaultSignatures, ConstraintKinds #-} + +{- | + Module : SDP.IndexedM + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.IndexedM" provides 'IndexedM' and 'Thaw' classes. +-} +module SDP.IndexedM +( + -- * Exports + module SDP.LinearM, + module SDP.Indexed, + module SDP.MapM, + + -- * IndexedM + IndexedM (..), IndexedM1, IndexedM2, + + -- * Thaw + Thaw (..), Thaw1 +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.LinearM +import SDP.Indexed +import SDP.MapM + +import Control.Exception.SDP + +default () + +-------------------------------------------------------------------------------- + +-- | 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 + {-# MINIMAL fromIndexed', fromIndexedM #-} + + {- | + @fromAssocs bnds ascs@ creates new structure from list of associations, + without default element. Note that @bnds@ is @ascs@ bounds and may not + match with the result bounds (not always possible). + -} + fromAssocs :: (i, i) -> [(i, e)] -> m v + fromAssocs = + let err = throw $ UndefinedValue "in SDP.IndexedM.fromAssocs {default}" + in flip fromAssocs' err + + {- | + @fromAssocs' bnds defvalue ascs@ creates new structure from list of + associations, with default element. Note that @bnds@ is @ascs@ bounds and + may not match with the result bounds (not always possible). + -} + fromAssocs' :: (i, i) -> e -> [(i, e)] -> m v + fromAssocs' bnds defvalue = newMap' defvalue . filter (inRange bnds . fst) + + {- | + @'writeM' map key e@ writes element @e@ to @key@ position safely (if @key@ + is out of @map@ range, do nothing). The 'writeM' function is intended to + overwrite only existing values, so its behavior is identical for + structures with both static and dynamic boundaries. + -} + writeM' :: v -> i -> e -> m () + writeM' es i e = do bnds <- getBounds es; writeM es (offset bnds i) e + + -- | Just swap two elements. + swapM' :: v -> i -> i -> m () + swapM' es i j = do ei <- es >! i; writeM' es i =<< es >! j; writeM' es j ei + + -- | fromIndexed' is overloaded version of thaw. + fromIndexed' :: (Indexed v' j e) => v' -> m v + + -- | fromIndexed converts one mutable structure to other. + fromIndexedM :: (IndexedM m v' j e) => v' -> m v + + -- | reshaped creates new indexed structure from old with reshaping function. + reshaped :: (IndexedM m v' j e) => (i, i) -> v' -> (i -> j) -> m v + reshaped bnds es f = fromAssocs bnds =<< range bnds `forM` \ i -> (,) i <$> es !> f i + + {- | + @'fromAccum' f es ies@ create a new structure from @es@ elements + selectively updated by function @f@ and @ies@ associations list. + -} + fromAccum :: (e -> e' -> e) -> v -> [(i, e')] -> m v + fromAccum f es ascs = getBounds es >>=<< ies $ fromAssocs + where + ies = sequence [ do e <- es !> i; return (i, f e e') | (i, e') <- ascs ] + + -- | Update element by given function. + updateM' :: v -> (e -> e) -> i -> m () + updateM' es f i = writeM' es i . f =<< es >! i + +-------------------------------------------------------------------------------- + +-- | Service class of immutable to mutable conversions. +class (Monad m) => Thaw m v v' | v' -> m + where + {- | + @thaw@ is safe way to convert a immutable structure to a mutable. @thaw@ + should copy the old structure or ensure that it will not be used after the + procedure calling. + -} + thaw :: v -> m v' + + {- | + @unsafeThaw@ is unsafe version of 'thaw'. @unsafeThaw@ doesn't guarantee + that the structure will be copied or locked. It only guarantees that if + the old structure isn't used, no error will occur. + -} + unsafeThaw :: v -> m v' + unsafeThaw = thaw + +-------------------------------------------------------------------------------- + +-- | Kind @(* -> *)@ 'IndexedM'. +type IndexedM1 m v i e = IndexedM m (v e) i e + +-- | Kind @(* -> * -> *)@ 'IndexedM'. +type IndexedM2 m v i e = IndexedM m (v i e) i e + +-- | Kind @(* -> *)@ 'Thaw'. +type Thaw1 m v v' e = Thaw m (v e) (v' e) + + diff --git a/src/SDP/Linear.hs b/src/SDP/Linear.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Linear.hs @@ -0,0 +1,920 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns, BangPatterns, DefaultSignatures #-} +{-# LANGUAGE Trustworthy, TypeOperators, TypeFamilies, ConstraintKinds #-} + +{- | + Module : SDP.Linear + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Linear" is a module that provides several convenient interfaces for + working with various linear data structures. +-} +module SDP.Linear +( + -- * Exports + module SDP.Nullable, + module SDP.Index, + module SDP.Sort, + module SDP.Zip, + + -- * Bordered class + Bordered (..), Bordered1, Bordered2, + + -- * Linear class + -- $linearDoc + Linear (..), Linear1, + + -- * Split class + -- $splitDoc + Split (..), Split1, + + -- * Patterns + -- $patternDoc + pattern (:>), pattern (:<), pattern Z, + + -- * Related functions + intercalate, tails, inits, ascending, + + stripPrefix, stripSuffix, stripPrefix', stripSuffix' +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Nullable +import SDP.Index +import SDP.Sort +import SDP.Zip + +import qualified Data.List as L + +import Control.Exception.SDP + +default () + +infix 8 `filter`, `except` + +infixr 5 :>, ++ +infixl 5 :< +infixl 9 !^ + +-------------------------------------------------------------------------------- + +-- | Class of bordered data structures. +class (Index i, Estimate b) => Bordered b i | b -> i + where + {-# MINIMAL (bounds|(lower, upper)) #-} + + {-# INLINE bounds #-} + {- | + Returns the exact 'upper' and 'lower' bounds of given structure. If the + structure doesn't have explicitly defined boundaries (list, for example), + use the @'defaultBounds' . 'sizeOf'@. + -} + bounds :: b -> (i, i) + bounds es = (lower es, upper es) + + {-# INLINE lower #-} + -- | Returns lower bound of structure + lower :: b -> i + lower = fst . bounds + + {-# INLINE upper #-} + -- | Returns upper bound of structure + upper :: b -> i + upper = snd . bounds + + {-# INLINE sizeOf #-} + -- | Returns actual size of structure. + sizeOf :: b -> Int + sizeOf = size . bounds + + -- | Returns actual sizes of structure. + sizesOf :: b -> [Int] + sizesOf = sizes . bounds + + {-# INLINE indexIn #-} + -- | Checks if an index falls within the boundaries of the structure. + indexIn :: b -> i -> Bool + indexIn = inRange . bounds + + {-# INLINE indices #-} + -- | Returns index range list. + indices :: b -> [i] + indices = range . bounds + + {-# INLINE indexOf #-} + -- | Returns index by offset in structure. + indexOf :: b -> Int -> i + indexOf = index . bounds + + {-# INLINE offsetOf #-} + -- | Returns index offset in structure bounds. + offsetOf :: b -> i -> Int + offsetOf = offset . bounds + +-------------------------------------------------------------------------------- + +instance (Index i) => Bordered (i, i) i + where + bounds = id + lower = fst + upper = snd + + indices = range + indexIn = inRange + + sizeOf = size + indexOf = index + offsetOf = offset + +instance Bordered [e] Int + where + sizeOf = length + lower = const 0 + + upper es = length es - 1 + +-------------------------------------------------------------------------------- + +{- $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 (Nullable l) => Linear l e | l -> e + where + {-# MINIMAL (listL|listR), (fromList|fromFoldable), (head,tail|uncons), (init,last|unsnoc) #-} + + -- | Separates line to 'head' and 'tail', deconstructor for ':>' pattern. + uncons :: l -> (e, l) + uncons xs = (head xs, tail xs) + + -- | Same as @'isNull' '?-' 'uncons'@ + uncons' :: l -> Maybe (e, l) + uncons' = isNull ?- uncons + + -- | Prepends element to line, constructor for ':>' pattern. + toHead :: e -> l -> l + toHead = (++) . single + + -- | Returns first element of line, may fail. + head :: l -> e + head = fst . uncons + + -- | Returns line except first, may fail. + tail :: l -> l + tail = snd . uncons + + -- | Separates line to 'init' and 'last', deconstructor for ':<' pattern. + unsnoc :: l -> (l, e) + unsnoc xs = (init xs, last xs) + + -- | Same as @'isNull' '?-' 'unsnoc'@ + unsnoc' :: l -> Maybe (l, e) + unsnoc' = isNull ?- unsnoc + + -- | Appends element to line, constructor for ':<' pattern. + toLast :: l -> e -> l + toLast es = (es ++) . single + + -- | Returns line except 'last' element, may fail. + init :: l -> l + init = fst . unsnoc + + -- | Returns last element, may fail. + last :: l -> e + last = snd . unsnoc + + -- | Just singleton. + single :: e -> l + single = fromList . pure + + -- | Concatenation of two lines. + (++) :: l -> l -> l + (++) = fromList ... on (++) listL + + -- | @replicate n e@ returns a line of @n@ repetitions of the element @e@. + replicate :: Int -> e -> l + replicate n = fromListN n . replicate n + + -- | Creates line from list. + fromList :: [e] -> l + fromList = fromFoldable + + -- | Create finite line from (possibly infinite) list. + fromListN :: Int -> [e] -> l + fromListN = fromList ... take + + -- | Right to left view of line. + listR :: l -> [e] + listR = listL . reverse + + -- | Left to right view of line, same to 'toList'. + listL :: l -> [e] + listL = reverse . listR + + -- | Generalized 'fromList'. + fromFoldable :: (Foldable f) => f e -> l + fromFoldable = fromList . toList + + {- | + Returns the element of a sequence by offset, may be completely unsafe. + This is an optimistic read function and shouldn't perform checks for + efficiency reasons. + + If you need safety, use (!) or (!?). The generalization of this function + by index type (.!). + + > es !^ i = listL es !! i + -} + (!^) :: l -> Int -> e + (!^) = (L.!!) . listL + + {- | + @write es n e@ writes value @e@ in position @n@ (offset), returns new + structure. If @n@ is out of range, returns equal structure (@es@ or copy). + -} + write :: l -> Int -> e -> l + write es = fromList ... write (listL es) + + -- | Generalized concat. + concat :: (Foldable f) => f l -> l + concat = foldr (++) Z + + -- | Generalized concatMap. + concatMap :: (Foldable f) => (a -> l) -> f a -> l + concatMap f = concat . foldr ((:) . f) [] + + -- | Generalized intersperse. + intersperse :: e -> l -> l + intersperse e = fromList . intersperse e . listL + + -- | Generalized filter. + filter :: (e -> Bool) -> l -> l + filter p = fromList . filter p . listL + + -- | Inverted filter. + except :: (e -> Bool) -> l -> l + except p = filter (not . p) + + -- | Generalization of partition. + partition :: (e -> Bool) -> l -> (l, l) + partition p es = (filter p es, except p es) + + -- | Generalization of partition, that select sublines by predicates. + partitions :: (Foldable f) => f (e -> Bool) -> l -> [l] + partitions ps es = + let f = \ (x : xs) -> (\ (y, ys) -> (ys : y : xs)) . (`partition` x) + in reverse $ foldl f [es] ps + + -- | @select f es@ is selective map of @es@ elements to new list. + select :: (e -> Maybe a) -> l -> [a] + select f = foldr (\ x es -> case f x of {(Just e) -> e : es; _ -> es}) [] . listL + + -- | @select' f es@ is selective map of @es@ elements to new line. + select' :: (t e ~ l, Linear1 t a) => (e -> Maybe a) -> l -> t a + select' = fromList ... select + + {- | + @extract f es@ returns a selective map of @es@ elements to new list and + the remaining elements of the line. + -} + extract :: (e -> Maybe a) -> l -> ([a], l) + extract f = + let g = \ b -> second (b :) `maybe` (first . (:)) $ f b + in fmap fromList . foldr g ([], []) . listL + + {- | + @extract' f es@ returns a selective map of @es@ elements to new line and + the remaining elements of the line. + -} + extract' :: (t e ~ l, Linear1 t a) => (e -> Maybe a) -> l -> (t a, l) + extract' = first fromList ... extract + + {- | + @selects fs es@ sequentially applies the functions from @fs@ to the + remainder of @es@, returns a list of selections and the remainder of the + last selection. + -} + selects :: (Foldable f) => f (e -> Maybe a) -> l -> ([[a]], l) + selects fs es = + let g = \ as -> first (: as) ... flip extract + in foldl (uncurry g) ([], es) fs + + {- | + @selects' fs es@ sequentially applies the functions from @fs@ to the + remainder of @es@, returns a line of selections and the remainder of the + last selection. + -} + selects' :: (Foldable f, t e ~ l, Linear1 t a) => f (e -> Maybe a) -> l -> ([t a], l) + selects' = first (map fromList) ... selects + + {- | + The @isSubseqOf xs ys@ checks if all the elements of the @xs@ occur, + in order, in the @ys@. The elements don't have to occur consecutively. + -} + isSubseqOf :: (Eq e) => l -> l -> Bool + isSubseqOf = isSubseqOf `on` listL + + -- | Generalized reverse. + reverse :: l -> l + reverse = fromList . listR + + -- | Create new line, equal to given. + force :: l -> l + force = fromList . listL + + -- | Generalized subsequences. + subsequences :: l -> [l] + subsequences = (Z :) . go + where + go (x :> xs) = single x : foldr (\ ys r -> ys : (x :> ys) : r) [] (go xs) + go _ = Z + + {- | + @iterate n f x@ returns sequence of @n@ applications of @f@ to @x@. + + Note that @iterate@ returns finite sequence, instead "Prelude" prototype. + -} + iterate :: Int -> (e -> e) -> e -> l + iterate n = fromListN n ... iterate n + + -- | Same as @nubBy ('==')@. + nub :: (Eq e) => l -> l + nub = nubBy (==) + + -- | Generalization of nubBy. + nubBy :: Equal e -> l -> l + nubBy f = fromList . nubBy f . listL + + {- Folds with offset. -} + + -- | 'ofoldr' is right fold with offset. + ofoldr :: (Int -> e -> b -> b) -> b -> l -> b + ofoldr f base = ofoldr f base . listL + + -- | 'ofoldl' is left fold with offset. + ofoldl :: (Int -> b -> e -> b) -> b -> l -> b + ofoldl f base = ofoldl f base . listL + + -- | 'ofoldr'' is strict version of 'ofoldr'. + ofoldr' :: (Int -> e -> b -> b) -> b -> l -> b + ofoldr' f = ofoldr (\ !i e !b -> f i e b) + + -- | 'ofoldl'' is strict version of 'ofoldl'. + ofoldl' :: (Int -> b -> e -> b) -> b -> l -> b + ofoldl' f = ofoldl (\ !i !b e -> f i b e) + + {- 'Foldable' crutches. -} + + -- | 'o_foldr' is just 'foldr' in 'Linear' context. + o_foldr :: (e -> b -> b) -> b -> l -> b + o_foldr = ofoldr . const + + -- | 'o_foldl' is just 'foldl' in 'Linear' context. + o_foldl :: (b -> e -> b) -> b -> l -> b + o_foldl = ofoldl . const + + -- | 'o_foldr'' is just 'foldr'' in 'Linear' context. + o_foldr' :: (e -> b -> b) -> b -> l -> b + o_foldr' = ofoldr' . const + + -- | 'o_foldl'' is just 'foldl'' in 'Linear' context. + o_foldl' :: (b -> e -> b) -> b -> l -> b + o_foldl' = ofoldl' . const + +-------------------------------------------------------------------------------- + +{- $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 + {-# MINIMAL (take|sans), (drop|keep) #-} + + -- | @take n es@ takes first @n@ elements of @es@. + take :: Int -> s -> s + default take :: (Bordered s i) => Int -> s -> s + take n es = sans (sizeOf es - n) es + + -- | @drop n es@ drops first @n@ elements of @es@. + drop :: Int -> s -> s + default drop :: (Bordered s i) => Int -> s -> s + drop n es = keep (sizeOf es - n) es + + -- | @keep n es@ takes last @n@ elements of @es@. + keep :: Int -> s -> s + default keep :: (Bordered s i) => Int -> s -> s + keep n es = drop (sizeOf es - n) es + + -- | @sans n es@ drops last @n@ elements of @es@. + sans :: Int -> s -> s + default sans :: (Bordered s i) => Int -> s -> s + sans n es = take (sizeOf es - n) es + + {- | + @save n es@ takes first @n@ elements of @es@ if @n > 0@ and last @-n@ + elements otherwise. + -} + save :: Int -> s -> s + save n = n > 0 ? take n $ keep (-n) + + {- | + @skip n es@ drops first @n@ elements of @es@ if @n > 0@ and last @-n@ + elements otherwise. + -} + skip :: Int -> s -> s + skip n = n > 0 ? drop n $ sans (-n) + + -- | @split n es@ is same to @(take n es, drop n es)@. + split :: Int -> s -> (s, s) + split n es = (take n es, drop n es) + + -- | @divide n es@ is same to @(sans n es, keep n es)@. + divide :: Int -> s -> (s, s) + divide n es = (sans n es, keep n es) + + {- | + Splits line into sequences of given sizes (left to right). + + > splits [5, 3, 12] ['a'..'z'] = ["abcde","fgh","ijklmnopqrst","uvwxyz"] + -} + splits :: (Foldable f) => f Int -> s -> [s] + splits ns es = + let f = \ (r : ds) n -> let (d, r') = split n r in r' : d : ds + in reverse $ foldl f [es] ns + + {- | + Splits line into sequences of given sizes (right to left). + + > divides [5,3,12] ['a'..'z'] == ["abcdef","ghijk","lmn","opqrstuvwxyz"] + -} + divides :: (Foldable f) => f Int -> s -> [s] + divides ns es = + let f = \ n (r : ds) -> let (r', d) = divide n r in r' : d : ds + in foldr f [es] ns + + {- | + Splits structures into parts by given offsets. + + > parts [0,5,6,12,26] ['a'..'z'] = ["","abcde","f","ghijkl","mnopqrstuvwxyz",""] + > -- if previous offset is equal or greater, subline is empty and next + > begins from previous: + > parts [0, 5, 4, 12, 26] ['a' .. 'z'] = ["","abcde","","fghijklm","nopqrstuvwxyz",""] + -} + parts :: (Foldable f) => f Int -> s -> [s] + parts = splits . go . toList where go is = zipWith (-) is (0 : is) + + {- | + Splits structures into chunks of size @n@ and the rest. + + > chunks x [] = [] -- forall x + > chunks 0 es = [] -- forall es + + > chunks 3 [1 .. 10] == [[1,2,3],[4,5,6],[7,8,9],[10]] + -} + chunks :: Int -> s -> [s] + chunks _ Z = [] + chunks n es = n < 1 ? [] $ let (x, xs) = split n es in x : chunks n xs + + {- | + Split line by first (left) separation element. If there is no such + element, @splitBy es = (es, Z)@. + + > splitBy (== '.') "foo" == ("foo","") + > splitBy (== '.') "foo." == ("foo","") + > splitBy (== '.') ".foo" == ("","foo") + > splitBy (== '.') "foo.bar" == ("foo","bar") + > splitBy (== '.') "foo.bar.baz" == ("foo","bar.baz") + -} + splitBy :: (e -> Bool) -> s -> (s, s) + splitBy f = bimap fromList fromList . splitBy f . listL + + {- | + Split line by last (right) separation element. If there is no such + element, @divide es = (Z, es)@. + + > divideBy (== '.') "foo" == ("","foo") + > divideBy (== '.') ".foo" == ("","foo") + > divideBy (== '.') "foo." == ("foo","") + > divideBy (== '.') "foo.bar" == ("foo","bar") + > divideBy (== '.') "foo.bar.baz" == ("foo.bar","baz") + -} + divideBy :: (e -> Bool) -> s -> (s, s) + divideBy f = bimap fromList fromList . divideBy f . listL + + -- | Splits line by separation elements. + splitsBy :: (e -> Bool) -> s -> [s] + splitsBy e = map fromList . splitsBy e . listL + + {- | + @splitsOn sub line@ splits @line@ by @sub@. + + > splitsOn "fo" "foobar bazfoobar1" == ["","obar baz","obar1"] + -} + default splitsOn :: (Eq e, Bordered s i) => s -> s -> [s] + splitsOn :: (Eq e) => s -> s -> [s] + splitsOn sub line = drop (sizeOf sub) <$> parts (infixes sub line) line + + {- | + @replaceBy sub new line@ replace every non-overlapping occurrence of @sub@ + in @line@ with @new@. + + > replaceBy "foo" "bar" "foobafoorbaz" == "barbabarrbaz" + -} + replaceBy :: (Eq e) => s -> s -> s -> s + replaceBy sub new = intercalate new . splitsOn sub + + {- | + Removes every non-overlapping occurrence of @sub@ with 'Z'. + + > removeAll = concat ... splitsOn + > (`replaceBy` Z) = removeAll + -} + removeAll :: (Eq e) => s -> s -> s + removeAll = concat ... splitsOn + + {- | + @combo f es@ returns the length of the @es@ subsequence (left to tight) + whose elements are in order @f@. + + > combo (<) [] == 0 + > combo (<) [1] == 1 + > combo (<) [7, 4, 12] == 1 + > combo (<) [1, 7, 3, 12] == 2 + -} + combo :: Equal e -> s -> Int + combo f = combo f . listL + + {- | + @justifyL n e es@ appends @e@ elements if the @es@ is shorter than @n@, + takes @n@ elements if longer. + -} + 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 :: Int -> e -> s -> s + justifyR n e = keep n . (replicate n e ++) + + {- | + @each n es@ returns each nth element of structure. + If @n == 1@, returns @es@. + If @n < 1@, returns 'Z'. + -} + each :: Int -> s -> s + each n = fromList . each n . listL + + {- | + @eachFrom o n es@ returns each nth element of structure, beginning from o. + + > eachFrom o n = each n . drop o + + > eachFrom 0 2 [1 .. 20] == [2, 4 .. 20] + > eachFrom 1 2 [1 .. 20] == [3, 5 .. 19] + -} + eachFrom :: Int -> Int -> s -> s + eachFrom o n = each n . drop o + + -- | isPrefixOf checks whether the first line is the beginning of the second + isPrefixOf :: (Eq e) => s -> s -> Bool + isPrefixOf (x :> xs) (y :> ys) = x == y && xs `isPrefixOf` ys + isPrefixOf xs _ = isNull xs + + -- | isSuffixOf checks whether the first line is the ending of the second + isSuffixOf :: (Eq e) => s -> s -> Bool + isSuffixOf (xs :< x) (ys :< y) = x == y && xs `isSuffixOf` ys + isSuffixOf xs _ = isNull xs + + -- | isInfixOf checks whether the first line is the substring of the second + isInfixOf :: (Eq e) => s -> s -> Bool + isInfixOf _ Z = False + isInfixOf xs ys = xs `isPrefixOf` ys || xs `isInfixOf` tail ys + + -- | prefix gives length of init, satisfying preducate. + prefix :: (e -> Bool) -> s -> Int + prefix p = o_foldr' (\ e c -> p e ? succ c $ 0) 0 + + -- | suffix gives length of tail, satisfying predicate. + suffix :: (e -> Bool) -> s -> Int + suffix p = o_foldl' (\ c e -> p e ? succ c $ 0) 0 + + {- | + @infixes inf es@ returns a list of @inf@ positions in @es@, without + intersections. + + > "" `infixes` es = [] + > "abba" `infixes` "baababba" == [4] + > "abab" `infixes` "baababab" == [2] + > "aaaa" `infixes` "aaaaaaaa" == [0, 4] + -} + infixes :: (Eq e) => s -> s -> [Int] + infixes = on infixes listL + + -- | @dropSide f = dropWhile f . dropEnd f@. + dropSide :: (e -> Bool) -> s -> s + dropSide f = dropWhile f . dropEnd f + + -- | Takes the longest init by predicate. + takeWhile :: (e -> Bool) -> s -> s + takeWhile p es = take (prefix p es) es + + -- | Drops the longest init by predicate. + dropWhile :: (e -> Bool) -> s -> s + dropWhile p es = drop (prefix p es) es + + -- | Takes the longest suffix by predicate. + takeEnd :: (e -> Bool) -> s -> s + takeEnd p es = keep (suffix p es) es + + -- | Drops the longest prefix by predicate. + dropEnd :: (e -> Bool) -> s -> s + dropEnd p es = sans (suffix p es) es + + -- | Left-side span. + spanl :: (e -> Bool) -> s -> (s, s) + spanl p es = (takeWhile p es, dropWhile p es) + + -- | Left-side break. + breakl :: (e -> Bool) -> s -> (s, s) + breakl p es = (takeWhile (not . p) es, dropWhile (not . p) es) + + -- | Right-side span. + spanr :: (e -> Bool) -> s -> (s, s) + spanr p es = (dropEnd p es, takeEnd p es) + + -- | Right-side break. + breakr :: (e -> Bool) -> s -> (s, s) + breakr p es = (dropEnd (not . p) es, takeEnd (not . p) es) + + {- | + @selectWhile f es@ selects results of applying @f@ to @es@ (left to right) + untill first fail. + -} + selectWhile :: (e -> Maybe a) -> s -> [a] + selectWhile f = selectWhile f . listL + + {- | + @selectEnd f es@ selects results of applying @f@ to @es@ (right to left) + untill first fail. + -} + selectEnd :: (e -> Maybe a) -> s -> [a] + selectEnd f = selectEnd f . listL + + {- | + @extractWhile f es@ selects results of applying @f@ to @es@ (left to + right) untill first fail. Returns selected results and rest of line. + -} + extractWhile :: (e -> Maybe a) -> s -> ([a], s) + extractWhile f es = let as = selectWhile f es in (as, length as `drop` es) + + {- | + @extractEnd f es@ selects results of applying @f@ to @es@ (right to left) + untill first fail. Returns rest of line and selected results. + -} + extractEnd :: (e -> Maybe a) -> s -> (s, [a]) + extractEnd f es = let as = selectEnd f es in (length as `sans` es, as) + + -- | @selectWhile'@ is 'selectWhile' version for generalized structures. + selectWhile' :: (t e ~ l, Split1 t a) => (e -> Maybe a) -> s -> t a + selectWhile' = fromList ... selectWhile + + -- | @selectEnd'@ is 'selectEnd' version for generalized structures. + selectEnd' :: (t e ~ l, Split1 t a) => (e -> Maybe a) -> s -> t a + selectEnd' = fromList ... selectEnd + + -- | @extractWhile'@ is 'extractWhile' version for generalized structures. + extractWhile' :: (t e ~ l, Split1 t a) => (e -> Maybe a) -> s -> (t a, s) + extractWhile' = first fromList ... extractWhile + + -- | @extractEnd'@ is 'extractEnd' version for generalized structures. + extractEnd' :: (t e ~ l, Split1 t a) => (e -> Maybe a) -> s -> (s, t a) + extractEnd' = second fromList ... extractEnd + +-------------------------------------------------------------------------------- + +{- $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 + +-- | Pattern @(':<')@ is right-size view of line. Same as 'unsnoc' and 'toLast'. +pattern (:<) :: (Linear l e) => l -> e -> l +pattern xs :< x <- (unsnoc' -> Just (xs, x)) where (:<) = toLast + +-------------------------------------------------------------------------------- + +-- | Kind @(* -> *)@ 'Linear' structure. +type Linear1 l e = Linear (l e) e + +-- | Kind @(* -> *)@ 'Split' structure. +type Split1 s e = Split (s e) e + +-- | Kind @(* -> *)@ 'Bordered' structure. +type Bordered1 l i e = Bordered (l e) i + +-- | Kind @(* -> * -> *)@ 'Bordered' structure. +type Bordered2 l i e = Bordered (l i e) i + +-------------------------------------------------------------------------------- + +{-# COMPLETE Z, (:) #-} +{-# COMPLETE [], (:>) #-} +{-# COMPLETE [], (:<) #-} + +instance Linear [e] e + where + toHead = (:) + single = pure + (++) = (L.++) + (!^) = (L.!!) + + fromList = id + fromListN = take + fromFoldable = toList + + write es n e = n < 0 ? es $ go n es + where + go i (x : xs) = i == 0 ? e : xs $ x : go (i - 1) xs + go _ _ = [] + + toLast = flip (foldr' (:) . pure) + listR = L.reverse + listL = toList + nubBy = L.nubBy + + -- | O(1) force, same as 'id'. + force = id + + uncons [] = throw $ PatternMatchFail "in SDP.Linear.(:>)" + uncons (e : es) = (e, es) + + unsnoc [ ] = throw $ PatternMatchFail "in SDP.Linear.(:<)" + unsnoc [e] = ([], e) + unsnoc (e : es) = let (es', e') = unsnoc es in (e : es', e') + + filter = L.filter + reverse = L.reverse + replicate = L.replicate + partition = L.partition + concatMap = L.concatMap + intersperse = L.intersperse + isSubseqOf = L.isSubsequenceOf + + iterate n f e = n < 1 ? [] $ e : iterate (n - 1) f (f e) + + ofoldr f base = + let go !i es = case es of {(x : xs) -> f i x $ go (i + 1) xs; _ -> base} + in go 0 + + ofoldl f = + let go !i base es = case es of {(x : xs) -> go (i + 1) (f i base x) xs; _ -> base} + in go 0 + + o_foldr' = foldr' + o_foldl' = foldl' + o_foldr = foldr + o_foldl = foldl + +instance Split [e] e + where + take = L.take + drop = L.drop + split = L.splitAt + + each n = case n <=> 1 of {LT -> const []; EQ -> id; GT -> go n} + where + go i (x : xs) = i == 1 ? x : go n xs $ go (i - 1) xs + go _ _ = [] + + infixes Z = const [] + infixes sub = go 0 + where + go _ [] = [] + go i es = sub `isPrefixOf` es ? i : go (i + n) (drop n es) $ go (i + 1) (tail es) + + n = sizeOf sub + + combo _ [ ] = 0 + combo _ [_] = 1 + combo f (e1 : e2 : es) = e1 `f` e2 ? go 2 e2 es $ 1 + where + go !i p (x : xs) = p `f` x ? go (i + 1) x xs $ i + go i _ _ = i + + splitBy f es = let (as, bs) = breakl f es in isNull bs ? (es, []) $ (as, tail bs) + divideBy f es = let (as, bs) = breakr f es in isNull as ? ([], es) $ (init as, bs) + splitsBy f es = dropWhile f <$> L.findIndices f es `parts` es + + isPrefixOf = L.isPrefixOf + isSuffixOf = L.isSuffixOf + isInfixOf = L.isInfixOf + + breakl = L.break + spanl = L.span + + selectWhile _ [] = [] + selectWhile f (x : xs) = case f x of {(Just e) -> e : select f xs; _ -> []} + + selectEnd f = reverse . selectWhile f . reverse + +-------------------------------------------------------------------------------- + +-- | @stripPrefix sub line@ strips prefix @sub@ of @line@ (if any). +stripPrefix :: (Split s e, Bordered s i, Eq e) => s -> s -> s +stripPrefix sub line = sub `isPrefixOf` line ? drop (sizeOf sub) line $ line + +-- | @stripSuffix sub line@ strips suffix @sub@ of @line@ (if any). +stripSuffix :: (Split s e, Bordered s i, Eq e) => s -> s -> s +stripSuffix sub line = sub `isSuffixOf` line ? sans (sizeOf sub) line $ line + +-- | @stripPrefix' sub line@ strips prefix @sub@ of @line@ or returns 'Nothing'. +stripPrefix' :: (Split s e, Bordered s i, Eq e) => s -> s -> Maybe s +stripPrefix' sub = isPrefixOf sub ?+ drop (sizeOf sub) + +-- | @stripSuffix sub line@ strips suffix @sub@ of @line@ or returns 'Nothing'. +stripSuffix' :: (Split s e, Bordered s i, Eq e) => s -> s -> Maybe s +stripSuffix' sub = isSuffixOf sub ?+ sans (sizeOf sub) + +-- | intercalate is generalization of intercalate +intercalate :: (Foldable f, Linear1 f l, Linear l e) => l -> f l -> l +intercalate = concat ... intersperse + +-- | @tails es@ returns sequence of @es@ tails. +tails :: (Linear l e) => l -> [l] +tails Z = [Z] +tails es = es : tails (tail es) + +-- | tails is generalization of inits. +inits :: (Linear l e) => l -> [l] +inits Z = [Z] +inits es = es : inits (init es) + +{- | + @ascending es lens@ checks if the subsequences of @es@ of lengths @lens@ 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 new file mode 100644 --- /dev/null +++ b/src/SDP/LinearM.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, BangPatterns #-} +{-# LANGUAGE Safe, ConstraintKinds, DefaultSignatures #-} + +{- | + Module : SDP.LinearM + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.LinearM" is a module that provides 'BorderedM' and 'LinearM' classes. +-} +module SDP.LinearM +( + -- * Exports + module SDP.Linear, + + -- * BorderedM class + BorderedM (..), BorderedM1, BorderedM2, + + -- * LinearM class + LinearM (..), LinearM1, + + -- * SplitM class + SplitM (..), SplitM1 +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Linear +import SDP.Map + +default () + +infixl 5 !#> + +-------------------------------------------------------------------------------- + +-- | 'BorderedM' is 'Bordered' version for mutable data structures. +class (Monad m, Index i) => BorderedM m b i | b -> m, b -> i + where + {-# MINIMAL (getBounds|getLower, getUpper) #-} + + -- | 'getBounds' returns 'bounds' of mutable data structure. + getBounds :: b -> m (i, i) + getBounds es = liftA2 (,) (getLower es) (getUpper es) + + -- | 'getLower' returns 'lower' bound of mutable data structure. + getLower :: b -> m i + getLower = fsts . getBounds + + -- | 'getUpper' returns 'upper' bound of mutable data structure. + getUpper :: b -> m i + getUpper = snds . getBounds + + -- | 'getSizeOf' returns 'size' of mutable data structure. + getSizeOf :: b -> m Int + getSizeOf = fmap size . getBounds + + -- | 'getSizesOf' returns 'sizes' of mutable data structure. + getSizesOf :: b -> m [Int] + getSizesOf = fmap sizes . getBounds + + -- | 'nowIndexIn' is 'indexIn' version for mutable structures. + nowIndexIn :: b -> i -> m Bool + nowIndexIn es i = flip inRange i <$> getBounds es + + -- | 'getOffsetOf' is 'offsetOf' version for mutable structures. + getOffsetOf :: b -> i -> m Int + getOffsetOf es i = flip offset i <$> getBounds es + + -- | 'getIndexOf' is 'indexOf' version for mutable structures. + getIndexOf :: b -> Int -> m i + getIndexOf es i = flip index i <$> getBounds es + + -- | 'getIndices' returns 'indices' of mutable data structure. + getIndices :: b -> m [i] + getIndices = fmap range . getBounds + +-------------------------------------------------------------------------------- + +{- | + 'LinearM' is 'Linear' version for mutable data structures. This class is + designed with the possibility of in-place implementation, so many operations + from 'Linear' have no analogues here. +-} +class (Monad m) => LinearM m l e | l -> m, l -> e + where + {-# MINIMAL (newLinear|fromFoldableM), (getLeft|getRight), (!#>), writeM, copyTo #-} + + -- | Monadic 'single'. + newNull :: m l + newNull = newLinear [] + + -- | Monadic 'isNull'. + nowNull :: l -> m Bool + nowNull = fmap isNull . getLeft + + -- | Monadic 'single'. + singleM :: e -> m l + singleM = newLinear . single + + {- | + 'getHead' is monadic version of 'head'. This procedure mustn't modify the + source structure or return references to its mutable fields. + -} + getHead :: l -> m e + getHead = fmap head . getLeft + + {- | + 'getLast' is monadic version of 'last'. This procedure mustn't modify the + source structure or return references to its mutable fields. + -} + getLast :: l -> m e + getLast = fmap head . getRight + + {- | + Prepends new element to the start of the structure (monadic 'toHead'). + Like most size-changing operations, @prepend@ doesn't guarantee the + correctness of the original structure after conversion. + -} + prepend :: e -> l -> m l + prepend e es = newLinear . (e :) =<< getLeft es + + {- | + Appends new element to the end of the structure (monadic 'toLast'). + Like most size-changing operations, @append@ doesn't guarantee the + correctness of the original structure after conversion. + -} + append :: l -> e -> m l + append es e = newLinear . (:< e) =<< getLeft es + + -- | Monadic 'fromList'. + {-# INLINE newLinear #-} + newLinear :: [e] -> m l + newLinear = fromFoldableM + + -- | Monadic 'fromListN'. + {-# INLINE newLinearN #-} + newLinearN :: Int -> [e] -> m l + newLinearN = newLinear ... take + + -- | Monadic 'fromFoldable'. + {-# INLINE fromFoldableM #-} + fromFoldableM :: (Foldable f) => f e -> m l + fromFoldableM = newLinear . toList + + -- | Left view of line. + {-# INLINE getLeft #-} + getLeft :: l -> m [e] + getLeft = fmap reverse . getRight + + -- | Right view of line. + {-# INLINE getRight #-} + getRight :: l -> m [e] + getRight = fmap reverse . getLeft + + -- | (!#>) is unsafe monadic offset-based reader. + (!#>) :: l -> Int -> m e + + -- | Unsafe monadic offset-based writer. + writeM :: l -> Int -> e -> m () + + -- | Create copy. + {-# INLINE copied #-} + copied :: l -> m l + copied = getLeft >=> newLinear + + -- | @copied' es l n@ returns the slice of @es@ from @l@ of length @n@. + {-# INLINE copied' #-} + copied' :: l -> Int -> Int -> m l + copied' es l n = getLeft es >>= newLinearN n . drop l + + -- | Monadic 'reverse'. + {-# INLINE reversed #-} + reversed :: l -> m l + reversed = newLinear <=< getRight + + -- | Monadic 'concat'. + merged :: (Foldable f) => f l -> m l + merged = newLinear . concat <=< sequence . foldr ((:) . getLeft) [] + + -- | Monadic version of 'replicate'. + {-# INLINE filled #-} + filled :: Int -> e -> m l + filled n = newLinearN n . replicate n + + {- | + @copyTo source soff target toff count@ writes @count@ elements of @source@ + from @soff@ to @target@ starting with @toff@. + -} + copyTo :: l -> Int -> l -> Int -> Int -> m () + + -- | 'ofoldrM' is right monadic fold with offset. + ofoldrM :: (Int -> e -> r -> m r) -> r -> l -> m r + ofoldrM f base = foldr ((=<<) . uncurry f) (pure base) . assocs <=< getLeft + + -- | '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 + + -- | 'ofoldrM'' is strict version of 'ofoldrM'. + ofoldrM' :: (Int -> e -> r -> m r) -> r -> l -> m r + ofoldrM' f = ofoldrM (\ !i e !r -> f i e r) + + -- | 'ofoldrM'' is strict version of 'ofoldrM'. + ofoldlM' :: (Int -> r -> e -> m r) -> r -> l -> m r + ofoldlM' f = ofoldlM (\ !i !r e -> f i r e) + + -- | 'foldrM' is just 'ofoldrM' in 'Linear' context. + foldrM :: (e -> r -> m r) -> r -> l -> m r + foldrM = ofoldrM . const + + -- | 'foldlM' is just 'ofoldlM' in 'Linear' context. + foldlM :: (r -> e -> m r) -> r -> l -> m r + foldlM = ofoldlM . const + + -- | 'foldrM'' is strict version of 'foldrM'. + foldrM' :: (e -> r -> m r) -> r -> l -> m r + foldrM' f = foldrM (\ e !r -> f e r) + + -- | 'foldlM'' is strict version of 'foldlM'. + foldlM' :: (r -> e -> m r) -> r -> l -> m r + foldlM' f = foldlM (\ !r e -> f r e) + + -- | 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 + +-------------------------------------------------------------------------------- + +{- | + 'SplitM' is 'Split' version for mutable data structures. This class is + designed with the possibility of in-place implementation, so many operations + from 'Split' have no analogues here. +-} +class (LinearM m s e) => SplitM m s e + where + {-# MINIMAL (takeM|sansM), (dropM|keepM) #-} + + {- | + @takeM n es@ returns a reference to the @es@, keeping first @n@ elements. + Changes in the source and result must be synchronous. + -} + takeM :: Int -> s -> m s + default takeM :: (BorderedM m s i) => Int -> s -> m s + takeM n es = do s <- getSizeOf es; sansM (s - n) es + + {- | + @dropM n es@ returns a reference to the @es@, discarding first @n@ elements. + Changes in the source and result must be synchronous. + -} + dropM :: Int -> s -> m s + default dropM :: (BorderedM m s i) => Int -> s -> m s + dropM n es = do s <- getSizeOf es; keepM (s - n) es + + {- | + @keepM n es@ returns a reference to the @es@, keeping last @n@ elements. + Changes in the source and result must be synchronous. + -} + keepM :: Int -> s -> m s + default keepM :: (BorderedM m s i) => Int -> s -> m s + keepM n es = do s <- getSizeOf es; dropM (s - n) es + + {- | + @sansM n es@ returns a reference to the @es@, discarding last @n@ elements. + Changes in the source and result must be synchronous. + -} + sansM :: Int -> s -> m s + default sansM :: (BorderedM m s i) => Int -> s -> m s + sansM n es = do s <- getSizeOf es; takeM (s - n) es + + {- | + @splitM n es@ returns pair of references to the @es@: keeping and + discarding first @n@ elements. Changes in the source and result must be + synchronous. + -} + splitM :: Int -> s -> m (s, s) + splitM n es = liftA2 (,) (takeM n es) (dropM n es) + + {- | + @divideM n es@ returns pair of references to the @es@: discarding and + keeping last @n@ elements. Changes in the source and results must be + synchronous. + -} + divideM :: Int -> s -> m (s, s) + divideM n es = liftA2 (,) (sansM n es) (keepM n es) + + {- | + @splitM ns es@ returns the sequence of @es@ prefix references of length + @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 + + {- | + @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 + + {- | + @partsM n es@ returns the sequence of @es@ prefix references, splitted by + offsets in @es@. Changes in the source and results must be synchronous. + -} + partsM :: (Foldable f) => f Int -> s -> m [s] + partsM = splitsM . go . toList where go is = zipWith (-) is (0 : is) + + {- | + @chunksM n es@ returns the sequence of @es@ prefix references of length + @n@. Changes in the source and results must be synchronous. + -} + chunksM :: Int -> s -> m [s] + chunksM n es = do (t, d) <- splitM n es; nowNull d ?^ pure [t] $ (t :) <$> chunksM n d + + {- | + @eachM n es@ returns new sequence of @es@ elements with step @n@. eachM + shouldn't return references to @es@. + -} + eachM :: Int -> s -> m s + eachM n = newLinearN n . each n <=< getLeft + + -- | @prefixM p es@ returns the longest @es@ prefix size, satisfying @p@. + prefixM :: (e -> Bool) -> s -> m Int + prefixM p = fmap (prefix p) . getLeft + + -- | @suffixM p es@ returns the longest @es@ suffix size, satisfying @p@. + suffixM :: (e -> Bool) -> s -> m Int + suffixM p = fmap (suffix p) . getLeft + + -- | @mprefix p es@ returns the longest @es@ prefix size, satisfying @p@. + mprefix :: (e -> m Bool) -> s -> m Int + mprefix p = foldr (\ e c -> do b <- p e; b ? succ <$> c $ pure 0) (pure 0) <=< getLeft + + -- | @msuffix p es@ returns the longest @es@ suffix size, satisfying @p@. + msuffix :: (e -> m Bool) -> s -> m Int + msuffix p = foldl (\ c e -> do b <- p e; b ? succ <$> c $ pure 0) (pure 0) <=< getLeft + +-------------------------------------------------------------------------------- + +-- | Kind @(* -> *)@ 'SplitM' structure. +type SplitM1 m l e = SplitM m (l e) e + +-- | Kind @(* -> *)@ 'LinearM' structure. +type LinearM1 m l e = LinearM m (l e) e + +-- | Kind @(* -> *)@ 'BorderedM' structure. +type BorderedM1 m l i e = BorderedM m (l e) i + +-- | Kind @(* -> * -> *)@ 'BorderedM' structure. +type BorderedM2 m l i e = BorderedM m (l i e) i + + + + + diff --git a/src/SDP/Map.hs b/src/SDP/Map.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Map.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE Safe, DefaultSignatures, ConstraintKinds, BangPatterns #-} + +{- | + Module : SDP.Map + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Map" provides 'Map' - class of immutable associative arrays. +-} +module SDP.Map +( + -- * Exports + module SDP.Set, + + -- * Map + Map (..), Map1, Map2 +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Linear +import SDP.Set + +import Data.List ( findIndex, findIndices ) + +import Control.Exception.SDP + +default () + +infixl 9 .!, !, !? + +-------------------------------------------------------------------------------- + +{- | + 'Map' is a class of dictionaries, simple associative arrays with an arbitrary + (implementation-dependent) key. + + 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). +-} +class (Nullable map) => Map map key e | map -> key, map -> e + where + {-# MINIMAL toMap', ((.!) | (!?)) #-} + + -- | Returns list of associations @(index, element)@. + default assocs :: (Bordered map key, Linear map e) => map -> [(key, e)] + assocs :: map -> [(key, e)] + assocs es = indices es `zip` listL es + + {- | + A less specific version of "SDP.Indexed.Indexed.assoc" that creates a new + associative array. For 'Linear' structures without gaps, it may be less + effective. + + > Z // ascs = toMap -- forall ascs + -} + toMap :: [(key, e)] -> map + toMap = toMap' (undEx "toMap {default}") + + {- | + Strict version of 'toMap' with default value. + + Note that the default value is set only for elements included in the range + of the created structure and will not be set for values outside its range + (when expanding, concatenating, etc.) for most structures since they don't + store it. + -} + toMap' :: e -> [(key, e)] -> map + + {- | + @'insert'' key e map@ inserts @e@ with @key@ to @map@. If @map@ already + contains an element with @key@, the element will be overwritten. + + 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) + + {- | + 'delete'' removes element with given key. + + If the structure has boundaries, when removed from the beginning (end), + they should change accordingly. If the structure doesn't allow gaps, then + when removed from the middle, the actual value should be replaced with the + default value. + -} + delete' :: key -> map -> map + default delete' :: (Eq key) => key -> map -> map + delete' k = toMap . except ((== k) . fst) . assocs + + -- | @'member'' key map@ checks if @key@ in @map@. + default member' :: (Bordered map key) => key -> map -> Bool + member' :: key -> map -> Bool + member' = flip indexIn + + -- | Update elements of immutable structure (by copying). + (//) :: map -> [(key, e)] -> map + (//) = toMap ... (++) . assocs + + -- | @('.!')@ is unsafe reader, can be faster @('!')@ by skipping checks. + {-# INLINE (.!) #-} + (.!) :: map -> key -> e + (.!) = (undEx "(.!)" +?) ... (!?) + + -- | @('!')@ is well-safe reader, may 'throw' 'IndexException'. + (!) :: map -> key -> e + default (!) :: (Bordered map key) => map -> key -> e + (!) es i = case inBounds (bounds es) i of + IN -> es .! i + ER -> empEx msg + OR -> overEx msg + UR -> underEx msg + where + msg = "(!) {default}" + + -- | @('!?')@ is completely safe, but very boring function. + (!?) :: map -> key -> Maybe e + (!?) es = flip member' es ?+ (es .!) + + -- | Filter with key. + filter' :: (key -> e -> Bool) -> map -> map + filter' f = toMap . filter (uncurry f) . assocs + + {- | + 'union'' is 'groupSetWith' for maps but works with real groups of + elements, not with consequentive equal elements. + + 'union'' merges/chooses elements with equal keys from two maps. + -} + union' :: (Ord key) => (e -> e -> e) -> map -> map -> map + union' f = toMap ... on go assocs + where + go xs'@(x'@(i, x) : xs) ys'@(y'@(j, y) : ys) = case i <=> j of + LT -> x' : go xs ys' + EQ -> (i, f x y) : go xs ys + GT -> y' : go xs' ys + go xs' Z = xs' + go Z ys' = ys' + + {- | + @'difference'' f mx my@ applies @comb@ to values with equal keys. + If @f x y@ (where @(k1, x) <- mx@, @(k2, y) <- my@, @k1 == k2@) is + 'Nothing', element isn't included to result map. + + Note that 'difference'' is poorer than a similar functions in containers. + -} + difference' :: (Ord key) => (e -> e -> Maybe e) -> map -> map -> map + difference' f = toMap ... on go assocs + where + go xs'@(x'@(i, x) : xs) ys'@((j, y) : ys) = case i <=> j of + GT -> go xs' ys + LT -> x' : go xs ys' + EQ -> case f x y of {(Just e) -> (i, e) : go xs ys; _ -> go xs ys} + go xs' _ = xs' + + {- | + @'intersection'' f mx my@ combines elements of 'intersection'' by @f@: + if @isJust (f x y)@ (where @(k1, x) <- mx, (k2, y) <- my, k1 == k2@), + then element is added to result map. + -} + intersection' :: (Ord key) => (e -> e -> e) -> map -> map -> map + intersection' f = toMap ... on go assocs + where + go xs'@((i, x) : xs) ys'@((j, y) : ys) = case i <=> j of + LT -> go xs ys' + GT -> go xs' ys + EQ -> (i, f x y) : go xs ys + go _ _ = [] + + -- | Update function, by default uses ('!') and may throw 'IndexException'. + update :: map -> (key -> e -> e) -> map + update es f = es // [ (i, f i e) | (i, e) <- assocs es ] + + {- | + @lookupLT' k map@ finds pair @(key, value)@ with smallest @key@, where + @key < k@ (if any). @k@ may not be a @map@ element. + -} + lookupLT' :: (Ord key) => key -> map -> Maybe (key, e) + lookupLT' k = lookupLTWith cmpfst (k, unreachEx "lookupLT'") . assocs + + {- | + @lookupGT' k map@ finds pair @(key, value)@ with greatest @key@, where + @key > k@ (if any). @k@ may not be a @map@ element. + -} + lookupGT' :: (Ord key) => key -> map -> Maybe (key, e) + lookupGT' k = lookupGTWith cmpfst (k, unreachEx "lookupGT'") . assocs + + {- | + @lookupLE' k map@ finds pair @(key, value)@ with smallest @key@, where + @key <= k@ (if any). If @k@ is a @map@ element, returns @(k, e)@. + -} + lookupLE' :: (Ord key) => key -> map -> Maybe (key, e) + lookupLE' k me = (,) k <$> (me !? k) <|> lookupLEWith cmpfst (k, unreachEx "lookupLE'") (assocs me) + + {- | + @lookupGE' k map@ finds pair @(key, value)@ with @key@, where + @key >= k@ (if any). + -} + lookupGE' :: (Ord key) => key -> map -> Maybe (key, e) + lookupGE' k me = (,) k <$> (me !? k) <|> lookupGEWith cmpfst (k, unreachEx "lookupGE'") (assocs me) + + -- | Returns list of map keys. + keys :: map -> [key] + keys = fsts . assocs + + -- | Searches the key of first matching element. + (.$) :: (e -> Bool) -> map -> Maybe key + (.$) = null ?- head ... (*$) + + -- | Searches the keys of all matching elements. + (*$) :: (e -> Bool) -> map -> [key] + (*$) f = select (f . snd ?+ fst) . assocs + + {- Folds with key. -} + + -- | 'kfoldr' is 'foldr' with key. + kfoldr :: (key -> e -> b -> b) -> b -> map -> b + kfoldr f base = foldr (uncurry f) base . assocs + + -- | 'kfoldl' is 'foldl' with key. + kfoldl :: (key -> b -> e -> b) -> b -> map -> b + kfoldl f base = foldl (\ acc (i, e) -> f i acc e) base . assocs + + -- | 'kfoldr'' is strict version of 'kfoldr'. + kfoldr' :: (key -> e -> b -> b) -> b -> map -> b + kfoldr' f = kfoldr (\ !i e !b -> f i e b) + + -- | 'kfoldl'' is strict version of 'kfoldl'. + kfoldl' :: (key -> b -> e -> b) -> b -> map -> b + kfoldl' f = kfoldl (\ !i !b e -> f i b e) + +-------------------------------------------------------------------------------- + +-- | Kind @(* -> *)@ 'Map' structure. +type Map1 map key e = Map (map e) key e + +-- | Kind @(* -> * -> *)@ 'Map' structure. +type Map2 map key e = Map (map key e) key e + +-------------------------------------------------------------------------------- + +instance Map [e] Int e + where + toMap' e = snds . fill . setWith cmpfst + where + fill (ix@(i1, _) : iy@(i2, _) : ies) = + let rest = i1 + 1 == i2 ? iy : ies $ (i1 + 1, e) : iy : ies + in ix : fill rest + fill xs = xs + + assocs = zip [0 ..] . listL + + insert' k e es = k < 0 ? es $ go k es + where + go 0 xs = isNull xs ? [e] $ e : tail xs + go i [] = err : go (i - 1) [] + go i (x : xs) = x : go (i - 1) xs + + err = undEx "insert'" + + (x : xs) .! n = n == 0 ? x $ xs .! (n - 1) + _ .! _ = error "in SDP.Map.(.!)" + + (!) [] _ = empEx "(!)" + (!) es n = n >= 0 ? es !# n $ underEx "(!)" + where + [] !# _ = overEx "(!)" + (x : xs) !# n' = n' == 0 ? x $ xs !# (n' - 1) + + [] !? _ = Nothing + (x : xs) !? n = case n <=> 0 of + GT -> xs !? (n - 1) + EQ -> Just x + LT -> Nothing + + xs // es = snds $ unionWith cmpfst (setWith cmpfst es) (assocs xs) + + (.$) = findIndex + (*$) = findIndices + + kfoldr f base = + let go i es = case es of {(x : xs) -> f i x $ go (i + 1) xs; _ -> base} + in go 0 + + kfoldl f = + let go i e es = case es of {(x : xs) -> go (i + 1) (f i e x) xs; _ -> e} + in go 0 + +-------------------------------------------------------------------------------- + +empEx :: String -> a +empEx = throw . EmptyRange . showString "in SDP.Map." + +undEx :: String -> a +undEx = throw . UndefinedValue . showString "in SDP.Map." + +overEx :: String -> a +overEx = throw . IndexOverflow . showString "in SDP.Map." + +underEx :: String -> a +underEx = throw . IndexUnderflow . showString "in SDP.Map." + +unreachEx :: String -> a +unreachEx = throw . UnreachableException . showString "in SDP.Map." + + + diff --git a/src/SDP/MapM.hs b/src/SDP/MapM.hs new file mode 100644 --- /dev/null +++ b/src/SDP/MapM.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE Safe, DefaultSignatures, ConstraintKinds, BangPatterns #-} + +{- | + Module : SDP.MapM + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.MapM" provides 'MapM' - class of mutable associative arrays. +-} +module SDP.MapM +( + -- * Mutable maps + MapM (..), MapM1, MapM2 +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.LinearM + +import Data.Maybe ( listToMaybe ) + +import Control.Exception.SDP + +default () + +infixl 5 >!, !>, !?> + +-------------------------------------------------------------------------------- + +-- | 'MapM' is class of mutable associative arrays. +class (Monad m) => MapM m map key e | map -> m, map -> key, map -> e + where + {-# MINIMAL newMap', overwrite, ((>!)|(!?>)), kfoldrM, kfoldlM #-} + + -- | Create new mutable map from list of @(key, element)@ associations. + newMap :: [(key, e)] -> m map + newMap = newMap' (undEx "newMap {default}") + + -- | Create new mutable map from list of @(key, element)@ associations. + newMap' :: e -> [(key, e)] -> m map + + -- | 'getAssocs' is version of 'SDP.Map.assocs' for mutable maps. + default getAssocs :: (LinearM m map e) => map -> m [(key, e)] + getAssocs :: map -> m [(key, e)] + getAssocs es = liftA2 zip (getKeys es) (getLeft es) + + -- | @('>!')@ is unsafe monadic reader. + {-# INLINE (>!) #-} + (>!) :: map -> key -> m e + (>!) = fmap (undEx "(!) {default}" +?) ... (!?>) + + -- | @('!>')@ is well-safe monadic reader. + {-# INLINE (!>) #-} + default (!>) :: (BorderedM m map key) => map -> key -> m e + (!>) :: map -> key -> m e + es !> i = do + let msg = "(!>) {default}" + bnds <- getBounds es + case inBounds bnds i of + IN -> es >! i + ER -> empEx msg + OR -> overEx msg + UR -> underEx msg + + -- | @('!?>')@ is completely safe monadic reader. + (!?>) :: map -> key -> m (Maybe e) + es !?> i = do b <- memberM' es i; b ? Just <$> (es >! i) $ pure empty + + -- | Update elements by mapping with indices. + updateM :: map -> (key -> e -> e) -> m map + updateM es f = do ascs <- getAssocs es; es `overwrite` [ (i, f i e) | (i, e) <- ascs ] + + {- | + This function designed to overwrite large enough fragments of the + structure (unlike 'writeM' and 'SDP.IndexedM.writeM'') + + In addition to write operations, 'overwrite' can move and clean, optimize + data presentation, etc. of a particular structure. Since the reference to + the original structure may not be the same as reference to the result + (which implementation is undesirable, but acceptable), the original + reference (argument) shouldn't be used after 'overwrite'. + + All standard @sdp@ structures support safe in-place 'overwrite'. + + If the structure uses unmanaged memory, then all unused fragments in the + resulting structure must be deallocated, regardless of reachability by + original reference (argument). + + Please note that @overwrite@ require a list of associations with indices + in the current structure bounds and ignore any other, therefore: + + > fromAssocs bnds ascs /= (fromAssocs bnds ascs >>= flip overwrite ascs) + -} + overwrite :: map -> [(key, e)] -> m map + + -- | Checks if key in map. + default memberM' :: (BorderedM m map key) => map -> key -> m Bool + memberM' :: map -> key -> m Bool + memberM' = nowIndexIn + + -- | Returns list of map keys. + default getKeys :: (BorderedM m map key) => map -> m [key] + getKeys :: map -> m [key] + getKeys = getIndices + + -- | (.?) is monadic version of (.$). + (.?) :: (e -> Bool) -> map -> m (Maybe key) + (.?) = fmap listToMaybe ... (*?) + + -- | (*?) is monadic version of (*$). + (*?) :: (e -> Bool) -> map -> m [key] + (*?) p = (select (p . snd ?+ fst) <$>) . getAssocs + + -- | 'kfoldrM' is right monadic fold with key. + kfoldrM :: (key -> e -> acc -> m acc) -> acc -> map -> m acc + kfoldrM f base = foldr ((=<<) . uncurry f) (pure base) <=< getAssocs + + -- | 'kfoldlM' is left monadic fold with key. + kfoldlM :: (key -> acc -> e -> m acc) -> acc -> map -> m acc + kfoldlM f base = foldl (flip $ \ (i, e) -> (flip (f i) e =<<)) (pure base) <=< getAssocs + + -- | 'kfoldrM'' is strict version of 'kfoldrM'. + kfoldrM' :: (key -> e -> acc -> m acc) -> acc -> map -> m acc + kfoldrM' f = kfoldrM (\ !i e !r -> f i e r) + + -- | 'kfoldlM'' is strict version of 'kfoldlM'. + kfoldlM' :: (key -> acc -> e -> m acc) -> acc -> map -> m acc + kfoldlM' f = kfoldlM (\ !i !r e -> f i r e) + +-------------------------------------------------------------------------------- + +-- | Rank @(* -> *)@ 'MapM'. +type MapM1 m map key e = MapM m (map e) key e + +-- | Rank @(* -> * -> *)@ 'MapM'. +type MapM2 m map key e = MapM m (map key e) key e + +-------------------------------------------------------------------------------- + +empEx :: String -> a +empEx = throw . EmptyRange . showString "in SDP.MapM." + +undEx :: String -> a +undEx = throw . UndefinedValue . showString "in SDP.MapM." + +overEx :: String -> a +overEx = throw . IndexOverflow . showString "in SDP.MapM." + +underEx :: String -> a +underEx = throw . IndexUnderflow . showString "in SDP.MapM." + diff --git a/src/SDP/Nullable.hs b/src/SDP/Nullable.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Nullable.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP, Trustworthy, PatternSynonyms, ViewPatterns, MagicHash #-} + +{- | + Module : SDP.Nullable + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Nullable" provides 'Nullable' - class of types with empty values. +-} +module SDP.Nullable +( + -- * Nullable + Nullable (..), pattern NULL +) +where + +import Foreign.Ptr + +import GHC.ForeignPtr +import GHC.Stable +import GHC.Base +import GHC.Exts + +default () + +-------------------------------------------------------------------------------- + +-- | 'Nullable' is class of types which value may be empty. +class Nullable e + where + -- | Empty value. + lzero :: e + + -- | Is value empty? + isNull :: 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 + +-------------------------------------------------------------------------------- + +instance Nullable (Maybe e) + where + isNull = \ mx -> case mx of {Nothing -> True; _ -> False} + lzero = Nothing + +instance Nullable [e] + where + isNull = null + lzero = [] + +instance Nullable (Ptr e) + where + isNull = (== nullPtr) + lzero = nullPtr + +-- Stolen from @bytestring@ package. +instance Nullable (ForeignPtr e) + where +#if __GLASGOW_HASKELL__ >= 811 + lzero = ForeignPtr nullAddr# FinalPtr +#else + lzero = ForeignPtr nullAddr# (error "nullForeignPtr in SDP.Nullable.lzero") +#endif + + isNull (ForeignPtr addr# _) = Ptr addr# == nullPtr + +instance Nullable (StablePtr e) + where + lzero = StablePtr (unsafeCoerce# 0#) + isNull = (== lzero) + diff --git a/src/SDP/Prim/SArray.hs b/src/SDP/Prim/SArray.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Prim/SArray.hs @@ -0,0 +1,1225 @@ +{-# LANGUAGE Trustworthy, MagicHash, UnboxedTuples, BangPatterns, TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, RoleAnnotations #-} + +{- | + Module : SDP.Prim.SArray + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Prim.SArray" provides lazy boxed array pseudo-primitive types + 'SArray#', 'STArray#' and 'IOArray#'. +-} +module SDP.Prim.SArray +( + -- * Exports + module SDP.IndexedM, + module SDP.SortM, + module SDP.Sort, + + -- * Pseudo-primitive types + MIOArray# (..), IOArray#, STArray#, SArray#, + + -- ** Safe (copy) unpack + fromSArray#, fromSTArray#, + + -- ** Unsafe unpack + unpackSArray#, offsetSArray#, unpackSTArray#, offsetSTArray#, + + -- ** Unsafe pack + packSArray#, packSTArray#, + + -- ** Coerce + coerceSArray#, coerceSTArray# +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.IndexedM +import SDP.SortM +import SDP.Sort +import SDP.Scan + +import SDP.SortM.Tim + +import qualified GHC.Exts as E +import GHC.Exts + ( + Array#, MutableArray#, State#, Int#, + + newArray#, indexArray#, readArray#, writeArray#, + + thawArray#, unsafeThawArray#, freezeArray#, unsafeFreezeArray#, + + copyArray#, copyMutableArray#, cloneArray#, cloneMutableArray#, + + sameMutableArray#, (+#), (-#), (==#) + ) + +import GHC.Types +import GHC.ST ( ST (..), STRep ) + +import Data.Default.Class +import Data.Typeable +import Data.Coerce +import Data.String +import Data.Proxy + +import Text.Read + +import Foreign ( Ptr, Storable, callocArray, peekElemOff, pokeElemOff ) + +import Control.Exception.SDP + +default () + +-------------------------------------------------------------------------------- + +{- | + 'SArray#' is immutable pseudo-primitive 'Int'-indexed lazy boxed array type. + + 'SArray#' isn't real Haskell primitive (like "GHC.Exts" types) but for + reliability and stability, I made it inaccessible to direct work. +-} +data SArray# e = SArray# + {-# UNPACK #-} !Int -- ^ Element count (not a real size) + {-# UNPACK #-} !Int -- ^ Offset (is elements) + !(Array# e) -- ^ Real primitive array + deriving ( Typeable ) + +type role SArray# representational + +-------------------------------------------------------------------------------- + +{- Eq and Eq1 instances. -} + +instance (Eq e) => Eq (SArray# e) where (==) = eq1 + +instance Eq1 SArray# + where + liftEq eq xs@(SArray# c1 _ _) ys@(SArray# c2 _ _) = + let eq' i = i == c1 || eq (xs !^ i) (ys !^ i) && eq' (i + 1) + in c1 == c2 && eq' 0 + +-------------------------------------------------------------------------------- + +{- Ord and Ord1 instances. -} + +instance (Ord e) => Ord (SArray# e) where compare = compare1 + +instance Ord1 SArray# + where + liftCompare f xs@(SArray# c1 _ _) ys@(SArray# c2 _ _) = + let f' i = i == (c1`min`c2) ? c1 <=> c2 $ (xs!^i) `f` (ys!^i) <> f' (i+1) + in f' 0 + +-------------------------------------------------------------------------------- + +{- Show and Read instances. -} + +instance (Show e) => Show (SArray# e) where showsPrec p = showsPrec p . listL + +instance (Read e) => Read (SArray# e) where readPrec = fromList <$> readPrec + +-------------------------------------------------------------------------------- + +{- Overloaded Lists and Strings support. -} + +instance IsString (SArray# Char) where fromString = fromList + +instance E.IsList (SArray# e) + where + type Item (SArray# e) = e + + fromListN = fromListN + fromList = fromList + toList = toList + +-------------------------------------------------------------------------------- + +{- Semigroup, Monoid, Nullable, Default and Estimate instances. -} + +instance Nullable (SArray# e) + where + lzero = runST $ filled 0 (unreachEx "lzero") >>= done + isNull = \ (SArray# c _ _) -> c == 0 + +instance Semigroup (SArray# e) where (<>) = (++) +instance Monoid (SArray# e) where mempty = Z +instance Default (SArray# e) where def = Z + +instance Estimate (SArray# e) + where + (<==>) = on (<=>) sizeOf + (.<=.) = on (<=) sizeOf + (.>=.) = on (>=) sizeOf + (.>.) = on (>) sizeOf + (.<.) = on (<) sizeOf + + (<.=>) = (<=>) . sizeOf + (.>=) = (>=) . sizeOf + (.<=) = (<=) . sizeOf + (.>) = (>) . sizeOf + (.<) = (<) . sizeOf + +-------------------------------------------------------------------------------- + +{- Functor, Zip and Applicative instances. -} + +instance Functor SArray# + where + fmap f arr@(SArray# n@(I# n#) _ _) = runST $ ST $ \ s1# -> + case newArray# n# (unreachEx "fmap") s1# of + (# s2#, marr# #) -> + let go i@(I# i#) s3# = if i == n + then case unsafeFreezeArray# marr# s3# of (# s4#, arr# #) -> (# s4#, SArray# n 0 arr# #) + else case writeArray# marr# i# (f $ arr ! i) s3# of s5# -> go (i + 1) s5# + in go 0 s2# + +instance Zip SArray# + where + all2 f as bs = go (minimum [sizeOf as, sizeOf 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]) + 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]) + 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]) + 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]) + 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]) + 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]) + 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]) + 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]) + 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]) + where + apply i = f (as!^i) (bs!^i) (cs!^i) (ds!^i) (es!^i) (fs!^i) + + go 0 = False + go i = let i' = i - 1 in apply i' || go i' + + zipWith f as bs = fromListN sz $ apply <$> range (0, sz - 1) + where + apply i = f (as !^ i) (bs !^ i) + sz = minimum [sizeOf as, sizeOf bs] + + zipWith3 f as bs cs = fromListN sz $ apply <$> range (0, sz - 1) + where + apply i = f (as !^ i) (bs !^ i) (cs !^ i) + sz = minimum [sizeOf as, sizeOf bs, sizeOf cs] + + zipWith4 f as bs cs ds = fromListN sz $ apply <$> range (0, sz - 1) + where + apply i = f (as !^ i) (bs !^ i) (cs !^ i) (ds !^ i) + sz = minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds] + + zipWith5 f as bs cs ds es = fromListN sz $ apply <$> range (0, sz - 1) + where + apply i = f (as !^ i) (bs !^ i) (cs !^ i) (ds !^ i) (es !^ i) + sz = minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds, sizeOf es] + + zipWith6 f as bs cs ds es fs = fromListN sz $ apply <$> range (0, sz - 1) + where + apply i = f (as !^ i) (bs !^ i) (cs !^ i) (ds !^ i) (es !^ i) (fs !^ i) + sz = minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds, sizeOf es, sizeOf fs] + +instance Applicative SArray# + where + pure = single + fs <*> es = concatMap (<$> es) fs + +-------------------------------------------------------------------------------- + +{- Foldable and Traversable instances. -} + +instance Foldable SArray# + where + foldr f base = \ arr -> + let go i = arr .== i ? base $ f (arr !^ i) (go $ i + 1) + in go 0 + + foldl f base = \ arr -> + let go i = -1 == i ? base $ f (go $ i - 1) (arr !^ i) + in go (sizeOf arr - 1) + + foldr' f base = \ arr -> + let go i !a = -1 == i ? a $ go (i - 1) (f (arr !^ i) a) + in go (sizeOf arr - 1) base + + foldl' f base = \ arr -> + let go i !a = arr .== i ? a $ go (i + 1) (f a $ arr !^ i) + in go 0 base + + foldr1 f = \ arr -> + let go i = arr .== (i + 1) ? e $ f e (go $ i + 1) where e = arr !^ i + in null arr ? pfailEx "foldr1" $ go 0 + + foldl1 f = \ arr -> + let go i = 0 == i ? e $ f (go $ i - 1) e where e = arr !^ i + in null arr ? pfailEx "foldl1" $ go (sizeOf arr - 1) + + length = sizeOf + null = isNull + +instance Traversable SArray# + where + traverse f = fmap fromList . foldr (liftA2 (:) . f) (pure []) + +-------------------------------------------------------------------------------- + +{- Linear, Split and Bordered instances. -} + +instance Linear (SArray# e) e + where + replicate n e = runST $ filled n e >>= done + single e = runST $ filled 1 e >>= done + + toHead e (SArray# (I# c#) (I# o#) arr#) = let n# = c# +# 1# in runST $ ST $ + \ s1# -> case newArray# n# e s1# of + (# s2#, marr# #) -> case copyArray# arr# o# marr# 1# c# s2# of + s3# -> case unsafeFreezeArray# marr# s3# of + (# s4#, res# #) -> (# s4#, SArray# (I# n#) 0 res# #) + + toLast (SArray# (I# c#) (I# o#) arr#) e = let n# = c# +# 1# in runST $ ST $ + \ s1# -> case newArray# n# e s1# of + (# s2#, marr# #) -> case copyArray# arr# o# marr# 0# c# s2# of + s3# -> case unsafeFreezeArray# marr# s3# of + (# s4#, res# #) -> (# s4#, SArray# (I# n#) 0 res# #) + + head es = es !^ 0 + last es@(SArray# c _ _) = es !^ (c - 1) + init (SArray# c o arr#) = SArray# (max 1 c - 1) o arr# + tail (SArray# c o arr#) = SArray# (max 1 c - 1) (o + 1) arr# + + fromList = fromFoldable + + fromListN n es = runST $ newLinearN n es >>= done + fromFoldable es = runST $ fromFoldableM es >>= done + + -- [internal]: always return new array, even if (at least) one is empty + SArray# (I# n1#) (I# o1#) arr1# ++ SArray# (I# n2#) (I# o2#) arr2# = + runST $ ST $ \ s1# -> case newArray# n# (unreachEx "(++)") s1# of + (#s2#, marr# #) -> case copyArray# arr1# o1# marr# 0# n1# s2# of + s3# -> case copyArray# arr2# o2# marr# n1# n2# s3# of + s4# -> case unsafeFreezeArray# marr# s4# of + (# s5#, arr# #) -> (# s5#, SArray# (I# n#) 0 arr# #) + where + n# = n1# +# n2# + + force (SArray# n@(I# n#) (I# o#) arr#) = runST $ ST $ + \ s1# -> case newArray# n# (unreachEx "force") s1# of + (# s2#, marr# #) -> case copyArray# arr# o# marr# 0# n# s2# of + s3# -> case unsafeFreezeArray# marr# s3# of + (# s4#, copy# #) -> (# s4#, SArray# n 0 copy# #) + + listL = toList + listR = flip (:) `foldl` [] + + (!^) (SArray# _ (I# o#) arr#) = \ (I# i#) -> + case indexArray# arr# (i# +# o#) of (# e #) -> e + + write es n e = not (indexIn es n) ? es $ runST $ do + es' <- thaw es + writeM es' n e + done es' + + reverse es = runST $ fromIndexed' es >>= reversed >>= done + + -- [internal]: always return new array, even if only one is nonempty + concat ess = runST $ do + let n = foldr' ((+) . sizeOf) 0 ess + 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 #) + + void $ foldl (\ b a -> write# a =<< b) (return 0) ess + done marr + + select f = foldr (\ o es -> case f o of {Just e -> e : es; _ -> es}) [] + + extract f = + let g = \ o -> case f o of {Just e -> first (e :); _ -> second (o :)} + in second fromList . foldr g ([], []) + + selects fs = second fromList . selects fs . listL + + ofoldr f base = \ arr@(SArray# c _ _) -> + let go i = c == i ? base $ f i (arr !^ i) (go $ i + 1) + in go 0 + + ofoldl f base = \ arr@(SArray# c _ _) -> + let go i = -1 == i ? base $ f i (go $ i - 1) (arr !^ i) + in go (c - 1) + + o_foldr = foldr + o_foldl = foldl + +instance Split (SArray# e) e + where + -- | O(1) 'take', O(1) memory. + take n es@(SArray# c o arr#) + | n <= 0 = Z + | n >= c = es + | True = SArray# n o arr# + + -- | O(1) 'drop', O(1) memory. + drop n es@(SArray# c o arr#) + | n <= 0 = es + | n >= c = Z + | True = SArray# (c - n) (o + n) arr# + + -- | O(1) 'split', O(1) memory. + split n es@(SArray# c o arr#) + | n <= 0 = (Z, es) + | n >= c = (es, Z) + | True = (SArray# n o arr#, SArray# (c - n) (o + n) arr#) + + -- | O(1) 'keep', O(1) memory. + keep n es@(SArray# c o arr#) + | n <= 0 = Z + | n >= c = es + | True = SArray# n (o + c - n) arr# + + -- | O(1) 'sans', O(1) memory. + sans n es@(SArray# c o arr#) + | n <= 0 = es + | n >= c = Z + | True = SArray# (c - n) o arr# + + -- | O(1) 'divide', O(1) memory. + divide n es@(SArray# c o arr#) + | n <= 0 = (Z, es) + | n >= c = (es, Z) + | True = (SArray# n (o + c - n) arr#, SArray# (c - n) o arr#) + + splitsBy f es = dropWhile f <$> f *$ es `parts` es + + justifyL n@(I# n#) e es@(SArray# c@(I# c#) (I# o#) src#) = case c <=> n of + EQ -> es + GT -> take n es + LT -> runST $ ST $ \ s1# -> case newArray# n# e s1# of + (# s2#, marr# #) -> case copyArray# src# o# marr# 0# c# s2# of + s3# -> case unsafeFreezeArray# marr# s3# of + (# s4#, arr# #) -> (# s4#, SArray# n 0 arr# #) + + justifyR n@(I# n#) e es@(SArray# c@(I# c#) (I# o#) src#) = case c <=> n of + EQ -> es + GT -> take n es + LT -> runST $ ST $ \ s1# -> case newArray# n# e s1# of + (# s2#, marr# #) -> case copyArray# src# o# marr# (n# -# c#) c# s2# of + s3# -> case unsafeFreezeArray# marr# s3# of + (# s4#, arr# #) -> (# s4#, SArray# n 0 arr# #) + + combo _ Z = 0 + combo f es@(SArray# n _ _) = + let go e i = let e' = es !^ i in i == n || not (f e e') ? i $ go e' (i + 1) + in go (head es) 1 + + each n es@(SArray# c _ _) = + let go i = i < c ? es!^i : go (i + n) $ [] + in case n <=> 1 of {LT -> Z; EQ -> es; GT -> fromList $ go (n - 1)} + + isPrefixOf xs@(SArray# c1 _ _) ys@(SArray# c2 _ _) = + let eq i = i == c1 || (xs !^ i) == (ys !^ i) && eq (i + 1) + in c1 <= c2 && eq 0 + + isSuffixOf xs@(SArray# c1 _ _) ys@(SArray# c2 _ _) = + let eq i j = i == c1 || (xs !^ i) == (ys !^ j) && eq (i + 1) (j + 1) + in c1 <= c2 && eq 0 (c2 - c1) + + selectWhile f es@(SArray# c _ _) = + let go i = i == c ? [] $ maybe [] (: go (i + 1)) $ f (es !^ i) + in go 0 + + selectEnd g xs@(SArray# c _ _) = + let go i es = i == 0 ? [] $ maybe [] (: go (i - 1) es) $ g (es !^ i) + in reverse $ go (c - 1) xs + +instance Bordered (SArray# e) Int + where + lower _ = 0 + + sizeOf (SArray# c _ _) = c + upper (SArray# c _ _) = c - 1 + bounds (SArray# c _ _) = (0, c - 1) + indices (SArray# c _ _) = [0 .. c - 1] + indexOf (SArray# c _ _) = index (0, c - 1) + offsetOf (SArray# c _ _) = offset (0, c - 1) + indexIn (SArray# c _ _) = \ i -> i >= 0 && i < c + +-------------------------------------------------------------------------------- + +{- Set, SetWith, Scan and Sort instances. -} + +instance (Ord e) => Set (SArray# e) e + +instance SetWith (SArray# e) e + where + 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 + + deleteWith f e es = memberWith f e es ? except (\ x -> f e x == EQ) es $ es + + {-# INLINE intersectionWith #-} + intersectionWith f xs@(SArray# n1 _ _) ys@(SArray# n2 _ _) = fromList $ go 0 0 + where + go i j = i == n1 || j == n2 ? [] $ case x `f` y of + EQ -> x : go (i + 1) (j + 1) + LT -> go (i + 1) j + GT -> go i (j + 1) + where + x = xs !^ i + y = ys !^ j + + {-# INLINE unionWith #-} + unionWith f xs@(SArray# n1 _ _) ys@(SArray# n2 _ _) = fromList $ go 0 0 + where + go i j + | i == n1 = (ys !^) <$> [j .. n2 - 1] + | j == n2 = (xs !^) <$> [i .. n1 - 1] + | True = case x `f` y of + EQ -> x : go (i + 1) (j + 1) + LT -> x : go (i + 1) j + GT -> y : go i (j + 1) + where + x = xs !^ i + y = ys !^ j + + {-# INLINE differenceWith #-} + differenceWith f xs@(SArray# n1 _ _) ys@(SArray# n2 _ _) = fromList $ go 0 0 + where + go i j + | i == n1 = [] + | j == n2 = (xs !^) <$> [i .. n1 - 1] + | True = case x `f` y of + EQ -> go (i + 1) (j + 1) + LT -> x : go (i + 1) j + GT -> go i (j + 1) + where + x = xs !^ i + y = ys !^ j + + {-# INLINE symdiffWith #-} + symdiffWith f xs@(SArray# n1 _ _) ys@(SArray# n2 _ _) = fromList $ symdiff' 0 0 + where + symdiff' i j + | i == n1 = (ys !^) <$> [j .. n2 - 1] + | j == n2 = (xs !^) <$> [i .. n1 - 1] + | True = case x `f` y of + EQ -> symdiff' (i + 1) (j + 1) + LT -> x : symdiff' (i + 1) j + GT -> y : symdiff' i (j + 1) + where + x = xs !^ i + y = ys !^ j + + memberWith = binaryContain + + lookupLTWith _ _ Z = Nothing + lookupLTWith f o es + | GT <- o `f` last' = Just last' + | GT <- o `f` head' = look' head' 0 u' + | True = Nothing + where + head' = es .! 0 + last' = es .! u' + u' = upper es + + look' r l u = l > u ? Just r $ case o `f` e of + EQ -> Just $ j < 1 ? r $ es !^ (j - 1) + LT -> look' r l (j - 1) + GT -> look' e (j + 1) u + where + j = l + (u - l) `div` 2 + e = es !^ j + + lookupLEWith _ _ Z = Nothing + lookupLEWith f o es + | GT <- o `f` last' = Just last' + | LT <- o `f` head' = Nothing + | True = look' head' 0 u' + where + head' = es .! 0 + last' = es .! u' + u' = upper es + + look' r l u = l > u ? Just r $ case o `f` e of + LT -> look' r l (j - 1) + _ -> look' e (j + 1) u + where + j = l + (u - l) `div` 2 + e = es !^ j + + lookupGTWith _ _ Z = Nothing + lookupGTWith f o es + | LT <- o `f` head' = Just head' + | LT <- o `f` last' = look' last' 0 u' + | True = Nothing + where + head' = es .! 0 + last' = es .! u' + u' = upper es + + look' r l u = l > u ? Just r $ case o `f` e of + LT -> look' e l (j - 1) + EQ -> j >= u' ? Nothing $ Just (es !^ (j + 1)) + GT -> look' r (j + 1) u + where + j = l + (u - l) `div` 2 + e = es !^ j + + lookupGEWith _ _ Z = Nothing + lookupGEWith f o es + | GT <- o `f` last' = Nothing + | GT <- o `f` head' = look' last' 0 u' + | True = Just head' + where + head' = es .! 0 + last' = es .! u' + u' = upper es + + look' r l u = l > u ? Just r $ case o `f` e of + LT -> look' e l (j - 1) + EQ -> Just e + GT -> look' r (j + 1) u + where + j = l + (u - l) `div` 2 + e = es !^ j + +instance Scan (SArray# e) e + +instance Sort (SArray# e) e + where + sortBy cmp es = runST $ do es' <- thaw es; timSortBy cmp es'; done es' + sortedBy f es = all2 f es (tail es) + +-------------------------------------------------------------------------------- + +{- Indexed instance. -} + +instance Map (SArray# e) Int e + where + toMap' e ascs = isNull ascs ? Z $ assoc' (ascsBounds ascs) e ascs + + Z // ascs = toMap ascs + es // ascs = runST $ fromFoldableM es >>= (`overwrite` ascs) >>= done + + (*$) p = ofoldr (\ i e is -> p e ? (i : is) $ is) [] + (.!) = (!^) + + kfoldr = ofoldr + kfoldl = ofoldl + +instance Indexed (SArray# e) Int e + where + assoc' bnds defvalue ascs = runST $ fromAssocs' bnds defvalue ascs >>= done + + 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 + +-------------------------------------------------------------------------------- + +instance Thaw (ST s) (SArray# e) (STArray# s e) + where + thaw (SArray# c@(I# c#) (I# o#) arr#) = ST $ + \ s1# -> case thawArray# arr# o# c# s1# of + (# s2#, marr# #) -> (# s2#, STArray# c 0 marr# #) + + unsafeThaw (SArray# c o arr#) = ST $ + \ s1# -> case unsafeThawArray# arr# s1# of + (# s2#, marr# #) -> (# s2#, STArray# c o marr# #) + +instance Freeze (ST s) (STArray# s e) (SArray# e) + where + freeze (STArray# c@(I# c#) (I# o#) marr#) = ST $ + \ s1# -> case freezeArray# marr# o# c# s1# of + (# s2#, arr# #) -> (# s2#, SArray# c 0 arr# #) + + unsafeFreeze = done + +-------------------------------------------------------------------------------- + +-- | 'STArray#' is mutable preudo-primitive 'Int'-indexed lazy boxed array type. +data STArray# s e = STArray# + {-# UNPACK #-} !Int -- ^ Element count (not a real size) + {-# UNPACK #-} !Int -- ^ Offset (in elements) + !(MutableArray# s e) -- ^ Real primitive array + deriving ( Typeable ) + +type role STArray# nominal representational + +-------------------------------------------------------------------------------- + +instance Eq (STArray# s e) + where + (STArray# c1 o1 marr1#) == (STArray# c2 o2 marr2#) = + let same = isTrue# (sameMutableArray# marr1# marr2#) + in c1 == c2 && (c1 == 0 || o1 == o2 && same) + +-------------------------------------------------------------------------------- + +{- Estimate, Bordered, BorderedM, LinearM and SplitM instances. -} + +instance Estimate (STArray# s e) + where + (<==>) = on (<=>) sizeOf + (.<=.) = on (<=) sizeOf + (.>=.) = on (>=) sizeOf + (.>.) = on (>) sizeOf + (.<.) = on (<) sizeOf + + (<.=>) = (<=>) . sizeOf + (.>=) = (>=) . sizeOf + (.<=) = (<=) . sizeOf + (.>) = (>) . sizeOf + (.<) = (<) . sizeOf + +instance Bordered (STArray# s e) Int + where + lower _ = 0 + + sizeOf (STArray# c _ _) = c + upper (STArray# c _ _) = c - 1 + bounds (STArray# c _ _) = (0, c - 1) + indices (STArray# c _ _) = [0 .. c - 1] + indexOf (STArray# c _ _) = index (0, c - 1) + offsetOf (STArray# c _ _) = offset (0, c - 1) + indexIn (STArray# c _ _) = \ i -> i >= 0 && i < c + +instance BorderedM (ST s) (STArray# s e) Int + where + nowIndexIn (STArray# c _ _) = return . inRange (0, c - 1) + getIndices (STArray# c _ _) = return [0 .. c - 1] + getBounds (STArray# c _ _) = return (0, c - 1) + getUpper (STArray# c _ _) = return (c - 1) + getSizeOf (STArray# c _ _) = return c + + getLower _ = return 0 + +instance LinearM (ST s) (STArray# s e) e + where + newNull = ST $ \ s1# -> case newArray# 0# (unreachEx "newNull") s1# of + (# s2#, marr# #) -> (# s2#, STArray# 0 0 marr# #) + + nowNull es = return (sizeOf es < 1) + + getHead es = es >! 0 + getLast es = es >! upper es + + newLinear = fromFoldableM + + newLinearN c es = ST $ \ s1# -> case newArray# n# err s1# of + (# s2#, marr# #) -> + let go y r = \ i# s3# -> case writeArray# 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 + err = undEx "newLinearN" + !n@(I# n#) = max 0 c + + fromFoldableM es = ST $ \ s1# -> case newArray# n# err s1# of + (# s2#, marr# #) -> + let go y r = \ i# s3# -> case writeArray# 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 + err = unreachEx "fromFoldableM" + !n@(I# n#) = length es + + getLeft es@(STArray# n _ _) = (es !#>) `mapM` [0 .. n - 1] + getRight es@(STArray# n _ _) = (es !#>) `mapM` [n - 1, n - 2 .. 0] + + {-# INLINE (!#>) #-} + (!#>) (STArray# _ (I# o#) marr#) = \ (I# i#) -> ST $ readArray# marr# (o# +# i#) + + 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' es l n = do + copy <- n `filled` unreachEx "copied'" + forM_ [0 .. n - 1] $ \ i -> es !#> (l + i) >>= writeM copy i + return copy + + 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 + + filled n e = let !n'@(I# n#) = max 0 n in ST $ + \ s1# -> case newArray# n# e s1# of + (# s2#, marr# #) -> (# s2#, STArray# n' 0 marr# #) + + copyTo src sc trg tc n@(I# n#) = when (n > 0) $ do + when (sc < 0 || tc < 0) $ underEx "copyTo" + when (sc + n > n1 || tc + n > n2) $ overEx "copyTo" + ST $ \ s1# -> case copyMutableArray# src# so# trg# to# n# s1# of + s2# -> (# s2#, () #) + where + !(STArray# n1 o1 src#) = src; !(I# so#) = o1 + sc + !(STArray# n2 o2 trg#) = trg; !(I# to#) = o2 + tc + + merged ess = do + marr <- filled n (unreachEx "merged") + let writer arr@(STArray# c _ _) i = (i + c) <$ copyTo arr 0 marr i c + + void $ foldr ((=<<) . writer) (return 0) ess + return marr + where + n = foldr' ((+) . sizeOf) 0 ess + + ofoldrM f base = \ arr@(STArray# n _ _) -> + let go i = n == i ? return base $ (arr !#> i) >>=<< go (i + 1) $ f i + in go 0 + + ofoldlM f base = \ arr@(STArray# n _ _) -> + let go i = -1 == i ? return base $ go (i - 1) >>=<< (arr !#> i) $ f i + in go (n - 1) + + foldrM f base = \ arr@(STArray# n _ _) -> + let go i = n == i ? return base $ (arr !#> i) >>=<< go (i + 1) $ f + in go 0 + + foldlM f base = \ arr@(STArray# n _ _) -> + let go i = -1 == i ? return base $ go (i - 1) >>=<< (arr !#> i) $ f + in go (n - 1) + +instance SplitM (ST s) (STArray# s e) e + where + takeM n es@(STArray# c o marr#) + | n <= 0 = newNull + | n >= c = return es + | True = return (STArray# n o marr#) + + dropM n es@(STArray# c o marr#) + | n >= c = newNull + | n <= 0 = return es + | True = return (STArray# (c - n) (o + n) marr#) + + keepM n es@(STArray# c o marr#) + | n <= 0 = newNull + | n >= c = return es + | True = return (STArray# n (c - n + o) marr#) + + sansM n es@(STArray# c o marr#) + | n >= c = newNull + | n <= 0 = return es + | True = return (STArray# (c - n) o marr#) + + splitM n es@(STArray# c o marr#) + | n <= 0 = do e' <- newNull; return (e', es) + | n >= c = do e' <- newNull; return (es, e') + | True = return (STArray# n o marr#, STArray# (c - n) (o + n) marr#) + + divideM n es@(STArray# c o marr#) + | n <= 0 = do e' <- newNull; return (es, e') + | n >= c = do e' <- newNull; return (e', es) + | True = return (STArray# n (c - n + o) marr#, STArray# (c - n) o marr#) + + prefixM p es@(STArray# c _ _) = + let go i = i >= c ? return c $ do e <- es !#> i; p e ? go (succ i) $ return i + in go 0 + + suffixM p es@(STArray# c _ _) = + let go i = i < 0 ? return c $ do e <- es !#> i; p e ? go (pred i) $ return (c - i - 1) + in go (max 0 (c - 1)) + + mprefix p es@(STArray# c _ _) = + let go i = i >= c ? return c $ do e <- es !#> i; p e ?^ go (succ 1) $ return i + in go 0 + + msuffix p es@(STArray# c _ _) = + let go i = i < 0 ? return c $ do e <- es !#> i; p e ?^ go (pred i) $ return (c - i - 1) + in go (max 0 (c - 1)) + +-------------------------------------------------------------------------------- + +{- MapM, IndexedM and SortM instances. -} + +instance MapM (ST s) (STArray# s e) Int e + where + newMap' defvalue ascs = fromAssocs' (ascsBounds ascs) defvalue ascs + + (>!) = (!#>) + + overwrite es@(STArray# c _ _) ascs = + let ies = filter (inRange (0, c - 1) . fst) ascs + in mapM_ (uncurry $ writeM es) ies >> return es + + kfoldrM = ofoldrM + kfoldlM = ofoldlM + +instance IndexedM (ST s) (STArray# s e) Int e + where + fromAssocs' bnds defvalue ascs = size bnds `filled` defvalue >>= (`overwrite` ascs) + + {-# INLINE writeM' #-} + writeM' (STArray# _ (I# o#) marr#) = \ (I# i#) e -> ST $ + \ s1# -> case writeArray# marr# (o# +# i#) e s1# of s2# -> (# s2#, () #) + + fromIndexed' es = do + let n = sizeOf es + copy <- filled n (unreachEx "fromIndexed'") + forM_ [0 .. n - 1] $ \ i -> writeM copy i (es !^ i) + return copy + + fromIndexedM es = do + n <- getSizeOf es + copy <- filled n (unreachEx "fromIndexedM") + forM_ [0 .. n - 1] $ \ i -> es !#> i >>= writeM copy i + return copy + +instance SortM (ST s) (STArray# s e) e + where + sortedMBy f es@(STArray# n _ _) = + let go i e1 = i == n ? return True $ do e2 <- es !#> i; e1 `f` e2 ? go (i + 1) e2 $ return False + in n < 2 ? return True $ go 1 =<< getHead es + + sortMBy = timSortBy + +-------------------------------------------------------------------------------- + +-- | 'MIOArray#' is mutable preudo-primitive 'Int'-indexed lazy boxed array. +newtype MIOArray# (io :: Type -> Type) e = MIOArray# (STArray# RealWorld e) + deriving ( Eq ) + +-- | 'IOArray#' is mutable preudo-primitive 'Int'-indexed lazy boxed array. +type IOArray# = MIOArray# IO + +{-# INLINE unpack #-} +unpack :: MIOArray# io e -> STArray# RealWorld e +unpack = coerce + +{-# INLINE pack #-} +pack :: (MonadIO io) => ST RealWorld (STArray# RealWorld e) -> io (MIOArray# io e) +pack = stToMIO . coerce + +-------------------------------------------------------------------------------- + +{- Estimate, Bordered and BorderedM instances. -} + +instance Estimate (MIOArray# io e) + where + (<==>) = on (<=>) sizeOf + (.<=.) = on (<=) sizeOf + (.>=.) = on (>=) sizeOf + (.>.) = on (>) sizeOf + (.<.) = on (<) sizeOf + + (<.=>) = (<=>) . sizeOf + (.>=) = (>=) . sizeOf + (.<=) = (<=) . sizeOf + (.>) = (>) . sizeOf + (.<) = (<) . sizeOf + +instance Bordered (MIOArray# io e) Int + where + lower _ = 0 + + sizeOf (MIOArray# (STArray# c _ _)) = c + upper (MIOArray# (STArray# c _ _)) = c - 1 + bounds (MIOArray# (STArray# c _ _)) = (0, c - 1) + indices (MIOArray# (STArray# c _ _)) = [0 .. c - 1] + indexOf (MIOArray# (STArray# c _ _)) = index (0, c - 1) + offsetOf (MIOArray# (STArray# c _ _)) = offset (0, c - 1) + indexIn (MIOArray# (STArray# c _ _)) = \ i -> i >= 0 && i < c + +instance (MonadIO io) => BorderedM io (MIOArray# io e) Int + where + getIndexOf = return ... indexOf . unpack + getIndices = return . indices . unpack + getSizeOf = return . sizeOf . unpack + getBounds = return . bounds . unpack + getUpper = return . upper . unpack + getLower _ = return 0 + +-------------------------------------------------------------------------------- + +{- LinearM and SplitM instances. -} + +instance (MonadIO io) => LinearM io (MIOArray# io e) e + where + newNull = pack newNull + singleM = pack . singleM + nowNull = stToMIO . nowNull . unpack + getHead = stToMIO . getHead . unpack + getLast = stToMIO . getLast . unpack + + prepend e = pack . prepend e . unpack + append es = pack . append (unpack es) + + newLinear = pack . newLinear + newLinearN = pack ... newLinearN + fromFoldableM = pack . fromFoldableM + + writeM = writeM' + (!#>) = stToMIO ... (!#>) . unpack + + copied = pack . copied . unpack + reversed = pack . reversed . unpack + getLeft = stToMIO . getLeft . unpack + getRight = stToMIO . getRight . unpack + + copied' es = pack ... copied' (unpack es) + + merged = pack . merged . foldr ((:) . unpack) [] + filled = pack ... filled + + copyTo src so trg to = stToMIO . copyTo (unpack src) so (unpack trg) to + + ofoldrM f base = \ arr@(MIOArray# (STArray# n _ _)) -> + let go i = n == i ? return base $ (arr !#> i) >>=<< go (i + 1) $ f i + in go 0 + + ofoldlM f base = \ arr@(MIOArray# (STArray# n _ _)) -> + let go i = -1 == i ? return base $ go (i - 1) >>=<< (arr !#> i) $ f i + in go (n - 1) + + foldrM f base arr = + let go i = sizeOf arr == i ? return base $ (arr !#> i) >>=<< go (i + 1) $ f + in go 0 + + foldlM f base arr = + let go i = -1 == i ? return base $ go (i - 1) >>=<< (arr !#> i) $ f + in go (sizeOf arr - 1) + +instance (MonadIO io) => SplitM io (MIOArray# io e) e + where + takeM n = pack . takeM n . unpack + dropM n = pack . dropM n . unpack + keepM n = pack . keepM n . unpack + sansM n = pack . sansM n . unpack + + prefixM f = stToMIO . prefixM f . unpack + suffixM f = stToMIO . suffixM f . unpack + + mprefix p es@(MIOArray# (STArray# c _ _)) = + let go i = i >= c ? return c $ do e <- es !#> i; p e ?^ go (succ 1) $ return i + in go 0 + + msuffix p es@(MIOArray# (STArray# c _ _)) = + let go i = i < 0 ? return c $ do e <- es !#> i; p e ?^ go (pred i) $ return (c - i - 1) + in go (max 0 (c - 1)) + +-------------------------------------------------------------------------------- + +{- MapM, IndexedM and SortM instances. -} + +instance (MonadIO io) => MapM io (MIOArray# io e) Int e + where + newMap' defvalue ascs = fromAssocs' (ascsBounds ascs) defvalue ascs + + (>!) = (!#>) + + overwrite = pack ... overwrite . unpack + + kfoldrM = ofoldrM + kfoldlM = ofoldlM + +instance (MonadIO io) => IndexedM io (MIOArray# io e) Int e + where + fromAssocs bnds = pack . fromAssocs bnds + fromAssocs' bnds = pack ... fromAssocs' bnds + + writeM' es = stToMIO ... writeM' (unpack es) + + fromIndexed' = pack . fromIndexed' + + fromIndexedM es = do + n <- getSizeOf es + copy <- filled n (unreachEx "fromIndexedM") + forM_ [0 .. n - 1] $ \ i -> es !#> i >>= writeM copy i + return copy + +instance (MonadIO io) => SortM io (MIOArray# io e) e + where + sortedMBy f = stToMIO . sortedMBy f . unpack + sortMBy = timSortBy + +-------------------------------------------------------------------------------- + +instance (MonadIO io) => Thaw io (SArray# e) (MIOArray# io e) + where + unsafeThaw = pack . unsafeThaw + thaw = pack . thaw + +instance (MonadIO io) => Freeze io (MIOArray# io e) (SArray# e) + where + unsafeFreeze = stToMIO . unsafeFreeze . unpack + freeze = stToMIO . freeze . unpack + +-------------------------------------------------------------------------------- + +instance (Storable e) => Freeze IO (Int, Ptr e) (SArray# e) + where + freeze (n, ptr) = do + let !n'@(I# n#) = max 0 n + es' <- stToIO . ST $ \ s1# -> case newArray# n# err s1# of + (# s2#, marr# #) -> (# s2#, MIOArray# (STArray# n' 0 marr#) #) + forM_ [0 .. n' - 1] $ \ i -> peekElemOff ptr i >>= writeM es' i + freeze es' + where + err = undEx "freeze {(Int, Ptr e) => SArray# e}" `asProxyTypeOf` ptr + +instance (Storable e) => Thaw IO (SArray# e) (Int, Ptr e) + where + thaw (SArray# n o arr#) = do + ptr <- callocArray n + forM_ [o .. n + o - 1] $ \ i@(I# i#) -> let (# e #) = indexArray# arr# i# in pokeElemOff ptr i e + return (n, ptr) + +-------------------------------------------------------------------------------- + +{- Primitive operations on SArray# and and STArray#. -} + +-- | 'unpackSArray#' returns 'MutableArray#' field of 'SArray#'. +unpackSArray# :: SArray# e -> Array# e +unpackSArray# = \ (SArray# _ _ arr#) -> arr# + +-- | 'offsetSArray#' returns 'SArray#' offset in elements. +offsetSArray# :: SArray# e -> Int# +offsetSArray# = \ (SArray# _ (I# o#) _) -> o# + +-- | 'packSArray#' creates new 'SArray#' from sized 'Array#'. +packSArray# :: Int -> Array# e -> SArray# e +packSArray# n arr# = SArray# (max 0 n) 0 arr# + +-- | 'fromSArray#' returns new 'Array#' (uses 'cloneArray#'). +fromSArray# :: SArray# e -> Array# e +fromSArray# (SArray# (I# c#) (I# o#) arr#) = cloneArray# arr# o# c# + +-- | 'coerceSArray#' is 'coerce' alias. +coerceSArray# :: (Coercible a b) => SArray# a -> SArray# b +coerceSArray# = coerce + +-- | 'unpackSTArray#' returns 'MutableArray#' field of 'STArray#' or fails. +unpackSTArray# :: STArray# s e -> MutableArray# s e +unpackSTArray# = \ (STArray# _ _ marr#) -> marr# + +-- | 'offsetSTArray#' returns 'STArray#' offset in elements. +offsetSTArray# :: STArray# s e -> Int# +offsetSTArray# = \ (STArray# _ (I# o#) _) -> o# + +-- | 'packSTArray#' creates new 'STArray#' from sized 'MutableArray#'. +packSTArray# :: Int -> MutableArray# s e -> STArray# s e +packSTArray# n marr# = STArray# (max 0 n) 0 marr# + +-- | 'fromSTArray#' returns new 'MutableArray#'. +fromSTArray# :: STArray# s e -> State# s -> (# State# s, MutableArray# s e #) +fromSTArray# (STArray# (I# c#) (I# o#) marr#) = cloneMutableArray# marr# o# c# + +-- | 'coerceSTArray#' is 'coerce' alias. +coerceSTArray# :: (Coercible a b) => STArray# s a -> STArray# s b +coerceSTArray# = coerce + +-------------------------------------------------------------------------------- + +{-# INLINE done #-} +done :: STArray# s e -> ST s (SArray# e) +done (STArray# n o marr#) = ST $ \ s1# -> case unsafeFreezeArray# marr# s1# of + (# s2#, arr# #) -> (# s2#, SArray# n o arr# #) + +{-# INLINE done' #-} +done' :: Int -> MutableArray# s e -> STRep s (STArray# s e) +done' n marr# = \ s1# -> (# s1#, STArray# n 0 marr# #) + +{-# INLINE nubSorted #-} +nubSorted :: Compare e -> SArray# e -> SArray# e +nubSorted _ Z = Z +nubSorted f es = fromList $ foldr fun [last es] ((es !^) <$> [0 .. sizeOf es - 2]) + 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 + +-------------------------------------------------------------------------------- + +undEx :: String -> a +undEx = throw . UndefinedValue . showString "in SDP.Prim.SArray." + +overEx :: String -> a +overEx = throw . IndexOverflow . showString "in SDP.Prim.SArray." + +underEx :: String -> a +underEx = throw . IndexUnderflow . showString "in SDP.Prim.SArray." + +pfailEx :: String -> a +pfailEx = throw . PatternMatchFail . showString "in SDP.Prim.SArray." + +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 new file mode 100644 --- /dev/null +++ b/src/SDP/Prim/SBytes.hs @@ -0,0 +1,1135 @@ +{-# LANGUAGE Trustworthy, MagicHash, UnboxedTuples, BangPatterns, TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, RoleAnnotations #-} + +{- | + Module : SDP.Prim.SBytes + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Prim.SBytes" provides strict unboxed array pseudo-primitive types + 'SBytes#', 'STBytes#' and 'IOBytes#'. +-} +module SDP.Prim.SBytes +( + -- * Exports + module SDP.IndexedM, + module SDP.Unboxed, + module SDP.SortM, + module SDP.Sort, + + -- * Preudo-primitive types + MIOBytes# (..), IOBytes#, STBytes#, SBytes#, + + -- ** Unpack unboxed arrays + fromSBytes#, packSBytes#, unpackSBytes#, offsetSBytes#, + fromSTBytes#, packSTBytes#, unpackSTBytes#, offsetSTBytes#, + + -- ** Coerce unboxed arrays + unsafeCoerceSBytes#, unsafeCoerceSTBytes#, + + -- ** Unsafe pointer conversions + unsafeSBytesToPtr#, unsafePtrToSBytes#, + + -- ** Hash + hashSBytesWith# +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.IndexedM +import SDP.Unboxed +import SDP.SortM +import SDP.Sort +import SDP.Scan + +import SDP.SortM.Tim + +import qualified GHC.Exts as E +import GHC.Exts + ( + ByteArray#, MutableByteArray#, State#, Int#, (+#), (-#), (==#), + newByteArray#, unsafeFreezeByteArray#, sameMutableByteArray# + ) + +import GHC.Types +import GHC.ST ( ST (..), STRep ) + +import Data.Default.Class +import Data.Typeable +import Data.Coerce +import Data.String +import Text.Read + +import Foreign + ( + Ptr, Storable, peekByteOff, peekElemOff, pokeByteOff, pokeElemOff, + mallocBytes, callocArray + ) + +import Control.Exception.SDP + +default () + +-------------------------------------------------------------------------------- + +{- | + 'SBytes#' is immutable pseudo-primitive 'Int'-indexed strict unboxed array + type. + + 'SBytes#' isn't real Haskell primitive (like "GHC.Exts" types) but for + reliability and stability, I made it inaccessible to direct work. +-} +data SBytes# e = SBytes# + {-# UNPACK #-} !Int -- ^ Element count (not a real size) + {-# UNPACK #-} !Int -- ^ Offset (in elements) + !(ByteArray#) -- ^ Real primitive byte array + deriving ( Typeable ) + +type role SBytes# representational + +-------------------------------------------------------------------------------- + +{- Eq instance. -} + +instance (Unboxed e) => Eq (SBytes# e) + where + xs@(SBytes# c1 _ _) == ys@(SBytes# c2 _ _) = + let eq' i = i == c1 || (xs!^i) == (ys!^i) && eq' (i + 1) + in c1 == c2 && eq' 0 + +-------------------------------------------------------------------------------- + +{- Ord and Ord1 instances. -} + +instance (Unboxed e, Ord e) => Ord (SBytes# e) + where + compare xs@(SBytes# c1 _ _) ys@(SBytes# c2 _ _) = cmp' 0 + where + cmp' i = i == c ? c1 <=> c2 $ (xs!^i <=> ys!^i) <> cmp' (i + 1) + c = min c1 c2 + +-------------------------------------------------------------------------------- + +{- Show and Read instances. -} + +instance (Unboxed e, Show e) => Show (SBytes# e) where showsPrec p = showsPrec p . listL + +instance (Unboxed e, Read e) => Read (SBytes# e) where readPrec = fromList <$> readPrec + +-------------------------------------------------------------------------------- + +{- Overloaded Lists and Strings support. -} + +instance IsString (SBytes# Char) where fromString = fromList + +instance (Unboxed e) => E.IsList (SBytes# e) + where + type Item (SBytes# e) = e + + fromListN = fromListN + fromList = fromList + toList = listL + +-------------------------------------------------------------------------------- + +{- Semigroup, Monoid, Nullable, Default and Estimate instances. -} + +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} + +instance (Unboxed e) => Semigroup (SBytes# e) where (<>) = (++) +instance (Unboxed e) => Monoid (SBytes# e) where mempty = Z + +instance Default (SBytes# e) + where + def = runST $ (done =<<) $ ST $ \ s1# -> case newByteArray# 0# s1# of + (# s2#, marr# #) -> (# s2#, STBytes# 0 0 marr# #) + +instance Estimate (SBytes# e) + where + (<==>) = on (<=>) sizeOf + (.<=.) = on (<=) sizeOf + (.>=.) = on (>=) sizeOf + (.>.) = on (>) sizeOf + (.<.) = on (<) sizeOf + + (<.=>) = (<=>) . sizeOf + (.>=) = (>=) . sizeOf + (.<=) = (<=) . sizeOf + (.>) = (>) . sizeOf + (.<) = (<) . sizeOf + +-------------------------------------------------------------------------------- + +{- Linear, Split and Bordered instances. -} + +instance (Unboxed e) => Linear (SBytes# e) e + where + toHead e (SBytes# (I# c#) (I# o#) arr#) = let n# = c# +# 1# in runST $ ST $ + \ s1# -> case newUnboxed' e n# s1# of + (# s2#, marr# #) -> case copyUnboxed# e arr# o# marr# 1# c# s2# of + s3# -> case unsafeFreezeByteArray# marr# s3# of + (# s4#, res# #) -> (# s4#, SBytes# (I# n#) 0 res# #) + + toLast (SBytes# (I# c#) (I# o#) arr#) e = let n# = c# +# 1# in runST $ ST $ + \ s1# -> case newUnboxed' e n# s1# of + (# s2#, marr# #) -> case copyUnboxed# e arr# o# marr# 0# c# s2# of + s3# -> case unsafeFreezeByteArray# marr# s3# of + (# s4#, res# #) -> (# s4#, SBytes# (I# n#) 0 res# #) + + head es = es !^ 0 + last es@(SBytes# c _ _) = es !^ (c - 1) + + tail (SBytes# c o arr#) = SBytes# (max 1 c - 1) (o + 1) arr# + init (SBytes# c o arr#) = SBytes# (max 1 c - 1) o arr# + + fromList = fromFoldable + + fromListN n es = runST $ newLinearN n es >>= done + fromFoldable es = runST $ fromFoldableM es >>= done + + single e = runST $ filled 1 e >>= done + + 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 + (# s2#, marr# #) -> case pcopyUnboxed xs arr1# o1# marr# 0# n1# s2# of + s3# -> case pcopyUnboxed xs arr2# o2# marr# n1# n2# s3# of + s4# -> case unsafeFreezeByteArray# marr# s4# of + (# s5#, arr# #) -> (# s5#, SBytes# (I# n#) 0 arr# #) + + force es@(SBytes# n@(I# n#) (I# o#) bytes#) = + SBytes# n 0 (cloneUnboxed1# es bytes# n# o#) + + {-# INLINE (!^) #-} + (!^) (SBytes# _ (I# o#) arr#) = \ (I# i#) -> arr# !# (i# +# o#) + + write es n e = not (indexIn es n) ? es $ runST $ do + es' <- thaw es + writeM es' n e + done es' + + replicate n e = runST $ filled n e >>= done + + listL = o_foldr (:) [] + listR = flip (:) `o_foldl` [] + + concat ess = runST $ do + let n = foldr' ((+) . sizeOf) 0 ess + marr@(STBytes# _ _ marr#) <- alloc n + + let + write# (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 + + reverse es = runST $ fromIndexed' es >>= reversed >>= done + + 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 + in second fromList . o_foldr g ([], []) + + selects fs = second fromList . selects fs . listL + + ofoldr f base = \ arr@(SBytes# c _ _) -> + let go i = c == i ? base $ f i (arr !^ i) (go $ i + 1) + in go 0 + + ofoldl f base = \ arr@(SBytes# c _ _) -> + let go i = -1 == i ? base $ f i (go $ i - 1) (arr !^ i) + in go (c - 1) + + o_foldr f base = \ arr@(SBytes# c _ _) -> + let go i = c == i ? base $ f (arr !^ i) (go $ i + 1) + in go 0 + + o_foldl f base = \ arr@(SBytes# c _ _) -> + let go i = -1 == i ? base $ f (go $ i - 1) (arr !^ i) + in go (c - 1) + +instance (Unboxed e) => Split (SBytes# e) e + where + -- | O(1) 'take', O(1) memory. + take n es@(SBytes# c o arr#) + | n <= 0 = Z + | n >= c = es + | True = SBytes# n o arr# + + -- | O(1) 'drop', O(1) memory. + drop n es@(SBytes# c o arr#) + | n <= 0 = es + | n >= c = Z + | True = SBytes# (c - n) (o + n) arr# + + -- | O(1) 'split', O(1) memory. + split n es@(SBytes# c o arr#) + | n <= 0 = (Z, es) + | n >= c = (es, Z) + | True = (SBytes# n o arr#, SBytes# (c - n) (o + n) arr#) + + -- | O(1) 'keep', O(1) memory. + keep n es@(SBytes# c o arr#) + | n <= 0 = Z + | n >= c = es + | True = SBytes# n (o + c - n) arr# + + -- | O(1) 'sans', O(1) memory. + sans n es@(SBytes# c o arr#) + | n <= 0 = es + | n >= c = Z + | True = SBytes# (c - n) o arr# + + -- | O(1) 'divide', O(1) memory. + divide n es@(SBytes# c o arr#) + | n <= 0 = (Z, es) + | n >= c = (es, Z) + | True = (SBytes# n (o + c - n) arr#, SBytes# (c - n) o arr#) + + splitsBy f es = dropWhile f <$> f *$ es `parts` es + + combo _ Z = 0 + combo f es@(SBytes# n _ _) = + let go e i = let e' = es !^ i in i == n || not (f e e') ? i $ go e' (i + 1) + in go (head es) 1 + + justifyL n@(I# n#) e es@(SBytes# c@(I# c#) (I# o#) src#) = case c <=> n of + EQ -> es + GT -> take n es + LT -> runST $ ST $ \ s1# -> case newUnboxed' e n# s1# of + (# s2#, mbytes# #) -> case copyUnboxed# e src# o# mbytes# 0# c# s2# of + s3# -> case unsafeFreezeByteArray# mbytes# s3# of + (# s4#, bytes# #) -> (# s4#, SBytes# n 0 bytes# #) + + justifyR n@(I# n#) e es@(SBytes# c@(I# c#) (I# o#) src#) = case c <=> n of + EQ -> es + GT -> take n es + LT -> runST $ ST $ \ s1# -> case newUnboxed' e n# s1# of + (# s2#, mbytes# #) -> case copyUnboxed# e src# o# mbytes# (n# -# c#) c# s2# of + s3# -> case unsafeFreezeByteArray# mbytes# s3# of + (# s4#, bytes# #) -> (# s4#, SBytes# n 0 bytes# #) + + each n es@(SBytes# c _ _) = + let go i = i < c ? es!^i : go (i + n) $ [] + in case n <=> 1 of {LT -> Z; EQ -> es; GT -> fromList $ go (n - 1)} + + isPrefixOf xs@(SBytes# c1 _ _) ys@(SBytes# c2 _ _) = + let eq i = i == c1 || (xs !^ i) == (ys !^ i) && eq (i + 1) + in c1 <= c2 && eq 0 + + isSuffixOf xs@(SBytes# c1 _ _) ys@(SBytes# c2 _ _) = + let eq i j = i == c1 || (xs !^ i) == (ys !^ j) && eq (i + 1) (j + 1) + in c1 <= c2 && eq 0 (c2 - c1) + + selectWhile f es@(SBytes# c _ _) = + let go i = i == c ? [] $ maybe [] (: go (i + 1)) $ f (es !^ i) + in go 0 + + selectEnd g xs@(SBytes# c _ _) = + let go i es = i == 0 ? [] $ maybe [] (: go (i - 1) es) $ g (es !^ i) + in reverse $ go (c - 1) xs + +instance Bordered (SBytes# e) Int + where + lower = const 0 + + sizeOf (SBytes# c _ _) = c + upper (SBytes# c _ _) = c - 1 + bounds (SBytes# c _ _) = (0, c - 1) + indices (SBytes# c _ _) = [0 .. c - 1] + indexOf (SBytes# c _ _) = index (0, c - 1) + offsetOf (SBytes# c _ _) = offset (0, c - 1) + indexIn (SBytes# c _ _) = \ i -> i >= 0 && i < c + +-------------------------------------------------------------------------------- + +{- Set, SetWith and Sort instances. -} + +instance (Unboxed e, Ord e) => Set (SBytes# e) e + +instance (Unboxed e) => SetWith (SBytes# e) e + where + 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 + _ -> es :< e + + deleteWith f e es = memberWith f e es ? except (\ x -> f e x == EQ) es $ es + + {-# INLINE intersectionWith #-} + intersectionWith f xs@(SBytes# n1 _ _) ys@(SBytes# n2 _ _) = fromList $ go 0 0 + where + go i j = i == n1 || j == n2 ? [] $ case x `f` y of + EQ -> x : go (i + 1) (j + 1) + LT -> go (i + 1) j + GT -> go i (j + 1) + where + x = xs !^ i + y = ys !^ j + + {-# INLINE unionWith #-} + unionWith f xs@(SBytes# n1 _ _) ys@(SBytes# n2 _ _) = fromList $ go 0 0 + where + go i j + | i == n1 = (ys !^) <$> [j .. n2 - 1] + | j == n2 = (xs !^) <$> [i .. n1 - 1] + | True = case x `f` y of + EQ -> x : go (i + 1) (j + 1) + LT -> x : go (i + 1) j + GT -> y : go i (j + 1) + where + x = xs !^ i + y = ys !^ j + + {-# INLINE differenceWith #-} + differenceWith f xs@(SBytes# n1 _ _) ys@(SBytes# n2 _ _) = fromList $ go 0 0 + where + go i j + | i == n1 = [] + | j == n2 = (xs !^) <$> [i .. n1 - 1] + | True = case x `f` y of + EQ -> go (i + 1) (j + 1) + LT -> x : go (i + 1) j + GT -> go i (j + 1) + where + x = xs !^ i + y = ys !^ j + + {-# INLINE symdiffWith #-} + symdiffWith f xs@(SBytes# n1 _ _) ys@(SBytes# n2 _ _) = fromList $ symdiff' 0 0 + where + symdiff' i j + | i == n1 = (ys !^) <$> [j .. n2 - 1] + | j == n2 = (xs !^) <$> [i .. n1 - 1] + | True = case x `f` y of + EQ -> symdiff' (i + 1) (j + 1) + LT -> x : symdiff' (i + 1) j + GT -> y : symdiff' i (j + 1) + where + x = xs !^ i + y = ys !^ j + + memberWith = binaryContain + + lookupLTWith _ _ Z = Nothing + lookupLTWith f o es + | GT <- o `f` last' = Just last' + | GT <- o `f` head' = look' head' 0 (sizeOf es - 1) + | True = Nothing + where + head' = es .! lower es + last' = es .! upper es + + look' r l u = l > u ? Just r $ case o `f` e of + LT -> look' r l (j - 1) + EQ -> Just $ j < 1 ? r $ es !^ (j - 1) + GT -> look' e (j + 1) u + where + j = l + (u - l) `div` 2 + e = es !^ j + + lookupLEWith _ _ Z = Nothing + lookupLEWith f o es + | GT <- o `f` last' = Just last' + | LT <- o `f` head' = Nothing + | True = look' head' 0 (sizeOf es - 1) + where + head' = es .! lower es + last' = es .! upper es + + look' r l u = l > u ? Just r $ case o `f` e of + LT -> look' r l (j - 1) + _ -> look' e (j + 1) u + where + j = l + (u - l) `div` 2 + e = es !^ j + + lookupGTWith _ _ Z = Nothing + lookupGTWith f o es + | LT <- o `f` head' = Just head' + | LT <- o `f` last' = look' last' 0 (sizeOf es - 1) + | True = Nothing + where + head' = es .! lower es + last' = es .! upper es + + look' r l u = l > u ? Just r $ case o `f` e of + LT -> look' e l (j - 1) + EQ -> j >= (sizeOf es - 1) ? Nothing $ Just (es !^ (j + 1)) + GT -> look' r (j + 1) u + where + j = l + (u - l) `div` 2 + e = es !^ j + + lookupGEWith _ _ Z = Nothing + lookupGEWith f o es + | GT <- o `f` last' = Nothing + | GT <- o `f` head' = look' last' 0 (sizeOf es - 1) + | True = Just head' + where + head' = es .! lower es + last' = es .! upper es + + look' r l u = l > u ? Just r $ case o `f` e of + LT -> look' e l (j - 1) + EQ -> Just e + GT -> look' r (j + 1) u + where + j = l + (u - l) `div` 2 + e = es !^ j + + isSubsetWith f xs ys = o_foldr (\ x b -> b && memberWith f x ys) True xs + +instance (Unboxed e) => Scan (SBytes# e) e + +instance (Unboxed e) => Sort (SBytes# e) e + where + sortBy cmp es = runST $ do es' <- thaw es; timSortBy cmp es'; done es' + + sortedBy f es@(SBytes# n _ _) = + let go i = let i1 = i + 1 in i1 == n || (f (es !^ i) (es !^ i1) && go i1) + in n < 2 || go 0 + +-------------------------------------------------------------------------------- + +{- Map and Indexed instances. -} + +instance (Unboxed e) => Map (SBytes# e) Int e + where + toMap ascs = isNull ascs ? Z $ assoc (ascsBounds ascs) ascs + + toMap' defvalue ascs = isNull ascs ? Z $ assoc' (ascsBounds ascs) defvalue ascs + + Z // ascs = toMap ascs + es // ascs = runST $ thaw es >>= flip overwrite ascs >>= done + + (*$) p = ofoldr (\ i e is -> p e ? (i : is) $ is) [] + (.!) = (!^) + + kfoldr = ofoldr + kfoldl = ofoldl + +instance (Unboxed e) => Indexed (SBytes# e) Int e + where + assoc bnds ascs = runST $ fromAssocs bnds ascs >>= done + assoc' bnds defvalue ascs = runST $ fromAssocs' bnds defvalue ascs >>= done + + fromIndexed es = runST $ do + let n = sizeOf es + copy <- alloc n + forM_ [0 .. n - 1] $ \ i -> writeM copy i (es !^ i) + done copy + +-------------------------------------------------------------------------------- + +instance (Unboxed e) => Thaw (ST s) (SBytes# e) (STBytes# s e) + 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#, () #) + return marr + +instance (Unboxed e) => Freeze (ST s) (STBytes# s e) (SBytes# e) + where + freeze = cloneSTBytes# >=> done + unsafeFreeze = done + +-------------------------------------------------------------------------------- + +-- | 'STBytes#' is mutable pseudo-primitive 'Int'-indexed strict unboxed array type. +data STBytes# s e = STBytes# + {-# UNPACK #-} !Int -- ^ Element count (not a real size) + {-# UNPACK #-} !Int -- ^ Offset (in elements) + !(MutableByteArray# s) -- ^ Real primitive byte array + deriving ( Typeable ) + +type role STBytes# nominal representational + +-------------------------------------------------------------------------------- + +instance Eq (STBytes# s e) + where + (STBytes# c1 o1 marr1#) == (STBytes# c2 o2 marr2#) = + let same = isTrue# (sameMutableByteArray# marr1# marr2#) + in c1 == c2 && (c1 == 0 || o1 == o2 && same) + +-------------------------------------------------------------------------------- + +{- Estimate, Bordered, BorderedM, LinearM and SplitM instances. -} + +instance Estimate (STBytes# s e) + where + (<==>) = on (<=>) sizeOf + (.<=.) = on (<=) sizeOf + (.>=.) = on (>=) sizeOf + (.>.) = on (>) sizeOf + (.<.) = on (<) sizeOf + + (<.=>) = (<=>) . sizeOf + (.>=) = (>=) . sizeOf + (.<=) = (<=) . sizeOf + (.>) = (>) . sizeOf + (.<) = (<) . sizeOf + +instance Bordered (STBytes# s e) Int + where + bounds (STBytes# c _ _) = (0, c - 1) + sizeOf (STBytes# c _ _) = c + +instance BorderedM (ST s) (STBytes# s e) Int + where + getLower _ = return 0 + + nowIndexIn (STBytes# c _ _) = return . inRange (0, c - 1) + getIndices (STBytes# c _ _) = return [0 .. c - 1] + getBounds (STBytes# c _ _) = return (0, c - 1) + getUpper (STBytes# c _ _) = return (c - 1) + getSizeOf (STBytes# c _ _) = return c + +instance (Unboxed e) => LinearM (ST s) (STBytes# s e) e + where + newNull = ST $ \ s1# -> case newByteArray# 0# s1# of + (# s2#, marr# #) -> (# s2#, STBytes# 0 0 marr# #) + + getHead es = es >! 0 + getLast es = es >! upper es + 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 + + 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 + + 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#) + + writeM = writeM' + + copied es@(STBytes# n _ _) = do + copy <- alloc n + forM_ [0 .. n - 1] $ \ i -> es !#> i >>= writeM copy i + return copy + + copied' es l n = do + copy <- alloc n + forM_ [0 .. n - 1] $ \ i -> es !#> (l + i) >>= writeM copy i + return copy + + 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 + + filled n e = ST $ \ s1# -> case newUnboxed' e n# s1# of + (# s2#, marr# #) -> (# s2#, STBytes# n' 0 marr# #) + where + !n'@(I# n#) = max 0 n + + copyTo src sc trg tc n@(I# n#) = when (n > 0) $ do + when (sc < 0 || tc < 0) $ underEx "copyTo" + when (sc + n > n1 || tc + n > n2) $ overEx "copyTo" + + ST $ \ s1# -> case pcopyUnboxedM src src# so# trg# to# n# s1# of + s2# -> (# s2#, () #) + where + !(STBytes# n1 o1 src#) = src; !(I# so#) = o1 + sc + !(STBytes# n2 o2 trg#) = trg; !(I# to#) = o2 + tc + + merged ess = do + marr <- alloc n + let writer arr@(STBytes# c _ _) i = (i + c) <$ copyTo arr 0 marr i c + marr <$ foldr ((=<<) . writer) (return 0) ess + where + n = foldr' ((+) . sizeOf) 0 ess + + ofoldrM f base = \ arr@(STBytes# n _ _) -> + let go i = n == i ? return base $ (arr !#> i) >>=<< go (i + 1) $ f i + in go 0 + + ofoldlM f base = \ arr@(STBytes# n _ _) -> + let go i = -1 == i ? return base $ go (i - 1) >>=<< (arr !#> i) $ (f i) + in go (n - 1) + + foldrM f base = \ arr@(STBytes# n _ _) -> + let go i = n == i ? return base $ (arr !#> i) >>=<< go (i + 1) $ f + in go 0 + + foldlM f base = \ arr@(STBytes# n _ _) -> + let go i = -1 == i ? return base $ go (i - 1) >>=<< (arr !#> i) $ f + in go (n - 1) + +instance (Unboxed e) => SplitM (ST s) (STBytes# s e) e + where + takeM n es@(STBytes# c o marr#) + | n <= 0 = newNull + | n >= c = return es + | True = return (STBytes# n o marr#) + + dropM n es@(STBytes# c o marr#) + | n >= c = newNull + | n <= 0 = return es + | True = return (STBytes# (c - n) (o + n) marr#) + + keepM n es@(STBytes# c o marr#) + | n <= 0 = newNull + | n >= c = return es + | True = return (STBytes# n (c - n + o) marr#) + + sansM n es@(STBytes# c o marr#) + | n >= c = newNull + | n <= 0 = return es + | True = return (STBytes# (c - n) o marr#) + + splitM n es@(STBytes# c o marr#) + | n <= 0 = do e' <- newNull; return (e', es) + | n >= c = do e' <- newNull; return (es, e') + | True = return (STBytes# n o marr#, STBytes# (c - n) (o + n) marr#) + + divideM n es@(STBytes# c o marr#) + | n <= 0 = do e' <- newNull; return (es, e') + | n >= c = do e' <- newNull; return (e', es) + | True = return (STBytes# n (c - n + o) marr#, STBytes# (c - n) o marr#) + + prefixM p es@(STBytes# c _ _) = + let go i = i >= c ? return c $ do e <- es !#> i; p e ? go (succ i) $ return i + in go 0 + + suffixM p es@(STBytes# c _ _) = + let go i = i < 0 ? return c $ do e <- es !#> i; p e ? go (pred i) $ return (c - i - 1) + in go (max 0 (c - 1)) + + mprefix p es@(STBytes# c _ _) = + let go i = i >= c ? return c $ do e <- es !#> i; p e ?^ go (succ 1) $ return i + in go 0 + + msuffix p es@(STBytes# c _ _) = + let go i = i < 0 ? return c $ do e <- es !#> i; p e ?^ go (pred i) $ return (c - i - 1) + in go (max 0 (c - 1)) + +-------------------------------------------------------------------------------- + +{- MapM, IndexedM and SortM instances. -} + +instance (Unboxed e) => MapM (ST s) (STBytes# s e) Int e + where + newMap ascs = fromAssocs (ascsBounds ascs) ascs + + newMap' defvalue ascs = fromAssocs' (ascsBounds ascs) defvalue ascs + + (>!) = (!#>) + + overwrite es@(STBytes# c _ _) ascs = + let ies = filter (inRange (0, c - 1) . fst) ascs + in mapM_ (uncurry $ writeM es) ies >> return es + + kfoldrM = ofoldrM + kfoldlM = ofoldlM + +instance (Unboxed e) => IndexedM (ST s) (STBytes# s e) Int e + where + fromAssocs bnds ascs = alloc (size bnds) >>= flip overwrite ascs + fromAssocs' bnds defvalue ascs = size bnds `filled` defvalue >>= (`overwrite` ascs) + + {-# INLINE writeM' #-} + writeM' (STBytes# _ (I# o#) marr#) = \ (I# i#) e -> ST $ + \ s1# -> case writeByteArray# marr# (o# +# i#) e s1# of + s2# -> (# s2#, () #) + + fromIndexed' es = do + let n = sizeOf es + copy <- alloc n + forM_ [0 .. n - 1] $ \ i -> writeM copy i (es !^ i) + return copy + + fromIndexedM es = do + n <- getSizeOf es + copy <- alloc n + forM_ [0 .. n - 1] $ \ i -> es !#> i >>= writeM copy i + return copy + +instance (Unboxed e) => SortM (ST s) (STBytes# s e) e + where + sortedMBy f es@(STBytes# n _ _) = + let go i e1 = i == n ? return True $ do e2 <- es !#> i; e1 `f` e2 ? go (i + 1) e2 $ return False + in n < 2 ? return True $ go 1 =<< getHead es + + sortMBy = timSortBy + +-------------------------------------------------------------------------------- + +-- | 'MIOBytes#' is mutable pseudo-primitive 'Int'-indexed strict unboxed array. +newtype MIOBytes# (io :: Type -> Type) e = MIOBytes# (STBytes# RealWorld e) + deriving ( Eq ) + +-- | 'IOBytes#' is mutable pseudo-primitive 'Int'-indexed strict unboxed array. +type IOBytes# = MIOBytes# IO + +{-# INLINE unpack #-} +unpack :: MIOBytes# io e -> STBytes# RealWorld e +unpack = coerce + +{-# INLINE pack #-} +pack :: (MonadIO io) => ST RealWorld (STBytes# RealWorld e) -> io (MIOBytes# io e) +pack = stToMIO . coerce + +-------------------------------------------------------------------------------- + +{- Estimate, Bordered and BorderedM instances. -} + +instance Estimate (MIOBytes# io e) + where + (<==>) = on (<=>) sizeOf + (.<=.) = on (<=) sizeOf + (.>=.) = on (>=) sizeOf + (.>.) = on (>) sizeOf + (.<.) = on (<) sizeOf + + (<.=>) = (<=>) . sizeOf + (.>=) = (>=) . sizeOf + (.<=) = (<=) . sizeOf + (.>) = (>) . sizeOf + (.<) = (<) . sizeOf + +instance Bordered (MIOBytes# io e) Int + where + lower = const 0 + + sizeOf (MIOBytes# (STBytes# c _ _)) = c + upper (MIOBytes# (STBytes# c _ _)) = c - 1 + bounds (MIOBytes# (STBytes# c _ _)) = (0, c - 1) + indices (MIOBytes# (STBytes# c _ _)) = [0 .. c - 1] + indexOf (MIOBytes# (STBytes# c _ _)) = index (0, c - 1) + offsetOf (MIOBytes# (STBytes# c _ _)) = offset (0, c - 1) + indexIn (MIOBytes# (STBytes# c _ _)) = \ i -> i >= 0 && i < c + +instance (MonadIO io) => BorderedM io (MIOBytes# io e) Int + where + getIndexOf = return ... indexOf . unpack + getIndices = return . indices . unpack + getSizeOf = return . sizeOf . unpack + getBounds = return . bounds . unpack + getUpper = return . upper . unpack + getLower _ = return 0 + +-------------------------------------------------------------------------------- + +{- LinearM and SplitM instances. -} + +instance (MonadIO io, Unboxed e) => LinearM io (MIOBytes# io e) e + where + newNull = pack newNull + singleM = pack . singleM + nowNull = stToMIO . nowNull . unpack + getHead = stToMIO . getHead . unpack + getLast = stToMIO . getLast . unpack + + prepend e = pack . prepend e . unpack + append es = pack . append (unpack es) + + newLinear = pack . newLinear + newLinearN = pack ... newLinearN + fromFoldableM = pack . fromFoldableM + + (!#>) = stToMIO ... (!#>) . unpack + + writeM es = stToMIO ... writeM (unpack es) + + copied = pack . copied . unpack + getLeft = stToMIO . getLeft . unpack + reversed = pack . reversed . unpack + getRight = stToMIO . getRight . unpack + + copied' es = pack ... copied' (unpack es) + + merged = pack . merged . foldr ((:) . unpack) [] + filled = pack ... filled + + copyTo src so trg to = stToMIO . copyTo (unpack src) so (unpack trg) to + + ofoldrM f base = \ arr@(MIOBytes# (STBytes# n _ _)) -> + let go i = n == i ? return base $ (arr !#> i) >>=<< go (i + 1) $ f i + in go 0 + + ofoldlM f base = \ arr@(MIOBytes# (STBytes# n _ _)) -> + let go i = -1 == i ? return base $ go (i - 1) >>=<< (arr !#> i) $ (f i) + in go (n - 1) + + foldrM f base arr = + let go i = sizeOf arr == i ? return base $ (arr !#> i) >>=<< go (i + 1) $ f + in go 0 + + foldlM f base arr = + let go i = -1 == i ? return base $ go (i - 1) >>=<< (arr !#> i) $ f + in go (sizeOf arr - 1) + +instance (MonadIO io, Unboxed e) => SplitM io (MIOBytes# io e) e + where + takeM n = pack . takeM n . unpack + dropM n = pack . dropM n . unpack + keepM n = pack . keepM n . unpack + sansM n = pack . sansM n . unpack + + prefixM f = stToMIO . prefixM f . unpack + suffixM f = stToMIO . suffixM f . unpack + + mprefix p es@(MIOBytes# (STBytes# c _ _)) = + let go i = i >= c ? return c $ do e <- es !#> i; p e ?^ go (succ 1) $ return i + in go 0 + + msuffix p es@(MIOBytes# (STBytes# c _ _)) = + let go i = i < 0 ? return c $ do e <- es !#> i; p e ?^ go (pred i) $ return (c - i - 1) + in go (max 0 (c - 1)) + +-------------------------------------------------------------------------------- + +{- MapM, IndexedM and SortM instances. -} + +instance (MonadIO io, Unboxed e) => MapM io (MIOBytes# io e) Int e + where + newMap' = pack ... newMap' + newMap = pack . newMap + + (>!) = (!#>) + + overwrite = pack ... overwrite . unpack + + kfoldrM = ofoldrM + kfoldlM = ofoldlM + +instance (MonadIO io, Unboxed e) => IndexedM io (MIOBytes# io e) Int e + where + fromAssocs bnds = pack . fromAssocs bnds + fromAssocs' bnds = pack ... fromAssocs' bnds + + writeM' es = stToMIO ... writeM' (unpack es) + + fromIndexed' = pack . fromIndexed' + + fromIndexedM es = do + n <- getSizeOf es + copy <- filled n (unreachEx "fromIndexedM") + forM_ [0 .. n - 1] $ \ i -> es !#> i >>= writeM copy i + return copy + +instance (MonadIO io, Unboxed e) => SortM io (MIOBytes# io e) e + where + sortedMBy f = stToMIO . sortedMBy f . unpack + sortMBy = timSortBy + +-------------------------------------------------------------------------------- + +instance (MonadIO io, Unboxed e) => Thaw io (SBytes# e) (MIOBytes# io e) + where + unsafeThaw = pack . unsafeThaw + thaw = pack . thaw + +instance (MonadIO io, Unboxed e) => Freeze io (MIOBytes# io e) (SBytes# e) + where + unsafeFreeze = stToMIO . unsafeFreeze . unpack + freeze = stToMIO . freeze . unpack + +-------------------------------------------------------------------------------- + +instance (Storable e, Unboxed e) => Freeze IO (Int, Ptr e) (SBytes# e) + where + freeze (n, ptr) = do + let !n'@(I# n#) = max 0 n + es' <- stToIO . ST $ \ s1# -> case pnewUnboxed ptr n# s1# of + (# s2#, marr# #) -> (# s2#, MIOBytes# (STBytes# n' 0 marr#) #) + forM_ [0 .. n' - 1] $ \ i -> peekElemOff ptr i >>= writeM es' i + freeze es' + +instance (Storable e, Unboxed e) => Thaw IO (SBytes# e) (Int, Ptr e) + where + thaw (SBytes# n o arr#) = do + ptr <- callocArray n + forM_ [o .. n + o - 1] $ \ i@(I# i#) -> pokeElemOff ptr i (arr# !# i#) + return (n, ptr) + +-------------------------------------------------------------------------------- + +-- | 'unpackSBytes#' returns 'ByteArray#' field of 'SBytes#'. +unpackSBytes# :: (Unboxed e) => SBytes# e -> ByteArray# +unpackSBytes# = \ (SBytes# _ _ marr#) -> marr# + +-- | 'offsetSBytes#' returns 'SBytes#' offset in elements. +offsetSBytes# :: (Unboxed e) => SBytes# e -> Int +offsetSBytes# = \ (SBytes# _ o _) -> o + +-- | 'packSBytes#' creates new 'SBytes#' from sized 'ByteArray#'. +packSBytes# :: (Unboxed e) => Int -> ByteArray# -> SBytes# e +packSBytes# n marr# = SBytes# (max 0 n) 0 marr# + +-- | 'fromSBytes#' returns new 'ByteArray#'. +fromSBytes# :: (Unboxed e) => SBytes# e -> ByteArray# +fromSBytes# es@(SBytes# c@(I# c#) o@(I# o#) src#) = + let + !(SBytes# _ _ res#) = runST $ ST $ \ s1# -> case pnewUnboxed es c# s1# of + (# s2#, mcopy# #) -> case pcopyUnboxed es src# o# mcopy# 0# c# s2# of + s3# -> case unsafeFreezeByteArray# mcopy# s3# of + (# s4#, copy# #) -> (# s4#, SBytes# c o copy# #) + in res# + +{- | + 'unsafeCoerceSBytes#' is unsafe low-lowel coerce of an array with recounting + the number of elements and offset (with possible rounding). +-} +unsafeCoerceSBytes# :: (Unboxed a, Unboxed b) => SBytes# a -> SBytes# b +unsafeCoerceSBytes# pa@(SBytes# n o arr#) = pb + where + n' = n * s1 `div` s2; s1 = psizeof pa 8 + o' = o * s1 `div` s2; s2 = psizeof pb 8 + pb = SBytes# n' o' arr# + +-- | 'unpackSTBytes#' returns 'MutableByteArray#' field of 'STBytes#'. +unpackSTBytes# :: (Unboxed e) => STBytes# s e -> MutableByteArray# s +unpackSTBytes# = \ (STBytes# _ _ marr#) -> marr# + +-- | 'offsetSTBytes#' returns 'STBytes#' offset in bytes. +offsetSTBytes# :: (Unboxed e) => STBytes# s e -> Int# +offsetSTBytes# = \ (STBytes# _ (I# o#) _) -> o# + +-- | 'packSTBytes#' creates new 'STBytes#' from sized 'MutableByteArray#'. +packSTBytes# :: (Unboxed e) => Int -> MutableByteArray# s -> STBytes# s e +packSTBytes# n marr# = STBytes# (max 0 n) 0 marr# + +-- | 'fromSTBytes#' returns new 'MutableByteArray#'. +fromSTBytes# :: (Unboxed e) => STBytes# s e -> State# s -> (# State# s, MutableByteArray# s #) +fromSTBytes# es = \ s1# -> case cloneSTBytes# es of + ST rep -> case rep s1# of (# s2#, (STBytes# _ _ marr#) #) -> (# s2#, marr# #) + +{- | + 'unsafeCoerceSTBytes#' is unsafe low-lowel coerce of an mutable array with + recounting the number of elements and offset (with possible rounding). +-} +unsafeCoerceSTBytes# :: (Unboxed a, Unboxed b) => STBytes# s a -> STBytes# s b +unsafeCoerceSTBytes# pa@(STBytes# n o arr#) = pb + where + n' = n * s1 `div` s2; s1 = psizeof pa 8 + o' = o * s1 `div` s2; s2 = psizeof pb 8 + pb = STBytes# n' o' arr# + +{- | + @'unsafeSBytesToPtr#' es@ byte-wise stores 'SBytes#' content to 'Ptr'. Returns + the number of overwritten elements and a pointer to @psizeof es (sizeOf es)@ + bytes of allocated memory. +-} +unsafeSBytesToPtr# :: (Unboxed e) => SBytes# e -> IO (Int, Ptr e) +unsafeSBytesToPtr# es@(SBytes# c (I# o#) marr#) = do + let + pokeByte :: Ptr a -> Int -> Word8 -> IO () + pokeByte = pokeByteOff + + n = psizeof es c + + ptr <- mallocBytes n + forM_ [0 .. n - 1] $ \ i@(I# i#) -> pokeByte ptr i (marr# !# (o# +# i#)) + return (n, ptr) + +{- | + @'unsafePtrToSBytes#' n ptr@ byte-wise stores @n@ elements of 'Ptr' @ptr@ to + 'SBytes#'. +-} +unsafePtrToSBytes# :: (Unboxed e) => (Int, Ptr e) -> IO (SBytes# e) +unsafePtrToSBytes# (c, ptr) = do + let + !n@(I# n#) = psizeof ptr c' + c' = max 0 c + + es@(STBytes# _ _ arr#) <- stToIO $ ST $ \ s1# -> case pnewUnboxed ptr n# s1# of + (# s2#, marr# #) -> (# s2#, STBytes# c' 0 marr# #) + + forM_ [0 .. n - 1] $ \ i@(I# i#) -> do + e <- peekByteOff ptr i :: IO Word8 + stToIO $ ST $ \ s1# -> case writeByteArray# arr# i# e s1# of + s2# -> (# s2#, () #) + + stToIO (done es) + +-- | Calculate hash 'SBytes#' using 'hashUnboxedWith'. +hashSBytesWith# :: (Unboxed e) => Int -> SBytes# e -> Int +hashSBytesWith# (I# salt#) es@(SBytes# (I# c#) (I# o#) bytes#) = + I# (hashUnboxedWith (fromProxy es) c# o# bytes# salt#) + +-------------------------------------------------------------------------------- + +{-# INLINE done #-} +done :: STBytes# s e -> ST s (SBytes# e) +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#) = + let res = ST $ \ s1# -> case pnewUnboxed1 res c# s1# of + (# s2#, marr# #) -> (# s2#, STBytes# c 0 marr# #) + in res + +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#, () #) + 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 +nubSorted _ Z = Z +nubSorted f es = + let fun = \ e ls -> e `f` head ls == EQ ? ls $ e : ls + in fromList $ foldr fun [last es] ((es !^) <$> [0 .. sizeOf es - 2]) + +ascsBounds :: (Ord a) => [(a, b)] -> (a, a) +ascsBounds = \ ((x, _) : xs) -> foldr (\ (e, _) (mn, mx) -> (min mn e, max mx e)) (x, x) xs + +-------------------------------------------------------------------------------- + +overEx :: String -> a +overEx = throw . IndexOverflow . showString "in SDP.Prim.SBytes." + +underEx :: String -> a +underEx = throw . IndexUnderflow . showString "in SDP.Prim.SBytes." + +unreachEx :: String -> a +unreachEx = throw . UnreachableException . showString "in SDP.Prim.SBytes." + diff --git a/src/SDP/Prim/TArray.hs b/src/SDP/Prim/TArray.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Prim/TArray.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE Trustworthy, MagicHash, MultiParamTypeClasses, FlexibleInstances #-} + +{- | + Module : SDP.Prim.TArray + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable + + "SDP.Prim.TArray" provides lazy boxed array of @stm@ 'TVar's. + Note that 'TArray#' stores each element in 'TVar'. +-} +module SDP.Prim.TArray +( + -- TArray + TArray# (..), STM, TVar +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Prim.SArray + +import GHC.Conc + +import Control.Exception.SDP + +default () + +-------------------------------------------------------------------------------- + +-- | 'SArray#' of @stm@ 'TVar's. +newtype TArray# e = TArray# (SArray# (TVar e)) deriving ( Eq ) + +-------------------------------------------------------------------------------- + +{- Nullable, Estimate, Bordered and BorderedM instances. -} + +instance Nullable (TArray# e) + where + isNull = \ (TArray# es) -> isNull es + lzero = TArray# Z + +instance Estimate (TArray# e) + where + (<==>) = on (<=>) sizeOf + (.<=.) = on (<=) sizeOf + (.>=.) = on (>=) sizeOf + (.>.) = on (>) sizeOf + (.<.) = on (<) sizeOf + + (<.=>) = (<=>) . sizeOf + (.>=) = (>=) . sizeOf + (.<=) = (<=) . sizeOf + (.>) = (>) . sizeOf + (.<) = (<) . sizeOf + +instance Bordered (TArray# e) Int + where + lower _ = 0 + + upper (TArray# arr) = upper arr + sizeOf (TArray# arr) = sizeOf arr + bounds (TArray# arr) = (0, upper arr) + indices (TArray# arr) = [0 .. upper arr] + indexOf (TArray# arr) = index (0, upper arr) + offsetOf (TArray# arr) = offset (0, upper arr) + indexIn (TArray# arr) = \ i -> i >= 0 && i < sizeOf arr + +instance BorderedM STM (TArray# e) Int + where + getIndexOf = return ... indexOf + getIndices = return . indices + getBounds = return . bounds + getSizeOf = return . sizeOf + getUpper = return . upper + getLower _ = return 0 + +-------------------------------------------------------------------------------- + +{- LinearM and SplitM instances. -} + +instance LinearM STM (TArray# e) e + where + newNull = return (TArray# Z) + nowNull = return . isNull . unpack + getHead = readTVar . head . unpack + getLast = readTVar . last . unpack + singleM = fmap (TArray# . single) . newTVar + + prepend e es = TArray# . (:> unpack es) <$> newTVar e + append es e = TArray# . (unpack es :<) <$> newTVar e + + newLinear = fmap (TArray# . fromList) . mapM newTVar + newLinearN n = fmap (TArray# . fromListN n) . mapM newTVar + fromFoldableM = fmap (TArray# . fromList) . foldr (liftA2 (:) . newTVar) (return []) + + (!#>) = readTVar ... (!^) . unpack + writeM = writeM' + + getLeft = mapM readTVar . listL . unpack + getRight = mapM readTVar . listR . unpack + merged = return . TArray# . concatMap unpack + reversed = return . TArray# . reverse . unpack + filled n = fmap (TArray# . fromList) . replicateM n . newTVar + + copyTo src so trg to n = when (n > 0) $ do + when (so < 0 || to < 0) $ underEx "copyTo" + when (so + n > n1 || to + n > n2) $ overEx "copyTo" + go so to n + where + go _ _ 0 = return () + go i j c = do e <- src !#> i; writeM trg j e; go (i + 1) (j + 1) (c - 1) + + n1 = sizeOf src + n2 = sizeOf trg + + ofoldlM f base = ofoldl (\ i es -> ($ f i) . (es >>=<<) . readTVar) (return base) . unpack + ofoldrM f base = ofoldr (\ i -> ($ f i) ... (>>=<<) . readTVar) (return base) . unpack + + foldlM f base = foldl (\ es -> ($ f) . (es >>=<<) . readTVar) (return base) . unpack + foldrM f base = foldr (($ f) ... (>>=<<) . readTVar) (return base) . unpack + +instance SplitM STM (TArray# e) e + where + takeM n = return . TArray# . take n . unpack + dropM n = return . TArray# . drop n . unpack + keepM n = return . TArray# . keep n . unpack + sansM n = return . TArray# . sans n . unpack + + prefixM p es = + let + go i = i >= c ? return c $ do e <- es !#> i; p e ? go (succ 1) $ return i + c = sizeOf es + in go 0 + + suffixM p es = + let + go i = i < 0 ? return c $ do e <- es !#> i; p e ? go (pred i) $ return (c - i - 1) + c = sizeOf es + in go (c - 1) + + mprefix p es = + let + go i = i >= c ? return c $ do e <- es !#> i; p e ?^ go (succ 1) $ return i + c = sizeOf es + in go 0 + + msuffix p es = + let + go i = i < 0 ? return c $ do e <- es !#> i; p e ?^ go (pred i) $ return (c - i - 1) + c = sizeOf es + in go (c - 1) + +-------------------------------------------------------------------------------- + +{- MapM and IndexedM instances. -} + +instance MapM STM (TArray# e) Int e + where + newMap' defvalue ascs = fromAssocs' (ascsBounds ascs) defvalue ascs + + (>!) = (!#>) + + overwrite es ascs = do + mapM_ (uncurry $ writeM es) (filter (indexIn es . fst) ascs) + return es + + kfoldrM = ofoldrM + kfoldlM = ofoldlM + +instance IndexedM STM (TArray# e) Int e + where + fromAssocs' bnds defvalue ascs = size bnds `filled` defvalue >>= (`overwrite` ascs) + + {-# INLINE writeM' #-} + writeM' = writeTVar ... (!^) . unpack + + fromIndexed' es = do + let n = sizeOf es + copy <- filled n (unreachEx "fromIndexed'") + forM_ [0 .. n - 1] $ \ i -> writeM copy i (es !^ i) + return copy + + fromIndexedM es = do + n <- getSizeOf es + copy <- filled n (unreachEx "fromIndexedM") + forM_ [0 .. n - 1] $ \ i -> es !#> i >>= writeM copy i + return copy + +-------------------------------------------------------------------------------- + +{- Freeze and Thaw instances. -} + +instance Thaw STM (SArray# e) (TArray# e) where thaw = fmap TArray# . mapM newTVar + +instance Freeze STM (TArray# e) (SArray# e) where freeze = mapM readTVar . unpack + +-------------------------------------------------------------------------------- + +ascsBounds :: (Ord a) => [(a, b)] -> (a, a) +ascsBounds = \ ((x, _) : xs) -> foldr (\ (e, _) (mn, mx) -> (min mn e, max mx e)) (x, x) xs + +unpack :: TArray# e -> SArray# (TVar e) +unpack = \ (TArray# arr) -> arr + +overEx :: String -> a +overEx = throw . IndexOverflow . showString "in SDP.Prim.TArray." + +underEx :: String -> a +underEx = throw . IndexUnderflow . showString "in SDP.Prim.TArray." + +unreachEx :: String -> a +unreachEx = throw . UnreachableException . showString "in SDP.Prim.TArray." + diff --git a/src/SDP/Ratio.hs b/src/SDP/Ratio.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Ratio.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe, ViewPatterns, PatternSynonyms #-} + +{- | + Module : SDP.Ratio + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Ratio" provides @(':%')@ pattern for 'Ratio'. +-} +module SDP.Ratio +( + -- * Export + module Data.Ratio, pattern (:%) +) +where + +import Data.Ratio + +infixl 7 :% + +default () + +-------------------------------------------------------------------------------- + +{-# COMPLETE (:%) #-} + +-- | Crutch pattern: real (':%') is closed 'Ratio' constructor. +pattern (:%) :: (Integral a) => a -> a -> Ratio a +pattern n :% d <- ((\ r -> (numerator r, denominator r)) -> (n, d)) where (:%) = (%) + + + + diff --git a/src/SDP/SafePrelude.hs b/src/SDP/SafePrelude.hs new file mode 100644 --- /dev/null +++ b/src/SDP/SafePrelude.hs @@ -0,0 +1,170 @@ +{-# OPTIONS_HADDOCK ignore-exports #-} +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.SafePrelude + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.SafePrelude" module re-exports common "Prelude" definitions except + 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", + "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 + @ +-} +module SDP.SafePrelude +( + -- * Exports + module Control.Applicative, liftA4, liftA5, liftA6, + + module Control.Monad.IO.Class, stToMIO, + module Control.Monad.ST, + module Control.Monad, liftM6, + + module Data.Functor.Classes, + module Data.Bifunctor, + module Data.Foldable, + + module SDP.Comparing, + module SDP.Estimate, + + module Prelude, + + -- * Combinators + on, (?), (?+), (?-), (?^), (?:), (+?), (...), (<=<<), (>>=>), (>>=<<) +) +where + +import Prelude hiding + ( + -- defined in SDP.Zip and Data.List + zip, zip3, zipWith, zipWith3, + + -- defined in SDP.Scan and Data.List + scanl, scanr, scanl1, scanr1, + + -- defined in SDP.Linear and Data.List + head, tail, init, last, take, drop, (!!), (++), reverse, filter, lookup, + concat, concatMap, replicate, takeWhile, dropWhile, iterate, + + -- defined in System.IO.Handle, System.IO.Classes (@sdp-io@) and System.IO + readFile, writeFile, appendFile, getContents, + getChar, putChar, getLine, putStr, putStrLn + ) + +import SDP.Comparing +import SDP.Estimate + +import Data.Functor.Classes +import Data.Bifunctor +import Data.Foldable hiding ( foldrM, foldlM, concat, concatMap ) +import Data.Function ( on ) + +import Control.Applicative + +import Control.Monad.IO.Class +import Control.Monad.ST +import Control.Monad + +infixl 8 ?+, ?- +infixr 1 ?, ?^ -- Lowest priority, compatible with infixr 0 $ +infixr 0 ... + +default () + +-------------------------------------------------------------------------------- + +{- | + Ternary operator. + + > (odd 1 ? "is True" $ "is False") == "is True" +-} +{-# INLINE (?) #-} +(?) :: Bool -> a -> a -> a +(?) = \ p t e -> if p then t else e + +-- | @p ?+ f $ a@ returns @'Just' (f a)@ if @(p a)@ and 'Nothing' otherwise. +{-# INLINE (?+) #-} +(?+) :: (a -> Bool) -> (a -> b) -> a -> Maybe b +(?+) = \ p f a -> p a ? Just (f a) $ Nothing + +-- | @p ?- f $ a@ returns 'Nothing' if @(p a)@ and @'Just' (f a)@ otherwise. +{-# INLINE (?-) #-} +(?-) :: (a -> Bool) -> (a -> b) -> a -> Maybe b +(?-) = \ p f a -> p a ? Nothing $ Just (f a) + +-- | Prepends 'Maybe' to list. +{-# INLINE (?:) #-} +(?:) :: Maybe a -> [a] -> [a] +(?:) = \ mx xs -> case mx of {(Just x) -> x : xs; _ -> xs} + +-- | Short version of 'Data.Maybe.fromMaybe'. +{-# INLINE (+?) #-} +(+?) :: a -> Maybe a -> a +_ +? Just x = x +x +? Nothing = x + +-- | @(...) = (.) . (.)@. +{-# INLINE (...) #-} +(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(...) = (.) . (.) + +-------------------------------------------------------------------------------- + +{-# INLINE (?^) #-} +-- | Lifted @('?')@. +(?^) :: (Monad m) => m Bool -> m a -> m a -> m a +(?^) = \ mb mt me -> do b <- mb; if b then mt else me + +-- | Monadic version of @('...')@. +(<=<<) :: (Monad m) => (c -> m d) -> (a -> b -> m c) -> (a -> b -> m d) +(<=<<) = \ mg mf a b -> mf a b >>= mg + +-- | Monadic vesion of @('...')@ with reversed arguments. +(>>=>) :: (Monad m) => (a -> b -> m c) -> (c -> m d) -> (a -> b -> m d) +(>>=>) = \ mf mg a b -> mf a b >>= mg + +-- | @ma >>=<< mb@ is composition of 'join' and 'liftM2'. +{-# INLINE (>>=<<) #-} +(>>=<<) :: (Monad m) => m a -> m b -> (a -> b -> m c) -> m c +(>>=<<) = \ ma mb f -> join $ liftM2 f ma mb + +-------------------------------------------------------------------------------- + +-- | Very useful combinator. +liftA4 :: (Applicative t) => (a -> b -> c -> d -> e) -> t a -> t b -> t c -> t d -> t e +liftA4 g as bs cs ds = g <$> as <*> bs <*> cs <*> ds + +-- | Very very useful combinator +liftA5 :: (Applicative t) => (a -> b -> c -> d -> e -> f) -> t a -> t b -> t c -> t d -> t e -> t f +liftA5 g as bs cs ds es = g <$> as <*> bs <*> cs <*> ds <*> es + +-- | An even more useful combinator. +liftA6 :: (Applicative t) => (a -> b -> c -> d -> e -> f -> g) -> t a -> t b -> t c -> t d -> t e -> t f -> t g +liftA6 g as bs cs ds es fs = g <$> as <*> bs <*> cs <*> ds <*> es <*> fs + +-- | See 'liftA6'. +liftM6 :: (Monad m) => (a -> b -> c -> d -> e -> f -> g) -> m a -> m b -> m c -> m d -> m e -> m f -> m g +liftM6 g as bs cs ds es fs = do a <- as; b <- bs; c <- cs; d <- ds; e <- es; f <- fs; return $ g a b c d e f + +-------------------------------------------------------------------------------- + +-- | 'stToMIO' is just @'liftIO' . 'stToIO'@. +stToMIO :: (MonadIO io) => ST RealWorld e -> io e +stToMIO = liftIO . stToIO + + + + diff --git a/src/SDP/Scan.hs b/src/SDP/Scan.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Scan.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Safe, MultiParamTypeClasses, FlexibleInstances #-} + +{- | + Module : SDP.Scan + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (requires non-portable modules) + + "SDP.Scan" provides 'Scan' - class for overloaded scans. 'Scan' needed for + generalization and not so useful is practice as other @sdp@ classes. +-} +module SDP.Scan ( Scan (..) ) where + +import Prelude () +import SDP.SafePrelude +import SDP.Linear + +import qualified Data.List as L ( scanl, scanr, scanl', scanl1, scanr1 ) + +default () + +-------------------------------------------------------------------------------- + +-- | Scan is class of scans. +class (Linear s a) => Scan s a + where + scanl, scanl' :: (b -> a -> b) -> b -> s -> [b] + scanr, scanr' :: (a -> b -> b) -> b -> s -> [b] + scanl1, scanr1 :: (a -> a -> a) -> s -> [a] + + scanl f base = scanl f base . listL + scanr f base = scanr f base . listL + scanl' f base = scanl' f base . listL + scanr' f base = scanr' f base . listL + + scanl1 f = scanl1 f . listL + scanr1 f = scanr1 f . listL + +-------------------------------------------------------------------------------- + +instance Scan [a] a + where + scanl = L.scanl + scanr = L.scanr + scanl' = L.scanl' + scanr' = L.scanr + scanl1 = L.scanl1 + scanr1 = L.scanr1 + diff --git a/src/SDP/Set.hs b/src/SDP/Set.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Set.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE TypeOperators, TypeFamilies, ConstraintKinds, DefaultSignatures #-} +{-# LANGUAGE Trustworthy #-} + +{- | + Module : SDP.Set + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC Extensions) + + "SDP.Set" provides 'Set' - class for basic set operations. +-} +module SDP.Set +( + -- * SetWith + SetWith (..), SetWith1, + + -- * Set + Set (..), Set1 +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Linear + +import Data.Maybe ( isJust ) +import Data.List ( groupBy ) + +import GHC.Types + +default () + +-------------------------------------------------------------------------------- + +{- | + 'SetWith' is a class of data structures, that can represent sets. + + 'SetWith' doesn't provide data protection/validation before each first action. + All functions (except 'setWith') works correctly only with correct sets. + 'SetWith' guarantee only that the returned data is correct. So if you need + maximum reliability and security, use @containers@. But if you want + 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. +-} +class (Nullable s) => SetWith s o | s -> o + where + {-# MINIMAL intersectionWith, unionWith, differenceWith, lookupLTWith, lookupGTWith #-} + + {- Creation functions. -} + + -- | Creates ordered set from linear structure. + default setWith :: (Linear s o) => Compare o -> s -> s + setWith :: Compare o -> s -> s + setWith f = fromList . setWith f . listL + + {- | + Creates set from linear structure using additional function for + choice/merge equal elements. + -} + default groupSetWith :: (Linear s o) => Compare o -> (o -> o -> o) -> s -> s + groupSetWith :: Compare o -> (o -> o -> o) -> s -> s + groupSetWith cmp f = fromList . groupSetWith cmp f . listL + + -- | Adding element to set. + default insertWith :: (Linear s o) => Compare o -> o -> s -> s + insertWith :: Compare o -> o -> s -> s + insertWith f = unionWith f . single + + -- | Deleting element from set. + default deleteWith :: (Linear s o) => Compare o -> o -> s -> s + deleteWith :: Compare o -> o -> s -> s + deleteWith f = flip (differenceWith f) . single + + {- Basic operations on sets. -} + + -- | Intersection of two sets. + intersectionWith :: Compare o -> s -> s -> s + + -- | Difference (relative complement, aka A / B) of two sets. + differenceWith :: Compare o -> s -> s -> s + + -- | Symmetric difference of two sets. + symdiffWith :: Compare o -> s -> s -> s + symdiffWith f xs ys = differenceWith f (unionWith f xs ys) (intersectionWith f xs ys) + + -- | Union of two sets. + unionWith :: Compare o -> s -> s -> s + + {- Generalization of basic set operations on foldable. -} + + -- | Fold by 'intersectionWith'. + intersectionsWith :: (Foldable f) => Compare o -> f s -> s + intersectionsWith = (`foldl` Z) . intersectionWith + + -- | Fold by 'differenceWith'. + differencesWith :: (Foldable f) => Compare o -> f s -> s + differencesWith = (`foldl` Z) . differenceWith + + -- | Fold by 'unionWith'. + unionsWith :: (Foldable f) => Compare o -> f s -> s + unionsWith = (`foldl` Z) . unionWith + + -- | Fold by 'symdiffWith'. + symdiffsWith :: (Foldable f) => Compare o -> f s -> s + symdiffsWith = (`foldl` Z) . symdiffWith + + {- Сomparsion operations. -} + + -- | Compares sets on intersection. + isIntersectsWith :: Compare o -> s -> s -> Bool + isIntersectsWith f = not ... isDisjointWith f + + -- | Compares sets on disjoint. + isDisjointWith :: Compare o -> s -> s -> Bool + isDisjointWith f = isNull ... intersectionWith f + + -- | Same as 'elem', but can work faster. By default, uses 'find'. + default memberWith :: (t o ~~ s, Foldable t) => Compare o -> o -> s -> Bool + memberWith :: Compare o -> o -> s -> Bool + memberWith f e = isJust . find (\ x -> f e x == EQ) + + -- | Сhecks whether a first set is a subset of second. + default isSubsetWith :: (t o ~~ s, Foldable t) => Compare o -> s -> s -> Bool + isSubsetWith :: Compare o -> s -> s -> Bool + isSubsetWith f xs ys = all (\ x -> memberWith f x ys) xs + + -- | Generates a list of different subsets (including empty and equivalent). + default subsets :: (Linear s o, Ord o) => s -> [s] + subsets :: (Ord o) => s -> [s] + subsets = subsequences . setWith compare + + {- Lookups. -} + + -- | 'lookupLTWith' trying to find lesser element in set. + lookupLTWith :: Compare o -> o -> s -> Maybe o + + -- | 'lookupGTWith' trying to find greater element in set. + lookupGTWith :: Compare o -> o -> s -> Maybe o + + -- | 'lookupGEWith' trying to find greater or equal element in set. + lookupGEWith :: Compare o -> o -> s -> Maybe o + lookupGEWith f e es = memberWith f e es ? Just e $ lookupGTWith f e es + + -- | 'lookupLEWith' trying to find lesser or equal element in set. + lookupLEWith :: Compare o -> o -> s -> Maybe o + lookupLEWith f e es = memberWith f e es ? Just e $ lookupLTWith f e es + +-------------------------------------------------------------------------------- + +{- | + 'Set' is a class of data structures, that can represent any sets. 'Set' is + intended for more specific sets than ordered linear structures. In particular, + it may not work with an arbitrary comparator, and also (unlike the early + implementation) does not impose restrictions on the element type. + + 'Set', as well as 'SetWith', doesn't provide data protection/validation. +-} +class (Nullable s) => Set s o | s -> o + where + -- | The same as @'setWith' 'compare'@. + default set :: (SetWith s o, Ord o) => s -> s + set :: s -> s + set = setWith compare + + -- | Same as @'insert' 'compare'@. + default insert :: (SetWith s o, Ord o) => o -> s -> s + insert :: o -> s -> s + insert = insertWith compare + + -- | Same as @'deleteWith' 'compare'@. + default delete :: (SetWith s o, Ord o) => o -> s -> s + delete :: o -> s -> s + delete = deleteWith compare + + -- | Same as @'intersectionWith' 'compare'@. + default (/\) :: (SetWith s o, Ord o) => s -> s -> s + (/\) :: s -> s -> s + (/\) = intersectionWith compare + + -- | Same as @'unionWith' 'compare'@. + default (\/) :: (SetWith s o, Ord o) => s -> s -> s + (\/) :: s -> s -> s + (\/) = unionWith compare + + -- | Same as @'differenceWith' 'compare'@. + default (\\) :: (SetWith s o, Ord o) => s -> s -> s + (\\) :: s -> s -> s + (\\) = differenceWith compare + + -- | Same as @'symdiffWith' 'compare'@. + default (\^/) :: (SetWith s o, Ord o) => s -> s -> s + (\^/) :: s -> s -> s + (\^/) = symdiffWith compare + + -- | Same as @'isDisjointWith' 'compare'@. + default (/?\) :: (SetWith s o, Ord o) => s -> s -> Bool + (/?\) :: s -> s -> Bool + (/?\) = isDisjointWith compare + + -- | Same as @'isIntersectsWith' 'compare'@. + default (\?/) :: (SetWith s o, Ord o) => s -> s -> Bool + (\?/) :: s -> s -> Bool + (\?/) = isIntersectsWith compare + + -- | Same as @'isSubsetWith' 'compare'@. + default (\+/) :: (SetWith s o, Ord o) => s -> s -> Bool + (\+/) :: s -> s -> Bool + (\+/) = isSubsetWith compare + + -- | Same as @'intersectionsWith' 'compare'@. + default intersections :: (Foldable f, SetWith s o, Ord o) => f s -> s + intersections :: (Foldable f) => f s -> s + intersections = intersectionsWith compare + + -- | Same as @'unionsWith' 'compare'@. + default unions :: (Foldable f, SetWith s o, Ord o) => f s -> s + unions :: (Foldable f) => f s -> s + unions = unionsWith compare + + -- | Same as @'differencesWith' 'compare'@. + default differences :: (Foldable f, SetWith s o, Ord o) => f s -> s + differences :: (Foldable f) => f s -> s + differences = differencesWith compare + + -- | Same as @'symdiffsWith' compare'@. + default symdiffs :: (Foldable f, SetWith s o, Ord o) => f s -> s + symdiffs :: (Foldable f) => f s -> s + symdiffs = symdiffsWith compare + + -- | Same as @'memberWith' 'compare'@. + default member :: (SetWith s o, Ord o) => o -> s -> Bool + member :: o -> s -> Bool + member = memberWith compare + + -- | Same as @'lookupLTWith' 'compare'@. + default lookupLT :: (SetWith s o, Ord o) => o -> s -> Maybe o + lookupLT :: (Ord o) => o -> s -> Maybe o + lookupLT = lookupLTWith compare + + -- | Same as @'lookupGTWith' 'compare'@. + default lookupGT :: (SetWith s o, Ord o) => o -> s -> Maybe o + lookupGT :: (Ord o) => o -> s -> Maybe o + lookupGT = lookupGTWith compare + + -- | Same as @'lookupLEWith' 'compare'@. + default lookupLE :: (SetWith s o, Ord o) => o -> s -> Maybe o + lookupLE :: (Ord o) => o -> s -> Maybe o + lookupLE = lookupLEWith compare + + -- | Same as @'lookupGEWith' 'compare'@. + default lookupGE :: (SetWith s o, Ord o) => o -> s -> Maybe o + lookupGE :: (Ord o) => o -> s -> Maybe o + lookupGE = lookupGEWith compare + +-------------------------------------------------------------------------------- + +-- | Kind @(* -> *)@ 'Set'. +type Set1 s o = Set (s o) o + +-- | Kind @(* -> *)@ 'SetWith'. +type SetWith1 s o = SetWith (s o) o + +-------------------------------------------------------------------------------- + +instance (Ord o) => Set [o] o + +instance SetWith [o] o + where + setWith f = sortBy f . nubBy ((EQ ==) ... f) + + insertWith f e es@(x : xs) = case e `f` x of {GT -> x : insertWith f e xs; LT -> e : es; EQ -> es} + insertWith _ e _ = [e] + + deleteWith f e es@(x : xs) = case e `f` x of {GT -> x : deleteWith f e xs; LT -> es; EQ -> xs} + deleteWith _ _ _ = [] + + memberWith f e (x : xs) = case e `f` x of {GT -> memberWith f e xs; LT -> False; EQ -> True} + memberWith _ _ _ = False + + intersectionWith f xs'@(x : xs) ys'@(y : ys) = case x `f` y of + LT -> intersectionWith f xs ys' + GT -> intersectionWith f xs' ys + EQ -> x : intersectionWith f xs ys + intersectionWith _ _ _ = [] + + unionWith f xs'@(x : xs) ys'@(y : ys) = case x `f` y of + LT -> x : unionWith f xs ys' + EQ -> x : unionWith f xs ys + GT -> y : unionWith f xs' ys + unionWith _ xs ys = xs ++ ys + + differenceWith f xs'@(x : xs) ys'@(y : ys) = case f x y of + LT -> x : differenceWith f xs ys' + EQ -> differenceWith f xs ys + GT -> differenceWith f xs' ys + differenceWith _ xs _ = xs + + symdiffWith f xs'@(x : xs) ys'@(y : ys) = case f x y of + EQ -> symdiffWith f xs ys + LT -> x : symdiffWith f xs ys' + GT -> y : symdiffWith f xs' ys + symdiffWith _ xs ys = xs ++ ys + + isIntersectsWith f xs'@(x : xs) ys'@(y : ys) = case f x y of + LT -> isIntersectsWith f xs ys' + GT -> isIntersectsWith f xs' ys + EQ -> True + isIntersectsWith _ _ _ = False + + isDisjointWith f xs'@(x : xs) ys'@(y : ys) = case f x y of + LT -> isDisjointWith f xs ys' + GT -> isDisjointWith f xs' ys + EQ -> False + isDisjointWith _ _ _ = True + + lookupLTWith f o (x : xs) = case o `f` x of {GT -> look x xs; _ -> Nothing} + where + look r (e : es) = case o `f` e of {GT -> look e es; _ -> Just r} + look r _ = Just r + lookupLTWith _ _ _ = Nothing + + lookupGTWith f o (x : xs) = case o `f` x of {LT -> Just x; _ -> look xs} + where + look (e : es) = case o `f` e of {LT -> Just e; _ -> look es} + look _ = Nothing + lookupGTWith _ _ _ = Nothing + + lookupLEWith f o (x : xs) = case o `f` x of {LT -> Nothing; _ -> look x xs} + where + look r (e : es) = case o `f` e of {LT -> Just r; _ -> look e es} + look r _ = Just r + lookupLEWith _ _ _ = Nothing + + lookupGEWith f o (x : xs) = case o `f` x of {GT -> look xs; _ -> Just x} + where + look (e : es) = case o `f` e of {GT -> look es; _ -> Just e} + look _ = Nothing + lookupGEWith _ _ _ = Nothing + + groupSetWith cmp f = map (foldr1 f) . groupBy ((== EQ) ... cmp) . sortBy cmp + + + + diff --git a/src/SDP/Shape.hs b/src/SDP/Shape.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Shape.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE TypeFamilies, TypeOperators, DefaultSignatures, ConstraintKinds #-} +{-# LANGUAGE CPP, FlexibleInstances, UndecidableInstances, OverloadedLists #-} +{-# LANGUAGE Trustworthy #-} + +{- | + Module : SDP.Shape + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Shape" module provides 'Shape' - class of generalized indices. +-} +module SDP.Shape +( + -- * Exports + module SDP.Finite, + module SDP.Tuple, + + module Data.Word, + module Data.Int, + + -- * Shapes + Shape (..), GIndex, toGBounds, fromGBounds, + + -- ** Rank constraints + RANK0, RANK1, RANK2, RANK3, RANK4, RANK5, RANK6, RANK7, + RANK8, RANK9, RANK10, RANK11, RANK12, RANK13, RANK14, RANK15 +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Finite +import SDP.Tuple + +import Data.Word +import Data.Int + +import GHC.Types + +import Foreign.C.Types + +default () + +-------------------------------------------------------------------------------- + +-- | Type operator 'GIndex' returns generalized equivalent of index. +type family GIndex i + where + GIndex E = E + GIndex (i' :& i) = i' :& i + GIndex i = GIndex (DimInit i) :& DimLast i + +-------------------------------------------------------------------------------- + +{- | + 'Shape' is service class that constraints 'SDP.Index.Index'. + + Rules: + + > rank i == rank (j `asTypeOf` i) + > rank i == length (sizes (i, i)) + + > rank (lastDim E) = 0 + > rank (lastDim i) = 1 + > rank (initDim E) = 0 + > rank (lastDim i) = rank i - 1 + + > fromGIndex . toGIndex = id + > toGIndex . fromGIndex = id +-} +class Shape i + where + -- | Type of index top dimension. + type DimLast i :: Type + type DimLast i = i + + {- | + The type of subspace of 'rank' @n - 1@, where @n@ is the 'rank' of the + space specified by this 'SDP.Index.Index' type. + -} + type DimInit i :: Type + type DimInit i = E + + -- | Create index from generalized index. + {-# INLINE fromGIndex #-} + default fromGIndex :: (RANK1 i) => GIndex i -> i + fromGIndex :: GIndex i -> i + fromGIndex = \ [i] -> i + + -- | Create generalized index from index. + {-# INLINE toGIndex #-} + default toGIndex :: (RANK1 i) => i -> GIndex i + toGIndex :: i -> GIndex i + toGIndex = \ i -> [i] + + -- | Count of dimensions in represented space (must be finite and constant). + {-# INLINE rank #-} + rank :: i -> Int + rank = const 1 + + -- | Add new dimension. + {-# INLINE consDim #-} + default consDim :: (DimLast i ~~ i) => DimInit i -> DimLast i -> i + consDim :: DimInit i -> DimLast i -> i + consDim = const id + + {-# INLINE initDim #-} + default initDim :: (DimInit i ~~ E) => i -> DimInit i + initDim :: i -> DimInit i + initDim = const E + + {-# INLINE lastDim #-} + default lastDim :: (DimLast i ~~ i) => i -> DimLast i + lastDim :: i -> DimLast i + lastDim = id + + {-# INLINE unconsDim #-} + unconsDim :: i -> (DimInit i, DimLast i) + unconsDim = \ i -> (initDim i, lastDim i) + +-------------------------------------------------------------------------------- + +{- Rank constraints. -} + +-- | A constraint corresponding to rank 0 indices ('E'). +type RANK0 i = i ~~ E +-- | The restriction corresponding to rank indices 1 (сhecks 'GIndex'). +type RANK1 i = GIndex i ~~ (E :& i) +-- | The restriction corresponding to rank indices 2 (сhecks 'GIndex'). +type RANK2 i = GIndex i ~~ I2 i +-- | The restriction corresponding to rank indices 3 (сhecks 'GIndex'). +type RANK3 i = GIndex i ~~ I3 i +-- | The restriction corresponding to rank indices 4 (сhecks 'GIndex'). +type RANK4 i = GIndex i ~~ I4 i +-- | The restriction corresponding to rank indices 5 (сhecks 'GIndex'). +type RANK5 i = GIndex i ~~ I5 i +-- | The restriction corresponding to rank indices 6 (сhecks 'GIndex'). +type RANK6 i = GIndex i ~~ I6 i +-- | The restriction corresponding to rank indices 7 (сhecks 'GIndex'). +type RANK7 i = GIndex i ~~ I7 i +-- | The restriction corresponding to rank indices 8 (сhecks 'GIndex'). +type RANK8 i = GIndex i ~~ I8 i +-- | The restriction corresponding to rank indices 9 (сhecks 'GIndex'). +type RANK9 i = GIndex i ~~ I9 i +-- | The restriction corresponding to rank indices 10 (сhecks 'GIndex'). +type RANK10 i = GIndex i ~~ I10 i +-- | The restriction corresponding to rank indices 11 (сhecks 'GIndex'). +type RANK11 i = GIndex i ~~ I11 i +-- | The restriction corresponding to rank indices 12 (сhecks 'GIndex'). +type RANK12 i = GIndex i ~~ I12 i +-- | The restriction corresponding to rank indices 13 (сhecks 'GIndex'). +type RANK13 i = GIndex i ~~ I13 i +-- | The restriction corresponding to rank indices 14 (сhecks 'GIndex'). +type RANK14 i = GIndex i ~~ I14 i +-- | The restriction corresponding to rank indices 15 (сhecks 'GIndex'). +type RANK15 i = GIndex i ~~ I15 i + +-------------------------------------------------------------------------------- + +{- Basic instances. -} + +instance Shape E where rank = const 0; toGIndex = id; fromGIndex = id +instance Shape () +instance Shape Char +instance Shape Integer + +instance Shape Int +instance Shape Int8 +instance Shape Int16 +instance Shape Int32 +instance Shape Int64 + +instance Shape Word +instance Shape Word8 +instance Shape Word16 +instance Shape Word32 +instance Shape Word64 + +-------------------------------------------------------------------------------- + +{- Foreign C instances. -} + +instance Shape CChar +instance Shape CUChar +instance Shape CSChar +instance Shape CWchar +instance Shape CShort +instance Shape CUShort + +instance Shape CInt +instance Shape CUInt +instance Shape CLong +instance Shape CLLong +instance Shape CULong +instance Shape CULLong +instance Shape CIntPtr +instance Shape CUIntPtr + +instance Shape CIntMax +instance Shape CUIntMax + +instance Shape CSize +instance Shape CBool +instance Shape CPtrdiff +instance Shape CSigAtomic + +-------------------------------------------------------------------------------- + +{- N-dimensional instances. -} + +instance (Shape i) => Shape (E :& i) + where + type DimInit (E :& i) = E + type DimLast (E :& i) = i + + fromGIndex = id + toGIndex = id + + consDim = (:&) + initDim = \ (is :& _) -> is + lastDim = \ (_ :& i) -> i + unconsDim = \ (is :& i) -> (is, i) + +instance (Shape i, Enum i, Bounded i, Shape (i' :& i)) => Shape (i' :& i :& i) + where + type DimInit (i' :& i :& i) = i' :& i + type DimLast (i' :& i :& i) = i + + rank = (const . succ . rank :: Shape i' => i' -> (i' :& i) -> Int) undefined + + fromGIndex = id + toGIndex = id + + consDim = (:&) + initDim = \ (is :& _) -> is + lastDim = \ (_ :& i) -> i + unconsDim = \ (is :& i) -> (is, i) + +-------------------------------------------------------------------------------- + +{- Tuple instances. -} + +#define SHAPE_INSTANCE(Type,Last,RANK)\ +instance (Shape i, Enum i, Bounded i) => Shape (Type i)\ +where\ +{\ +type DimInit (Type i) = Last i;\ +type DimLast (Type i) = 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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} +#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/Shaped.hs b/src/SDP/Shaped.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Shaped.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE Safe, MultiParamTypeClasses, TypeOperators #-} + +{- | + Module : SDP.Shaped + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Shaped" provides advanced operations on 'SDP.Indexed.Indexed' + structures, generalized by 'Index' type. +-} +module SDP.Shaped +( + -- * Shaped + Shaped (..) +) +where + +import SDP.Linear + +default () + +-------------------------------------------------------------------------------- + +{- | + Service class for structures with arbitrary bounds. Allows you to extract + subsequences corresponding to index subranges. +-} +class Shaped s e + where + {-# MINIMAL reshape, (!!), slices, unslice #-} + + -- | 'rebound' with 'defaultBounds'. + defaultRebound :: (Index i, Index j, Bordered2 s i e) => s i e -> s j e + defaultRebound es = es `reshape` defaultBounds (sizeOf es) + + -- | Set new bounds of same type, may shrink. + rebound :: (Index i) => s i e -> (i, i) -> s i e + rebound = reshape + + -- | Set new bounds, may shrink. + reshape :: (Index i, Index j) => s i e -> (j, j) -> s j e + + -- | @es !! ij@ returns subshape @ij@ of @es@. + (!!) :: (SubIndex i j) => s i e -> i :|: j -> s j e + + -- | Returns list of @es@ subshapes. + slices :: (SubIndex i j) => s i e -> [s j e] + + -- | Unslice subshapes. + unslice :: (Foldable f, SubIndex i j) => f (s j e) -> s i e + + + diff --git a/src/SDP/Sort.hs b/src/SDP/Sort.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Sort.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.Index + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Sort" provides 'Sort' - class of sortable immutable structures. +-} +module SDP.Sort +( + -- * Sort + Sort (..), sort, sortOn, sorted, sortedOn +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Zip + +import qualified Data.List as L + +default () + +-------------------------------------------------------------------------------- + +-- | 'Sort' is class of types that can be sorted. +class Sort s e | s -> e + where + {-# MINIMAL sortBy, sortedBy #-} + + {- | + Checks if structure is already sorted. Should always return 'True' for + structures with less than 2 elements. + -} + sortedBy :: (e -> e -> Bool) -> s -> Bool + + -- | 'sortBy' function is common sorting algorithm. + sortBy :: Compare e -> s -> s + +instance Sort [a] a + where + sortedBy f (e : es) = all2 f (e : es) es + sortedBy _ [] = True + + sortBy = L.sortBy + +-------------------------------------------------------------------------------- + +-- | Checks if the structure is 'sorted'. +sorted :: (Sort s e, Ord e) => s -> Bool +sorted = sortedBy (<=) + +-- | Sort by comparing the results of a given function applied to each element. +sortedOn :: (Sort s e, Ord o) => (e -> o) -> s -> Bool +sortedOn = sortedBy . (on (<=)) + +-- | 'sort' is just @'sortBy' 'compare'@ +sort :: (Sort s e, Ord e) => s -> s +sort = sortBy compare + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/SDP/SortM.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, ConstraintKinds #-} +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.SortM + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.SortM" provides 'SortM' - class of sortable mutable structures. +-} +module SDP.SortM + ( + -- * SortM + SortM (..), SortM1, sortM, sortMOn, sortedM, sortedMOn + ) +where + +import Prelude () +import SDP.SafePrelude + +default () + +-------------------------------------------------------------------------------- + +-- | 'SortM' is class of sortable mutable structures. +class SortM m s e | s -> m, s -> e + where + {-# MINIMAL sortedMBy, sortMBy #-} + + {- | + Checks if structure is already sorted. Should always return 'True' for + structures with less than 2 elements. + -} + sortedMBy :: (e -> e -> Bool) -> s -> m Bool + + -- | 'sortMBy' is common sorting algorithm. + sortMBy :: Compare e -> s -> m () + +-------------------------------------------------------------------------------- + +-- | Kind (* -> *) version of 'SortM'. +type SortM1 m s e = SortM m (s e) e + +-------------------------------------------------------------------------------- + +-- | Checks if the structure is sorted. +sortedM :: (SortM m s e, Ord e) => s -> m Bool +sortedM = sortedMBy (<=) + +-- | Sort by comparing the results of a given function applied to each element. +sortedMOn :: (SortM m s e, Ord o) => (e -> o) -> s -> m Bool +sortedMOn = sortedMBy . (on (<=)) + +-- | 'sortM' is just @'sortMBy' 'compare'@ +sortM :: (SortM m s e, Ord e) => s -> m () +sortM = sortMBy compare + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/SDP/SortM/Insertion.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.SortM.Insertion + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.SortM.Insertion" provides insertion sort - simple sorting algorithm. +-} +module SDP.SortM.Insertion +( + -- * Insertion Sort + insertionSort, insertionSortBy, insertionSortOn, unsafeInsertionSort +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.IndexedM + +default () + +-------------------------------------------------------------------------------- + +-- | 'insertionSort' is just synonym for @'insertionSortBy' 'compare'@. +{-# INLINE insertionSort #-} +insertionSort :: (LinearM m v e, BorderedM m v i, Ord e) => v -> m () +insertionSort = insertionSortBy compare + +{- | + 'insertionSortOn' is a version of 'insertionSortBy' that uses a cast function + to 'compare' elements. +-} +{-# INLINE insertionSortOn #-} +insertionSortOn :: (LinearM m v e, BorderedM m v i, Ord o) => (e -> o) -> v -> m () +insertionSortOn = insertionSortBy . comparing + +{- | + 'insertionSortBy' is naive service sorting procedure, that have @O(n^2)@ + complexity in all cases. +-} +{-# INLINE insertionSortBy #-} +insertionSortBy :: (LinearM m v e, BorderedM m v i) => Compare e -> v -> m () +insertionSortBy cmp es = do n <- getSizeOf es; unsafeInsertionSort cmp es 0 0 (n - 1) + +-------------------------------------------------------------------------------- + +{- | + 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. +-} +unsafeInsertionSort :: (LinearM m v e) => Compare e -> v -> Int -> Int -> Int -> m () +unsafeInsertionSort cmp es b s e = forM_ [s + 1 .. e] $ \ i -> do + ei <- es !#> i + let + next' l u j = l > u ? return j $ do + let c = (l + u) `div` 2 + ec <- es !#> c + case ei `cmp` ec of + GT -> next' (c + 1) u j + LT -> next' l (c - 1) c + EQ -> return (c + 1) + p <- next' b (i - 1) i + mapM_ (swapM es i) [p .. i - 1] + + + diff --git a/src/SDP/SortM/Tim.hs b/src/SDP/SortM/Tim.hs new file mode 100644 --- /dev/null +++ b/src/SDP/SortM/Tim.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.SortM.Tim + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (requires non-portable modules) + + "SDP.SortM.Tim" provides @InsertionSort@ and @TimSort@ algorithms. +-} +module SDP.SortM.Tim +( + -- * TimSort + timSort, timSortBy, timSortOn, minrunTS +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.IndexedM + +import SDP.SortM.Insertion + +import Data.Bits + +default () + +-------------------------------------------------------------------------------- + +-- | 'timSort' is just synonym for @'timSortBy' 'compare'@. +{-# INLINE timSort #-} +timSort :: (LinearM m v e, BorderedM m v i, Ord e) => v -> m () +timSort = timSortBy compare + +{- | + 'timSortOn' is a version of 'timSortBy' that uses a conversion function to + compare elements. +-} +{-# INLINE timSortOn #-} +timSortOn :: (LinearM m v e, BorderedM m v i, Ord o) => (e -> o) -> v -> m () +timSortOn = timSortBy . comparing + +{- | + 'timSortBy' is a sorting procedure for mutable random access data structures + using any comparison function and having @O(nlogn)@ complexity in the worst + case. +-} +{-# INLINE timSortBy #-} +timSortBy :: (LinearM m v e, BorderedM m v i) => Compare e -> v -> m () +timSortBy cmp es = sort' =<< getSizeOf es + where + gt = \ x y -> case cmp x y of {GT -> True; _ -> False} + + sort' n + | n < 0 = return () + | n <= 64 = unsafeInsertionSort cmp es 0 0 (n - 1) + | True = iteratePreN (3 :: Int) 0 >>= go + where + go [sx, sy, sz] = do + nxt <- iteratePreN (1 :: Int) (sx + sy + sz) + if (sx > sy + sz && sy > sz) || sz <= sx + then do merge sx sy sz; go ([sx, sy + sz] ++ nxt) + else do merge 0 sx sy; go ([sx + sy, sz] ++ nxt) + go [sx, sy] = merge 0 sx sy + go _ = return () + + iteratePreN 0 _ = return [] + iteratePreN j o = case n - o of + 0 -> return [] + 1 -> return [1] + 2 -> do + e0 <- es !#> o + e1 <- es !#> o + 1 + when (e0 `gt` e1) $ swapM es o (o + 1) + return [2] + _ -> do + end <- normalized =<< actual + end == 0 ? return [end - o] $ (end - o :) <$> iteratePreN (j - 1) end + where + actual = (es !#> o) >>=<< (es !#> o + 1) $ \ e0 e1 -> + e0 `gt` e1 ? desc e1 (o + 2) $ asc e1 (o + 2) + where + desc p i = do c <- es !#> i; c `gt` p ? rev' o i $ i /= n - 1 ? desc c (i + 1) $ rev' o (i + 1) + asc p i = do c <- es !#> i; p `gt` c ? return i $ i /= n - 1 ? asc c (i + 1) $ return (i + 1) + rev f l = when (f < l) $ do swapM es f l; rev (f + 1) (l - 1) + rev' f l = do rev f (l - 1); return l + + normalized s = do + let ex = min n (o + minrunTS n) -- minimal expected ending + when (ex > s) $ unsafeInsertionSort cmp es o (s - 1) (ex - 1) + return (ex `max` s) + + merge o sx sy = copied' es o sx >>= mergeGo o 0 (o + sx) + where + mergeGo ic il ir left + | il >= lb = return () -- at least left is empty, merge is completed. + | ir >= rb = copyTo left il es ic (lb - il) + | True = (left !#> il) >>=<< (es !#> ir) $ + \ l r -> if r `gt` l + then writeM es ic l >> mergeGo (ic + 1) (il + 1) ir left + else writeM es ic r >> mergeGo (ic + 1) il (ir + 1) left + rb = o + sx + sy + lb = sx + +-------------------------------------------------------------------------------- + +{-# INLINE minrunTS #-} +-- | 'minrunTS' returns @TimSort@ chunk size by given length. +minrunTS :: Int -> Int +minrunTS i = mr i 0 where mr n r = n >= 64 ? mr (shiftR n 1) (n .&. 1) $ n + r + + + + diff --git a/src/SDP/Templates/AnyBorder.hs b/src/SDP/Templates/AnyBorder.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Templates/AnyBorder.hs @@ -0,0 +1,605 @@ +{-# LANGUAGE TypeFamilies, DeriveDataTypeable, DeriveGeneric, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE Trustworthy, UndecidableInstances #-} + +{- | + Module : SDP.Templates.AnyBorder + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Plate.AnyBorder" provides 'AnyBorder' - template of generalized by + index type structure, based on 'Int'-indexed primitive. +-} +module SDP.Templates.AnyBorder +( + -- * Export + module SDP.IndexedM, + module SDP.Shaped, + module SDP.Sort, + module SDP.Scan, + + -- * Border template + AnyBorder (..) +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.IndexedM +import SDP.Shaped +import SDP.SortM +import SDP.Sort +import SDP.Scan + +import Data.Default.Class +import Data.Typeable +import Data.String +import Data.Data + +import Text.Read.SDP +import Text.Show.SDP + +import GHC.Generics +import qualified GHC.Exts as E + +import Control.Exception.SDP + +default () + +-------------------------------------------------------------------------------- + +{- | + 'AnyBorder' is template, that appends arbitrary bounds to any structure. + + * 'Eq', 'Ord', 'Eq1' and 'Ord1' instances ingores bounds. + * 'Thaw' and 'Freeze' instances for @'AnyBorder' rep e@ inherit @rep e@ + behavior. +-} +data AnyBorder rep i e = AnyBorder !i !i !(rep e) + deriving ( Typeable, Data, Generic ) + +-------------------------------------------------------------------------------- + +{- Eq ad Eq1 instances. -} + +instance (Index i, Eq (rep e)) => Eq (AnyBorder rep i e) + where + (==) = on (==) unpack + +instance (Index i, Eq1 rep) => Eq1 (AnyBorder rep i) + where + liftEq f xs ys = liftEq f (unpack xs) (unpack ys) + +-------------------------------------------------------------------------------- + +{- Ord and Ord1 instances. -} + +instance (Index i, Ord (rep e)) => Ord (AnyBorder rep i e) + where + compare = on (<=>) unpack + +instance (Index i, Ord1 rep) => Ord1 (AnyBorder rep i) + where + liftCompare f xs ys = liftCompare f (unpack xs) (unpack ys) + +-------------------------------------------------------------------------------- + +{- Show and Read instances. -} + +instance {-# OVERLAPPABLE #-} (Indexed1 rep Int e, Index i, Show i, Show e) => Show (AnyBorder rep i e) + where + showsPrec = assocsPrec "array " + +instance (Indexed1 rep Int Char, Index i, Show i) => Show (AnyBorder rep i Char) + where + showsPrec = shows ... const listL + +instance (Index i, Read i, Read e, Indexed1 rep Int e) => Read (AnyBorder rep i e) + where + readPrec = indexedPrec' "array" + readList = readListDefault + +-------------------------------------------------------------------------------- + +{- Overloaded Lists and String support. -} + +instance (Index i, IsString (rep Char), Bordered1 rep Int Char) => IsString (AnyBorder rep i Char) + where + fromString = withBounds . fromString + +instance (Index i, E.IsList (rep e), Bordered1 rep Int e) => E.IsList (AnyBorder rep i e) + where + type Item (AnyBorder rep i e) = E.Item (rep e) + + fromListN = withBounds ... E.fromListN + fromList = withBounds . E.fromList + toList = E.toList . unpack + +-------------------------------------------------------------------------------- + +{- Semigroup, Monoid, Nullable, Default and Estimate instances. -} + +instance (Index i, Bordered (rep e) Int, Nullable (rep e)) => Nullable (AnyBorder rep i e) + where + isNull = \ (AnyBorder l u rep) -> isEmpty (l, u) || isNull rep + lzero = withBounds lzero + +instance (Linear1 (AnyBorder rep i) e) => Semigroup (AnyBorder rep i e) where (<>) = (++) +instance (Linear1 (AnyBorder rep i) e) => Monoid (AnyBorder rep i e) where mempty = Z +instance (Linear1 (AnyBorder rep i) e) => Default (AnyBorder rep i e) where def = Z + +instance (Index i) => Estimate (AnyBorder rep i e) + where + (<==>) = on (<=>) sizeOf + (.<=.) = on (<=) sizeOf + (.>=.) = on (>=) sizeOf + (.>.) = on (>) sizeOf + (.<.) = on (<) sizeOf + + (<.=>) = (<=>) . sizeOf + (.>=) = (>=) . sizeOf + (.<=) = (<=) . sizeOf + (.>) = (>) . sizeOf + (.<) = (<) . sizeOf + +-------------------------------------------------------------------------------- + +{- Functor, Zip and Applicative instances. -} + +instance (Index i, Functor rep) => Functor (AnyBorder rep i) + where + fmap f (AnyBorder l u rep) = AnyBorder l u (f <$> rep) + +instance (Index i, Zip rep) => Zip (AnyBorder rep i) + where + all2 f as bs = all2 f (unpack as) (unpack bs) + all3 f as bs cs = all3 f (unpack as) (unpack bs) (unpack cs) + all4 f as bs cs ds = all4 f (unpack as) (unpack bs) (unpack cs) (unpack ds) + all5 f as bs cs ds es = all5 f (unpack as) (unpack bs) (unpack cs) (unpack ds) (unpack es) + all6 f as bs cs ds es fs = all6 f (unpack as) (unpack bs) (unpack cs) (unpack ds) (unpack es) (unpack fs) + + any2 f as bs = any2 f (unpack as) (unpack bs) + any3 f as bs cs = any3 f (unpack as) (unpack bs) (unpack cs) + any4 f as bs cs ds = any4 f (unpack as) (unpack bs) (unpack cs) (unpack ds) + any5 f as bs cs ds es = any5 f (unpack as) (unpack bs) (unpack cs) (unpack ds) (unpack es) + any6 f as bs cs ds es fs = any6 f (unpack as) (unpack bs) (unpack cs) (unpack ds) (unpack es) (unpack fs) + + zipWith f as bs = + let (l, u) = defaultBounds $ minimum [sizeOf as, sizeOf bs] + in AnyBorder l u $ zipWith f (unpack as) (unpack bs) + + zipWith3 f as bs cs = + let (l, u) = defaultBounds $ minimum [sizeOf as, sizeOf bs, sizeOf cs] + in AnyBorder l u $ zipWith3 f (unpack as) (unpack bs) (unpack cs) + + zipWith4 f as bs cs ds = + let (l, u) = defaultBounds $ minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds] + in AnyBorder l u $ zipWith4 f (unpack as) (unpack bs) (unpack cs) (unpack ds) + + zipWith5 f as bs cs ds es = + let (l, u) = defaultBounds $ minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds, sizeOf es] + in AnyBorder l u $ zipWith5 f (unpack as) (unpack bs) (unpack cs) (unpack ds) (unpack es) + + zipWith6 f as bs cs ds es fs = + let (l, u) = defaultBounds $ minimum [sizeOf as, sizeOf bs, sizeOf cs, sizeOf ds, sizeOf es, sizeOf fs] + in AnyBorder l u $ zipWith6 f (unpack as) (unpack bs) (unpack cs) (unpack ds) (unpack es) (unpack fs) + +instance (Index i, Applicative rep) => Applicative (AnyBorder rep i) + where + pure = uncurry AnyBorder (defaultBounds 1) . pure + + (AnyBorder lf uf fs) <*> (AnyBorder le ue es) = + let (l, u) = defaultBounds (size (lf, uf) * size (le, ue)) + in AnyBorder l u (fs <*> es) + +-------------------------------------------------------------------------------- + +{- Foldable and Traversable instances. -} + +instance (Index i, Foldable rep) => Foldable (AnyBorder rep i) + where + foldr f base = foldr f base . unpack + foldl f base = foldl f base . unpack + foldr' f base = foldr' f base . unpack + foldl' f base = foldl' f base . unpack + + foldr1 f = foldr1 f . unpack + foldl1 f = foldl1 f . unpack + + length = length . unpack + toList = toList . unpack + null = null . unpack + +instance (Index i, Traversable rep) => Traversable (AnyBorder rep i) + where + traverse f (AnyBorder l u es) = AnyBorder l u <$> traverse f es + +-------------------------------------------------------------------------------- + +{- Bordered, Linear and Split instances. -} + +instance (Index i) => Bordered (AnyBorder rep i e) i + where + lower (AnyBorder l _ _) = l + upper (AnyBorder _ u _) = u + bounds (AnyBorder l u _) = (l, u) + sizeOf (AnyBorder l u _) = size (l, u) + indices (AnyBorder l u _) = range (l, u) + indexOf (AnyBorder l u _) = index (l, u) + indexIn (AnyBorder l u _) = inRange (l, u) + offsetOf (AnyBorder l u _) = offset (l, u) + +instance (Index i, Linear1 rep e, Bordered1 rep Int e) => Linear (AnyBorder rep i e) e + where + single = withBounds . single + + toHead e es = withBounds (e :> unpack es) + toLast es e = withBounds (unpack es :< e) + + head = head . unpack + last = last . unpack + tail = withBounds . tail . unpack + init = withBounds . init . unpack + + fromList = fromFoldable + fromListN = withBounds ... fromListN + replicate = withBounds ... replicate + iterate n = withBounds ... iterate n + + fromFoldable = withBounds . fromFoldable + + listL = listL . unpack + listR = listR . unpack + + {-# INLINE (!^) #-} + (!^) = (!^) . unpack + (++) = withBounds ... on (++) unpack + + write (AnyBorder l u es) n e = AnyBorder l u (write es n e) + + concatMap = withBounds ... concatMap . (unpack .) + concat = withBounds . concatMap unpack + + partitions f = fmap fromList . partitions f . listL + intersperse e = withBounds . intersperse e . unpack + + filter f = withBounds . filter f . unpack + + reverse (AnyBorder l u rep) = AnyBorder l u (reverse rep) + force (AnyBorder l u rep) = AnyBorder l u (force rep) + + select f = select f . unpack + extract f = second withBounds . extract f . unpack + selects fs = second withBounds . selects fs . unpack + + nubBy f = withBounds . nubBy f . unpack + nub = withBounds . nub . unpack + + ofoldr f base = ofoldr f base . unpack + ofoldl f base = ofoldl f base . unpack + + o_foldr f base = o_foldr f base . unpack + o_foldl f base = o_foldl f base . unpack + +instance (Index i, Split1 rep e, Bordered1 rep Int e) => Split (AnyBorder rep i e) e + where + take n = withBounds . take n . unpack + drop n = withBounds . drop n . unpack + keep n = withBounds . keep n . unpack + sans n = withBounds . sans n . unpack + + splits ns = fmap withBounds . splits ns . unpack + chunks ns = fmap withBounds . chunks ns . unpack + parts ns = fmap withBounds . parts ns . unpack + + justifyL n e = withBounds . justifyL n e . unpack + justifyR n e = withBounds . justifyR n e . unpack + + isPrefixOf xs ys = xs .<=. ys && on isPrefixOf unpack xs ys + isSuffixOf xs ys = xs .<=. ys && on isSuffixOf unpack xs ys + + prefix p = prefix p . unpack + suffix p = suffix p . unpack + +-------------------------------------------------------------------------------- + +{- BorderedM, LinearM and SplitM instances. -} + +instance (Index i, BorderedM1 m rep Int e) => BorderedM m (AnyBorder rep i e) i + where + nowIndexIn (AnyBorder l u _) = return . inRange (l, u) + getIndices (AnyBorder l u _) = return $ range (l, u) + getSizeOf (AnyBorder l u _) = return $ size (l, u) + getBounds (AnyBorder l u _) = return (l, u) + getLower (AnyBorder l _ _) = return l + getUpper (AnyBorder _ u _) = return u + +instance (Index i, LinearM1 m rep e, BorderedM1 m rep Int e) => LinearM m (AnyBorder rep i e) e + where + newNull = uncurry AnyBorder (defaultBounds 0) <$> newNull + + nowNull (AnyBorder l u es) = isEmpty (l, u) ? return True $ nowNull es + + getHead = getHead . unpack + getLast = getLast . unpack + + prepend e = withBounds' <=< prepend e . unpack + append es = withBounds' <=< append (unpack es) + + newLinear = withBounds' <=< newLinear + filled n = withBounds' <=< filled n + + getLeft = getLeft . unpack + getRight = getRight . unpack + + {-# INLINE (!#>) #-} + (!#>) = (!#>) . unpack + + {-# INLINE writeM #-} + writeM = writeM . unpack + + copied (AnyBorder l u es) = AnyBorder l u <$> copied es + copied' (AnyBorder l u es) = (AnyBorder l u <$>) ... copied' es + reversed (AnyBorder l u es) = AnyBorder l u <$> reversed es + + copyTo src os trg ot = copyTo (unpack src) os (unpack trg) ot + + ofoldrM f e = ofoldrM f e . unpack + ofoldlM f e = ofoldlM f e . unpack + + foldrM f e = foldrM f e . unpack + foldlM f e = foldlM f e . unpack + +instance (Index i, BorderedM1 m rep Int e, SplitM1 m rep e) => SplitM m (AnyBorder rep i e) e + where + takeM n es@(AnyBorder l u rep) + | n <= 0 = newNull + | n >= c = return es + | True = AnyBorder l (index (l, u) n) <$> takeM n rep + where + c = size (l, u) + + dropM n es@(AnyBorder l u rep) + | n >= c = newNull + | n <= 0 = return es + | True = AnyBorder (index (l, u) n) u <$> dropM n rep + where + c = size (l, u) + + keepM n es@(AnyBorder l u rep) + | n <= 0 = newNull + | n >= c = return es + | True = AnyBorder (index (l, u) (c - n)) u <$> keepM n rep + where + c = size (l, u) + + sansM n es@(AnyBorder l u rep) + | n >= c = newNull + | n <= 0 = return es + | True = AnyBorder (index (l, u) (c - n)) u <$> sansM n rep + where + c = size (l, u) + + splitM n es@(AnyBorder l u rep) + | n <= 0 = do e' <- newNull; return (e', es) + | n >= c = do e' <- newNull; return (es, e') + | True = bimap (AnyBorder l i) (AnyBorder i u) <$> splitM n rep + where + i = index (l, u) n + c = size (l, u) + + divideM n es@(AnyBorder l u rep) + | n <= 0 = do e' <- newNull; return (es, e') + | n >= c = do e' <- newNull; return (e', es) + | True = bimap (AnyBorder l i) (AnyBorder i u) <$> divideM n rep + where + i = index (l, u) (c - n) + c = size (l, u) + + prefixM p = prefixM p . unpack + suffixM p = suffixM p . unpack + mprefix p = mprefix p . unpack + msuffix p = msuffix p . unpack + +-------------------------------------------------------------------------------- + +{- Set, Scan and Sort instances. -} + +instance (SetWith1 (AnyBorder rep i) e, Nullable (AnyBorder rep i e), Ord e) => Set (AnyBorder rep i e) e + +instance (Index i, SetWith1 rep e, Linear1 rep e, Bordered1 rep Int e) => SetWith (AnyBorder rep i e) e + where + isSubsetWith f = isSubsetWith f `on` unpack + + setWith f = withBounds . setWith f . unpack + + subsets = map withBounds . subsets . unpack + + insertWith f e = withBounds . insertWith f e . unpack + deleteWith f e = withBounds . deleteWith f e . unpack + + intersectionWith f = withBounds ... on (intersectionWith f) unpack + unionWith f = withBounds ... on (unionWith f) unpack + differenceWith f = withBounds ... on (differenceWith f) unpack + symdiffWith f = withBounds ... on (symdiffWith f) unpack + + memberWith f e = memberWith f e . unpack + lookupLTWith f o = lookupLTWith f o . unpack + lookupGTWith f o = lookupGTWith f o . unpack + lookupLEWith f o = lookupLEWith f o . unpack + lookupGEWith f o = lookupGEWith f o . unpack + +instance (Linear1 (AnyBorder rep i) e) => Scan (AnyBorder rep i e) e + +instance (Index i, Sort (rep e) e) => Sort (AnyBorder rep i e) e + where + sortBy cmp = \ (AnyBorder l u rep) -> AnyBorder l u (sortBy cmp rep) + sortedBy f = sortedBy f . unpack + +-------------------------------------------------------------------------------- + +{- Map, Indexed and Shaped instances. -} + +instance (Index i, Indexed1 rep Int e) => Map (AnyBorder rep i e) i e + where + toMap ascs = isNull ascs ? Z $ assoc (ascsBounds ascs) ascs + + toMap' e ascs = isNull ascs ? Z $ assoc' (ascsBounds ascs) e ascs + + {-# INLINE (.!) #-} + (.!) (AnyBorder l u rep) = (rep !^) . offset (l, u) + + Z // ascs = toMap ascs + (AnyBorder l u rep) // ascs = + let ies = [ (offset (l, u) i, e) | (i, e) <- ascs, inRange (l, u) i ] + in AnyBorder l u (rep // ies) + + p .$ (AnyBorder l u rep) = index (l, u) <$> p .$ rep + p *$ (AnyBorder l u rep) = index (l, u) <$> p *$ rep + + kfoldr f base (AnyBorder l u es) = kfoldr (f . index (l, u)) base es + kfoldl f base (AnyBorder l u es) = kfoldl (f . index (l, u)) base es + +instance (Index i, Indexed1 rep Int e) => Indexed (AnyBorder rep i e) i e + where + assoc bnds@(l, u) ascs = AnyBorder l u (assoc bnds' ies) + where + ies = [ (offset bnds i, e) | (i, e) <- ascs, inRange bnds i ] + bnds' = defaultBounds (size bnds) + + assoc' bnds@(l, u) defvalue ascs = AnyBorder l u (assoc' bnds' defvalue ies) + where + ies = [ (offset bnds i, e) | (i, e) <- ascs, inRange bnds i ] + bnds' = defaultBounds $ size bnds + + fromIndexed = withBounds . fromIndexed + +instance (Bordered1 rep Int e, Split1 rep e) => Shaped (AnyBorder rep) e + where + reshape es bs = size bs >. es ? expEx "reshape" $ uncurry AnyBorder bs (unpack es) + + (AnyBorder l u rep) !! ij = uncurry AnyBorder sub . take s $ drop o rep + where + (num, sub) = slice (l, u) ij + + o = offset num ij * s + s = size sub + + slices es = + let bnds = both takeDim (bounds es) + in uncurry AnyBorder bnds <$> size bnds `chunks` unpack es + + unslice ess = + let bnds = defaultBounds (foldr' ((+) . sizeOf) 0 ess) + in uncurry AnyBorder bnds (concatMap unpack ess) + +-------------------------------------------------------------------------------- + +{- MapM, IndexedM and SortM instances. -} + +instance (Index i, MapM1 m rep Int e, LinearM1 m rep e, BorderedM1 m rep Int e) => MapM m (AnyBorder rep i e) i e + where + newMap ascs = + let bnds@(l, u) = ascsBounds ascs + in AnyBorder l u <$> newMap [ (offset bnds i, e) | (i, e) <- ascs ] + + newMap' defvalue ascs = + let bnds@(l, u) = ascsBounds ascs + in AnyBorder l u <$> newMap' defvalue [ (offset bnds i, e) | (i, e) <- ascs ] + + {-# INLINE (>!) #-} + (>!) (AnyBorder l u es) = (es !#>) . offset (l, u) + + overwrite es [] = return es + overwrite (AnyBorder l u es) ascs = + let ies = [ (offset (l, u) i, e) | (i, e) <- ascs, inRange (l, u) i ] + in isEmpty (l, u) ? newMap ascs $ AnyBorder l u <$> overwrite es ies + + kfoldrM f base (AnyBorder l u es) = ofoldrM (f . index (l, u)) base es + kfoldlM f base (AnyBorder l u es) = ofoldlM (f . index (l, u)) base es + +instance (Index i, IndexedM1 m rep Int e) => IndexedM m (AnyBorder rep i e) i e + where + fromAssocs (l, u) ascs = AnyBorder l u <$> fromAssocs bnds ies + where + ies = [ (offset (l, u) i, e) | (i, e) <- ascs, inRange (l, u) i ] + bnds = (0, size (l, u) - 1) + + fromAssocs' (l, u) defvalue ascs = AnyBorder l u <$> fromAssocs' bnds defvalue ies + where + ies = [ (offset (l, u) i, e) | (i, e) <- ascs, inRange (l, u) i ] + bnds = (0, size (l, u) - 1) + + {-# INLINE writeM' #-} + writeM' (AnyBorder l u es) = writeM' es . offset (l, u) + + fromIndexed' = withBounds' <=< fromIndexed' + fromIndexedM = withBounds' <=< fromIndexedM + +instance (Index i, SortM1 m rep e) => SortM m (AnyBorder rep i e) e + where + sortedMBy f = sortedMBy f . unpack + sortMBy f = sortMBy f . unpack + +-------------------------------------------------------------------------------- + +{- Freeze and Thaw instances. -} + +-- Bordered (with any index) to prim. +instance {-# OVERLAPPABLE #-} (Index i, Thaw m (rep e) mut) => Thaw m (AnyBorder rep i e) mut + where + unsafeThaw = unsafeThaw . unpack + thaw = thaw . unpack + +-- Prim to bordered (with any index). +instance {-# OVERLAPPABLE #-} (Index i, Thaw m imm (rep e), Bordered1 rep Int e) => Thaw m imm (AnyBorder rep i e) + where + unsafeThaw = fmap withBounds . unsafeThaw + thaw = fmap withBounds . thaw + +-- Lift prim to prim on bordered on bordered (with same index). +instance {-# OVERLAPS #-} (Index i, Thaw1 m imm mut e) => Thaw m (AnyBorder imm i e) (AnyBorder mut i e) + where + unsafeThaw (AnyBorder l u imm) = AnyBorder l u <$> unsafeThaw imm + thaw (AnyBorder l u imm) = AnyBorder l u <$> thaw imm + +-- Bordered (with any index) to prim. +instance {-# OVERLAPPABLE #-} (Index i, Freeze m (rep e) imm) => Freeze m (AnyBorder rep i e) imm + where + unsafeFreeze = unsafeFreeze . unpack + freeze = freeze . unpack + +-- Prim to bordered (with any index). +instance {-# OVERLAPPABLE #-} (Index i, Freeze m mut (rep e), Bordered1 rep Int e) => Freeze m mut (AnyBorder rep i e) + where + unsafeFreeze = fmap withBounds . unsafeFreeze + freeze = fmap withBounds . freeze + +-- Lift prim to prim on bordered to bordered (with same index). +instance {-# OVERLAPS #-} (Index i, Freeze1 m mut imm e) => Freeze m (AnyBorder mut i e) (AnyBorder imm i e) + where + unsafeFreeze (AnyBorder l u mut) = AnyBorder l u <$> unsafeFreeze mut + freeze (AnyBorder l u mut) = AnyBorder l u <$> freeze mut + +-------------------------------------------------------------------------------- + +expEx :: String -> a +expEx = throw . UnacceptableExpansion . showString "in SDP.Templates.AnyBorder." + +ascsBounds :: (Ord a) => [(a, b)] -> (a, a) +ascsBounds = \ ((x, _) : xs) -> foldr (\ (e, _) (mn, mx) -> (min mn e, max mx e)) (x, x) xs + +{-# INLINE unpack #-} +unpack :: AnyBorder rep i e -> rep e +unpack = \ (AnyBorder _ _ es) -> es + +{-# INLINE withBounds #-} +withBounds :: (Index i, Bordered1 rep Int e) => rep e -> AnyBorder rep i e +withBounds rep = uncurry AnyBorder (defaultBounds $ sizeOf rep) rep + +{-# 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 new file mode 100644 --- /dev/null +++ b/src/SDP/Templates/AnyChunks.hs @@ -0,0 +1,630 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies, DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE Trustworthy, UndecidableInstances, BangPatterns #-} + +{- | + Module : SDP.Templates.AnyChunks + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Templates.AnyChunks" provides 'AnyChunks' - list of data chunks. +-} +module SDP.Templates.AnyChunks +( + -- * Export + module SDP.IndexedM, + module SDP.Scan, + + -- * Chunk list + AnyChunks, fromChunks, fromChunksM, toChunks +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.IndexedM +import SDP.SortM +import SDP.Scan + +import qualified GHC.Exts as E + +import GHC.Generics + +import Data.Default.Class +import Data.Typeable +import Data.String +import Data.Data + +import Text.Read.SDP +import Text.Show.SDP + +import SDP.SortM.Tim + +import Control.Exception.SDP + +default () + +-------------------------------------------------------------------------------- + +{- | + 'AnyChunks' is list of data chunks. AnyChunks shouldn't contain empty chunks, + so the 'AnyChunks' constructor is made private (see 'fromChunks' and + 'fromChunksM'). + + * Efficiency of operations on @'AnyChunks' rep e@ are very sensitive in the + efficiency of 'Bordered', 'Linear' and 'Split' on @rep e@. + * @'AnyChunks' rep e@ is only defined for Int-indexed @rep e@. + * 'Eq', 'Ord', 'Eq1' and 'Ord1' instances compare @'AnyChunks' rep e@ as + streams of equal size chunks. To do this, the comparison @rep e@ must also be + lexicographic, also for @rep e@ must implement 'Bordered' and 'Split'. + * 'Freeze' and 'Thaw' for @'AnyChunks' rep e@ are defined for all @rep e@ that + already have 'Freeze' and 'Thaw' instances. +-} +newtype AnyChunks rep e = AnyChunks [rep e] deriving ( Typeable, Data, Generic ) + +-- | Construct immutable 'AnyChunks' safely. +fromChunks :: (Nullable (rep e)) => [rep e] -> AnyChunks rep e +fromChunks = AnyChunks . except isNull + +-- | Construct mutable 'AnyChunks' safely. +fromChunksM :: (BorderedM1 m rep Int e) => [rep e] -> m (AnyChunks rep e) +fromChunksM = fmap AnyChunks . go + where + go (x : xs) = do n <- getSizeOf x; n == 0 ? go xs $ (x :) <$> go xs + go [] = return [] + +-- | Extract immutable 'AnyChunks' chunks safely. +toChunks :: AnyChunks rep e -> [rep e] +toChunks = E.coerce + +-------------------------------------------------------------------------------- + +{- Eq and Ord instances. -} + +instance (Eq (rep e), Bordered1 rep Int e, Split1 rep e) => Eq (AnyChunks rep e) + where + Z == Z = True + xs@(AnyChunks (x : xs')) == ys@(AnyChunks (y : ys')) = if n1 > n2 + then take n2 x == y && drop n2 xs == AnyChunks ys' + else take n1 y == x && drop n1 ys == AnyChunks xs' + where + n1 = sizeOf x + n2 = sizeOf y + _ == _ = False + +instance (Ord (rep e), Bordered1 rep Int e, Split1 rep e) => Ord (AnyChunks rep e) + where + compare Z Z = EQ + compare xs@(AnyChunks (x : xs')) ys@(AnyChunks (y : ys')) = if n1 > n2 + then (take n2 x <=> y) <> (drop n2 xs <=> AnyChunks ys') + else (x <=> take n1 y) <> (AnyChunks xs' <=> drop n1 ys) + where + n1 = sizeOf x + n2 = sizeOf y + compare Z _ = LT + compare _ _ = GT + +-------------------------------------------------------------------------------- + +{- Show and Read instances. -} + +instance {-# OVERLAPPABLE #-} (Indexed1 rep Int e, Show e) => Show (AnyChunks rep e) + where + showsPrec = assocsPrec "unlist " + +instance (Indexed1 rep Int Char) => Show (AnyChunks rep Char) + where + showsPrec = shows ... const listL + +instance (Indexed1 rep Int e, Read e) => Read (AnyChunks rep e) + where + readPrec = indexedPrec' "ublist" + readList = readListDefault + +-------------------------------------------------------------------------------- + +{- Semigroup, Monoid, Nullable, Default and Estimate instances. -} + +instance Nullable (AnyChunks rep e) + where + isNull = \ (AnyChunks es) -> null es + lzero = AnyChunks [] + +instance Semigroup (AnyChunks rep e) + where + AnyChunks xs <> AnyChunks ys = AnyChunks (xs ++ ys) + +instance Monoid (AnyChunks rep e) where mempty = AnyChunks [] +instance Default (AnyChunks rep e) where def = AnyChunks [] + +instance (Bordered1 rep Int e) => Estimate (AnyChunks rep e) + where + (<==>) = go 0 + where + go o (AnyChunks []) (AnyChunks []) = o <=> 0 + go o (AnyChunks []) ys = o <=.> ys + go o xs (AnyChunks []) = xs <.=> (-o) + go o (AnyChunks (x : xs)) (AnyChunks (y : ys)) = + go (o + sizeOf x - sizeOf y) (AnyChunks xs) (AnyChunks ys) + + (AnyChunks []) <.=> n = 0 <=> n + (AnyChunks (x : xs)) <.=> n = c > n ? GT $ AnyChunks xs <.=> (n - c) + where + c = sizeOf x + +-------------------------------------------------------------------------------- + +{- Overloaded Lists and Strings support. -} + +instance (Linear1 (AnyChunks rep) Char) => IsString (AnyChunks rep Char) + where + fromString = fromList + +instance (Linear1 (AnyChunks rep) e) => E.IsList (AnyChunks rep e) + where + type Item (AnyChunks rep e) = e + + fromListN = fromListN + fromList = fromList + toList = listL + +-------------------------------------------------------------------------------- + +{- Functor and Applicative instances. -} + +instance (Functor rep) => Functor (AnyChunks rep) + where + fmap f (AnyChunks es) = AnyChunks (fmap f <$> es) + +instance (Applicative rep) => Applicative (AnyChunks rep) + where + AnyChunks fs <*> AnyChunks es = AnyChunks $ liftA2 (<*>) fs es + pure e = AnyChunks [pure e] + +-------------------------------------------------------------------------------- + +{- Foldable and Traversable instances. -} + +instance (Foldable rep) => Foldable (AnyChunks rep) + where + foldr f base (AnyChunks es) = flip (foldr f) `foldr` base $ es + foldl f base (AnyChunks es) = foldl (foldl f) base es + + elem e (AnyChunks es) = foldr ((||) . elem e) False es + length (AnyChunks es) = foldr' ((+) . length) 0 es + null (AnyChunks es) = null es + +instance (Traversable rep) => Traversable (AnyChunks rep) + where + traverse f (AnyChunks es) = AnyChunks <$> traverse (traverse f) es + +-------------------------------------------------------------------------------- + +{- Bordered, Linear and Split instances. -} + +instance (Bordered1 rep Int e) => Bordered (AnyChunks rep e) Int + where + sizeOf (AnyChunks es) = foldr' ((+) . sizeOf) 0 es + + indexIn es = \ i -> i >= 0 && i <. es + + -- | Quick unchecked offset. + offsetOf = const id + + -- | Quick unchecked index. + indexOf = const id + + lower _ = 0 + upper es = sizeOf es - 1 + bounds es = (0, sizeOf es - 1) + +instance (Bordered1 rep Int e, Linear1 rep e) => Linear (AnyChunks rep e) e + where + single e = AnyChunks [single e] + + toHead e (AnyChunks es@(x : xs)) = AnyChunks $ sizeOf x < lim ? (e :> x) : xs $ single e : es + toHead e _ = single e + + toLast (AnyChunks (xs :< x)) e = isNull x ? AnyChunks xs :< e $ AnyChunks (xs :< (x :< e)) + toLast _ e = single e + + uncons = go . toChunks + where + go ((x :> xs) : xss) = (x, AnyChunks (xs : xss)) + go _ = pfailEx "(:>)" + + unsnoc = go . toChunks + where + go (xss :< (xs :< x)) = (AnyChunks (xss :< xs), x) + go _ = pfailEx "(:<)" + + fromList = AnyChunks . fmap fromList . chunks lim + listL = foldr ((++) . listL) [] . toChunks + + (AnyChunks (x : xs)) !^ i = let n = sizeOf x in i < n ? x !^ i $ AnyChunks xs !^ (i - n) + _ !^ _ = error "in SDP.Unrolled.Unlist.(!^)" + + write es'@(AnyChunks es) n e = + let + go i (x : xs) = let c = sizeOf x in i < c ? write x i e : xs $ x : go (i - c) xs + go _ xs = xs + in n < 0 ? es' $ AnyChunks (go n es) + + -- | Deduplicated chunks. + replicate n e = AnyChunks $ replicate count chunk :< rest + where + (count, rst) = n `divMod` lim + + chunk = replicate lim e + rest = replicate rst e + + reverse (AnyChunks es) = AnyChunks (reverse <$> reverse es) + force (AnyChunks es) = AnyChunks (force <$> es) + + partition p = both fromList . partition p . listL + + select f (AnyChunks es) = concatMap (select f) es + extract f (AnyChunks es) = bimap concat AnyChunks . unzip $ extract f <$> es + + selects fs = second fromList . selects fs . listL + + ofoldr f' base' = go 0 f' base' . toChunks + where + go o f base (x : xs) = ofoldr (f . (o +)) (go (o + sizeOf x) f base xs) x + go _ _ base _ = base + + ofoldl f' base' = go 0 f' base' . toChunks + where + go o f base (x : xs) = go (o + sizeOf x) f (ofoldl (f . (o +)) base x) xs + go _ _ base _ = base + + o_foldr f base = foldr (flip $ o_foldr f) base . toChunks + o_foldl f base = foldl (o_foldl f) base . toChunks + +instance (Bordered1 rep Int e, Split1 rep e) => Split (AnyChunks rep e) e + where + take n = AnyChunks . go n . toChunks + where + go c (x : xs) = let s = sizeOf x in case c <=> s of + GT -> x : go (c - s) xs + LT -> [take c x] + EQ -> [x] + go _ [] = [] + + drop n = AnyChunks . go n . toChunks + where + go c (x : xs) = let s = sizeOf x in case c <=> s of + GT -> go (c - s) xs + LT -> drop c x : xs + EQ -> xs + go _ [] = [] + + prefix f = foldr' (\ e n -> let p = prefix f e in p ==. e ? p + n $ p) 0 . toChunks + suffix f = foldl' (\ n e -> let s = suffix f e in s ==. e ? s + n $ s) 0 . toChunks + combo f = foldr' (\ e n -> let c = combo f e in c ==. e ? c + n $ c) 0 . toChunks + +-------------------------------------------------------------------------------- + +{- BorderedM, LinearM and SplitM instances. -} + +instance (BorderedM1 m rep Int e) => BorderedM m (AnyChunks rep e) Int + where + getLower _ = return 0 + getUpper es = do n <- getSizeOf es; return (n - 1) + + getSizeOf = foldr (liftA2 (+) . getSizeOf) (return 0) . toChunks + + getIndices es = do n <- getSizeOf es; return [0 .. n - 1] + nowIndexIn es = \ i -> i < 0 ? return False $ do n <- getSizeOf es; return (i < n) + +instance (BorderedM1 m rep Int e, SplitM1 m rep e) => LinearM m (AnyChunks rep e) e + where + nowNull = fmap and . mapM nowNull . toChunks + getHead = getHead . head . toChunks + getLast = getLast . last . toChunks + newNull = return (AnyChunks []) + + prepend e' es' = AnyChunks <$> go e' (toChunks es') + where + go e es@(x : xs) = do n <- getSizeOf x; n < lim ? (: xs) <$> prepend e x $ (: es) <$> newLinear [e] + go e _ = pure <$> newLinear [e] + + append es' e' = AnyChunks <$> go e' (toChunks es') + where + go e es@(xs :< x) = do n <- getSizeOf x; n < lim ? (xs :<) <$> append x e $ (es :<) <$> newLinear [e] + go e _ = pure <$> newLinear [e] + + newLinear = fmap AnyChunks . mapM newLinear . chunks lim + + (!#>) (AnyChunks es) = go es + where + go (x : xs) i = do n <- getSizeOf x; i < n ? x !#> i $ go xs (i - n) + go _ _ = overEx "(>!)" + + {-# INLINE writeM #-} + writeM = go . toChunks + where + go (x : xs) i e = do n <- getSizeOf x; i < n ? writeM x i e $ go xs (i - n) e + go _ _ _ = return () + + getLeft (AnyChunks es) = concat <$> mapM getLeft es + getRight (AnyChunks es) = (concat . reverse) <$> mapM getRight es + reversed (AnyChunks es) = (AnyChunks . reverse) <$> mapM reversed es + + filled c e = AnyChunks <$> sequence (replicate d (filled lim e) :< filled n e) + 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 + trg' <- dropM ot trg + go c src' trg' + where + go n xs@(AnyChunks (x : _)) ys@(AnyChunks (y : _)) = do + n1 <- getSizeOf x + n2 <- getSizeOf y + let n' = minimum [n1, n2, n] + + copyTo x 0 y 0 n' + dropM n' xs >>=<< dropM n' ys $ go (n - n') + go n _ _ = when (n > 0) $ overEx "copyTo" + + -- | Unsafe, returns joined stream of existing chunks. + merged = return . AnyChunks . foldr ((++) . toChunks) [] + + ofoldrM f base' = ofoldrCh 0 base' . toChunks + where + ofoldrCh !o base (x : xs) = do + n <- getSizeOf x + xs' <- ofoldrCh (o + n) base xs + ofoldrM (f . (o +)) xs' x + ofoldrCh _ base _ = return base + + ofoldlM f base' = ofoldlCh 0 base' . toChunks + where + ofoldlCh !o base (x : xs) = do + n <- getSizeOf x + x' <- ofoldlM (f . (o +)) base x + ofoldlCh (o + n) x' xs + ofoldlCh _ base _ = return base + + foldrM f base = foldr ((=<<) . flip (foldrM f)) (return base) . toChunks + foldlM f base = foldl (flip $ (=<<) . flip (foldlM f)) (return base) . toChunks + +instance (BorderedM1 m rep Int e, SplitM1 m rep e) => SplitM m (AnyChunks rep e) e + where + takeM n (AnyChunks (e : es)) = n < 1 ? newNull $ do + c <- getSizeOf e + case n <=> c of + EQ -> return (AnyChunks [e]) + LT -> do t <- takeM n e; return (AnyChunks [t]) + GT -> do (AnyChunks ts) <- takeM (n - c) (AnyChunks es); return $ AnyChunks (e : ts) + takeM _ es = return es + + dropM n es'@(AnyChunks (e : es)) = n < 1 ? return es' $ do + c <- getSizeOf e + case n <=> c of + EQ -> return (AnyChunks es) + GT -> dropM (n - c) (AnyChunks es) + LT -> do d <- dropM n e; return $ AnyChunks (d : es) + dropM _ es = return es + + prefixM f (AnyChunks es) = foldr (\ e p -> do n <- getSizeOf e; c <- prefixM f e; c == n ? (+ c) <$> p $ return c) (return 0) es + suffixM f (AnyChunks es) = foldl (\ p e -> do n <- getSizeOf e; c <- suffixM f e; c == n ? (+ c) <$> p $ return c) (return 0) es + mprefix f (AnyChunks es) = foldr (\ e p -> do n <- getSizeOf e; c <- mprefix f e; c == n ? (+ c) <$> p $ return c) (return 0) es + msuffix f (AnyChunks es) = foldl (\ p e -> do n <- getSizeOf e; c <- msuffix f e; c == n ? (+ c) <$> p $ return c) (return 0) es + +-------------------------------------------------------------------------------- + +{- Set and Scan instances. -} + +instance (Nullable (AnyChunks rep e), SetWith1 (AnyChunks rep) e, Ord e) => Set (AnyChunks rep e) e + +instance (SetWith1 rep e, Linear1 rep e, Ord (rep e), Bordered1 rep Int e) => SetWith (AnyChunks rep e) e + where + insertWith f' e' = AnyChunks . go f' e' . toChunks + where + go f e (x : xs) = memberWith f e x ? insertWith f e x : xs $ x : go f e xs + go _ e _ = [single e] + + deleteWith f' e' = AnyChunks . go f' e' . toChunks + where + go f e (x : xs) = memberWith f e x ? deleteWith f e x : xs $ x : go f e xs + go _ _ _ = [] + + intersectionWith f = fromList ... on (intersectionWith f) listL + differenceWith f = fromList ... on (differenceWith f) listL + symdiffWith f = fromList ... on (symdiffWith f) listL + unionWith f = fromList ... on (unionWith f) listL + + lookupLTWith f o = foldr ((<|>) . lookupLTWith f o) Nothing . toChunks + lookupLEWith f o = foldr ((<|>) . lookupLEWith f o) Nothing . toChunks + lookupGTWith f o = foldr ((<|>) . lookupGTWith f o) Nothing . toChunks + lookupGEWith f o = foldr ((<|>) . lookupGEWith f o) Nothing . toChunks + + memberWith f x (AnyChunks es) = memberWith f x `any` es + + isSubsetWith f xs ys = o_foldr (\ e b -> memberWith f e ys && b) True xs + +instance (Linear1 (AnyChunks rep) e) => Scan (AnyChunks rep e) e + +-------------------------------------------------------------------------------- + +{- Indexed instance. -} + +instance (Indexed1 rep Int e) => Map (AnyChunks rep e) Int e + where + toMap ascs = isNull ascs ? Z $ assoc (ascsBounds ascs) ascs + + toMap' defvalue ascs = isNull ascs ? Z $ assoc' (ascsBounds ascs) defvalue ascs + + (.!) = (!^) + + Z // ascs = toMap ascs + AnyChunks es // ascs = AnyChunks (go 0 es ascs) + where + go _ [] _ = [] + go _ xs [ ] = xs + go l (x : xs) ies = x // as : go n xs bs + where + (as, bs) = partition (inRange (l, n - 1) . fst) ies + n = l + sizeOf es + + p .$ AnyChunks (x : xs) = p .$ x <|> (+ sizeOf x) <$> p .$ AnyChunks xs + _ .$ _ = Nothing + + p *$ AnyChunks (x : xs) = p *$ x ++ fmap (+ sizeOf x) (p *$ AnyChunks xs) + _ *$ _ = [] + + kfoldr f base es = let bnds = bounds es in kfoldr (f . index bnds) base es + kfoldl f base es = let bnds = bounds es in kfoldl (f . index bnds) base es + +instance (Indexed1 rep Int e) => Indexed (AnyChunks rep e) Int e + where + assoc bnds ascs = AnyChunks (go bnds ascs) + where + go (l, u) ies = isEmpty (l, u) ? [] $ assoc (l, n) as : go (n + 1, u) bs + where + (as, bs) = partition (inRange (l, n) . fst) ies + n = min u (l + lim) + + assoc' bnds defvalue ascs = AnyChunks (go bnds ascs) + where + go (l, u) ies = isEmpty (l, u) ? [] $ assoc' (l, n) defvalue as : go (n + 1, u) bs + where + (as, bs) = partition (inRange (l, n) . fst) ies + n = min u (l + lim) + + fromIndexed es = AnyChunks [fromIndexed es] + +-------------------------------------------------------------------------------- + +{- MapM, IndexedM and SortM instances. -} + +instance (SplitM1 m rep e, MapM1 m rep Int e, BorderedM1 m rep Int e) => MapM m (AnyChunks rep e) Int e + where + newMap ascs = AnyChunks <$> sequence (go (ascsBounds ascs) ascs) + where + go (l, u) ies = isEmpty (l, u) ? [] $ newMap as : go (n + 1, u) bs + where + (as, bs) = partition (inRange (l, n) . fst) ies + n = min u (l + lim) + + newMap' defvalue ascs = AnyChunks <$> sequence (go (ascsBounds ascs) ascs) + where + go (l, u) ies = newMap' defvalue as : go (n + 1, u) bs + where + (as, bs) = partition (inRange (l, n) . fst) ies + n = min u (l + lim) + + {-# INLINE (>!) #-} + es >! i = i < 0 ? overEx "(>!)" $ es !#> i + + overwrite es'@(AnyChunks []) ascs = isNull ascs ? return es' $ newMap ascs + overwrite es'@(AnyChunks es) ascs = es' <$ go 0 es ((< 0) . fst `except` ascs) + where + go o (x : xs) ie = unless (null ie) $ do + n <- getSizeOf x + let (as, bs) = partition (\ (i, _) -> i < n + o) ie + overwrite x as >> go (n + o) xs bs + go _ _ _ = return () + + kfoldrM = ofoldrM + kfoldlM = ofoldlM + +instance (SplitM1 m rep e, IndexedM1 m rep Int e) => IndexedM m (AnyChunks rep e) Int e + where + fromAssocs bnds ascs = AnyChunks <$> sequence (go bnds ascs) + where + go (l, u) ies = isEmpty (l, u) ? [] $ fromAssocs (l, n) as : go (n + 1, u) bs + where + (as, bs) = partition (inRange (l, n) . fst) ies + n = min u (l + lim) + + fromAssocs' bnds defvalue ascs = AnyChunks <$> sequence (go bnds ascs) + where + go (l, u) ies = fromAssocs' (l, n) defvalue as : go (n + 1, u) bs + where + (as, bs) = partition (inRange (l, n) . fst) ies + n = min u (l + lim) + + {-# INLINE writeM' #-} + writeM' es i e = (i < 0) `unless` writeM es i e + + fromIndexed' = newLinear . listL + fromIndexedM = newLinear <=< getLeft + +instance (BorderedM1 m rep Int e, SortM1 m rep e, SplitM1 m rep e, LinearM1 m rep e) => SortM m (AnyChunks rep e) e + where + sortMBy = timSortBy + + sortedMBy f = go . toChunks + where + go (x1 : x2 : xs) = + let restM = liftA2 f (getLast x1) (getHead x2) ?^ go (x2 : xs) $ return False + in sortedMBy f x1 ?^ restM $ return False + go [x1] = sortedMBy f x1 + go [] = return True + +-------------------------------------------------------------------------------- + +-- | Creates new local immutable structure and thaw it as fast, as possible. +instance {-# OVERLAPPABLE #-} (Linear1 imm e, Thaw1 m imm mut e) => Thaw m (AnyChunks imm e) (mut e) + where + -- @concat [e]@ may return e + thaw (AnyChunks [e]) = thaw e + -- any correct concat will create an intermediate structure in this case + thaw (AnyChunks ess) = unsafeThaw (concat ess) + + unsafeThaw = unsafeThaw . concat . toChunks + +-- | Creates one-chunk mutable stream, may be memory inefficient. +instance {-# OVERLAPPABLE #-} (Thaw1 m imm mut e) => Thaw m (imm e) (AnyChunks mut e) + where + unsafeThaw = fmap (AnyChunks . single) . unsafeThaw + thaw = fmap (AnyChunks . single) . thaw + +instance {-# OVERLAPS #-} (Thaw1 m imm mut e) => Thaw m (AnyChunks imm e) (AnyChunks mut e) + where + unsafeThaw (AnyChunks imm) = AnyChunks <$> mapM unsafeThaw imm + thaw (AnyChunks imm) = AnyChunks <$> mapM thaw imm + +-- | Creates one-chunk immutable stream, may be memory inefficient. +instance {-# OVERLAPPABLE #-} (Freeze1 m mut imm e) => Freeze m (mut e) (AnyChunks imm e) + where + unsafeFreeze = fmap (AnyChunks . single) . unsafeFreeze + freeze = fmap (AnyChunks . single) . freeze + +-- | Creates new immutable structure using 'merged'. +instance {-# OVERLAPPABLE #-} (LinearM1 m mut e, Freeze1 m mut imm e) => Freeze m (AnyChunks mut e) (imm e) + where + unsafeFreeze (AnyChunks es) = unsafeFreeze =<< merged es + freeze (AnyChunks es) = freeze =<< merged es + +instance {-# OVERLAPS #-} (Freeze1 m mut imm e) => Freeze m (AnyChunks mut e) (AnyChunks imm e) + where + unsafeFreeze (AnyChunks mut) = AnyChunks <$> mapM unsafeFreeze mut + freeze (AnyChunks mut) = AnyChunks <$> mapM freeze mut + +-------------------------------------------------------------------------------- + +ascsBounds :: (Ord a) => [(a, b)] -> (a, a) +ascsBounds = \ ((x, _) : xs) -> foldr (\ (e, _) (mn, mx) -> (min mn e, max mx e)) (x, x) xs + +overEx :: String -> a +overEx = throw . IndexOverflow . showString "in SDP.Templates.AnyChunks." + +underEx :: String -> a +underEx = throw . IndexUnderflow . showString "in SDP.Templates.AnyChunks." + +pfailEx :: String -> a +pfailEx = throw . PatternMatchFail . showString "in SDP.Templates.AnyChunks." + +lim :: Int +lim = 1024 + + diff --git a/src/SDP/Tuple.hs b/src/SDP/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Tuple.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.Tuple + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Tuple" provides tuple type synonyms. +-} +module SDP.Tuple +( + -- * Tuple synonyms + T2, T3, T4, T5, T6, T7, T8, T9, T10, T11, T12, T13, T14, T15, + + -- * Related combinators + fsts, snds, both +) +where + +import Data.Function ( on ) + +default () + +-------------------------------------------------------------------------------- + +-- | Return all first elements in pairs. +fsts :: (Functor f) => f (a, b) -> f a +fsts = fmap fst + +-- | Return all first elements in pairs. +snds :: (Functor f) => f (a, b) -> f b +snds = fmap snd + +-- | Applies function to both elements of pair. +both :: (a -> b) -> (a, a) -> (b, b) +both = uncurry . on (,) + +-------------------------------------------------------------------------------- + +-- | Tuple synonym +type T2 i = (i,i) +-- | Tuple synonym +type T3 i = (i,i,i) +-- | Tuple synonym +type T4 i = (i,i,i,i) +-- | Tuple synonym +type T5 i = (i,i,i,i,i) +-- | Tuple synonym +type T6 i = (i,i,i,i,i,i) +-- | Tuple synonym +type T7 i = (i,i,i,i,i,i,i) +-- | Tuple synonym +type T8 i = (i,i,i,i,i,i,i,i) +-- | Tuple synonym +type T9 i = (i,i,i,i,i,i,i,i,i) +-- | Tuple synonym +type T10 i = (i,i,i,i,i,i,i,i,i,i) +-- | Tuple synonym +type T11 i = (i,i,i,i,i,i,i,i,i,i,i) +-- | Tuple synonym +type T12 i = (i,i,i,i,i,i,i,i,i,i,i,i) +-- | Tuple synonym +type T13 i = (i,i,i,i,i,i,i,i,i,i,i,i,i) +-- | Tuple synonym +type T14 i = (i,i,i,i,i,i,i,i,i,i,i,i,i,i) +-- | Tuple synonym +type T15 i = (i,i,i,i,i,i,i,i,i,i,i,i,i,i,i) + diff --git a/src/SDP/Unboxed.hs b/src/SDP/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Unboxed.hs @@ -0,0 +1,680 @@ +{-# 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) +SDP_DERIVE_FOREIGN_UNBOXED(CBool) +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# + +{-# INLINE bool_index #-} +bool_index :: Int# -> Int# +#if SIZEOF_HSWORD == 4 +bool_index = (`uncheckedIShiftRA#` 5#) +#elif SIZEOF_HSWORD == 8 +bool_index = (`uncheckedIShiftRA#` 6#) +#endif + +consSizeof :: (a -> b) -> b -> a +consSizeof = \ _ _ -> undefined + + diff --git a/src/SDP/Unboxed/IntAs.hs b/src/SDP/Unboxed/IntAs.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Unboxed/IntAs.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, Trustworthy, GeneralizedNewtypeDeriving #-} + +{- | + Module : SDP.Unboxed.IntAs + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Unboxed.IntAs" provides additional 'Int' instances for 'Unboxed'. +-} +module SDP.Unboxed.IntAs +( + IntAs8 (..), IntAs16 (..), IntAs32 (..), IntAs64 (..) +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Unboxed +import SDP.Index + +import GHC.Base +import GHC.Exts + +import Foreign.Storable + +import Text.Read + +#include "MachDeps.h" + +default () + +-------------------------------------------------------------------------------- + +-- | Int value as 1 byte. +newtype IntAs8 = IntAs8 Int + deriving ( Eq, Ord, Enum, Bounded, Num, Real, Integral ) + +-- | Int value as 2 bytes. +newtype IntAs16 = IntAs16 Int + deriving ( Eq, Ord, Enum, Bounded, Num, Real, Integral ) + +-- | Int value as 4 bytes. +newtype IntAs32 = IntAs32 Int + deriving ( Eq, Ord, Enum, Bounded, Num, Real, Integral ) + +-- | Int value as 8 bytes. +newtype IntAs64 = IntAs64 Int + deriving ( Eq, Ord, Enum, Bounded, Num, Real, Integral ) + +-------------------------------------------------------------------------------- + +instance Shape IntAs8 +instance Shape IntAs16 +instance Shape IntAs32 +instance Shape IntAs64 + +instance Index IntAs8 where offset = offsetIntegral +instance Index IntAs16 where offset = offsetIntegral +instance Index IntAs32 where offset = offsetIntegral +instance Index IntAs64 where offset = offsetIntegral + +instance Show IntAs8 where show (IntAs8 x) = show x +instance Show IntAs16 where show (IntAs16 x) = show x +instance Show IntAs32 where show (IntAs32 x) = show x +instance Show IntAs64 where show (IntAs64 x) = show x + +instance Read IntAs8 where readPrec = IntAs8 <$> readPrec +instance Read IntAs16 where readPrec = IntAs16 <$> readPrec +instance Read IntAs32 where readPrec = IntAs32 <$> readPrec +instance Read IntAs64 where readPrec = IntAs64 <$> readPrec + +instance Unboxed IntAs8 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n + + {-# INLINE (!#) #-} + bytes# !# i# = IntAs8 (I# (indexInt8Array# bytes# i#)) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readInt8Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, IntAs8 (I# e#) #) + + writeByteArray# mbytes# n# (IntAs8 (I# e#)) = writeInt8Array# mbytes# n# e# + + newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: IntAs8) s2# of + s3# -> (# s3#, mbytes# #) + +instance Unboxed IntAs16 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 2 + + {-# INLINE (!#) #-} + bytes# !# i# = IntAs16 (I# (indexInt16Array# bytes# i#)) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readInt16Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, IntAs16 (I# e#) #) + + writeByteArray# mbytes# n# (IntAs16 (I# e#)) = writeInt16Array# mbytes# n# e# + + newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: IntAs16) s2# of + s3# -> (# s3#, mbytes# #) + +instance Unboxed IntAs32 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 4 + + {-# INLINE (!#) #-} + bytes# !# i# = IntAs32 (I# (indexInt32Array# bytes# i#)) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readInt32Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, IntAs32 (I# e#) #) + + writeByteArray# mbytes# n# (IntAs32 (I# e#)) = writeInt32Array# mbytes# n# e# + + newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: IntAs32) s2# of + s3# -> (# s3#, mbytes# #) + +instance Unboxed IntAs64 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 8 + + {-# INLINE (!#) #-} + bytes# !# i# = IntAs64 (I# (indexInt64Array# bytes# i#)) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readInt64Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, IntAs64 (I# e#) #) + + writeByteArray# mbytes# n# (IntAs64 (I# e#)) = writeInt64Array# mbytes# n# e# + + newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: IntAs64) s2# of + s3# -> (# s3#, mbytes# #) + +-------------------------------------------------------------------------------- + +instance Storable IntAs8 + where + sizeOf _ = SIZEOF_INT8 + alignment _ = ALIGNMENT_INT8 + + peekElemOff (Ptr p#) (I# i#) = IO $ + \ s1# -> case readInt8OffAddr# p# i# s1# of + (# s2#, x #) -> (# s2#, IntAs8 (I# x) #) + + pokeElemOff (Ptr p#) (I# i#) (IntAs8 (I# x)) = IO $ + \ s1# -> case writeInt8OffAddr# p# i# x s1# of s2 -> (# s2, () #) + +instance Storable IntAs16 + where + sizeOf _ = SIZEOF_INT16 + alignment _ = ALIGNMENT_INT16 + + peekElemOff (Ptr p#) (I# i#) = IO $ + \ s1# -> case readInt16OffAddr# p# i# s1# of + (# s2, x #) -> (# s2, IntAs16 (I# x) #) + + pokeElemOff (Ptr p#) (I# i#) (IntAs16 (I# x)) = IO $ + \ s1# -> case writeInt16OffAddr# p# i# x s1# of s2 -> (# s2, () #) + +instance Storable IntAs32 + where + sizeOf _ = SIZEOF_INT32 + alignment _ = ALIGNMENT_INT32 + + peekElemOff (Ptr p#) (I# i#) = IO $ + \ s1# -> case readInt32OffAddr# p# i# s1# of + (# s2, x #) -> (# s2, IntAs32 (I# x) #) + + pokeElemOff (Ptr p#) (I# i#) (IntAs32 (I# x)) = IO $ + \ s1# -> case writeInt32OffAddr# p# i# x s1# of s2 -> (# s2, () #) + +instance Storable IntAs64 + where + sizeOf _ = SIZEOF_INT64 + alignment _ = ALIGNMENT_INT64 + + peekElemOff (Ptr p#) (I# i#) = IO $ + \ s1# -> case readInt64OffAddr# p# i# s1# of + (# s2, x #) -> (# s2, IntAs64 (I# x) #) + + pokeElemOff (Ptr p#) (I# i#) (IntAs64 (I# x)) = IO $ + \ s1# -> case writeInt64OffAddr# p# i# x s1# of s2 -> (# s2, () #) + diff --git a/src/SDP/Unboxed/WordAs.hs b/src/SDP/Unboxed/WordAs.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Unboxed/WordAs.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, Trustworthy, GeneralizedNewtypeDeriving #-} + +{- | + Module : SDP.Unboxed.WordAs + Copyright : (c) Andrey Mulik 2020 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : non-portable (GHC extensions) + + "SDP.Unboxed.WordAs" provides additional 'Word' instances for 'Unboxed'. +-} +module SDP.Unboxed.WordAs +( + WordAs8 (..), WordAs16 (..), WordAs32 (..), WordAs64 (..) +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Unboxed +import SDP.Index + +import GHC.Base +import GHC.Exts + +import Foreign.Storable + +import Text.Read + +#include "MachDeps.h" + +default () + +-------------------------------------------------------------------------------- + +-- | Word value as 1 byte. +newtype WordAs8 = WordAs8 Word + deriving ( Eq, Ord, Enum, Bounded, Num, Real, Integral ) + +-- | Word value as 2 bytes. +newtype WordAs16 = WordAs16 Word + deriving ( Eq, Ord, Enum, Bounded, Num, Real, Integral ) + +-- | Word value as 4 bytes. +newtype WordAs32 = WordAs32 Word + deriving ( Eq, Ord, Enum, Bounded, Num, Real, Integral ) + +-- | Word value as 8 bytes. +newtype WordAs64 = WordAs64 Word + deriving ( Eq, Ord, Enum, Bounded, Num, Real, Integral ) + +-------------------------------------------------------------------------------- + +instance Shape WordAs8 +instance Shape WordAs16 +instance Shape WordAs32 +instance Shape WordAs64 + +instance Index WordAs8 where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index WordAs16 where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index WordAs32 where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign +instance Index WordAs64 where offset = offsetIntegral; defaultBounds = defaultBoundsUnsign + +instance Show WordAs8 where show (WordAs8 x) = show x +instance Show WordAs16 where show (WordAs16 x) = show x +instance Show WordAs32 where show (WordAs32 x) = show x +instance Show WordAs64 where show (WordAs64 x) = show x + +instance Read WordAs8 where readPrec = WordAs8 <$> readPrec +instance Read WordAs16 where readPrec = WordAs16 <$> readPrec +instance Read WordAs32 where readPrec = WordAs32 <$> readPrec +instance Read WordAs64 where readPrec = WordAs64 <$> readPrec + +instance Unboxed WordAs8 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n + + {-# INLINE (!#) #-} + bytes# !# i# = WordAs8 (W# (indexWord8Array# bytes# i#)) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWord8Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, WordAs8 (W# e#) #) + + writeByteArray# mbytes# n# (WordAs8 (W# e#)) = writeWord8Array# mbytes# n# e# + + newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: WordAs8) s2# of + s3# -> (# s3#, mbytes# #) + +instance Unboxed WordAs16 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 2 + + {-# INLINE (!#) #-} + bytes# !# i# = WordAs16 (W# (indexWord16Array# bytes# i#)) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWord16Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, WordAs16 (W# e#) #) + + writeByteArray# mbytes# n# (WordAs16 (W# e#)) = writeWord16Array# mbytes# n# e# + + newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: WordAs16) s2# of + s3# -> (# s3#, mbytes# #) + +instance Unboxed WordAs32 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 4 + + {-# INLINE (!#) #-} + bytes# !# i# = WordAs32 (W# (indexWord32Array# bytes# i#)) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWord32Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, WordAs32 (W# e#) #) + + writeByteArray# mbytes# n# (WordAs32 (W# e#)) = writeWord32Array# mbytes# n# e# + + newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: WordAs32) s2# of + s3# -> (# s3#, mbytes# #) + +instance Unboxed WordAs64 + where + {-# INLINE sizeof #-} + sizeof _ n = max 0 n * 8 + + {-# INLINE (!#) #-} + bytes# !# i# = WordAs64 (W# (indexWord64Array# bytes# i#)) + + {-# INLINE (!>#) #-} + mbytes# !># i# = \ s1# -> case readWord64Array# mbytes# i# s1# of + (# s2#, e# #) -> (# s2#, WordAs64 (W# e#) #) + + writeByteArray# mbytes# n# (WordAs64 (W# e#)) = writeWord64Array# mbytes# n# e# + + newUnboxed e n# = \ s1# -> case newByteArray# (sizeof# e n#) s1# of + (# s2#, mbytes# #) -> case fillByteArray# mbytes# n# (0 :: WordAs64) s2# of + s3# -> (# s3#, mbytes# #) + +-------------------------------------------------------------------------------- + +instance Storable WordAs8 + where + sizeOf _ = SIZEOF_WORD8 + alignment _ = ALIGNMENT_WORD8 + + peekElemOff (Ptr p#) (I# i#) = IO $ + \ s1# -> case readWord8OffAddr# p# i# s1# of + (# s2#, x #) -> (# s2#, WordAs8 (W# x) #) + + pokeElemOff (Ptr p#) (I# i#) (WordAs8 (W# x)) = IO $ + \ s1# -> case writeWord8OffAddr# p# i# x s1# of s2 -> (# s2, () #) + +instance Storable WordAs16 + where + sizeOf _ = SIZEOF_WORD16 + alignment _ = ALIGNMENT_WORD16 + + peekElemOff (Ptr p#) (I# i#) = IO $ + \ s1# -> case readWord16OffAddr# p# i# s1# of + (# s2, x #) -> (# s2, WordAs16 (W# x) #) + + pokeElemOff (Ptr p#) (I# i#) (WordAs16 (W# x)) = IO $ + \ s1# -> case writeWord16OffAddr# p# i# x s1# of s2 -> (# s2, () #) + +instance Storable WordAs32 + where + sizeOf _ = SIZEOF_WORD32 + alignment _ = ALIGNMENT_WORD32 + + peekElemOff (Ptr p#) (I# i#) = IO $ + \ s1# -> case readWord32OffAddr# p# i# s1# of + (# s2, x #) -> (# s2, WordAs32 (W# x) #) + + pokeElemOff (Ptr p#) (I# i#) (WordAs32 (W# x)) = IO $ + \ s1# -> case writeWord32OffAddr# p# i# x s1# of s2 -> (# s2, () #) + +instance Storable WordAs64 + where + sizeOf _ = SIZEOF_WORD64 + alignment _ = ALIGNMENT_WORD64 + + peekElemOff (Ptr p#) (I# i#) = IO $ + \ s1# -> case readWord64OffAddr# p# i# s1# of + (# s2, x #) -> (# s2, WordAs64 (W# x) #) + + pokeElemOff (Ptr p#) (I# i#) (WordAs64 (W# x)) = IO $ + \ s1# -> case writeWord64OffAddr# p# i# x s1# of s2 -> (# s2, () #) + diff --git a/src/SDP/Unrolled.hs b/src/SDP/Unrolled.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Unrolled.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.Unrolled + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Unrolled" provides 'Unrolled' - lazy boxed unrolled linked list. +-} +module SDP.Unrolled +( + -- * Exports + module SDP.Indexed, + module SDP.Sort, + module SDP.Scan, + module SDP.Set, + + -- * Unrolled + Unrolled, + + -- * Unlist + Unlist +) +where + +import SDP.Indexed +import SDP.Sort +import SDP.Scan +import SDP.Set + +import SDP.Templates.AnyBorder +import SDP.Unrolled.Unlist + +default () + +-------------------------------------------------------------------------------- + +-- | 'Unrolled' is bordered unrolled linked list. +type Unrolled = AnyBorder Unlist + + + + diff --git a/src/SDP/Unrolled/IO.hs b/src/SDP/Unrolled/IO.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Unrolled/IO.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.Unrolled.IO + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Unrolled.IO" provides 'IOUnrolled' - mutable lazy boxed unrolled linked + list type. +-} +module SDP.Unrolled.IO +( + -- * Exports + module SDP.IndexedM, + module SDP.SortM, + + -- * MonadIO and IO Unrolled + MIOUnrolled, IOUnrolled +) +where + +import SDP.Templates.AnyBorder +import SDP.Unrolled.IOUnlist +import SDP.IndexedM +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'MIOUnrolled' is mutable version of 'SDP.Unrolled.Unrolled'. +type MIOUnrolled io = AnyBorder (MIOUnlist io) + +-- | 'IOUnrolled' is mutable version of 'SDP.Unrolled.Unrolled'. +type IOUnrolled = AnyBorder IOUnlist + + + diff --git a/src/SDP/Unrolled/IOUnlist.hs b/src/SDP/Unrolled/IOUnlist.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Unrolled/IOUnlist.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.Unrolled.IOUnlist + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Unrolled.IOUnlist" provides 'IOUnlist' - mutable lazy boxed unrolled + linked list. +-} +module SDP.Unrolled.IOUnlist +( + -- * Exports + module SDP.IndexedM, + module SDP.SortM, + + -- * MonadIO and IO Unlists + MIOUnlist, IOUnlist +) +where + +import SDP.Templates.AnyChunks +import SDP.Prim.SArray +import SDP.IndexedM +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'MIOUnlist' is mutable version of 'SDP.Unrolled.Unlist.Unlist'. +type MIOUnlist io = AnyChunks (MIOArray# io) + +-- | 'IOUnlist' is mutable version of 'SDP.Unrolled.Unlist.Unlist'. +type IOUnlist = AnyChunks IOArray# + + + diff --git a/src/SDP/Unrolled/ST.hs b/src/SDP/Unrolled/ST.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Unrolled/ST.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.Unrolled.ST + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Unrolled.ST" provides 'STUnrolled' - mutable boxed lazy unrolled linked + list. +-} +module SDP.Unrolled.ST +( + -- * Exports + module SDP.IndexedM, + module SDP.SortM, + + -- * STUnrolled + STUnrolled +) +where + +import SDP.Templates.AnyBorder +import SDP.Unrolled.STUnlist +import SDP.IndexedM +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'STUnrolled' is mutable version 'SDP.Unrolled.Unrolled'. +type STUnrolled s = AnyBorder (STUnlist s) + diff --git a/src/SDP/Unrolled/STUnlist.hs b/src/SDP/Unrolled/STUnlist.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Unrolled/STUnlist.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe, MagicHash #-} + +{- | + Module : SDP.Unrolled.STUnlist + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Unrolled.STUnlist" provides 'STUnlist' - mutable boxed lazy unrolled + linked list. +-} +module SDP.Unrolled.STUnlist +( + -- * Exports + module SDP.IndexedM, + module SDP.SortM, + + -- * STUnlist + STUnlist +) +where + +import SDP.Templates.AnyChunks +import SDP.Prim.SArray +import SDP.IndexedM +import SDP.SortM + +default () + +-------------------------------------------------------------------------------- + +-- | 'STUnlist' is mutable version of 'SDP.Unrolled.Unlist.Unlist'. +type STUnlist s = AnyChunks (STArray# s) + diff --git a/src/SDP/Unrolled/Unlist.hs b/src/SDP/Unrolled/Unlist.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Unrolled/Unlist.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE Safe, MagicHash, MultiParamTypeClasses, FlexibleInstances #-} + +{- | + Module : SDP.Unrolled.Unlist + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Unrolled.Unlist" provides 'Unlist' - lazy boxed unrolled linked list. +-} +module SDP.Unrolled.Unlist +( + -- * Exports + module SDP.Indexed, + module SDP.Sort, + module SDP.Scan, + module SDP.Set, + + -- * Unlist + Unlist +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Indexed +import SDP.Sort +import SDP.Scan +import SDP.Set + +import SDP.Templates.AnyChunks +import SDP.Prim.SArray +import SDP.SortM.Tim + +default () + +-------------------------------------------------------------------------------- + +-- | 'Unlist' is unrolled linked list of boxed values. +type Unlist = AnyChunks SArray# + +-------------------------------------------------------------------------------- + +{- Eq1 and Ord1 instances. -} + +instance Eq1 Unlist + where + liftEq _ Z Z = True + liftEq _ Z _ = False + liftEq _ _ Z = False + liftEq f xs ys = if n1 > n2 + then liftEq f (take n2 x) y && liftEq f (drop n2 xs) (fromChunks ys') + else liftEq f x (take n1 y) && liftEq f (fromChunks xs') (drop n1 ys) + where + (x : xs') = toChunks xs; n1 = sizeOf x + (y : ys') = toChunks ys; n2 = sizeOf y + +instance Ord1 Unlist + where + liftCompare _ Z Z = EQ + liftCompare _ Z _ = LT + liftCompare _ _ Z = GT + liftCompare f xs ys = if n1 > n2 + then liftCompare f (take n2 x) y <> liftCompare f (drop n2 xs) (fromChunks ys') + else liftCompare f x (take n1 y) <> liftCompare f (fromChunks xs') (drop n1 ys) + where + (x : xs') = toChunks xs; n1 = sizeOf x + (y : ys') = toChunks ys; n2 = sizeOf y + +instance Zip Unlist + where + all2 f as bs = all2 f (listL as) (listL bs) + any2 f as bs = any2 f (listL as) (listL bs) + all3 f as bs cs = all3 f (listL as) (listL bs) (listL cs) + any3 f as bs cs = any3 f (listL as) (listL bs) (listL cs) + all4 f as bs cs ds = all4 f (listL as) (listL bs) (listL cs) (listL ds) + any4 f as bs cs ds = any4 f (listL as) (listL bs) (listL cs) (listL ds) + all5 f as bs cs ds es = all5 f (listL as) (listL bs) (listL cs) (listL ds) (listL es) + any5 f as bs cs ds es = any5 f (listL as) (listL bs) (listL cs) (listL ds) (listL es) + all6 f as bs cs ds es fs = all6 f (listL as) (listL bs) (listL cs) (listL ds) (listL es) (listL fs) + any6 f as bs cs ds es fs = any6 f (listL as) (listL bs) (listL cs) (listL ds) (listL es) (listL fs) + + zipWith f as bs = fromList $ zipWith f (listL as) (listL bs) + zipWith3 f as bs cs = fromList $ zipWith3 f (listL as) (listL bs) (listL cs) + zipWith4 f as bs cs ds = fromList $ zipWith4 f (listL as) (listL bs) (listL cs) (listL ds) + zipWith5 f as bs cs ds es = fromList $ zipWith5 f (listL as) (listL bs) (listL cs) (listL ds) (listL es) + zipWith6 f as bs cs ds es fs = fromList $ zipWith6 f (listL as) (listL bs) (listL cs) (listL ds) (listL es) (listL fs) + +instance Sort (Unlist e) e + where + sortBy cmp es = runST $ do es' <- thaw es; timSortBy cmp es'; done es' + + 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 + go [] = True + +-------------------------------------------------------------------------------- + +{-# INLINE done #-} +done :: STArray# s e -> ST s (Unlist e) +done = unsafeFreeze + diff --git a/src/SDP/Zip.hs b/src/SDP/Zip.hs new file mode 100644 --- /dev/null +++ b/src/SDP/Zip.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : SDP.Zip + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "SDP.Zip" provides 'Zip' - class of 'Control.Applicative.ZipList"-like + structures. +-} +module SDP.Zip ( Zip (..) ) where + +import Prelude () +import SDP.SafePrelude + +default () + +-------------------------------------------------------------------------------- + +-- | Zip is generalization of ZipList applicative semantics (but without pure). +class (Functor z) => Zip z + where + {-# MINIMAL (zap | zipWith), all2, any2 #-} + + -- | ZipList-like '<*>' + zap :: z (a -> b) -> z a -> z b + zap = zipWith ($) + + all2 :: (a -> b -> Bool) -> z a -> z b -> Bool + all3 :: (a -> b -> c -> Bool) -> z a -> z b -> z c -> Bool + all4 :: (a -> b -> c -> d -> Bool) -> z a -> z b -> z c -> z d -> Bool + all5 :: (a -> b -> c -> d -> e -> Bool) -> z a -> z b -> z c -> z d -> z e -> Bool + all6 :: (a -> b -> c -> d -> e -> f -> Bool) -> z a -> z b -> z c -> z d -> z e -> z f -> Bool + + all3 f = all2 ($) ... zipWith f + all4 f as = all2 ($) ... zipWith3 f as + all5 f as bs = all2 ($) ... zipWith4 f as bs + all6 f as bs cs = all2 ($) ... zipWith5 f as bs cs + + any2 :: (a -> b -> Bool) -> z a -> z b -> Bool + any3 :: (a -> b -> c -> Bool) -> z a -> z b -> z c -> Bool + any4 :: (a -> b -> c -> d -> Bool) -> z a -> z b -> z c -> z d -> Bool + any5 :: (a -> b -> c -> d -> e -> Bool) -> z a -> z b -> z c -> z d -> z e -> Bool + any6 :: (a -> b -> c -> d -> e -> f -> Bool) -> z a -> z b -> z c -> z d -> z e -> z f -> Bool + + any3 f = any2 ($) ... zipWith f + any4 f as = any2 ($) ... zipWith3 f as + any5 f as bs = any2 ($) ... zipWith4 f as bs + any6 f as bs cs = any2 ($) ... zipWith5 f as bs cs + + zip :: z a -> z b -> z (a, b) + zip3 :: z a -> z b -> z c -> z (a, b, c) + zip4 :: z a -> z b -> z c -> z d -> z (a, b, c, d) + zip5 :: z a -> z b -> z c -> z d -> z e -> z (a, b, c, d, e) + zip6 :: z a -> z b -> z c -> z d -> z e -> z f -> z (a, b, c, d, e, f) + + zip = zipWith (,) + zip3 = zipWith3 (,,) + zip4 = zipWith4 (,,,) + zip5 = zipWith5 (,,,,) + zip6 = zipWith6 (,,,,,) + + zipWith :: (a -> b -> c) -> z a -> z b -> z c + zipWith3 :: (a -> b -> c -> d) -> z a -> z b -> z c -> z d + zipWith4 :: (a -> b -> c -> d -> e) -> z a -> z b -> z c -> z d -> z e + zipWith5 :: (a -> b -> c -> d -> e -> f) -> z a -> z b -> z c -> z d -> z e -> z f + zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> z a -> z b -> z c -> z d -> z e -> z f -> z g + + zipWith = zap ... fmap + zipWith3 f = zap ... zipWith f + zipWith4 f as = zap ... zipWith3 f as + zipWith5 f as bs = zap ... zipWith4 f as bs + zipWith6 f as bs cs = zap ... zipWith5 f as bs cs + +-------------------------------------------------------------------------------- + +instance Zip [] + where + zap (f : fs) (x : xs) = f x : zap fs xs + zap _ _ = [] + + all2 f (a:as) (b:bs) = f a b && all2 f as bs + all2 _ _ _ = True + + all3 f (a:as) (b:bs) (c:cs) = f a b c && all3 f as bs cs + all3 _ _ _ _ = True + + all4 f (a:as) (b:bs) (c:cs) (d:ds) = f a b c d && all4 f as bs cs ds + all4 _ _ _ _ _ = True + + all5 f (a:as) (b:bs) (c:cs) (d:ds) (e:es) = f a b c d e && all5 f as bs cs ds es + all5 _ _ _ _ _ _ = True + + all6 f (a:as) (b:bs) (c:cs) (d:ds) (e:es) (g:gs) = f a b c d e g && all6 f as bs cs ds es gs + all6 _ _ _ _ _ _ _ = True + + any2 f (a:as) (b:bs) = f a b || any2 f as bs + any2 _ _ _ = False + + any3 f (a:as) (b:bs) (c:cs) = f a b c || any3 f as bs cs + any3 _ _ _ _ = False + + any4 f (a:as) (b:bs) (c:cs) (d:ds) = f a b c d || any4 f as bs cs ds + any4 _ _ _ _ _ = False + + any5 f (a:as) (b:bs) (c:cs) (d:ds) (e:es) = f a b c d e || any5 f as bs cs ds es + any5 _ _ _ _ _ _ = False + + any6 f (a:as) (b:bs) (c:cs) (d:ds) (e:es) (g:gs) = f a b c d e g || any6 f as bs cs ds es gs + any6 _ _ _ _ _ _ _ = False + + zipWith f (a:as) (b:bs) = f a b:zipWith f as bs + zipWith _ _ _ = [] + + zipWith3 f (a:as) (b:bs) (c:cs) = f a b c:zipWith3 f as bs cs + zipWith3 _ _ _ _ = [] + + zipWith4 f (a:as) (b:bs) (c:cs) (d:ds) = f a b c d:zipWith4 f as bs cs ds + zipWith4 _ _ _ _ _ = [] + + zipWith5 f (a:as) (b:bs) (c:cs) (d:ds) (e:es) = f a b c d e:zipWith5 f as bs cs ds es + zipWith5 _ _ _ _ _ _ = [] + + zipWith6 f (a:as) (b:bs) (c:cs) (d:ds) (e:es) (g:gs) = f a b c d e g:zipWith6 f as bs cs ds es gs + zipWith6 _ _ _ _ _ _ _ = [] + + + diff --git a/src/Text/Read/SDP.hs b/src/Text/Read/SDP.hs new file mode 100644 --- /dev/null +++ b/src/Text/Read/SDP.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : Text.Read.SDP + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "Text.Read.SDP" provides common 'ReadPrec' parsers and related stuff. +-} +module Text.Read.SDP +( + -- * Exports + module Text.Read, + module Text.Read.Lex, + + appPrec, + + -- * Common parsers + linearPrec, indexedPrec, indexedPrec', + + readZeroPrec, readAsList, readAsListN, readAssocsPrec, + + -- * Common parser combinators + allPrec, allPrecWith, expectPrec, namedPrec, + + -- * Generalized readers + readDef, readBy, readMaybeBy, readEitherBy, readDefBy, + + -- * Enum parsers + readAsEnum, enumFromPrec, enumFromToPrec, enumFromThenPrec, enumFromThenToPrec +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Indexed + +import Data.Default.Class + +import Text.ParserCombinators.ReadP ( eof, manyTill, skipSpaces ) +import Text.Read.Lex ( expect ) +import Text.Read + +import GHC.Show ( appPrec ) + +default () + +-------------------------------------------------------------------------------- + +{- | + @'indexedPrec' ident@ is common parser of 'Indexed' structure with name + @ident@: + + > read "ident (0,1) [(0,0),(1,1)]" == read "(0,1) [(0,0),(1,1)]" == assoc (0,1) [(0,0),(1,1)] +-} +indexedPrec :: (Indexed v i e, Read i, Read e) => String -> ReadPrec v +indexedPrec = namedPrec readAssocsPrec + +{- | + @'linearPrec' ident@ is common parser of 'Linear' structure with name + @ident@: + + > read "Z" == read "[]" == [] + > read "['l','g','p','l']" == fromList "lgpl" + > read "4 [1,5,-1,45,12,6,0,0,12]" == fromListN 4 [1,5,-1,45,12,6,0,0,12] +-} +linearPrec :: (Linear l e, Read e) => String -> ReadPrec l +linearPrec = namedPrec (readZeroPrec +++ readAsList +++ readAsListN) + +-- | 'indexedPrec'' is common 'Linear' and 'Indexed' parser (recommended). +indexedPrec' :: (Indexed v i e, Read i, Read e) => String -> ReadPrec v +indexedPrec' = namedPrec (readZeroPrec +++ readAsList +++ readAsListN +++ readAssocsPrec) + +-------------------------------------------------------------------------------- + +{- Common parsers. -} + +-- | 'readZeroPrec' is just 'Z' parser, see 'linearPrec'. +readZeroPrec :: (Linear l e) => ReadPrec l +readZeroPrec = parens $ prec appPrec (expectPrec $ Ident "Z") >> return Z + +-- | 'readAsList' is 'fromList'-based parser, see 'linearPrec'. +readAsList :: (Linear l e, Read e) => ReadPrec l +readAsList = fromList <$> readListPrec + +-- | 'readAsListN' is 'fromListN'-based parser, see 'linearPrec'. +readAsListN :: (Linear l e, Read e) => ReadPrec l +readAsListN = liftA2 fromListN (step readPrec) (step readPrec) + +{- | + 'readAssocsPrec' is @sdp@ recommended format 'ReadPrec' parser for 'Indexed'. +-} +readAssocsPrec :: (Indexed v i e, Read i, Read e) => ReadPrec v +readAssocsPrec = parens $ liftA2 assoc (step readPrec) (step readPrec) + +-------------------------------------------------------------------------------- + +{- Enum parsers. -} + +-- | Common 'Enum' parser. +readAsEnum :: (Linear l e, Read e, Enum e) => ReadPrec l +readAsEnum = fromList <$> parens' (fromPrec_ +++ fromThenPrec_ +++ fromToPrec_ +++ fromThenToPrec_) + +{- | + 'enumFrom' parser: + + > take 5 (readBy enumFromPrec "[1 ..]") == take 5 [1 ..] = [1,2,3,4,5] +-} +enumFromPrec :: (Linear l e, Read e, Enum e) => ReadPrec l +enumFromPrec = fromList <$> parens' fromPrec_ + +{- | + 'enumFromTo' parser: + + > readBy enumFromToPrec "[9 .. 12]" == [9 .. 12] == [9,10,11,12] +-} +enumFromToPrec :: (Linear l e, Read e, Enum e) => ReadPrec l +enumFromToPrec = fromList <$> parens' fromToPrec_ + +{- | + 'enumFromThen' parser: + + > take 4 (readBy enumFromThenPrec "[17, -6 .. ]") == take 4 [17, -6 ..] == [17,-6,-29,-52] +-} +enumFromThenPrec :: (Linear l e, Read e, Enum e) => ReadPrec l +enumFromThenPrec = fromList <$> parens' fromThenPrec_ + +{- | + 'enumFromThenTo' parser: + + > take 4 (readBy enumFromThenToPrec "[17, -6 .. 4]") == [17, -6 .. 4] == [17] +-} +enumFromThenToPrec :: (Linear l e, Read e, Enum e) => ReadPrec l +enumFromThenToPrec = fromList <$> parens' fromThenToPrec_ + +-------------------------------------------------------------------------------- + +{- Common parser combinators. -} + +-- | Just lifted 'expect'. +expectPrec :: Lexeme -> ReadPrec () +expectPrec = lift . expect + +-- | @allPrec@ is just @'allPrecWith' 'readPrec'@ +allPrec :: (Read e) => ReadPrec [e] +allPrec = allPrecWith readPrec + +{- | + allPrecWith is 'manyTill'-based combinator, which reads a sequence of elements + without any separators: + + > readBy allPrecWith readPrec "1 2 3 4 5 6 7" :: [Int] == [1 .. 7] +-} +allPrecWith :: ReadPrec e -> ReadPrec [e] +allPrecWith parser = lift (manyTill reader eof) + where + reader = readPrec_to_P parser 0 + +-- | @'namedPrec' readprec name@ is 'readPrec' with optional @name@ prefix. +namedPrec :: ReadPrec e -> String -> ReadPrec e +namedPrec parser name = + let named = prec appPrec (expectPrec $ Ident name) >> parser + in named +++ parser + +-------------------------------------------------------------------------------- + +-- | 'read' with implicit default value. +readDef :: (Read e, Default e) => String -> e +readDef = (def +?) . readMaybe + +-- | 'readBy' with implicit default value. +readDefBy :: (Default e) => ReadPrec e -> String -> e +readDefBy = (def +?) ... readMaybeBy + +-- | 'readBy' is generalized 'read'. +readBy :: ReadPrec e -> String -> e +readBy parser string = case readEitherBy parser string of + Left msg -> error msg + Right x -> x + +-- | 'readMaybeBy' is generalized 'readMaybe'. +readMaybeBy :: ReadPrec e -> String -> Maybe e +readMaybeBy parser string = case readPrec_to_S read' minPrec string of + [(x, "")] -> Just x + _ -> Nothing + where + read' = do x <- parser; lift skipSpaces; return x + +-- | 'readEitherBy' is generalized 'readEither'. +readEitherBy :: ReadPrec e -> String -> Either String e +readEitherBy parser string = case readPrec_to_S read' minPrec string of + [(x, "")] -> Right x + [] -> Left "SDP.Internal.Read.readBy: no parse" + _ -> Left "SDP.Internal.Read.readBy: ambiguous parse" + where + read' = do x <- parser; lift skipSpaces; return x + +-------------------------------------------------------------------------------- + +fromPrec_ :: (Read e, Enum e) => ReadPrec [e] +fromPrec_ = do + fr <- parens (step readPrec) + expectPrec (Punc "..") + return (enumFrom fr) + +fromToPrec_ :: (Read e, Enum e) => ReadPrec [e] +fromToPrec_ = do + fr <- parens (step readPrec) + expectPrec (Punc "..") + to <- parens (step readPrec) + return (enumFromTo fr to) + +fromThenPrec_ :: (Read e, Enum e) => ReadPrec [e] +fromThenPrec_ = do + fr <- parens (step readPrec) + expectPrec (Punc ",") + th <- parens (step readPrec) + expectPrec (Punc "..") + return (enumFromThen fr th) + +fromThenToPrec_ :: (Read e, Enum e) => ReadPrec [e] +fromThenToPrec_ = do + fr <- parens (step readPrec) + expectPrec (Punc ",") + th <- parens (step readPrec) + expectPrec (Punc "..") + to <- parens (step readPrec) + return (enumFromThenTo fr th to) + +parens' :: ReadPrec e -> ReadPrec e +parens' parser = do + expectPrec (Punc "[") + value <- parser + expectPrec (Punc "]") + return value + + + diff --git a/src/Text/Show/SDP.hs b/src/Text/Show/SDP.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/SDP.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE Safe #-} + +{- | + Module : Text.Show.SDP + Copyright : (c) Andrey Mulik 2019 + License : BSD-style + Maintainer : work.a.mulik@gmail.com + Portability : portable + + "Text.Show.SDP" provides common 'ShowS' stuff. +-} +module Text.Show.SDP +( + -- * Common show templates + assocsPrec, showsRaw, showsRawLinear +) +where + +import Prelude () +import SDP.SafePrelude +import SDP.Indexed + +import GHC.Show ( appPrec ) + +default () + +-------------------------------------------------------------------------------- + +-- | 'assocsPrec' is 'showsPrec' template. +assocsPrec :: (Indexed v i e, Show i, Show e) => String -> Int -> v -> ShowS +assocsPrec name = \ p es -> showParen (p > appPrec) $ showString name + . shows (bounds es) + . showChar ' ' + . shows (assocs es) + +{- | + 'showsRaw' is a primitive list-to-string conversion pattern. + + Note that attempting to parse the resulting string with standard @ReadS@-based + functions will cause an error (ambiguous parse). To properly parse a string, + use the @readRawSequence@ function from the "SDP.Text.Read" module. +-} +showsRaw :: (Show e) => Int -> [e] -> ShowS +showsRaw _ [] = id +showsRaw p (x : xs) = showParen (p > appPrec) stream + where + stream = shows x . foldr (\ e rest -> showChar ' ' . shows e . rest) id xs + +-- | Just 'showsRaw' version for 'Linear'. +showsRawLinear :: (Linear l e, Show e) => Int -> l -> ShowS +showsRawLinear p = showsRaw p . listL + + + +