packages feed

sdp (empty) → 0.2

raw patch · 58 files changed

+10887/−0 lines, 58 filesdep +basedep +data-default-classdep +ghc-primsetup-changed

Dependencies added: base, data-default-class, ghc-prim

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sdp.cabal view
@@ -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+
+ src/Control/Concurent/SDP/TArray.hs view
@@ -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#+++
+ src/Control/Concurent/SDP/TUnlist.hs view
@@ -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#++
+ src/Control/Concurent/SDP/TUnrolled.hs view
@@ -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++
+ src/Control/Exception/SDP.hs view
@@ -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+++
+ src/SDP/Array.hs view
@@ -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#++
+ src/SDP/Array/IO.hs view
@@ -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#++++
+ src/SDP/Array/ST.hs view
@@ -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)++
+ src/SDP/ByteList.hs view
@@ -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++
+ src/SDP/ByteList/IO.hs view
@@ -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+
+ src/SDP/ByteList/IOUblist.hs view
@@ -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#+
+ src/SDP/ByteList/ST.hs view
@@ -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)++++
+ src/SDP/ByteList/STUblist.hs view
@@ -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)++++
+ src/SDP/ByteList/Ublist.hs view
@@ -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++++
+ src/SDP/Bytes.hs view
@@ -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#+++++
+ src/SDP/Bytes/IO.hs view
@@ -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#++
+ src/SDP/Bytes/ST.hs view
@@ -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)++
+ src/SDP/Comparing.hs view
@@ -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++
+ src/SDP/Estimate.hs view
@@ -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++
+ src/SDP/Finite.hs view
@@ -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"+
+ src/SDP/Index.hs view
@@ -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."+++
+ src/SDP/Indexed.hs view
@@ -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."++
+ src/SDP/IndexedM.hs view
@@ -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)++
+ src/SDP/Linear.hs view
@@ -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+++
+ src/SDP/LinearM.hs view
@@ -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+++++
+ src/SDP/Map.hs view
@@ -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."+++
+ src/SDP/MapM.hs view
@@ -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."+
+ src/SDP/Nullable.hs view
@@ -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)+
+ src/SDP/Prim/SArray.hs view
@@ -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."+
+ src/SDP/Prim/SBytes.hs view
@@ -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."+
+ src/SDP/Prim/TArray.hs view
@@ -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."+
+ src/SDP/Ratio.hs view
@@ -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 (:%) = (%)++++
+ src/SDP/SafePrelude.hs view
@@ -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++++
+ src/SDP/Scan.hs view
@@ -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+
+ src/SDP/Set.hs view
@@ -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++++
+ src/SDP/Shape.hs view
@@ -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+
+ src/SDP/Shaped.hs view
@@ -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+++
+ src/SDP/Sort.hs view
@@ -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+++
+ src/SDP/SortM.hs view
@@ -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+++
+ src/SDP/SortM/Insertion.hs view
@@ -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]+++
+ src/SDP/SortM/Tim.hs view
@@ -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++++
+ src/SDP/Templates/AnyBorder.hs view
@@ -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+
+ src/SDP/Templates/AnyChunks.hs view
@@ -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++
+ src/SDP/Tuple.hs view
@@ -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)+
+ src/SDP/Unboxed.hs view
@@ -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++
+ src/SDP/Unboxed/IntAs.hs view
@@ -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, () #)+
+ src/SDP/Unboxed/WordAs.hs view
@@ -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, () #)+
+ src/SDP/Unrolled.hs view
@@ -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++++
+ src/SDP/Unrolled/IO.hs view
@@ -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+++
+ src/SDP/Unrolled/IOUnlist.hs view
@@ -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#+++
+ src/SDP/Unrolled/ST.hs view
@@ -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)+
+ src/SDP/Unrolled/STUnlist.hs view
@@ -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)+
+ src/SDP/Unrolled/Unlist.hs view
@@ -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+
+ src/SDP/Zip.hs view
@@ -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 _ _ _ _ _ _ _ = []+++
+ src/Text/Read/SDP.hs view
@@ -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+++
+ src/Text/Show/SDP.hs view
@@ -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++++