{-# LANGUAGE Trustworthy, MagicHash, UnboxedTuples, BangPatterns, TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, RoleAnnotations #-}

{- |
    Module      :  SDP.Prim.SBytes
    Copyright   :  (c) Andrey Mulik 2019-2021
    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 (..) )

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
    isNull es = case es of {(SBytes# 0 _ _) -> True; _ -> False}
    lzero     = def

instance (Unboxed e) => Semigroup (SBytes# e) where (<>) = (++)
instance (Unboxed e) => Monoid    (SBytes# e) where mempty = Z; mappend = (<>)

instance Default (SBytes# e) where def = SBytes# 0 0 (unwrap lzero#)

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 = SBytes# 1 0 (single# e)
    
    xs@(SBytes# (I# n1#) (I# o1#) arr1#) ++ SBytes# (I# n2#) (I# o2#) arr2# =
      let n# = n1# +# n2# in runST $ ST $ \ s1# -> case pnewUnboxed xs n# s1# of
        (# 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
        writeBlock# (SBytes# c@(I# c#) (I# o#) arr#) i@(I# i#) = ST $
          \ s2# -> case pcopyUnboxed1 ess arr# o# marr# i# c# s2# of
            s3# -> (# s3#, i + c #)
      
      foldl (flip $ (=<<) . writeBlock#) (return 0) ess >> done marr
    
    reverse es = runST $ do es' <- fromIndexed' es; reversed' es'; done es'
    
    before es@(SBytes# c@(I# c#) (I# o#) arr#) n@(I# n#) e
      | n >= c = es :< e
      | n <= 0 = e :> es
      |  True  = runST $ ST $ \ s1# -> case newUnboxed' e (c# +# 1#) s1# of
        (# s2#, marr# #) -> case copyUnboxed# e arr# o# marr# 0# n# s2# of
          s3# -> case copyUnboxed# e arr# (o# +# n#) marr# (n# +# 1#) (c# -# n#) s3# of
            s4# -> case unsafeFreezeByteArray# marr# s4# of
              (# s5#, res# #) -> (# s5#, SBytes# (c + 1) 0 res# #)
    
    remove n@(I# n#) es@(SBytes# c@(I# c#) (I# o#) arr#) = n < 0 || n >= c ? es $
      runST $ ST $ \ s1# -> case pnewUnboxed es (c# -# 1#) s1# of
        (# s2#, marr# #) -> case pcopyUnboxed es arr# o# marr# 0# n# s2# of
          s3# -> case pcopyUnboxed es arr# (o# +# n# +# 1#) marr# n# (c# -# n# -# 1#) s3# of
            s4# -> case unsafeFreezeByteArray# marr# s4# of
              (# s5#, res# #) -> (# s5#, SBytes# (c - 1) 0 res# #)
    
    select  f = o_foldr (\ o es -> case f o of {Just e -> e : es; _ -> es}) []
    extract f =
      let g o = second (o :) `maybe` (first . (:)) $ f o
      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 es i e
      _      -> 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# -> (# pcopyUnboxed es arr# o# marr# 0# c# s1#, () #)
      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 = let !n@(I# n#) = max 0 c in ST $
      \ s1# -> case newLinearN# n# es s1# of
        (# s2#, marr# #) -> (# s2#, STBytes# n 0 marr# #)
    
    fromFoldableM es = ST $ \ s1# -> case fromFoldableM# es s1# of
      (# s2#, n, marr# #) -> (# s2#, STBytes# n 0 marr# #)
    
    getLeft  es@(STBytes# n _ _) = (es !#>) `mapM` [0 .. n - 1]
    getRight es@(STBytes# n _ _) = (es !#>) `mapM` [n - 1, n - 2 .. 0]
    
    {-# INLINE (!#>) #-}
    STBytes# _ (I# o#) marr# !#> I# i# = ST $ marr# !># (o# +# i#)
    
    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 = do es' <- copied es; reversed' es'; return es'
    
    reversed' es@(STBytes# n _ _) =
      let go i j = when (i < j) $ go (i + 1) (j - 1) >> swapM es i j
      in  go 0 (n - 1)
    
    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
    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@(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# #)

-- | 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# -> (# pcopyUnboxedM es marr# o# copy# 0# c# s1#, () #)
  return copy

{-# 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."