Initial commit

.gitignore

@@ -0,0 +1,3 @@
+cabal.project.local
+dist-newstyle/
+*.sw?

COPYING

@@ -0,0 +1,15 @@
+Stellar Veritas is released under the terms of GNU AFFERO GENERAL PUBLIC LICENSE Version 3.
+
+Following bundled libraries are released under their corresponding licenses as published on Hackage:
+base32
+base64-bytestring
+cereal
+ed25519
+scientific
+stellar-sdk
+stellar-horizon
+SHA
+integer-logarithms
+cryptonite
+memory
+basement

README.md

@@ -0,0 +1,7 @@
+# Stellar Veritas
+
+The aim is to create a trustworthy Stellar transaction signer (and, by necessity, a pretty printer) using only Glasgow Haskell compiler code and Haskell Core libraries, reducing the possible supply chain attack surface.
+
+To build and run it, install `cabal-install` and use `cabal run`.
+
+The project contains the code of trimmed-down non-core dependencies, mainly cryptographic libraries. To avoid using bundled libraries (to build against the current Hackage), do the same in the `src` directory. To further reduce the amount of code under audit, weeder can be used, although the utility is dubious.

bundled/Basement/Alg/Class.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+
+module Basement.Alg.Class
+    ( Indexable, index
+    , RandomAccess, read, write
+    ) where
+
+import           Basement.Types.OffsetSize
+
+class Indexable container ty where
+    index :: container -> (Offset ty) -> ty
+
+class RandomAccess container prim ty where
+    read  :: container -> (Offset ty)       -> prim ty
+    write :: container -> (Offset ty) -> ty -> prim ()

bundled/Basement/Alg/Mutable.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Basement.Alg.Mutable
+    ( inplaceSortBy
+    ) where
+
+import           GHC.Types
+import           GHC.Prim
+import           Basement.Compat.Base
+import           Basement.Numerical.Additive
+import           Basement.Numerical.Multiplicative
+import           Basement.Types.OffsetSize
+import           Basement.PrimType
+import           Basement.Monad
+import           Basement.Alg.Class
+
+inplaceSortBy :: (PrimMonad prim, RandomAccess container prim ty) 
+              => (ty -> ty -> Ordering)
+              -- ^ Function defining the ordering relationship
+              -> (Offset ty) -- ^ Offset to first element to sort
+              -> (CountOf ty) -- ^ Number of elements to sort
+              -> container -- ^ Data to be sorted
+              -> prim ()
+inplaceSortBy ford start len mvec
+    = qsort start (start `offsetPlusE` len `offsetSub` 1)
+    where
+        qsort lo hi
+            | lo >= hi  = pure ()
+            | otherwise = do
+                p <- partition lo hi
+                qsort lo (pred p)
+                qsort (p+1) hi
+        pivotStrategy (Offset low) hi@(Offset high) = do
+            let mid = Offset $ (low + high) `div` 2
+            pivot <- read mvec mid
+            read mvec hi >>= write mvec mid
+            write mvec hi pivot -- move pivot @ pivotpos := hi
+            pure pivot
+        partition lo hi = do
+            pivot <- pivotStrategy lo hi
+            -- RETURN: index of pivot with [<pivot | pivot | >=pivot]
+            -- INVARIANT: i & j are valid array indices; pivotpos==hi
+            let go i j = do
+                    -- INVARIANT: k <= pivotpos
+                    let fw k = do ak <- read mvec k
+                                  if ford ak pivot == LT 
+                                    then fw (k+1)
+                                    else pure (k, ak)
+                    (i, ai) <- fw i -- POST: ai >= pivot
+                    -- INVARIANT: k >= i
+                    let bw k | k==i = pure (i, ai)
+                             | otherwise = do ak <- read mvec k
+                                              if ford ak pivot /= LT
+                                                then bw (pred k)
+                                                else pure (k, ak)
+                    (j, aj) <- bw j -- POST: i==j OR (aj<pivot AND j<pivotpos)
+                    -- POST: ai>=pivot AND (i==j OR aj<pivot AND (j<pivotpos))
+                    if i < j
+                        then do -- (ai>=p AND aj<p) AND (i<j<pivotpos)
+                            -- swap two non-pivot elements and proceed
+                            write mvec i aj
+                            write mvec j ai
+                            -- POST: (ai < pivot <= aj)
+                            go (i+1) (pred j)
+                        else do -- ai >= pivot 
+                            -- complete partitioning by swapping pivot to the center
+                            write mvec hi ai 
+                            write mvec i pivot
+                            pure i
+            go lo hi
+{-# INLINE inplaceSortBy #-}

bundled/Basement/Alg/PrimArray.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE MagicHash                  #-}
+module Basement.Alg.PrimArray
+    ( Indexable, index
+    , findIndexElem
+    , revFindIndexElem
+    , findIndexPredicate
+    , revFindIndexPredicate
+    , foldl
+    , foldr
+    , foldl1
+    , all
+    , any
+    , filter
+    ) where
+
+import           GHC.Types
+import           GHC.Prim
+import           Basement.Alg.Class
+import           Basement.Compat.Base
+import           Basement.Numerical.Additive
+import           Basement.Numerical.Multiplicative
+import           Basement.Types.OffsetSize
+import           Basement.PrimType
+import           Basement.Monad
+
+findIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty
+findIndexElem ty ba startIndex endIndex = loop startIndex
+  where
+    loop !i
+        | i >= endIndex    = sentinel
+        | index ba i == ty = i
+        | otherwise        = loop (i+1)
+{-# INLINE findIndexElem #-}
+
+revFindIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty
+revFindIndexElem ty ba startIndex endIndex = loop endIndex
+  where
+    loop !iplus1
+        | iplus1 <= startIndex = sentinel
+        | index ba i == ty     = i
+        | otherwise            = loop i
+      where !i = iplus1 `offsetMinusE` 1
+{-# INLINE revFindIndexElem #-}
+
+findIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty
+findIndexPredicate predicate ba startIndex endIndex = loop startIndex
+  where
+    loop !i
+        | i >= endIndex          = sentinel
+        | predicate (index ba i) = i
+        | otherwise              = loop (i+1)
+{-# INLINE findIndexPredicate #-}
+
+revFindIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty
+revFindIndexPredicate predicate ba startIndex endIndex = loop endIndex
+  where
+    loop !iplus1
+        | iplus1 <= startIndex   = sentinel
+        | predicate (index ba i) = i
+        | otherwise              = loop i
+      where !i = iplus1 `offsetMinusE` 1
+{-# INLINE revFindIndexPredicate #-}
+
+foldl :: Indexable container ty => (a -> ty -> a) -> a -> container -> Offset ty -> Offset ty -> a
+foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc
+  where
+    loop !i !acc
+        | i == endIndex = acc
+        | otherwise     = loop (i+1) (f acc (index ba i))
+{-# INLINE foldl #-}
+
+foldr :: Indexable container ty => (ty -> a -> a) -> a -> container -> Offset ty -> Offset ty -> a
+foldr f !initialAcc ba startIndex endIndex = loop startIndex
+  where
+    loop !i
+        | i == endIndex = initialAcc
+        | otherwise     = index ba i `f` loop (i+1)
+{-# INLINE foldr #-}
+
+foldl1 :: Indexable container ty => (ty -> ty -> ty) -> container -> Offset ty -> Offset ty -> ty
+foldl1 f ba startIndex endIndex = loop (startIndex+1) (index ba startIndex)
+  where
+    loop !i !acc
+        | i == endIndex = acc
+        | otherwise     = loop (i+1) (f acc (index ba i))
+{-# INLINE foldl1 #-}
+
+filter :: (PrimMonad prim, PrimType ty, Indexable container ty)
+       => (ty -> Bool) -> MutableByteArray# (PrimState prim) 
+       -> container -> Offset ty -> Offset ty -> prim (CountOf ty)
+filter predicate dst src start end = loop azero start
+  where
+    loop !d !s
+        | s == end    = pure (offsetAsSize d)
+        | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)
+        | otherwise   = loop d (s+Offset 1)
+      where
+        v = index src s
+{-# INLINE filter #-}
+
+all :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Bool
+all predicate ba start end = loop start
+  where
+    loop !i
+        | i == end               = True
+        | predicate (index ba i) = loop (i+1)
+        | otherwise              = False
+{-# INLINE all #-}
+
+any :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Bool
+any predicate ba start end = loop start
+  where
+    loop !i
+        | i == end               = False
+        | predicate (index ba i) = True
+        | otherwise              = loop (i+1)
+{-# INLINE any #-}

bundled/Basement/Alg/String.hs

@@ -0,0 +1,140 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE CPP                        #-}
+module Basement.Alg.String
+    ( copyFilter
+    , validate
+    , findIndexPredicate
+    , revFindIndexPredicate
+    ) where
+
+import           GHC.Prim
+import           GHC.ST
+import           Basement.Alg.Class
+import           Basement.Alg.UTF8
+import           Basement.Compat.Base
+import           Basement.Numerical.Additive
+import           Basement.Types.OffsetSize
+import           Basement.PrimType
+import           Basement.Block (MutableBlock(..))
+
+import           Basement.UTF8.Helper
+import           Basement.UTF8.Table
+import           Basement.UTF8.Types
+
+copyFilter :: forall s container . Indexable container Word8
+           => (Char -> Bool)
+           -> CountOf Word8
+           -> MutableByteArray# s
+           -> container
+           -> Offset Word8
+           -> ST s (CountOf Word8)
+copyFilter predicate !sz dst src start = loop (Offset 0) start
+  where
+    !end = start `offsetPlusE` sz
+    loop !d !s
+        | s == end  = pure (offsetAsSize d)
+        | otherwise =
+            let !h = nextAscii src s
+             in case headerIsAscii h of
+                    True | predicate (toChar1 h) -> primMbaWrite dst d (stepAsciiRawValue h) >> loop (d + Offset 1) (s + Offset 1)
+                         | otherwise             -> loop d (s + Offset 1)
+                    False ->
+                        case next src s of
+                            Step c s' | predicate c -> writeUTF8 (MutableBlock dst :: MutableBlock Word8 s) d c >>= \d' -> loop d' s'
+                                      | otherwise   -> loop d s'
+{-# INLINE copyFilter #-}
+
+validate :: Indexable container Word8
+         => Offset Word8
+         -> container
+         -> Offset Word8
+         -> (Offset Word8, Maybe ValidationFailure)
+validate end ba ofsStart = loop4 ofsStart
+  where
+    loop4 !ofs
+        | ofs4 < end =
+            let h1 = nextAscii ba ofs
+                h2 = nextAscii ba (ofs+1)
+                h3 = nextAscii ba (ofs+2)
+                h4 = nextAscii ba (ofs+3)
+             in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4
+                    then loop4 ofs4
+                    else loop ofs
+        | otherwise     = loop ofs
+      where
+        !ofs4 = ofs+4
+    loop !ofs
+        | ofs == end      = (end, Nothing)
+        | headerIsAscii h = loop (ofs + Offset 1)
+        | otherwise       = multi (CountOf $ getNbBytes h) ofs
+      where
+        h = nextAscii ba ofs
+
+    multi (CountOf 0xff) pos = (pos, Just InvalidHeader)
+    multi nbConts pos
+        | (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte)
+        | otherwise =
+            case nbConts of
+                CountOf 1 ->
+                    let c1 = index ba posNext
+                    in if isContinuation c1
+                        then loop (pos + Offset 2)
+                        else (pos, Just InvalidContinuation)
+                CountOf 2 ->
+                    let c1 = index ba posNext
+                        c2 = index ba (pos + Offset 2)
+                     in if isContinuation2 c1 c2
+                            then loop (pos + Offset 3)
+                            else (pos, Just InvalidContinuation)
+                CountOf _ ->
+                    let c1 = index ba posNext
+                        c2 = index ba (pos + Offset 2)
+                        c3 = index ba (pos + Offset 3)
+                     in if isContinuation3 c1 c2 c3
+                            then loop (pos + Offset 4)
+                            else (pos, Just InvalidContinuation)
+      where posNext = pos + Offset 1
+{-# INLINE validate #-}
+
+findIndexPredicate :: Indexable container Word8
+                   => (Char -> Bool)
+                   -> container
+                   -> Offset Word8
+                   -> Offset Word8
+                   -> Offset Word8
+findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex
+  where
+    loop !i
+        | i < endIndex && not (predicate c) = loop (i')
+        | otherwise                         = i
+      where
+        Step c i' = next ba i
+{-# INLINE findIndexPredicate #-}
+
+revFindIndexPredicate :: Indexable container Word8
+                      => (Char -> Bool)
+                      -> container
+                      -> Offset Word8
+                      -> Offset Word8
+                      -> Offset Word8
+revFindIndexPredicate predicate ba startIndex endIndex
+    | endIndex > startIndex = loop endIndex
+    | otherwise             = endIndex
+  where
+    loop !i
+        | predicate c     = i'
+        | i' > startIndex = loop i'
+        | otherwise       = endIndex
+      where 
+        StepBack c i' = prev ba i
+{-# INLINE revFindIndexPredicate #-}

bundled/Basement/Alg/UTF8.hs

@@ -0,0 +1,298 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE CPP                        #-}
+module Basement.Alg.UTF8
+    ( nextAscii
+    , nextAsciiDigit
+    , expectAscii
+    , next
+    , nextSkip
+    , nextWith
+    , prev
+    , prevSkip
+    , writeASCII
+    , writeUTF8
+    , toList
+    , all
+    , any
+    , foldr
+    , length
+    , reverse
+    ) where
+
+import           GHC.Types
+import           GHC.Word
+import           GHC.Prim
+import           Data.Bits
+import           Data.Proxy
+import           Basement.Alg.Class
+import           Basement.Compat.Base hiding (toList)
+import           Basement.Compat.Primitive
+import           Basement.Monad
+import           Basement.Numerical.Additive
+import           Basement.Numerical.Subtractive
+import           Basement.Types.OffsetSize
+import           Basement.Types.Char7 (Char7(..))
+import           Basement.IntegralConv
+import           Basement.PrimType
+import           Basement.UTF8.Helper
+import           Basement.UTF8.Table
+import           Basement.UTF8.Types
+
+nextAscii :: Indexable container Word8 => container -> Offset Word8 -> StepASCII
+nextAscii ba n = StepASCII w
+  where
+    !w = index ba n
+{-# INLINE nextAscii #-}
+
+-- | nextAsciiBa specialized to get a digit between 0 and 9 (included)
+nextAsciiDigit :: Indexable container Word8 => container -> Offset Word8 -> StepDigit
+nextAsciiDigit ba n = StepDigit (index ba n - 0x30)
+{-# INLINE nextAsciiDigit #-}
+
+expectAscii :: Indexable container Word8 => container -> Offset Word8 -> Word8 -> Bool
+expectAscii ba n v = index ba n == v
+{-# INLINE expectAscii #-}
+
+next :: Indexable container Word8 => container -> Offset8 -> Step
+next ba n =
+    case getNbBytes h of
+        0 -> Step (toChar1 h) (n + Offset 1)
+        1 -> Step (toChar2 h (index ba (n + Offset 1))) (n + Offset 2)
+        2 -> Step (toChar3 h (index ba (n + Offset 1))
+                             (index ba (n + Offset 2))) (n + Offset 3)
+        3 -> Step (toChar4 h (index ba (n + Offset 1))
+                             (index ba (n + Offset 2))
+                             (index ba (n + Offset 3))) (n + Offset 4)
+        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show (stepAsciiRawValue h))
+  where
+    !h = nextAscii ba n
+{-# INLINE next #-}
+
+nextSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8
+nextSkip ba n = n + 1 + Offset (getNbBytes (nextAscii ba n))
+{-# INLINE nextSkip #-}
+
+-- | special case for only non ascii next'er function
+nextWith :: Indexable container Word8
+         => StepASCII
+         -> container
+         -> Offset8
+         -> Step
+nextWith h ba n =
+    case getNbBytes h of
+        1 -> Step (toChar2 h (index ba n)) (n + Offset 1)
+        2 -> Step (toChar3 h (index ba n) (index ba (n + Offset 1))) (n + Offset 2)
+        3 -> Step (toChar4 h (index ba n)
+                             (index ba (n + Offset 1))
+                             (index ba (n + Offset 2))) (n + Offset 3)
+        r -> error ("nextWith: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show (stepAsciiRawValue h))
+{-# INLINE nextWith #-}
+
+-- Given a non null offset, give the previous character and the offset of this character
+-- will fail bad if apply at the beginning of string or an empty string.
+prev :: Indexable container Word8 => container -> Offset Word8 -> StepBack
+prev ba offset =
+    case integralUpsize $ index ba prevOfs1 of
+        (W# v1) | isContinuationW# v1 -> atLeast2 (maskContinuation# v1)
+                | otherwise           -> StepBack (toChar# v1) prevOfs1
+  where
+    sz1 = CountOf 1
+    !prevOfs1 = offset `offsetMinusE` sz1
+    prevOfs2 = prevOfs1 `offsetMinusE` sz1
+    prevOfs3 = prevOfs2 `offsetMinusE` sz1
+    prevOfs4 = prevOfs3 `offsetMinusE` sz1
+    atLeast2 !v  =
+        case integralUpsize $ index ba prevOfs2 of
+            (W# v2) | isContinuationW# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)
+                    | otherwise          -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2
+    atLeast3 !v =
+        case integralUpsize $ index ba prevOfs3 of
+            (W# v3) | isContinuationW# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)
+                    | otherwise           -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3
+    atLeast4 !v =
+        case integralUpsize $ index ba prevOfs4 of
+            (W# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4
+
+prevSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8
+prevSkip ba offset = loop (offset `offsetMinusE` sz1)
+  where
+    sz1 = CountOf 1
+    loop o
+        | isContinuation (index ba o) = loop (o `offsetMinusE` sz1)
+        | otherwise                       = o
+
+writeASCII :: (PrimMonad prim, RandomAccess container prim Word8)
+           => container -> Offset8 -> Char7 -> prim ()
+writeASCII mba !i (Char7 c) = write mba i c
+{-# INLINE writeASCII #-}
+
+writeUTF8 :: (PrimMonad prim, RandomAccess container prim Word8)
+          => container -> Offset8 -> Char -> prim Offset8
+writeUTF8 mba !i !c
+    | bool# (ltWord# x 0x80##   ) = encode1
+    | bool# (ltWord# x 0x800##  ) = encode2
+    | bool# (ltWord# x 0x10000##) = encode3
+    | otherwise                   = encode4
+  where
+    !(I# xi) = fromEnum c
+    !x       = int2Word# xi
+
+    encode1 = write mba i (W8# (wordToWord8# x)) >> pure (i + Offset 1)
+    encode2 = do
+        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##
+            x2  = toContinuation x
+        write mba i     (W8# (wordToWord8# x1))
+        write mba (i+1) (W8# (wordToWord8# x2))
+        pure (i + Offset 2)
+
+    encode3 = do
+        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##
+            x2  = toContinuation (uncheckedShiftRL# x 6#)
+            x3  = toContinuation x
+        write mba i            (W8# (wordToWord8# x1))
+        write mba (i+Offset 1) (W8# (wordToWord8# x2))
+        write mba (i+Offset 2) (W8# (wordToWord8# x3))
+        pure (i + Offset 3)
+
+    encode4 = do
+        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##
+            x2  = toContinuation (uncheckedShiftRL# x 12#)
+            x3  = toContinuation (uncheckedShiftRL# x 6#)
+            x4  = toContinuation x
+        write mba i            (W8# (wordToWord8# x1))
+        write mba (i+Offset 1) (W8# (wordToWord8# x2))
+        write mba (i+Offset 2) (W8# (wordToWord8# x3))
+        write mba (i+Offset 3) (W8# (wordToWord8# x4))
+        pure (i + Offset 4)
+
+    toContinuation :: Word# -> Word#
+    toContinuation w = or# (and# w 0x3f##) 0x80##
+{-# INLINE writeUTF8 #-}
+
+toList :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8 -> [Char]
+toList ba !start !end = loop start
+  where
+    loop !idx
+        | idx == end = []
+        | otherwise  = c : loop idx'
+      where (Step c idx') = next ba idx
+
+all :: Indexable container Word8
+    => (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool
+all predicate ba start end = loop start
+  where
+    loop !idx
+        | idx == end  = True
+        | predicate c = loop idx'
+        | otherwise   = False
+      where (Step c idx') = next ba idx
+{-# INLINE all #-}
+
+any :: Indexable container Word8
+    => (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool
+any predicate ba start end = loop start
+  where
+    loop !idx
+        | idx == end  = False
+        | predicate c = True
+        | otherwise   = loop idx'
+      where (Step c idx') = next ba idx
+{-# INLINE any #-}
+
+foldr :: Indexable container Word8
+      => container -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a
+foldr dat start end f acc = loop start
+  where
+    loop !i
+        | i == end  = acc
+        | otherwise =
+            let (Step c i') = next dat i
+             in c `f` loop i'
+{-# INLINE foldr #-}
+
+length :: (Indexable container Word8, Indexable container Word64)
+       => container -> Offset Word8 -> Offset Word8 -> CountOf Char
+length dat start end
+    | start == end = 0
+    | otherwise    = processStart 0 start
+  where
+    end64 :: Offset Word64
+    end64 = offsetInElements end
+
+    prx64 :: Proxy Word64
+    prx64 = Proxy
+
+    mask64_80 :: Word64
+    mask64_80 = 0x8080808080808080
+
+    processStart :: CountOf Char -> Offset Word8 -> CountOf Char
+    processStart !c !i
+        | i == end                = c
+        | offsetIsAligned prx64 i = processAligned c (offsetInElements i)
+        | otherwise               =
+            let h    = index dat i
+                cont = (h .&. 0xc0) == 0x80
+                c'   = if cont then c else c+1
+             in processStart c' (i+1)
+    processAligned :: CountOf Char -> Offset Word64 -> CountOf Char
+    processAligned !c !i
+        | i >= end64 = processEnd c (offsetInBytes i)
+        | otherwise  =
+            let !h   = index dat i -- Word64
+                !h80 = h .&. mask64_80
+             in if h80 == 0
+                 then processAligned (c+8) (i+1)
+                 else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80)
+                          !nbHigh  = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1))
+                       in processAligned (c + nbAscii + nbHigh) (i+1)
+    processEnd !c !i
+        | i == end  = c
+        | otherwise =
+            let h    = index dat i
+                cont = (h .&. 0xc0) == 0x80
+                c'   = if cont then c else c+1
+             in processStart c' (i+1)
+{-# INLINE length #-}
+
+reverse :: (PrimMonad prim, Indexable container Word8)
+        => MutableByteArray# (PrimState prim) -- ^ Destination buffer
+        -> Offset Word8                       -- ^ Destination start
+        -> container                          -- ^ Source buffer
+        -> Offset Word8                       -- ^ Source start
+        -> Offset Word8                       -- ^ Source end
+        -> prim ()
+reverse dst dstOfs src start end
+    | start == end = pure ()
+    | otherwise    = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start
+  where
+    loop !d !s
+        | s == end        = pure ()
+        | headerIsAscii h = primMbaWrite dst d (stepAsciiRawValue h) >> loop (d `offsetSub` 1) (s + 1)
+        | otherwise       = do
+            case getNbBytes h of
+                1 -> do
+                    primMbaWrite dst (d `offsetSub` 1) (stepAsciiRawValue h)
+                    primMbaWrite dst d                 (index src (s + 1))
+                    loop (d `offsetSub` 2) (s + 2)
+                2 -> do
+                    primMbaWrite dst (d `offsetSub` 2) (stepAsciiRawValue h)
+                    primMbaWrite dst (d `offsetSub` 1) (index src (s + 1))
+                    primMbaWrite dst d                 (index src (s + 2))
+                    loop (d `offsetSub` 3) (s + 3)
+                3 -> do
+                    primMbaWrite dst (d `offsetSub` 3) (stepAsciiRawValue h)
+                    primMbaWrite dst (d `offsetSub` 2) (index src (s + 1))
+                    primMbaWrite dst (d `offsetSub` 1) (index src (s + 2))
+                    primMbaWrite dst d                 (index src (s + 3))
+                    loop (d `offsetSub` 4) (s + 4)
+                _ -> error "impossible"
+      where h = nextAscii src s
+{-# INLINE reverse #-}

bundled/Basement/Alg/XorShift.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Foundation.Random.XorShift
+-- License     : BSD-style
+--
+-- XorShift variant: Xoroshiro128+
+-- <https://en.wikipedia.org/wiki/Xoroshiro128%2B>
+--
+-- Xoroshiro128+ is a PRNG that uses a shift/rotate-based linear transformation.
+-- This is lar
+--
+-- C implementation at:
+-- <http://xoroshiro.di.unimi.it/xoroshiro128plus.c>
+--
+module Basement.Alg.XorShift
+    ( State(..)
+    , next
+    , nextDouble
+    , jump
+    ) where
+
+import           Data.Word
+import           Data.Bits
+import           Basement.Compat.Base
+import           Basement.Floating (wordToDouble)
+import           Basement.Numerical.Additive
+import           Basement.Numerical.Subtractive
+
+-- | State of Xoroshiro128 plus
+data State = State {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
+
+-- | Given a state, call the function 'f' with the generated Word64 and the next State
+next :: State -> (Word64 -> State -> a) -> a
+next (State s0 s1prev) f = f ran stNext
+  where
+    !stNext = State s0' s1'
+    !ran    = s0 + s1prev
+    !s1     = s0 `xor` s1prev
+    s0'     = (s0 `rotateL` 55) `xor` s1 `xor` (s1 `unsafeShiftL` 14)
+    s1'     = (s1 `rotateL` 36)
+
+-- | Same as 'next' but give a random value of type Double in the range of [0.0 .. 1.0]
+nextDouble :: State -> (Double -> State -> a) -> a
+nextDouble st f = next st $ \w -> f (toDouble w)
+  where
+    -- generate a number in the interval [1..2[ by bit manipulation.
+    -- this generate double with a ~2^52
+    toDouble w = wordToDouble (upperMask .|. (w .&. lowerMask)) - 1.0
+      where
+        upperMask = 0x3FF0000000000000
+        lowerMask = 0x000FFFFFFFFFFFFF
+
+-- | Jump the state by 2^64 calls of next
+jump :: State -> State
+jump (State s0 s1) = withK 0xd86b048b86aa9922
+                   $ withK 0xbeac0467eba5facb
+                   $ (State 0 0)
+  where
+    withK :: Word64 -> State -> State
+    withK !k = loop 0
+      where
+        loop !i st@(State c0 c1)
+            | i == 64     = st
+            | testBit k i = loop (i+1) (State (c0 `xor` s0) (c1 `xor` s1))
+            | otherwise   = st

bundled/Basement/Base16.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash     #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns  #-}
+module Basement.Base16
+    ( unsafeConvertByte
+    , hexWord16
+    , hexWord32
+    , escapeByte
+    , Base16Escape(..)
+    ) where
+
+import GHC.Prim (Addr#, indexWord8OffAddr#, word2Int#, chr#)
+import GHC.Types
+import GHC.Word
+import Basement.Types.Char7
+import Basement.Compat.Primitive
+
+data Base16Escape = Base16Escape {-# UNPACK #-} !Char7 {-# UNPACK #-} !Char7
+
+-- | Convert a byte value in Word# to two Word#s containing
+-- the hexadecimal representation of the Word#
+--
+-- The output words# are guaranteed to be included in the 0 to 2^7-1 range
+--
+-- Note that calling convertByte with a value greater than 256
+-- will cause segfault or other horrible effect. From GHC9.2, Word8#
+-- cannot be >= 256.
+unsafeConvertByte :: Word8# -> (# Word8#, Word8# #)
+unsafeConvertByte b = (# r tableHi b, r tableLo b #)
+  where
+    r :: Table -> Word8# -> Word8#
+    r (Table !table) index = indexWord8OffAddr# table (word2Int# (word8ToWord# index))
+{-# INLINE unsafeConvertByte #-}
+
+escapeByte :: Word8 -> Base16Escape
+escapeByte !(W8# b) = Base16Escape (r tableHi b) (r tableLo b)
+  where
+    r :: Table -> Word8# -> Char7
+    r (Table !table) index = Char7 (W8# (indexWord8OffAddr# table (word2Int# (word8ToWord# index))))
+{-# INLINE escapeByte #-}
+
+-- | hex word16
+hexWord16 :: Word16 -> (Char, Char, Char, Char)
+hexWord16 (W16# w) = (toChar w1,toChar w2,toChar w3,toChar w4)
+  where
+    toChar :: Word8# -> Char
+    toChar c = C# (chr# (word2Int# (word8ToWord# c)))
+    !(# w1, w2 #) = unsafeConvertByte (word16ToWord8# (uncheckedShiftRLWord16# w 8#))
+    !(# w3, w4 #) = unsafeConvertByte (word16ToWord8# w)
+
+-- | hex word32
+hexWord32 :: Word32 -> (Char, Char, Char, Char, Char, Char, Char, Char)
+hexWord32 (W32# w) = (toChar w1,toChar w2,toChar w3,toChar w4
+                     ,toChar w5,toChar w6,toChar w7,toChar w8)
+  where
+    toChar :: Word8# -> Char
+    toChar c = C# (chr# (word2Int# (word8ToWord# c)))
+    !(# w1, w2 #) = unsafeConvertByte (word32ToWord8# (uncheckedShiftRLWord32# w 24#))
+    !(# w3, w4 #) = unsafeConvertByte (word32ToWord8# (uncheckedShiftRLWord32# w 16#))
+    !(# w5, w6 #) = unsafeConvertByte (word32ToWord8# (uncheckedShiftRLWord32# w 8#))
+    !(# w7, w8 #) = unsafeConvertByte (word32ToWord8# w)
+
+data Table = Table Addr#
+
+tableLo:: Table
+tableLo = Table
+    "0123456789abcdef0123456789abcdef\
+    \0123456789abcdef0123456789abcdef\
+    \0123456789abcdef0123456789abcdef\
+    \0123456789abcdef0123456789abcdef\
+    \0123456789abcdef0123456789abcdef\
+    \0123456789abcdef0123456789abcdef\
+    \0123456789abcdef0123456789abcdef\
+    \0123456789abcdef0123456789abcdef"#
+
+tableHi :: Table
+tableHi = Table
+    "00000000000000001111111111111111\
+    \22222222222222223333333333333333\
+    \44444444444444445555555555555555\
+    \66666666666666667777777777777777\
+    \88888888888888889999999999999999\
+    \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\
+    \ccccccccccccccccdddddddddddddddd\
+    \eeeeeeeeeeeeeeeeffffffffffffffff"#

bundled/Basement/Bindings/Memory.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+module Basement.Bindings.Memory
+    where
+
+import GHC.IO
+import GHC.Prim
+import GHC.Word
+import Basement.Compat.C.Types
+import Foreign.Ptr
+import Basement.Types.OffsetSize
+
+foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaBa ::
+    ByteArray# -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt
+
+foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaPtr ::
+    ByteArray# -> Offset Word8 -> Ptr a -> Offset Word8 -> CountOf Word8 -> IO CInt
+
+foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrBa ::
+    Ptr a -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt
+
+foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrPtr ::
+    Ptr a -> Offset Word8 -> Ptr b -> Offset Word8 -> CountOf Word8 -> IO CInt
+
+foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteBa ::
+    ByteArray# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8
+
+foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteAddr ::
+    Addr# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8

bundled/Basement/Bits.hs

@@ -0,0 +1,478 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Bits
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+-- Stability   : experimental
+-- Portability : portable
+--
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE NegativeLiterals #-}
+
+#include "MachDeps.h"
+
+module Basement.Bits
+    ( BitOps(..)
+    , FiniteBitsOps(..)
+    , Bits
+    , toBits
+    , allOne
+    ) where
+
+import Basement.Compat.Base
+import Basement.Compat.Natural
+import Basement.Numerical.Additive
+import Basement.Numerical.Subtractive
+import Basement.Numerical.Multiplicative
+import Basement.Types.OffsetSize
+import Basement.Types.Word128 (Word128)
+import qualified Basement.Types.Word128 as Word128
+import Basement.Types.Word256 (Word256)
+import qualified Basement.Types.Word256 as Word256
+import Basement.IntegralConv (wordToInt)
+import Basement.Nat
+
+import qualified Prelude
+import qualified Data.Bits as OldBits
+import Data.Maybe (fromMaybe)
+import Data.Proxy
+import GHC.Base hiding ((.))
+import GHC.Prim
+import GHC.Types
+import GHC.Word
+import GHC.Int
+import Basement.Compat.Primitive
+
+#if WORD_SIZE_IN_BITS < 64
+import GHC.IntWord64
+#endif
+
+-- | operation over finite bits
+class FiniteBitsOps bits where
+    -- | get the number of bits in the given object
+    --
+    numberOfBits :: bits -> CountOf Bool
+
+    -- | rotate the given bit set.
+    rotateL :: bits -> CountOf Bool -> bits
+    -- | rotate the given bit set.
+    rotateR :: bits -> CountOf Bool -> bits
+
+    -- | count of number of bit set to 1 in the given bit set.
+    popCount :: bits -> CountOf Bool
+
+    -- | reverse all bits in the argument
+    bitFlip   :: bits -> bits
+
+    -- | count of the number of leading zeros
+    countLeadingZeros :: bits -> CountOf Bool
+    default countLeadingZeros :: BitOps bits => bits -> CountOf Bool
+    countLeadingZeros n = loop stop azero
+      where
+        stop = numberOfBits n
+        loop idx count
+            | idx == azero = count
+            | isBitSet n (sizeAsOffset idx) = count
+            | otherwise = loop (fromMaybe azero (idx - 1)) (count + 1)
+
+    -- | count of the number of trailing zeros
+    countTrailingZeros :: bits -> CountOf Bool
+    default countTrailingZeros :: BitOps bits => bits -> CountOf Bool
+    countTrailingZeros n = loop azero
+      where
+        stop = numberOfBits n
+        loop count
+            | count == stop = count
+            | isBitSet n (sizeAsOffset count) = count
+            | otherwise = loop (count + 1)
+
+-- | operation over bits
+class BitOps bits where
+    (.&.)     :: bits -> bits -> bits
+    (.|.)     :: bits -> bits -> bits
+    (.^.)     :: bits -> bits -> bits
+    (.<<.)    :: bits -> CountOf Bool -> bits
+    (.>>.)    :: bits -> CountOf Bool -> bits
+    -- | construct a bit set with the bit at the given index set.
+    bit       :: Offset Bool -> bits
+    default bit :: Integral bits => Offset Bool -> bits
+    bit n = 1 .<<. (offsetAsSize n)
+
+    -- | test the bit at the given index is set
+    isBitSet  :: bits -> Offset Bool -> Bool
+    default isBitSet :: (Integral bits, Eq bits) => bits -> Offset Bool -> Bool
+    isBitSet x n = x .&. (bit n) /= 0
+
+    -- | set the bit at the given index
+    setBit    :: bits -> Offset Bool -> bits
+    default setBit :: Integral bits => bits -> Offset Bool -> bits
+    setBit x n = x .|. (bit n)
+
+    -- | clear the bit at the given index
+    clearBit  :: bits -> Offset Bool -> bits
+    default clearBit :: FiniteBitsOps bits => bits -> Offset Bool -> bits
+    clearBit x n = x .&. (bitFlip (bit n))
+
+infixl 8 .<<., .>>., `rotateL`, `rotateR`
+infixl 7 .&.
+infixl 6 .^.
+infixl 5 .|.
+
+-- | Bool set of 'n' bits.
+--
+newtype Bits (n :: Nat) = Bits { bitsToNatural :: Natural }
+  deriving (Show, Eq, Ord, Typeable)
+
+-- | convenient Type Constraint Alias fot 'Bits' functions
+type SizeValid n = (KnownNat n, 1 <= n)
+
+-- convert an 'Int' into a 'Natural'.
+-- This functions is not meant to be exported
+lift :: Int -> Natural
+lift = Prelude.fromIntegral
+{-# INLINABLE lift #-}
+
+-- | convert the given 'Natural' into a 'Bits' of size 'n'
+--
+-- if bits that are not within the boundaries of the 'Bits n' will be truncated.
+toBits :: SizeValid n => Natural -> Bits n
+toBits nat = Bits nat .&. allOne
+
+-- | construct a 'Bits' with all bits set.
+--
+-- this function is equivalet to 'maxBound'
+allOne :: forall n . SizeValid n => Bits n
+allOne = Bits (2 Prelude.^ n Prelude.- midentity)
+  where
+    n = natVal (Proxy @n)
+
+instance SizeValid n => Enum (Bits n) where
+    toEnum i | i < 0 && lift i > bitsToNatural maxi = error "Bits n not within bound"
+             | otherwise                            = Bits (lift i)
+      where maxi = allOne :: Bits n
+    fromEnum (Bits n) = fromEnum n
+instance SizeValid n => Bounded (Bits n) where
+    minBound = azero
+    maxBound = allOne
+instance SizeValid n => Additive (Bits n) where
+    azero = Bits 0
+    (+) (Bits a) (Bits b) = toBits (a + b)
+    scale n (Bits a) = toBits (scale n a)
+instance SizeValid n => Subtractive (Bits n) where
+    type Difference (Bits n) = Bits n
+    (-) (Bits a) (Bits b) = maybe azero toBits (a - b)
+instance SizeValid n => Multiplicative (Bits n) where
+    midentity = Bits 1
+    (*) (Bits a) (Bits b) = Bits (a Prelude.* b)
+instance SizeValid n => IDivisible (Bits n) where
+    div (Bits a) (Bits b) = Bits (a `Prelude.div` b)
+    mod (Bits a) (Bits b) = Bits (a `Prelude.mod` b)
+    divMod (Bits a) (Bits b) = let (q, r) = Prelude.divMod a b in (Bits q, Bits r)
+
+instance SizeValid n => BitOps (Bits n) where
+    (.&.)    (Bits a) (Bits b)    = Bits (a OldBits..&. b)
+    (.|.)    (Bits a) (Bits b)    = Bits (a OldBits..|. b)
+    (.^.)    (Bits a) (Bits b)    = Bits (a `OldBits.xor` b)
+    (.<<.)   (Bits a) (CountOf w) = Bits (a `OldBits.shiftL` w)
+    (.>>.)   (Bits a) (CountOf w) = Bits (a `OldBits.shiftR` w)
+    bit               (Offset w)  = Bits (OldBits.bit w)
+    isBitSet (Bits a) (Offset w)  = OldBits.testBit a w
+    setBit   (Bits a) (Offset w)  = Bits (OldBits.setBit a w)
+    clearBit (Bits a) (Offset w)  = Bits (OldBits.clearBit a w)
+instance (SizeValid n, NatWithinBound (CountOf Bool) n) => FiniteBitsOps (Bits n) where
+    bitFlip (Bits a) = Bits (OldBits.complement a)
+    numberOfBits _ = natValCountOf (Proxy @n)
+    rotateL a i = (a .<<. i) .|. (a .>>. d)
+      where
+        n = natValCountOf (Proxy :: Proxy n)
+        d = fromMaybe (fromMaybe (error "impossible") (i - n)) (n - i)
+    rotateR a i = (a .>>. i) .|. (a .<<. d)
+      where
+        n = natValCountOf (Proxy :: Proxy n)
+        d = fromMaybe (fromMaybe (error "impossible") (i - n)) (n - i)
+    popCount (Bits n) = CountOf (OldBits.popCount n)
+
+-- Bool ------------------------------------------------------------------------
+
+instance FiniteBitsOps Bool where
+    numberOfBits _ = 1
+    rotateL x _ = x
+    rotateR x _ = x
+    popCount True = 1
+    popCount False = 0
+    bitFlip  = not
+    countLeadingZeros True  = 0
+    countLeadingZeros False = 1
+    countTrailingZeros True  = 0
+    countTrailingZeros False = 1
+instance BitOps Bool where
+    (.&.) = (&&)
+    (.|.) = (||)
+    (.^.) = (/=)
+    x .<<. 0 = x
+    _ .<<. _ = False
+    x .>>. 0 = x
+    _ .>>. _ = False
+    bit 0 = True
+    bit _ = False
+    isBitSet x 0 = x
+    isBitSet _ _ = False
+    setBit _ 0 = True
+    setBit _ _ = False
+    clearBit _ 0 = False
+    clearBit x _ = x
+
+-- Word8 ----------------------------------------------------------------------
+
+instance FiniteBitsOps Word8 where
+    numberOfBits _ = 8
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (W8# x#) = CountOf $ wordToInt (W# (popCnt8# (word8ToWord# x#)))
+    countLeadingZeros (W8# w) = CountOf (wordToInt (W# (clz8# (word8ToWord# w))))
+    countTrailingZeros (W8# w) = CountOf (wordToInt (W# (ctz8# (word8ToWord# w))))
+instance BitOps Word8 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+
+-- Word16 ---------------------------------------------------------------------
+
+instance FiniteBitsOps Word16 where
+    numberOfBits _ = 16
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (W16# x#) = CountOf $ wordToInt (W# (popCnt16# (word16ToWord# x#)))
+    countLeadingZeros (W16# w#) = CountOf $ wordToInt (W# (clz16# (word16ToWord# w#)))
+    countTrailingZeros (W16# w#) = CountOf $ wordToInt (W# (ctz16# (word16ToWord# w#)))
+instance BitOps Word16 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+
+-- Word32 ---------------------------------------------------------------------
+
+instance FiniteBitsOps Word32 where
+    numberOfBits _ = 32
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (W32# x#) = CountOf $ wordToInt (W# (popCnt32# (word32ToWord# x#)))
+    countLeadingZeros (W32# w#) = CountOf $ wordToInt (W# (clz32# (word32ToWord# w#)))
+    countTrailingZeros (W32# w#) = CountOf $ wordToInt (W# (ctz32# (word32ToWord# w#)))
+instance BitOps Word32 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+
+-- Word ---------------------------------------------------------------------
+
+#if WORD_SIZE_IN_BITS == 64
+instance FiniteBitsOps Word where
+    numberOfBits _ = 64
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+#if __GLASGOW_HASKELL__ >= 904
+    popCount (W# x#) = CountOf $ wordToInt (W# (popCnt64# (wordToWord64# x#)))
+    countLeadingZeros (W# w#) = CountOf $ wordToInt (W# (clz64# (wordToWord64# w#)))
+    countTrailingZeros (W# w#) = CountOf $ wordToInt (W# (ctz64# (wordToWord64# w#)))
+#else
+    popCount (W# x#) = CountOf $ wordToInt (W# (popCnt64# x#))
+    countLeadingZeros (W# w#) = CountOf $ wordToInt (W# (clz64# w#))
+    countTrailingZeros (W# w#) = CountOf $ wordToInt (W# (ctz64# w#))
+#endif
+#else
+instance FiniteBitsOps Word where
+    numberOfBits _ = 32
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (W# x#) = CountOf $ wordToInt (W# (popCnt32# x#))
+    countLeadingZeros (W# w#) = CountOf $ wordToInt (W# (clz32# w#))
+    countTrailingZeros (W# w#) = CountOf $ wordToInt (W# (ctz32# w#))
+#endif
+
+instance BitOps Word where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+
+-- Word64 ---------------------------------------------------------------------
+
+#if WORD_SIZE_IN_BITS == 64
+instance FiniteBitsOps Word64 where
+    numberOfBits _ = 64
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (W64# x#) = CountOf $ wordToInt (W# (popCnt64# x#))
+    countLeadingZeros (W64# w#) = CountOf $ wordToInt (W# (clz64# w#))
+    countTrailingZeros (W64# w#) = CountOf $ wordToInt (W# (ctz64# w#))
+instance BitOps Word64 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+#else
+instance FiniteBitsOps Word64 where
+    numberOfBits _ = 64
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (W64# x#) = CountOf $ wordToInt (W# (popCnt64# x#))
+    countLeadingZeros (W64# w#) = CountOf $ wordToInt (W# (clz64# w#))
+    countTrailingZeros (W64# w#) = CountOf $ wordToInt (W# (ctz64# w#))
+instance BitOps Word64 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+#endif
+
+-- Word128 --------------------------------------------------------------------
+
+instance FiniteBitsOps Word128 where
+    numberOfBits _ = 128
+    rotateL w (CountOf n) = Word128.rotateL w n
+    rotateR w (CountOf n) = Word128.rotateR w n
+    bitFlip = Word128.complement
+    popCount = CountOf . Word128.popCount
+instance BitOps Word128 where
+    (.&.) = Word128.bitwiseAnd
+    (.|.) = Word128.bitwiseOr
+    (.^.) = Word128.bitwiseXor
+    (.<<.) w (CountOf n) = Word128.shiftL w n
+    (.>>.) w (CountOf n) = Word128.shiftR w n
+
+-- Word256 --------------------------------------------------------------------
+
+instance FiniteBitsOps Word256 where
+    numberOfBits _ = 256
+    rotateL w (CountOf n) = Word256.rotateL w n
+    rotateR w (CountOf n) = Word256.rotateR w n
+    bitFlip = Word256.complement
+    popCount = CountOf . Word256.popCount
+instance BitOps Word256 where
+    (.&.) = Word256.bitwiseAnd
+    (.|.) = Word256.bitwiseOr
+    (.^.) = Word256.bitwiseXor
+    (.<<.) w (CountOf n) = Word256.shiftL w n
+    (.>>.) w (CountOf n) = Word256.shiftR w n
+
+-- Int8 -----------------------------------------------------------------------
+instance FiniteBitsOps Int8 where
+    numberOfBits _ = 8
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (I8# x#) = CountOf $ wordToInt (W# (popCnt8# (int2Word# (int8ToInt# x#))))
+    countLeadingZeros (I8# w#) = CountOf $ wordToInt (W# (clz8# (int2Word# (int8ToInt# w#))))
+    countTrailingZeros (I8# w#) = CountOf $ wordToInt (W# (ctz8# (int2Word# (int8ToInt# w#))))
+instance BitOps Int8 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+
+-- Int16 ----------------------------------------------------------------------
+
+instance FiniteBitsOps Int16 where
+    numberOfBits _ = 16
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (I16# x#) = CountOf $ wordToInt (W# (popCnt16# (int2Word# (int16ToInt# x#))))
+    countLeadingZeros (I16# w#) = CountOf $ wordToInt (W# (clz16# (int2Word# (int16ToInt# w#))))
+    countTrailingZeros (I16# w#) = CountOf $ wordToInt (W# (ctz16# (int2Word# (int16ToInt# w#))))
+instance BitOps Int16 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+
+-- Int32 ----------------------------------------------------------------------
+
+instance FiniteBitsOps Int32 where
+    numberOfBits _ = 32
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (I32# x#) = CountOf $ wordToInt (W# (popCnt32# (int2Word# (int32ToInt# x#))))
+    countLeadingZeros (I32# w#) = CountOf $ wordToInt (W# (clz32# (int2Word# (int32ToInt# w#))))
+    countTrailingZeros (I32# w#) = CountOf $ wordToInt (W# (ctz32# (int2Word# (int32ToInt# w#))))
+instance BitOps Int32 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+-- Int64 ----------------------------------------------------------------------
+
+#if WORD_SIZE_IN_BITS == 64
+instance FiniteBitsOps Int64 where
+    numberOfBits _ = 64
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+#if __GLASGOW_HASKELL__ >= 904
+    popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (wordToWord64# (int2Word# (int64ToInt# x#)))))
+    countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (wordToWord64# (int2Word# (int64ToInt# w#)))))
+    countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (wordToWord64# (int2Word# (int64ToInt# w#)))))
+#else
+    popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (int2Word# x#)))
+    countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (int2Word# w#)))
+    countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (int2Word# w#)))
+#endif
+instance BitOps Int64 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+#else
+instance FiniteBitsOps Int64 where
+    numberOfBits _ = 64
+    rotateL w (CountOf i) = w `OldBits.rotateL` i
+    rotateR w (CountOf i) = w `OldBits.rotateR` i
+    bitFlip = OldBits.complement
+    popCount (I64# x#) = CountOf $ wordToInt (W# (popCnt64# (int64ToWord64# x#)))
+    countLeadingZeros (I64# w#) = CountOf $ wordToInt (W# (clz64# (int64ToWord64# w#)))
+    countTrailingZeros (I64# w#) = CountOf $ wordToInt (W# (ctz64# (int64ToWord64# w#)))
+instance BitOps Int64 where
+    (.&.)    a b    = (a OldBits..&. b)
+    (.|.)    a b    = (a OldBits..|. b)
+    (.^.)    a b    = (a `OldBits.xor` b)
+    (.<<.)   a (CountOf w) = (a `OldBits.shiftL` w)
+    (.>>.)   a (CountOf w) = (a `OldBits.shiftR` w)
+
+#endif

bundled/Basement/Block.hs

@@ -0,0 +1,447 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Block
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+--
+-- A block of memory that contains elements of a type,
+-- very similar to an unboxed array but with the key difference:
+--
+-- * It doesn't have slicing capability (no cheap take or drop)
+-- * It consume less memory: 1 Offset, 1 CountOf
+-- * It's unpackable in any constructor
+-- * It uses unpinned memory by default
+--
+{-# LANGUAGE MagicHash           #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnboxedTuples       #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+module Basement.Block
+    ( Block(..)
+    , MutableBlock(..)
+    -- * Properties
+    , length
+    -- * Lowlevel functions
+    , unsafeThaw
+    , unsafeFreeze
+    , unsafeIndex
+    , thaw
+    , freeze
+    , copy
+    , unsafeCast
+    , cast
+    -- * safer api
+    , empty
+    , create
+    , isPinned
+    , isMutablePinned
+    , singleton
+    , replicate
+    , index
+    , map
+    , foldl'
+    , foldr
+    , foldl1'
+    , foldr1
+    , cons
+    , snoc
+    , uncons
+    , unsnoc
+    , sub
+    , splitAt
+    , revSplitAt
+    , splitOn
+    , break
+    , breakEnd
+    , span
+    , elem
+    , all
+    , any
+    , find
+    , filter
+    , reverse
+    , sortBy
+    , intersperse
+    -- * Foreign interfaces
+    , createFromPtr
+    , unsafeCopyToPtr
+    , withPtr
+    ) where
+
+import           GHC.Prim
+import           GHC.Types
+import           GHC.ST
+import qualified Data.List
+import           Basement.Compat.Base
+import           Data.Proxy
+import           Basement.Compat.Primitive
+import           Basement.NonEmpty
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+import           Basement.Exception
+import           Basement.PrimType
+import qualified Basement.Block.Mutable as M
+import           Basement.Block.Mutable (Block(..), MutableBlock(..), new, unsafeThaw, unsafeFreeze)
+import           Basement.Block.Base
+import           Basement.Numerical.Additive
+import           Basement.Numerical.Subtractive
+import           Basement.Numerical.Multiplicative
+import qualified Basement.Alg.Mutable as MutAlg
+import qualified Basement.Alg.Class as Alg
+import qualified Basement.Alg.PrimArray as Alg
+
+instance (PrimMonad prim, st ~ PrimState prim, PrimType ty) 
+         => Alg.RandomAccess (MutableBlock ty st) prim ty where
+    read (MutableBlock mba) = primMbaRead mba
+    write (MutableBlock mba) = primMbaWrite mba
+
+instance (PrimType ty) => Alg.Indexable (Block ty) ty where
+    index (Block ba) = primBaIndex ba
+    {-# INLINE index #-}
+
+instance Alg.Indexable (Block Word8) Word64 where
+    index (Block ba) = primBaIndex ba
+    {-# INLINE index #-}
+
+-- | Copy all the block content to the memory starting at the destination address
+unsafeCopyToPtr :: forall ty prim . PrimMonad prim
+                => Block ty -- ^ the source block to copy
+                -> Ptr ty   -- ^ The destination address where the copy is going to start
+                -> prim ()
+unsafeCopyToPtr (Block blk) (Ptr p) = primitive $ \s1 ->
+    (# copyByteArrayToAddr# blk 0# p (sizeofByteArray# blk) s1, () #)
+
+-- | Create a new array of size @n by settings each cells through the
+-- function @f.
+create :: forall ty . PrimType ty
+       => CountOf ty           -- ^ the size of the block (in element of ty)
+       -> (Offset ty -> ty) -- ^ the function that set the value at the index
+       -> Block ty          -- ^ the array created
+create n initializer
+    | n == 0    = mempty
+    | otherwise = runST $ do
+        mb <- new n
+        M.iterSet initializer mb
+        unsafeFreeze mb
+
+-- | Freeze a chunk of memory pointed, of specific size into a new unboxed array
+createFromPtr :: PrimType ty
+              => Ptr ty
+              -> CountOf ty
+              -> IO (Block ty)
+createFromPtr p sz = do
+    mb <- new sz
+    M.copyFromPtr p mb 0 sz
+    unsafeFreeze mb
+
+singleton :: PrimType ty => ty -> Block ty
+singleton ty = create 1 (const ty)
+
+replicate :: PrimType ty => CountOf ty -> ty -> Block ty
+replicate sz ty = create sz (const ty)
+
+-- | Thaw a Block into a MutableBlock
+--
+-- the Block is not modified, instead a new Mutable Block is created
+-- and its content is copied to the mutable block
+thaw :: (PrimMonad prim, PrimType ty) => Block ty -> prim (MutableBlock ty (PrimState prim))
+thaw array = do
+    ma <- M.unsafeNew Unpinned (lengthBytes array)
+    M.unsafeCopyBytesRO ma 0 array 0 (lengthBytes array)
+    pure ma
+{-# INLINE thaw #-}
+
+-- | Freeze a MutableBlock into a Block, copying all the data
+--
+-- If the data is modified in the mutable block after this call, then
+-- the immutable Block resulting is not impacted.
+freeze :: (PrimType ty, PrimMonad prim) => MutableBlock ty (PrimState prim) -> prim (Block ty)
+freeze ma = do
+    ma' <- unsafeNew Unpinned len
+    M.unsafeCopyBytes ma' 0 ma 0 len
+    --M.copyAt ma' (Offset 0) ma (Offset 0) len
+    unsafeFreeze ma'
+  where
+    len = M.mutableLengthBytes ma
+
+-- | Copy every cells of an existing Block to a new Block
+copy :: PrimType ty => Block ty -> Block ty
+copy array = runST (thaw array >>= unsafeFreeze)
+
+-- | Return the element at a specific index from an array.
+--
+-- If the index @n is out of bounds, an error is raised.
+index :: PrimType ty => Block ty -> Offset ty -> ty
+index array n
+    | isOutOfBound n len = outOfBound OOB_Index n len
+    | otherwise          = unsafeIndex array n
+  where
+    !len = length array
+{-# INLINE index #-}
+
+-- | Map all element 'a' from a block to a new block of 'b'
+map :: (PrimType a, PrimType b) => (a -> b) -> Block a -> Block b
+map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))
+  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a)
+
+foldr :: PrimType ty => (ty -> a -> a) -> a -> Block ty -> a
+foldr f initialAcc vec = loop 0
+  where
+    !len = length vec
+    loop !i
+        | i .==# len = initialAcc
+        | otherwise  = unsafeIndex vec i `f` loop (i+1)
+{-# SPECIALIZE [2] foldr :: (Word8 -> a -> a) -> a -> Block Word8 -> a #-}
+
+foldl' :: PrimType ty => (a -> ty -> a) -> a -> Block ty -> a
+foldl' f initialAcc vec = loop 0 initialAcc
+  where
+    !len = length vec
+    loop !i !acc
+        | i .==# len = acc
+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))
+{-# SPECIALIZE [2] foldl' :: (a -> Word8 -> a) -> a -> Block Word8 -> a #-}
+
+foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty
+foldl1' f (NonEmpty arr) = loop 1 (unsafeIndex arr 0)
+  where
+    !len = length arr
+    loop !i !acc
+        | i .==# len = acc
+        | otherwise  = loop (i+1) (f acc (unsafeIndex arr i))
+{-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (Block Word8) -> Word8 #-}
+
+foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty
+foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr
+               in foldr f (unsafeIndex initialAcc 0) rest
+
+cons :: PrimType ty => ty -> Block ty -> Block ty
+cons e vec
+    | len == 0  = singleton e
+    | otherwise = runST $ do
+        muv <- new (len + 1)
+        M.unsafeCopyElementsRO muv 1 vec 0 len
+        M.unsafeWrite muv 0 e
+        unsafeFreeze muv
+  where
+    !len = length vec
+
+snoc :: PrimType ty => Block ty -> ty -> Block ty
+snoc vec e
+    | len == 0  = singleton e
+    | otherwise = runST $ do
+        muv <- new (len + 1)
+        M.unsafeCopyElementsRO muv 0 vec 0 len
+        M.unsafeWrite muv (0 `offsetPlusE` len) e
+        unsafeFreeze muv
+  where
+     !len = length vec
+
+sub :: PrimType ty => Block ty -> Offset ty -> Offset ty -> Block ty
+sub blk start end
+    | start >= end' = mempty
+    | otherwise     = runST $ do
+        dst <- new newLen
+        M.unsafeCopyElementsRO dst 0 blk start newLen
+        unsafeFreeze dst
+  where
+    newLen = end' - start
+    end' = min (sizeAsOffset len) end
+    !len = length blk
+
+uncons :: PrimType ty => Block ty -> Maybe (ty, Block ty)
+uncons vec
+    | nbElems == 0 = Nothing
+    | otherwise    = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems))
+  where
+    !nbElems = length vec
+
+unsnoc :: PrimType ty => Block ty -> Maybe (Block ty, ty)
+unsnoc vec = case length vec - 1 of
+    Nothing -> Nothing
+    Just offset -> Just (sub vec 0 lastElem, unsafeIndex vec lastElem)
+                     where !lastElem = 0 `offsetPlusE` offset
+
+splitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty)
+splitAt nbElems blk
+    | nbElems <= 0 = (mempty, blk)
+    | Just nbTails <- length blk - nbElems, nbTails > 0 = runST $ do
+        left  <- new nbElems
+        right <- new nbTails
+        M.unsafeCopyElementsRO left  0 blk 0                      nbElems
+        M.unsafeCopyElementsRO right 0 blk (sizeAsOffset nbElems) nbTails
+        (,) <$> unsafeFreeze left <*> unsafeFreeze right
+    | otherwise    = (blk, mempty)
+{-# SPECIALIZE [2] splitAt :: CountOf Word8 -> Block Word8 -> (Block Word8, Block Word8) #-}
+
+revSplitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty)
+revSplitAt n blk 
+    | n <= 0                         = (mempty, blk)
+    | Just nbElems <- length blk - n = let (x, y) = splitAt nbElems blk in (y, x)
+    | otherwise                      = (blk, mempty)
+
+break :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty)
+break predicate blk = findBreak 0
+  where
+    !len = length blk
+    findBreak !i
+        | i .==# len                    = (blk, mempty)
+        | predicate (unsafeIndex blk i) = splitAt (offsetAsSize i) blk
+        | otherwise                     = findBreak (i + 1)
+    {-# INLINE findBreak #-}
+{-# SPECIALIZE [2] break :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-}
+
+breakEnd :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty)
+breakEnd predicate blk
+    | k == sentinel = (blk, mempty)
+    | otherwise     = splitAt (offsetAsSize (k+1)) blk
+  where
+    !k = Alg.revFindIndexPredicate predicate blk 0 end
+    !end = sizeAsOffset $ length blk
+{-# SPECIALIZE [2] breakEnd :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-}
+
+span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty)
+span p = break (not . p)
+
+elem :: PrimType ty => ty -> Block ty -> Bool
+elem v blk = loop 0
+  where
+    !len = length blk
+    loop !i
+        | i .==# len             = False
+        | unsafeIndex blk i == v = True
+        | otherwise              = loop (i+1)
+{-# SPECIALIZE [2] elem :: Word8 -> Block Word8 -> Bool #-}
+
+all :: PrimType ty => (ty -> Bool) -> Block ty -> Bool
+all p blk = loop 0
+  where
+    !len = length blk
+    loop !i
+        | i .==# len            = True
+        | p (unsafeIndex blk i) = loop (i+1)
+        | otherwise             = False
+{-# SPECIALIZE [2] all :: (Word8 -> Bool) -> Block Word8 -> Bool #-}
+
+any :: PrimType ty => (ty -> Bool) -> Block ty -> Bool
+any p blk = loop 0
+  where
+    !len = length blk
+    loop !i
+        | i .==# len            = False
+        | p (unsafeIndex blk i) = True
+        | otherwise             = loop (i+1)
+{-# SPECIALIZE [2] any :: (Word8 -> Bool) -> Block Word8 -> Bool #-}
+
+splitOn :: PrimType ty => (ty -> Bool) -> Block ty -> [Block ty]
+splitOn predicate blk
+    | len == 0  = [mempty]
+    | otherwise = go 0 0
+  where
+    !len = length blk
+    go !prevIdx !idx
+        | idx .==# len = [sub blk prevIdx idx]
+        | otherwise    =
+            let e = unsafeIndex blk idx
+                idx' = idx + 1
+             in if predicate e
+                    then sub blk prevIdx idx : go idx' idx'
+                    else go prevIdx idx'
+
+find :: PrimType ty => (ty -> Bool) -> Block ty -> Maybe ty
+find predicate vec = loop 0
+  where
+    !len = length vec
+    loop i
+        | i .==# len = Nothing
+        | otherwise  =
+            let e = unsafeIndex vec i
+             in if predicate e then Just e else loop (i+1)
+
+filter :: PrimType ty => (ty -> Bool) -> Block ty -> Block ty
+filter predicate vec = fromList $ Data.List.filter predicate $ toList vec
+
+reverse :: forall ty . PrimType ty => Block ty -> Block ty
+reverse blk
+    | len == 0  = mempty
+    | otherwise = runST $ do
+        mb <- new len
+        go mb
+        unsafeFreeze mb
+  where
+    !len = length blk
+    !endOfs = 0 `offsetPlusE` len
+
+    go :: MutableBlock ty s -> ST s ()
+    go mb = loop endOfs 0
+      where
+        loop o i
+            | i .==# len = pure ()
+            | otherwise  = unsafeWrite mb o' (unsafeIndex blk i) >> loop o' (i+1)
+          where o' = pred o
+
+sortBy :: PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty
+sortBy ford vec
+    | len == 0  = mempty
+    | otherwise = runST $ do
+        mblock <- thaw vec
+        MutAlg.inplaceSortBy ford 0 len mblock
+        unsafeFreeze mblock
+  where len = length vec
+{-# SPECIALIZE [2] sortBy :: (Word8 -> Word8 -> Ordering) -> Block Word8 -> Block Word8 #-}
+
+intersperse :: forall ty . PrimType ty => ty -> Block ty -> Block ty
+intersperse sep blk = case len - 1 of
+    Nothing -> blk
+    Just 0 -> blk
+    Just size -> runST $ do
+        mb <- new (len+size)
+        go mb
+        unsafeFreeze mb
+  where
+    !len = length blk
+
+    go :: MutableBlock ty s -> ST s ()
+    go mb = loop 0 0
+      where
+        loop !o !i
+            | (i + 1) .==# len = unsafeWrite mb o (unsafeIndex blk i)
+            | otherwise        = do
+                unsafeWrite mb o     (unsafeIndex blk i)
+                unsafeWrite mb (o+1) sep
+                loop (o+2) (i+1)
+
+-- | Unsafely recast an UArray containing 'a' to an UArray containing 'b'
+--
+-- The offset and size are converted from units of 'a' to units of 'b',
+-- but no check are performed to make sure this is compatible.
+--
+-- use 'cast' if unsure.
+unsafeCast :: PrimType b => Block a -> Block b
+unsafeCast (Block ba) = Block ba
+
+-- | Cast a Block of 'a' to a Block of 'b'
+--
+-- The requirement is that the size of type 'a' need to be a multiple or
+-- dividend of the size of type 'b'.
+--
+-- If this requirement is not met, the InvalidRecast exception is thrown
+cast :: forall a b . (PrimType a, PrimType b) => Block a -> Block b
+cast blk@(Block ba)
+    | aTypeSize == bTypeSize || bTypeSize == 1 = unsafeCast blk
+    | missing   == 0                           = unsafeCast blk
+    | otherwise                                =
+        throw $ InvalidRecast (RecastSourceSize alen) (RecastDestinationSize $ alen + missing)
+  where
+    (CountOf alen) = lengthBytes blk
+
+    aTypeSize = primSizeInBytes (Proxy :: Proxy a)
+    bTypeSize@(CountOf bs) = primSizeInBytes (Proxy :: Proxy b)
+
+    missing = alen `mod` bs

bundled/Basement/Block/Base.hs

@@ -0,0 +1,493 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash           #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnboxedTuples       #-}
+module Basement.Block.Base
+    ( Block(..)
+    , MutableBlock(..)
+    -- * Basic accessor
+    , unsafeNew
+    , unsafeThaw
+    , unsafeFreeze
+    , unsafeShrink
+    , unsafeCopyElements
+    , unsafeCopyElementsRO
+    , unsafeCopyBytes
+    , unsafeCopyBytesRO
+    , unsafeCopyBytesPtr
+    , unsafeRead
+    , unsafeWrite
+    , unsafeIndex
+    -- * Properties
+    , length
+    , lengthBytes
+    , isPinned
+    , isMutablePinned
+    , mutableLength
+    , mutableLengthBytes
+    -- * Other methods
+    , empty
+    , mutableEmpty
+    , new
+    , newPinned
+    , withPtr
+    , withMutablePtr
+    , withMutablePtrHint
+    , mutableWithPtr
+    , unsafeRecast
+    ) where
+
+import           GHC.Prim
+import           GHC.Types
+import           GHC.ST
+import           GHC.IO
+import qualified Data.List
+import           Basement.Compat.Base
+import           Data.Proxy
+import           Basement.Compat.Primitive
+import           Basement.Compat.Semigroup
+import           Basement.Bindings.Memory (sysHsMemcmpBaBa)
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+import           Basement.NormalForm
+import           Basement.Numerical.Additive
+import           Basement.PrimType
+
+-- | A block of memory containing unpacked bytes representing values of type 'ty'
+data Block ty = Block ByteArray#
+    deriving (Typeable)
+
+unsafeBlockPtr :: Block ty -> Ptr ty
+unsafeBlockPtr (Block arrBa) = Ptr (byteArrayContents# arrBa)
+{-# INLINE unsafeBlockPtr #-}
+
+instance Data ty => Data (Block ty) where
+    dataTypeOf _ = blockType
+    toConstr _   = error "toConstr"
+    gunfold _ _  = error "gunfold"
+
+blockType :: DataType
+blockType = mkNoRepType "Basement.Block"
+
+instance NormalForm (Block ty) where
+    toNormalForm (Block !_) = ()
+instance (PrimType ty, Show ty) => Show (Block ty) where
+    show v = show (toList v)
+instance (PrimType ty, Eq ty) => Eq (Block ty) where
+    {-# SPECIALIZE instance Eq (Block Word8) #-}
+    (==) = equal
+instance (PrimType ty, Ord ty) => Ord (Block ty) where
+    compare = internalCompare
+
+instance PrimType ty => Semigroup (Block ty) where
+    (<>) = append
+instance PrimType ty => Monoid (Block ty) where
+    mempty  = empty
+    mconcat = concat
+
+instance PrimType ty => IsList (Block ty) where
+    type Item (Block ty) = ty
+    fromList = internalFromList
+    toList = internalToList
+
+-- | A Mutable block of memory containing unpacked bytes representing values of type 'ty'
+data MutableBlock ty st = MutableBlock (MutableByteArray# st)
+
+isPinned :: Block ty -> PinnedStatus
+isPinned (Block ba) = toPinnedStatus# (compatIsByteArrayPinned# ba)
+
+isMutablePinned :: MutableBlock s ty -> PinnedStatus
+isMutablePinned (MutableBlock mba) = toPinnedStatus# (compatIsMutableByteArrayPinned# mba)
+
+length :: forall ty . PrimType ty => Block ty -> CountOf ty
+length (Block ba) =
+    case primShiftToBytes (Proxy :: Proxy ty) of
+        0           -> CountOf (I# (sizeofByteArray# ba))
+        (I# szBits) -> CountOf (I# (uncheckedIShiftRL# (sizeofByteArray# ba) szBits))
+{-# INLINE[1] length #-}
+{-# SPECIALIZE [2] length :: Block Word8 -> CountOf Word8 #-}
+
+lengthBytes :: Block ty -> CountOf Word8
+lengthBytes (Block ba) = CountOf (I# (sizeofByteArray# ba))
+{-# INLINE[1] lengthBytes #-}
+
+-- | Return the length of a Mutable Block
+--
+-- note: we don't allow resizing yet, so this can remain a pure function
+mutableLength :: forall ty st . PrimType ty => MutableBlock ty st -> CountOf ty
+mutableLength mb = sizeRecast $ mutableLengthBytes mb
+{-# INLINE[1] mutableLength #-}
+
+mutableLengthBytes :: MutableBlock ty st -> CountOf Word8
+mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba))
+{-# INLINE[1] mutableLengthBytes #-}
+
+-- | Create an empty block of memory
+empty :: Block ty
+empty = Block ba where !(Block ba) = empty_
+
+empty_ :: Block ()
+empty_ = runST $ primitive $ \s1 ->
+    case newByteArray# 0# s1           of { (# s2, mba #) ->
+    case unsafeFreezeByteArray# mba s2 of { (# s3, ba  #) ->
+        (# s3, Block ba #) }}
+
+mutableEmpty :: PrimMonad prim => prim (MutableBlock ty (PrimState prim))
+mutableEmpty = primitive $ \s1 ->
+    case newByteArray# 0# s1 of { (# s2, mba #) ->
+        (# s2, MutableBlock mba #) }
+
+-- | Return the element at a specific index from an array without bounds checking.
+--
+-- Reading from invalid memory can return unpredictable and invalid values.
+-- use 'index' if unsure.
+unsafeIndex :: forall ty . PrimType ty => Block ty -> Offset ty -> ty
+unsafeIndex (Block ba) n = primBaIndex ba n
+{-# SPECIALIZE unsafeIndex :: Block Word8 -> Offset Word8 -> Word8 #-}
+{-# INLINE unsafeIndex #-}
+
+-- | make a block from a list of elements.
+internalFromList :: PrimType ty => [ty] -> Block ty
+internalFromList l = runST $ do
+    ma <- new (CountOf len)
+    iter azero l $ \i x -> unsafeWrite ma i x
+    unsafeFreeze ma
+  where
+    !len = Data.List.length l
+
+    iter _  []     _ = return ()
+    iter !i (x:xs) z = z i x >> iter (i+1) xs z
+
+-- | transform a block to a list.
+internalToList :: forall ty . PrimType ty => Block ty -> [ty]
+internalToList blk@(Block ba)
+    | len == azero = []
+    | otherwise    = loop azero
+  where
+    !len = length blk
+    loop !i | i .==# len = []
+            | otherwise  = primBaIndex ba i : loop (i+1)
+
+-- | Check if two blocks are identical
+equal :: (PrimType ty, Eq ty) => Block ty -> Block ty -> Bool
+equal a b
+    | la /= lb  = False
+    | otherwise = loop azero
+  where
+    !la = lengthBytes a
+    !lb = lengthBytes b
+    lat = length a
+
+    loop !n | n .==# lat = True
+            | otherwise  = (unsafeIndex a n == unsafeIndex b n) && loop (n+o1)
+    o1 = Offset (I# 1#)
+{-# RULES "Block/Eq/Word8" [3]
+   forall (a :: Block Word8) b . equal a b = equalMemcmp a b #-}
+{-# INLINEABLE [2] equal #-}
+-- {-# SPECIALIZE equal :: Block Word8 -> Block Word8 -> Bool #-}
+
+equalMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Bool
+equalMemcmp b1@(Block a) b2@(Block b)
+    | la /= lb  = False
+    | otherwise = unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 la) == 0
+  where
+    la = lengthBytes b1
+    lb = lengthBytes b2
+{-# SPECIALIZE equalMemcmp :: Block Word8 -> Block Word8 -> Bool #-}
+
+-- | Compare 2 blocks
+internalCompare :: (Ord ty, PrimType ty) => Block ty -> Block ty -> Ordering
+internalCompare a b = loop azero
+  where
+    !la = length a
+    !lb = length b
+    !end = sizeAsOffset (min la lb)
+    loop !n
+        | n == end  = la `compare` lb
+        | v1 == v2  = loop (n + Offset (I# 1#))
+        | otherwise = v1 `compare` v2
+      where
+        v1 = unsafeIndex a n
+        v2 = unsafeIndex b n
+{-# RULES "Block/Ord/Word8" [3] forall (a :: Block Word8) b . internalCompare a b = compareMemcmp a b #-}
+{-# NOINLINE internalCompare #-}
+
+compareMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Ordering
+compareMemcmp b1@(Block a) b2@(Block b) =
+    case unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 sz) of
+        0             -> la `compare` lb
+        n | n > 0     -> GT
+          | otherwise -> LT
+  where
+    la = lengthBytes b1
+    lb = lengthBytes b2
+    sz = min la lb
+{-# SPECIALIZE [3] compareMemcmp :: Block Word8 -> Block Word8 -> Ordering #-}
+
+-- | Append 2 blocks together by creating a new bigger block
+append :: Block ty -> Block ty -> Block ty
+append a b
+    | la == azero = b
+    | lb == azero = a
+    | otherwise = runST $ do
+        r  <- unsafeNew Unpinned (la+lb)
+        unsafeCopyBytesRO r 0                 a 0 la
+        unsafeCopyBytesRO r (sizeAsOffset la) b 0 lb
+        unsafeFreeze r
+  where
+    !la = lengthBytes a
+    !lb = lengthBytes b
+
+concat :: forall ty . [Block ty] -> Block ty
+concat original = runST $ do
+    r <- unsafeNew Unpinned total
+    goCopy r zero original
+    unsafeFreeze r
+  where
+    !total = size 0 original
+    -- size
+    size !sz []     = sz
+    size !sz (x:xs) = size (lengthBytes x + sz) xs
+
+    zero = Offset 0
+
+    goCopy r = loop
+      where
+        loop _  []      = pure ()
+        loop !i (x:xs) = do
+            unsafeCopyBytesRO r i x zero lx
+            loop (i `offsetPlusE` lx) xs
+          where !lx = lengthBytes x
+
+-- | Freeze a mutable block into a block.
+--
+-- If the mutable block is still use after freeze,
+-- then the modification will be reflected in an unexpected
+-- way in the Block.
+unsafeFreeze :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Block ty)
+unsafeFreeze (MutableBlock mba) = primitive $ \s1 ->
+    case unsafeFreezeByteArray# mba s1 of
+        (# s2, ba #) -> (# s2, Block ba #)
+{-# INLINE unsafeFreeze #-}
+
+unsafeShrink :: PrimMonad prim => MutableBlock ty (PrimState prim) -> CountOf ty -> prim (MutableBlock ty (PrimState prim))
+unsafeShrink (MutableBlock mba) (CountOf (I# nsz)) = primitive $ \s ->
+    case shrinkMutableByteArray# mba nsz s of
+        s -> (# s, MutableBlock mba #)
+
+-- | Thaw an immutable block.
+--
+-- If the immutable block is modified, then the original immutable block will
+-- be modified too, but lead to unexpected results when querying
+unsafeThaw :: (PrimType ty, PrimMonad prim) => Block ty -> prim (MutableBlock ty (PrimState prim))
+unsafeThaw (Block ba) = primitive $ \st -> (# st, MutableBlock (unsafeCoerce# ba) #)
+
+-- | Create a new mutable block of a specific size in bytes.
+--
+-- Note that no checks are made to see if the size in bytes is compatible with the size
+-- of the underlaying element 'ty' in the block.
+--
+-- use 'new' if unsure
+unsafeNew :: PrimMonad prim
+          => PinnedStatus
+          -> CountOf Word8
+          -> prim (MutableBlock ty (PrimState prim))
+unsafeNew pinSt (CountOf (I# bytes)) = case pinSt of
+    Unpinned -> primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }
+    _        -> primitive $ \s1 -> case newAlignedPinnedByteArray# bytes 8# s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }
+
+-- | Create a new unpinned mutable block of a specific N size of 'ty' elements
+--
+-- If the size exceeds a GHC-defined threshold, then the memory will be
+-- pinned. To be certain about pinning status with small size, use 'newPinned'
+new :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))
+new n = unsafeNew Unpinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)
+
+-- | Create a new pinned mutable block of a specific N size of 'ty' elements
+newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))
+newPinned n = unsafeNew Pinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)
+
+-- | Copy a number of elements from an array to another array with offsets
+unsafeCopyElements :: forall prim ty . (PrimMonad prim, PrimType ty)
+                   => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                   -> Offset ty                        -- ^ offset at destination
+                   -> MutableBlock ty (PrimState prim) -- ^ source mutable block
+                   -> Offset ty                        -- ^ offset at source
+                   -> CountOf ty                          -- ^ number of elements to copy
+                   -> prim ()
+unsafeCopyElements dstMb destOffset srcMb srcOffset n = -- (MutableBlock dstMba) ed (MutableBlock srcBa) es n =
+    unsafeCopyBytes dstMb (offsetOfE sz destOffset)
+                    srcMb (offsetOfE sz srcOffset)
+                    (sizeOfE sz n)
+  where
+    !sz = primSizeInBytes (Proxy :: Proxy ty)
+
+unsafeCopyElementsRO :: forall prim ty . (PrimMonad prim, PrimType ty)
+                     => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                     -> Offset ty                        -- ^ offset at destination
+                     -> Block ty                         -- ^ source block
+                     -> Offset ty                        -- ^ offset at source
+                     -> CountOf ty                          -- ^ number of elements to copy
+                     -> prim ()
+unsafeCopyElementsRO dstMb destOffset srcMb srcOffset n =
+    unsafeCopyBytesRO dstMb (offsetOfE sz destOffset)
+                      srcMb (offsetOfE sz srcOffset)
+                      (sizeOfE sz n)
+  where
+    !sz = primSizeInBytes (Proxy :: Proxy ty)
+
+-- | Copy a number of bytes from a MutableBlock to another MutableBlock with specific byte offsets
+unsafeCopyBytes :: forall prim ty . PrimMonad prim
+                => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                -> Offset Word8                     -- ^ offset at destination
+                -> MutableBlock ty (PrimState prim) -- ^ source mutable block
+                -> Offset Word8                     -- ^ offset at source
+                -> CountOf Word8                       -- ^ number of elements to copy
+                -> prim ()
+unsafeCopyBytes (MutableBlock dstMba) (Offset (I# d)) (MutableBlock srcBa) (Offset (I# s)) (CountOf (I# n)) =
+    primitive $ \st -> (# copyMutableByteArray# srcBa s dstMba d n st, () #)
+{-# INLINE unsafeCopyBytes #-}
+
+-- | Copy a number of bytes from a Block to a MutableBlock with specific byte offsets
+unsafeCopyBytesRO :: forall prim ty . PrimMonad prim
+                  => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                  -> Offset Word8                     -- ^ offset at destination
+                  -> Block ty                         -- ^ source block
+                  -> Offset Word8                     -- ^ offset at source
+                  -> CountOf Word8                       -- ^ number of elements to copy
+                  -> prim ()
+unsafeCopyBytesRO (MutableBlock dstMba) (Offset (I# d)) (Block srcBa) (Offset (I# s)) (CountOf (I# n)) =
+    primitive $ \st -> (# copyByteArray# srcBa s dstMba d n st, () #)
+{-# INLINE unsafeCopyBytesRO #-}
+
+-- | Copy a number of bytes from a Ptr to a MutableBlock with specific byte offsets
+unsafeCopyBytesPtr :: forall prim ty . PrimMonad prim
+                   => MutableBlock ty (PrimState prim) -- ^ destination mutable block
+                   -> Offset Word8                     -- ^ offset at destination
+                   -> Ptr ty                           -- ^ source block
+                   -> CountOf Word8                    -- ^ number of bytes to copy
+                   -> prim ()
+unsafeCopyBytesPtr (MutableBlock dstMba) (Offset (I# d)) (Ptr srcBa) (CountOf (I# n)) =
+    primitive $ \st -> (# copyAddrToByteArray# srcBa dstMba d n st, () #)
+{-# INLINE unsafeCopyBytesPtr #-}
+
+-- | read from a cell in a mutable block without bounds checking.
+--
+-- Reading from invalid memory can return unpredictable and invalid values.
+-- use 'read' if unsure.
+unsafeRead :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty
+unsafeRead (MutableBlock mba) i = primMbaRead mba i
+{-# INLINE unsafeRead #-}
+
+-- | write to a cell in a mutable block without bounds checking.
+--
+-- Writing with invalid bounds will corrupt memory and your program will
+-- become unreliable. use 'write' if unsure.
+unsafeWrite :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
+unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v
+{-# INLINE unsafeWrite #-}
+
+-- | Get a Ptr pointing to the data in the Block.
+--
+-- Since a Block is immutable, this Ptr shouldn't be
+-- to use to modify the contents
+--
+-- If the Block is pinned, then its address is returned as is,
+-- however if it's unpinned, a pinned copy of the Block is made
+-- before getting the address.
+withPtr :: PrimMonad prim
+        => Block ty
+        -> (Ptr ty -> prim a)
+        -> prim a
+withPtr x@(Block ba) f
+    | isPinned x == Pinned = f (Ptr (byteArrayContents# ba)) <* touch x
+    | otherwise            = do
+        arr <- makeTrampoline
+        f (unsafeBlockPtr arr) <* touch arr
+  where
+    makeTrampoline = do
+        trampoline <- unsafeNew Pinned (lengthBytes x)
+        unsafeCopyBytesRO trampoline 0 x 0 (lengthBytes x)
+        unsafeFreeze trampoline
+
+touch :: PrimMonad prim => Block ty -> prim ()
+touch (Block ba) =
+    unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) }
+
+unsafeRecast :: (PrimType t1, PrimType t2)
+             => MutableBlock t1 st
+             -> MutableBlock t2 st
+unsafeRecast (MutableBlock mba) = MutableBlock mba
+
+-- | Use the 'Ptr' to a mutable block in a safer construct
+--
+-- If the block is not pinned, this is a _dangerous_ operation
+mutableWithPtr :: PrimMonad prim
+                => MutableBlock ty (PrimState prim)
+                -> (Ptr ty -> prim a)
+                -> prim a
+mutableWithPtr = withMutablePtr
+{-# DEPRECATED mutableWithPtr "use withMutablePtr" #-}
+
+-- | Create a pointer on the beginning of the MutableBlock
+-- and call a function 'f'.
+--
+-- The mutable block can be mutated by the 'f' function
+-- and the change will be reflected in the mutable block
+--
+-- If the mutable block is unpinned, a trampoline buffer
+-- is created and the data is only copied when 'f' return.
+--
+-- it is all-in-all highly inefficient as this cause 2 copies
+withMutablePtr :: PrimMonad prim
+               => MutableBlock ty (PrimState prim)
+               -> (Ptr ty -> prim a)
+               -> prim a
+withMutablePtr = withMutablePtrHint False False
+
+
+-- | Same as 'withMutablePtr' but allow to specify 2 optimisations
+-- which is only useful when the MutableBlock is unpinned and need
+-- a pinned trampoline to be called safely.
+--
+-- If skipCopy is True, then the first copy which happen before
+-- the call to 'f', is skipped. The Ptr is now effectively
+-- pointing to uninitialized data in a new mutable Block.
+--
+-- If skipCopyBack is True, then the second copy which happen after
+-- the call to 'f', is skipped. Then effectively in the case of a
+-- trampoline being used the memory changed by 'f' will not
+-- be reflected in the original Mutable Block.
+--
+-- If using the wrong parameters, it will lead to difficult to
+-- debug issue of corrupted buffer which only present themselves
+-- with certain Mutable Block that happened to have been allocated
+-- unpinned.
+--
+-- If unsure use 'withMutablePtr', which default to *not* skip
+-- any copy.
+withMutablePtrHint :: forall ty prim a . PrimMonad prim
+                   => Bool -- ^ hint that the buffer doesn't need to have the same value as the mutable block when calling f
+                   -> Bool -- ^ hint that the buffer is not supposed to be modified by call of f
+                   -> MutableBlock ty (PrimState prim)
+                   -> (Ptr ty -> prim a)
+                   -> prim a
+withMutablePtrHint skipCopy skipCopyBack mb f
+    | isMutablePinned mb == Pinned = callWithPtr mb
+    | otherwise                    = do
+        trampoline <- unsafeNew Pinned vecSz
+        unless skipCopy $
+            unsafeCopyBytes trampoline 0 mb 0 vecSz
+        r <- callWithPtr trampoline
+        unless skipCopyBack $
+            unsafeCopyBytes mb 0 trampoline 0 vecSz
+        pure r
+  where
+    vecSz = mutableLengthBytes mb
+    callWithPtr pinnedMb = do
+        b <- unsafeFreeze pinnedMb
+        f (unsafeBlockPtr b) <* touch b

bundled/Basement/Block/Builder.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Block.Builder
+-- License     : BSD-style
+-- Maintainer  : Foundation
+--
+-- Block builder
+
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Basement.Block.Builder
+    ( Builder
+    , run
+
+    -- * Emit functions
+    , emit
+    , emitPrim
+    , emitString
+    , emitUTF8Char
+
+    -- * unsafe
+    , unsafeRunString
+    ) where
+
+import qualified Basement.Alg.UTF8 as UTF8
+import           Basement.UTF8.Helper          (charToBytes)
+import           Basement.Numerical.Conversion (charToInt)
+import           Basement.Block.Base (Block(..), MutableBlock(..))
+import qualified Basement.Block.Base as B
+import           Basement.Cast
+import           Basement.Compat.Base
+import           Basement.Compat.Semigroup
+import           Basement.Monad
+import           Basement.FinalPtr (FinalPtr, withFinalPtr)
+import           Basement.Numerical.Additive
+import           Basement.String                (String(..))
+import qualified Basement.String as S
+import           Basement.Types.OffsetSize
+import           Basement.PrimType (PrimType(..), primMbaWrite)
+import           Basement.UArray.Base (UArray(..))
+import qualified Basement.UArray.Base as A
+
+import           GHC.ST
+import           Data.Proxy
+
+newtype Action = Action
+    { runAction_ :: forall prim . PrimMonad prim
+                 => MutableBlock Word8 (PrimState prim)
+                 -> Offset Word8
+                 -> prim (Offset Word8)
+    }
+
+data Builder = Builder {-# UNPACK #-} !(CountOf Word8)
+                                      !Action
+
+instance Semigroup Builder where
+    (<>) = append
+    {-# INLINABLE (<>) #-}
+instance Monoid Builder where
+    mempty = empty
+    {-# INLINABLE mempty #-}
+    mconcat = concat
+    {-# INLINABLE mconcat #-}
+
+-- | create an empty builder
+--
+-- this does nothing, build nothing, take no space (in the resulted block)
+empty :: Builder
+empty = Builder 0 (Action $ \_ !off -> pure off)
+{-# INLINE empty #-}
+
+-- | concatenate the 2 given bulider
+append :: Builder -> Builder -> Builder
+append (Builder size1 (Action action1)) (Builder size2 (Action action2)) =
+    Builder size action
+  where
+    action = Action $ \arr off -> do
+      off' <- action1 arr off
+      action2 arr off'
+    size = size1 + size2
+{-# INLINABLE append #-}
+
+-- | concatenate the list of builder
+concat :: [Builder] -> Builder
+concat = loop 0 (Action $ \_ !off -> pure off)
+  where
+    loop !sz acc          []                              = Builder sz acc
+    loop !sz (Action acc) (Builder !s (Action action):xs) =
+       loop (sz + s) (Action $ \arr off -> acc arr off >>= action arr) xs
+{-# INLINABLE concat #-}
+
+-- | run the given builder and return the generated block
+run :: PrimMonad prim => Builder -> prim (Block Word8)
+run (Builder sz action) = do
+    mb <- B.new sz
+    off <- runAction_ action mb 0
+    B.unsafeShrink mb (offsetAsSize off) >>= B.unsafeFreeze
+
+-- | run the given builder and return a UTF8String
+--
+-- this action is unsafe as there is no guarantee upon the validity of the
+-- content of the built block.
+unsafeRunString :: PrimMonad prim => Builder -> prim String
+unsafeRunString b = do
+    str <- run b
+    pure $ String $ A.UArray 0 (B.length str) (A.UArrayBA str)
+
+-- | add a Block in the builder
+emit :: Block a -> Builder
+emit b = Builder size $ Action $ \arr off ->
+    B.unsafeCopyBytesRO arr off b' 0 size *> pure (off + sizeAsOffset size)
+  where
+    b' :: Block Word8
+    b' = cast b
+    size :: CountOf Word8
+    size = B.length b'
+
+emitPrim :: (PrimType ty, ty ~ Word8) => ty -> Builder
+emitPrim a = Builder size $ Action $ \(MutableBlock arr) off ->
+    primMbaWrite arr off a *> pure (off + sizeAsOffset size)
+  where
+    size = getSize Proxy a
+    getSize :: PrimType ty => Proxy ty -> ty -> CountOf Word8
+    getSize p _ = primSizeInBytes p
+
+-- | add a string in the builder
+emitString :: String -> Builder
+emitString (String str) = Builder size $ Action $ \arr off ->
+    A.onBackendPrim (onBA arr off) (onAddr arr off) str *> pure (off + sizeAsOffset size)
+  where
+    size = A.length str
+    onBA :: PrimMonad prim
+         => MutableBlock Word8 (PrimState prim)
+         -> Offset Word8
+         -> Block Word8
+         -> prim ()
+    onBA   arr off ba   = B.unsafeCopyBytesRO arr off ba 0 size
+    onAddr :: PrimMonad prim
+           => MutableBlock Word8 (PrimState prim)
+           -> Offset Word8
+           -> FinalPtr Word8
+           -> prim ()
+    onAddr arr off fptr = withFinalPtr fptr $ \ptr -> B.unsafeCopyBytesPtr arr off ptr size
+
+-- | emit a UTF8 char in the builder
+--
+-- this function may be replaced by `emit :: Encoding -> Char -> Builder`
+emitUTF8Char :: Char -> Builder
+emitUTF8Char c = Builder (charToBytes $ charToInt c) $ Action $ \block@(MutableBlock !_) off ->
+    UTF8.writeUTF8 block off c

bundled/Basement/Block/Mutable.hs

@@ -0,0 +1,159 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Block.Mutable
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+--
+-- A block of memory that contains elements of a type,
+-- very similar to an unboxed array but with the key difference:
+--
+-- * It doesn't have slicing capability (no cheap take or drop)
+-- * It consume less memory: 1 Offset, 1 CountOf, 1 Pinning status trimmed
+-- * It's unpackable in any constructor
+-- * It uses unpinned memory by default
+--
+-- It should be rarely needed in high level API, but
+-- in lowlevel API or some data structure containing lots
+-- of unboxed array that will benefit from optimisation.
+--
+-- Because it's unpinned, the blocks are compactable / movable,
+-- at the expense of making them less friendly to interop with the C layer
+-- as address.
+--
+-- Note that sadly the bytearray primitive type automatically create
+-- a pinned bytearray if the size is bigger than a certain threshold
+--
+-- GHC Documentation associated:
+--
+-- includes/rts/storage/Block.h
+--   * LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10))
+--   * BLOCK_SIZE   (1<<BLOCK_SHIFT)
+--
+-- includes/rts/Constant.h
+--   * BLOCK_SHIFT  12
+--
+{-# LANGUAGE MagicHash           #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnboxedTuples       #-}
+module Basement.Block.Mutable
+    ( Block(..)
+    , MutableBlock(..)
+    , mutableLengthSize
+    , mutableLength
+    , mutableLengthBytes
+    , mutableWithPtr
+    , withMutablePtr
+    , withMutablePtrHint
+    , new
+    , newPinned
+    , mutableEmpty
+    , iterSet
+    , read
+    , write
+    , unsafeNew
+    , unsafeWrite
+    , unsafeRead
+    , unsafeFreeze
+    , unsafeThaw
+    , unsafeCopyElements
+    , unsafeCopyElementsRO
+    , unsafeCopyBytes
+    , unsafeCopyBytesRO
+    , unsafeCopyBytesPtr
+    -- * Foreign
+    , copyFromPtr
+    , copyToPtr
+    ) where
+
+import           GHC.Prim
+import           GHC.Types
+import           Basement.Compat.Base
+import           Data.Proxy
+import           Basement.Exception
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+import           Basement.Numerical.Additive
+import           Basement.PrimType
+import           Basement.Block.Base
+
+-- | Set all mutable block element to a value
+iterSet :: (PrimType ty, PrimMonad prim)
+        => (Offset ty -> ty)
+        -> MutableBlock ty (PrimState prim)
+        -> prim ()
+iterSet f ma = loop 0
+  where
+    !sz = mutableLength ma
+    loop i
+        | i .==# sz = pure ()
+        | otherwise = unsafeWrite ma i (f i) >> loop (i+1)
+    {-# INLINE loop #-}
+
+mutableLengthSize :: PrimType ty => MutableBlock ty st -> CountOf ty
+mutableLengthSize = mutableLength
+{-# DEPRECATED mutableLengthSize "use mutableLength" #-}
+
+-- | read a cell in a mutable array.
+--
+-- If the index is out of bounds, an error is raised.
+read :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty
+read array n
+    | isOutOfBound n len = primOutOfBound OOB_Read n len
+    | otherwise          = unsafeRead array n
+  where len = mutableLength array
+{-# INLINE read #-}
+
+-- | Write to a cell in a mutable array.
+--
+-- If the index is out of bounds, an error is raised.
+write :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
+write array n val
+    | isOutOfBound n len = primOutOfBound OOB_Write n len
+    | otherwise          = unsafeWrite array n val
+  where
+    len = mutableLengthSize array
+{-# INLINE write #-}
+
+-- | Copy from a pointer, @count@ elements, into the Mutable Block at a starting offset @ofs@
+--
+-- if the source pointer is invalid (size or bad allocation), bad things will happen
+--
+copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty)
+            => Ptr ty                           -- ^ Source Ptr of 'ty' to start of memory
+            -> MutableBlock ty (PrimState prim) -- ^ Destination mutable block
+            -> Offset ty                        -- ^ Start offset in the destination mutable block
+            -> CountOf ty                       -- ^ Number of 'ty' elements
+            -> prim ()
+copyFromPtr src@(Ptr src#) mb@(MutableBlock mba) ofs count
+    | end > sizeAsOffset arrSz = primOutOfBound OOB_MemCopy end arrSz
+    | otherwise                = primitive $ \st -> (# copyAddrToByteArray# src# mba od# bytes# st, () #)
+  where
+    end = od `offsetPlusE` arrSz
+
+    sz = primSizeInBytes (Proxy :: Proxy ty)
+    !arrSz@(CountOf (I# bytes#)) = sizeOfE sz count
+    !od@(Offset (I# od#)) = offsetOfE sz ofs
+
+-- | Copy all the block content to the memory starting at the destination address
+--
+-- If the destination pointer is invalid (size or bad allocation), bad things will happen
+copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim)
+          => MutableBlock ty (PrimState prim) -- ^ The source mutable block to copy
+          -> Offset ty                        -- ^ The source offset in the mutable block
+          -> Ptr ty                           -- ^ The destination address where the copy is going to start
+          -> CountOf ty                       -- ^ The number of bytes
+          -> prim ()
+copyToPtr mb@(MutableBlock mba) ofs dst@(Ptr dst#) count
+    | srcEnd > sizeAsOffset arrSz = primOutOfBound OOB_MemCopy srcEnd arrSz
+    | otherwise                = do
+        blk <- unsafeFreeze mb
+        let !(Block ba) = blk
+        primitive $ \s1 -> (# copyByteArrayToAddr# ba os# dst# szBytes# s1, () #)
+  where
+    srcEnd = os `offsetPlusE` arrSz
+    !os@(Offset (I# os#)) = offsetInBytes ofs
+    !arrSz@(CountOf (I# szBytes#)) = mutableLengthBytes mb

bundled/Basement/BlockN.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Block
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+--
+-- A Nat-sized version of Block
+
+module Basement.BlockN (module X) where
+
+import Basement.Sized.Block as X

bundled/Basement/Bounded.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Block
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+--
+-- Types to represent ℤ/nℤ.
+--
+-- ℤ/nℤ is a finite field and is defined as the set of natural number:
+-- {0, 1, ..., n − 1}.
+--
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Basement.Bounded
+    ( Zn64
+    , unZn64
+    , Zn
+    , unZn
+    , zn64
+    , zn
+    , zn64Nat
+    , znNat
+    ) where
+
+import           GHC.TypeLits
+import           Data.Word
+import           Basement.Compat.Base
+import           Basement.Compat.Natural
+import           Basement.Numerical.Number
+import           Data.Proxy
+import           Basement.Nat
+import qualified Prelude
+
+-- | A type level bounded natural backed by a Word64
+newtype Zn64 (n :: Nat) = Zn64 { unZn64 :: Word64 }
+    deriving (Show,Eq,Ord)
+
+instance (KnownNat n, NatWithinBound Word64 n) => Prelude.Num (Zn64 n) where
+    fromInteger = zn64 . Prelude.fromInteger
+    (+) = add64
+    (-) = sub64
+    (*) = mul64
+    abs a = a
+    negate _ = error "cannot negate Zn64: use Foundation Numerical hierarchy for this function to not be exposed to Zn64"
+    signum (Zn64 a) = Zn64 (Prelude.signum a)
+
+type instance NatNumMaxBound (Zn64 n) = n
+
+instance (KnownNat n, NatWithinBound Word64 n) => Integral (Zn64 n) where
+    fromInteger = zn64 . Prelude.fromInteger
+instance (KnownNat n, NatWithinBound Word64 n) => IsIntegral (Zn64 n) where
+    toInteger (Zn64 n) = toInteger n
+instance (KnownNat n, NatWithinBound Word64 n) => IsNatural (Zn64 (n :: Nat)) where
+    toNatural (Zn64 n) = toNatural n
+
+-- | Create an element of ℤ/nℤ from a Word64
+--
+-- If the value is greater than n, then the value is normalized by using the
+-- integer modulus n
+zn64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Word64 -> Zn64 n
+zn64 v = Zn64 (v `Prelude.mod` natValWord64 (Proxy :: Proxy n))
+
+-- | Create an element of ℤ/nℤ from a type level Nat
+zn64Nat :: forall m n . (KnownNat m, KnownNat n, NatWithinBound Word64 m, NatWithinBound Word64 n, CmpNat m n ~ 'LT)
+        => Proxy m
+        -> Zn64 n
+zn64Nat p = Zn64 (natValWord64 p)
+
+-- | Add 2 Zn64
+add64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Zn64 n -> Zn64 n -> Zn64 n
+add64 (Zn64 a) (Zn64 b) = Zn64 ((a Prelude.+ b) `Prelude.mod` natValWord64 (Proxy :: Proxy n))
+
+-- | subtract 2 Zn64
+sub64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Zn64 n -> Zn64 n -> Zn64 n
+sub64 (Zn64 a) (Zn64 b) = Zn64 ((a Prelude.- b) `Prelude.mod` natValWord64 (Proxy :: Proxy n))
+
+-- | Multiply 2 Zn64
+mul64 :: forall n . (KnownNat n, NatWithinBound Word64 n) => Zn64 n -> Zn64 n -> Zn64 n
+mul64 (Zn64 a) (Zn64 b) = Zn64 ((a Prelude.* b) `Prelude.mod` natValWord64 (Proxy :: Proxy n))
+
+-- | A type level bounded natural
+newtype Zn (n :: Nat) = Zn { unZn :: Natural }
+    deriving (Show,Eq,Ord)
+
+instance KnownNat n => Prelude.Num (Zn n) where
+    fromInteger = zn . Prelude.fromInteger
+    (+) = add
+    (-) = sub
+    (*) = mul
+    abs a = a
+    negate _ = error "cannot negate Zn: use Foundation Numerical hierarchy for this function to not be exposed to Zn"
+    signum = Zn . Prelude.signum . unZn
+
+type instance NatNumMaxBound (Zn n) = n
+
+instance KnownNat n => Integral (Zn n) where
+    fromInteger = zn . Prelude.fromInteger
+instance KnownNat n => IsIntegral (Zn n) where
+    toInteger (Zn n) = toInteger n
+instance KnownNat n => IsNatural (Zn n) where
+    toNatural i = unZn i
+
+-- | Create an element of ℤ/nℤ from a Natural.
+--
+-- If the value is greater than n, then the value is normalized by using the
+-- integer modulus n
+zn :: forall n . KnownNat n => Natural -> Zn n
+zn v = Zn (v `Prelude.mod` natValNatural (Proxy :: Proxy n))
+
+-- | Create an element of ℤ/nℤ from a type level Nat
+znNat :: forall m n . (KnownNat m, KnownNat n, CmpNat m n ~ 'LT) => Proxy m -> Zn n
+znNat m = Zn (natValNatural m)
+
+-- | Add 2 Zn
+add :: forall n . KnownNat n => Zn n -> Zn n -> Zn n
+add (Zn a) (Zn b) = Zn ((a Prelude.+ b) `Prelude.mod` natValNatural (Proxy :: Proxy n))
+
+-- | subtract 2 Zn
+sub :: forall n . KnownNat n => Zn n -> Zn n -> Zn n
+sub (Zn a) (Zn b) = Zn ((a Prelude.- b) `Prelude.mod` natValNatural (Proxy :: Proxy n))
+
+-- | Multiply 2 Zn
+mul :: forall n . KnownNat n => Zn n -> Zn n -> Zn n
+mul (Zn a) (Zn b) = Zn ((a Prelude.* b) `Prelude.mod` natValNatural (Proxy :: Proxy n))
+

bundled/Basement/BoxedArray.hs

@@ -0,0 +1,781 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.BoxedArray
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Simple boxed array abstraction
+--
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+module Basement.BoxedArray
+    ( Array
+    , MArray
+    , empty
+    , length
+    , mutableLength
+    , copy
+    , unsafeCopyAtRO
+    , thaw
+    , new
+    , create
+    , unsafeFreeze
+    , unsafeThaw
+    , freeze
+    , unsafeWrite
+    , unsafeRead
+    , unsafeIndex
+    , write
+    , read
+    , index
+    , singleton
+    , replicate
+    , null
+    , take
+    , drop
+    , splitAt
+    , revTake
+    , revDrop
+    , revSplitAt
+    , splitOn
+    , sub
+    , intersperse
+    , span
+    , spanEnd
+    , break
+    , breakEnd
+    , mapFromUnboxed
+    , mapToUnboxed
+    , cons
+    , snoc
+    , uncons
+    , unsnoc
+    -- , findIndex
+    , sortBy
+    , filter
+    , reverse
+    , elem
+    , find
+    , foldl'
+    , foldr
+    , foldl1'
+    , foldr1
+    , all
+    , any
+    , isPrefixOf
+    , isSuffixOf
+    , builderAppend
+    , builderBuild
+    , builderBuild_
+    ) where
+
+import           GHC.Prim
+import           GHC.Types
+import           GHC.ST
+import           Data.Proxy
+import           Basement.Numerical.Additive
+import           Basement.Numerical.Subtractive
+import           Basement.NonEmpty
+import           Basement.Compat.Base
+import qualified Basement.Alg.Class as Alg
+import qualified Basement.Alg.Mutable as Alg
+import           Basement.Compat.MonadTrans
+import           Basement.Compat.Semigroup
+import           Basement.Compat.Primitive
+import           Basement.Types.OffsetSize
+import           Basement.PrimType
+import           Basement.NormalForm
+import           Basement.Monad
+import           Basement.UArray.Base (UArray)
+import qualified Basement.UArray.Base as UArray
+import           Basement.Exception
+import           Basement.MutableBuilder
+import qualified Basement.Compat.ExtList as List
+
+-- | Array of a
+data Array a = Array {-# UNPACK #-} !(Offset a)
+                     {-# UNPACK #-} !(CountOf a)
+                                    (Array# a)
+    deriving (Typeable)
+
+instance Data ty => Data (Array ty) where
+    dataTypeOf _ = arrayType
+    toConstr _   = error "toConstr"
+    gunfold _ _  = error "gunfold"
+
+arrayType :: DataType
+arrayType = mkNoRepType "Foundation.Array"
+
+instance NormalForm a => NormalForm (Array a) where
+    toNormalForm arr = loop 0
+      where
+        !sz = length arr
+        loop !i
+            | i .==# sz = ()
+            | otherwise = unsafeIndex arr i `seq` loop (i+1)
+
+-- | Mutable Array of a
+data MArray a st = MArray {-# UNPACK #-} !(Offset a)
+                          {-# UNPACK #-} !(CountOf a)
+                                         (MutableArray# st a)
+    deriving (Typeable)
+
+instance Functor Array where
+    fmap = map
+
+instance Semigroup (Array a) where
+    (<>) = append
+instance Monoid (Array a) where
+    mempty  = empty
+    mconcat = concat
+
+instance Show a => Show (Array a) where
+    show v = show (toList v)
+
+instance Eq a => Eq (Array a) where
+    (==) = equal
+instance Ord a => Ord (Array a) where
+    compare = vCompare
+
+instance IsList (Array ty) where
+    type Item (Array ty) = ty
+    fromList = vFromList
+    fromListN len = vFromListN (CountOf len)
+    toList = vToList
+
+-- | return the numbers of elements in a mutable array
+mutableLength :: MArray ty st -> Int
+mutableLength (MArray _ (CountOf len) _) = len
+{-# INLINE mutableLength #-}
+
+-- | return the numbers of elements in a mutable array
+mutableLengthSize :: MArray ty st -> CountOf ty
+mutableLengthSize (MArray _ size _) = size
+{-# INLINE mutableLengthSize #-}
+
+-- | Return the element at a specific index from an array.
+--
+-- If the index @n is out of bounds, an error is raised.
+index :: Array ty -> Offset ty -> ty
+index array n
+    | isOutOfBound n len = outOfBound OOB_Index n len
+    | otherwise          = unsafeIndex array n
+  where len = length array
+{-# INLINE index #-}
+
+-- | Return the element at a specific index from an array without bounds checking.
+--
+-- Reading from invalid memory can return unpredictable and invalid values.
+-- use 'index' if unsure.
+unsafeIndex :: Array ty -> Offset ty -> ty
+unsafeIndex (Array start _ a) ofs = primArrayIndex a (start+ofs)
+{-# INLINE unsafeIndex #-}
+
+-- | read a cell in a mutable array.
+--
+-- If the index is out of bounds, an error is raised.
+read :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty
+read array n
+    | isOutOfBound n len = primOutOfBound OOB_Read n len
+    | otherwise          = unsafeRead array n
+  where len = mutableLengthSize array
+{-# INLINE read #-}
+
+-- | read from a cell in a mutable array without bounds checking.
+--
+-- Reading from invalid memory can return unpredictable and invalid values.
+-- use 'read' if unsure.
+unsafeRead :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty
+unsafeRead (MArray start _ ma) i = primMutableArrayRead ma (start + i)
+{-# INLINE unsafeRead #-}
+
+-- | Write to a cell in a mutable array.
+--
+-- If the index is out of bounds, an error is raised.
+write :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim ()
+write array n val
+    | isOutOfBound n len = primOutOfBound OOB_Write n len
+    | otherwise          = unsafeWrite array n val
+  where len = mutableLengthSize array
+{-# INLINE write #-}
+
+-- | write to a cell in a mutable array without bounds checking.
+--
+-- Writing with invalid bounds will corrupt memory and your program will
+-- become unreliable. use 'write' if unsure.
+unsafeWrite :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim ()
+unsafeWrite (MArray start _ ma) ofs v =
+    primMutableArrayWrite ma (start + ofs) v
+{-# INLINE unsafeWrite #-}
+
+-- | Freeze a mutable array into an array.
+--
+-- the MArray must not be changed after freezing.
+unsafeFreeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty)
+unsafeFreeze (MArray ofs sz ma) = primitive $ \s1 ->
+    case unsafeFreezeArray# ma s1 of
+        (# s2, a #) -> (# s2, Array ofs sz a #)
+{-# INLINE unsafeFreeze #-}
+
+-- | Thaw an immutable array.
+--
+-- The Array must not be used after thawing.
+unsafeThaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim))
+unsafeThaw (Array ofs sz a) = primitive $ \st -> (# st, MArray ofs sz (unsafeCoerce# a) #)
+{-# INLINE unsafeThaw #-}
+
+-- | Thaw an array to a mutable array.
+--
+-- the array is not modified, instead a new mutable array is created
+-- and every values is copied, before returning the mutable array.
+thaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim))
+thaw array = do
+    m <- new (length array)
+    unsafeCopyAtRO m (Offset 0) array (Offset 0) (length array)
+    pure m
+{-# INLINE thaw #-}
+
+freeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty)
+freeze marray = do
+    m <- new sz
+    copyAt m (Offset 0) marray (Offset 0) sz
+    unsafeFreeze m
+  where
+    sz = mutableLengthSize marray
+
+-- | Copy the element to a new element array
+copy :: Array ty -> Array ty
+copy a = runST (unsafeThaw a >>= freeze)
+
+-- | Copy a number of elements from an array to another array with offsets
+copyAt :: PrimMonad prim
+       => MArray ty (PrimState prim) -- ^ destination array
+       -> Offset ty                  -- ^ offset at destination
+       -> MArray ty (PrimState prim) -- ^ source array
+       -> Offset ty                  -- ^ offset at source
+       -> CountOf ty                 -- ^ number of elements to copy
+       -> prim ()
+copyAt dst od src os n = loop od os
+  where -- !endIndex = os `offsetPlusE` n
+        loop d s
+            | s .==# n  = pure ()
+            | otherwise = unsafeRead src s >>= unsafeWrite dst d >> loop (d+1) (s+1)
+
+-- | Copy @n@ sequential elements from the specified offset in a source array
+--   to the specified position in a destination array.
+--
+--   This function does not check bounds. Accessing invalid memory can return
+--   unpredictable and invalid values.
+unsafeCopyAtRO :: PrimMonad prim
+               => MArray ty (PrimState prim) -- ^ destination array
+               -> Offset ty                  -- ^ offset at destination
+               -> Array ty                   -- ^ source array
+               -> Offset ty                  -- ^ offset at source
+               -> CountOf ty                    -- ^ number of elements to copy
+               -> prim ()
+unsafeCopyAtRO (MArray (Offset (I# dstart)) _ da) (Offset (I# dofs))
+               (Array  (Offset (I# sstart)) _ sa) (Offset (I# sofs))
+               (CountOf (I# n)) =
+    primitive $ \st ->
+        (# copyArray# sa (sstart +# sofs) da (dstart +# dofs) n st, () #)
+
+-- | Allocate a new array with a fill function that has access to the elements of
+--   the source array.
+unsafeCopyFrom :: Array ty -- ^ Source array
+               -> CountOf ty  -- ^ Length of the destination array
+               -> (Array ty -> Offset ty -> MArray ty s -> ST s ())
+               -- ^ Function called for each element in the source array
+               -> ST s (Array ty) -- ^ Returns the filled new array
+unsafeCopyFrom v' newLen f = new newLen >>= fill (Offset 0) f >>= unsafeFreeze
+  where len = length v'
+        endIdx = Offset 0 `offsetPlusE` len
+        fill i f' r'
+            | i == endIdx = pure r'
+            | otherwise   = do f' v' i r'
+                               fill (i + Offset 1) f' r'
+
+-- | Create a new mutable array of size @n.
+--
+-- all the cells are uninitialized and could contains invalid values.
+--
+-- All mutable arrays are allocated on a 64 bits aligned addresses
+-- and always contains a number of bytes multiples of 64 bits.
+new :: PrimMonad prim => CountOf ty -> prim (MArray ty (PrimState prim))
+new sz@(CountOf (I# n)) = primitive $ \s1 ->
+    case newArray# n (error "vector: internal error uninitialized vector") s1 of
+        (# s2, ma #) -> (# s2, MArray (Offset 0) sz ma #)
+
+-- | Create a new array of size @n by settings each cells through the
+-- function @f.
+create :: forall ty . CountOf ty -- ^ the size of the array
+       -> (Offset ty -> ty)   -- ^ the function that set the value at the index
+       -> Array ty            -- ^ the array created
+create n initializer = runST (new n >>= iter initializer)
+  where
+    iter :: PrimMonad prim => (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty)
+    iter f ma = loop 0
+      where
+        loop s
+            | s .==# n  = unsafeFreeze ma
+            | otherwise = unsafeWrite ma s (f s) >> loop (s+1)
+        {-# INLINE loop #-}
+    {-# INLINE iter #-}
+
+-----------------------------------------------------------------------
+-- higher level collection implementation
+-----------------------------------------------------------------------
+equal :: Eq a => Array a -> Array a -> Bool
+equal a b = (len == length b) && eachEqual 0
+  where
+    len = length a
+    eachEqual !i
+        | i .==# len                         = True
+        | unsafeIndex a i /= unsafeIndex b i = False
+        | otherwise                          = eachEqual (i+1)
+
+vCompare :: Ord a => Array a -> Array a -> Ordering
+vCompare a b = loop 0
+  where
+    !la = length a
+    !lb = length b
+    loop n
+        | n .==# la = if la == lb then EQ else LT
+        | n .==# lb = GT
+        | otherwise =
+            case unsafeIndex a n `compare` unsafeIndex b n of
+                EQ -> loop (n+1)
+                r  -> r
+
+empty :: Array a
+empty = runST $ onNewArray 0 (\_ s -> s)
+
+length :: Array a -> CountOf a
+length (Array _ sz _) = sz
+
+vFromList :: [a] -> Array a
+vFromList l = runST (new len >>= loop 0 l)
+  where
+    len = List.length l
+    loop _ []     ma = unsafeFreeze ma
+    loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma
+
+-- | just like vFromList but with a length hint.
+--
+-- The resulting array is guarantee to have been allocated to the length
+-- specified, but the slice might point to the initialized cells only in
+-- case the length is bigger than the list.
+--
+-- If the length is too small, then the list is truncated.
+--
+vFromListN :: forall a . CountOf a -> [a] -> Array a
+vFromListN len l = runST $ do
+    ma <- new len
+    sz <- loop 0 l ma
+    unsafeFreezeShrink ma sz
+  where
+    -- TODO rewrite without ma as parameter
+    loop :: Offset a -> [a] -> MArray a s -> ST s (CountOf a)
+    loop i []     _  = return (offsetAsSize i)
+    loop i (x:xs) ma
+        | i .==# len = return (offsetAsSize i)
+        | otherwise  = unsafeWrite ma i x >> loop (i+1) xs ma
+
+vToList :: Array a -> [a]
+vToList v
+    | len == 0  = []
+    | otherwise = fmap (unsafeIndex v) [0..sizeLastOffset len]
+  where !len = length v
+
+-- | Append 2 arrays together by creating a new bigger array
+append :: Array ty -> Array ty -> Array ty
+append a b = runST $ do
+    r  <- new (la+lb)
+    unsafeCopyAtRO r (Offset 0) a (Offset 0) la
+    unsafeCopyAtRO r (sizeAsOffset la) b (Offset 0) lb
+    unsafeFreeze r
+  where la = length a
+        lb = length b
+
+concat :: [Array ty] -> Array ty
+concat l = runST $ do
+    r <- new (mconcat $ fmap length l)
+    loop r (Offset 0) l
+    unsafeFreeze r
+  where loop _ _ []     = pure ()
+        loop r i (x:xs) = do
+            unsafeCopyAtRO r i x (Offset 0) lx
+            loop r (i `offsetPlusE` lx) xs
+          where lx = length x
+
+{-
+modify :: PrimMonad m
+       => Array a
+       -> (MArray (PrimState m) a -> m ())
+       -> m (Array a)
+modify (Array a) f = primitive $ \st -> do
+    case thawArray# a 0# (sizeofArray# a) st of
+        (# st2, mv #) ->
+            case internal_ (f $ MArray mv) st2 of
+                st3 ->
+                    case unsafeFreezeArray# mv st3 of
+                        (# st4, a' #) -> (# st4, Array a' #)
+-}
+
+-----------------------------------------------------------------------
+-- helpers
+
+onNewArray :: PrimMonad m
+           => Int
+           -> (MutableArray# (PrimState m) a -> State# (PrimState m) -> State# (PrimState m))
+           -> m (Array a)
+onNewArray len@(I# len#) f = primitive $ \st -> do
+    case newArray# len# (error "onArray") st of { (# st2, mv #) ->
+    case f mv st2                            of { st3           ->
+    case unsafeFreezeArray# mv st3           of { (# st4, a #)  ->
+        (# st4, Array (Offset 0) (CountOf len) a #) }}}
+
+-----------------------------------------------------------------------
+
+
+null :: Array ty -> Bool
+null = (==) 0 . length
+
+take :: CountOf ty -> Array ty -> Array ty
+take nbElems a@(Array start len arr)
+    | nbElems <= 0 = empty
+    | n == len     = a
+    | otherwise    = Array start n arr
+  where
+    n = min nbElems len
+
+drop :: CountOf ty -> Array ty -> Array ty
+drop nbElems a@(Array start len arr)
+    | nbElems <= 0                               = a
+    | Just nbTails <- len - nbElems, nbTails > 0 = Array (start `offsetPlusE` nbElems) nbTails arr
+    | otherwise                                  = empty
+
+splitAt :: CountOf ty -> Array ty -> (Array ty, Array ty)
+splitAt nbElems a@(Array start len arr)
+    | nbElems <= 0 = (empty, a)
+    | Just nbTails <- len - nbElems, nbTails > 0 = ( Array start                         nbElems arr
+                                                   , Array (start `offsetPlusE` nbElems) nbTails arr)
+    | otherwise = (a, empty)
+
+-- inverse a CountOf that is specified from the end (e.g. take n elements from the end)
+countFromStart :: Array ty -> CountOf ty -> CountOf ty
+countFromStart v sz@(CountOf sz')
+    | sz >= len = CountOf 0
+    | otherwise = CountOf (len' - sz')
+  where len@(CountOf len') = length v
+
+revTake :: CountOf ty -> Array ty -> Array ty
+revTake n v = drop (countFromStart v n) v
+
+revDrop :: CountOf ty -> Array ty -> Array ty
+revDrop n v = take (countFromStart v n) v
+
+revSplitAt :: CountOf ty -> Array ty -> (Array ty, Array ty)
+revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n
+
+splitOn ::  (ty -> Bool) -> Array ty -> [Array ty]
+splitOn predicate vec
+    | len == CountOf 0 = [mempty]
+    | otherwise     = loop (Offset 0) (Offset 0)
+  where
+    !len = length vec
+    !endIdx = Offset 0 `offsetPlusE` len
+    loop prevIdx idx
+        | idx == endIdx = [sub vec prevIdx idx]
+        | otherwise     =
+            let e = unsafeIndex vec idx
+                idx' = idx + 1
+             in if predicate e
+                    then sub vec prevIdx idx : loop idx' idx'
+                    else loop prevIdx idx'
+
+sub :: Array ty -> Offset ty -> Offset ty -> Array ty
+sub (Array start len a) startIdx expectedEndIdx
+    | startIdx == endIdx           = empty
+    | otherwise                    = Array (start + startIdx) newLen a
+  where
+    newLen = endIdx - startIdx
+    endIdx = min expectedEndIdx (sizeAsOffset len)
+
+break ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty)
+break predicate v = findBreak 0
+  where
+    !len = length v
+    findBreak i
+        | i .==# len  = (v, empty)
+        | otherwise   =
+            if predicate (unsafeIndex v i)
+                then splitAt (offsetAsSize i) v
+                else findBreak (i+1)
+
+breakEnd ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty)
+breakEnd predicate v = findBreak (sizeAsOffset len)
+  where
+    !len = length v
+    findBreak !i
+        | i == 0      = (v, empty)
+        | predicate e = splitAt (offsetAsSize i) v
+        | otherwise   = findBreak i'
+      where
+        e = unsafeIndex v i'
+        i' = i `offsetSub` 1
+
+intersperse :: ty -> Array ty -> Array ty
+intersperse sep v = case len - 1 of
+    Nothing -> v
+    Just 0 -> v
+    Just more -> runST $ unsafeCopyFrom v (len + more) (go (Offset 0 `offsetPlusE` more) sep)
+  where len = length v
+        -- terminate 1 before the end
+
+        go :: Offset ty -> ty -> Array ty -> Offset ty -> MArray ty s -> ST s ()
+        go endI sep' oldV oldI newV
+            | oldI == endI = unsafeWrite newV dst e
+            | otherwise    = do
+                unsafeWrite newV dst e
+                unsafeWrite newV (dst + 1) sep'
+          where
+            e = unsafeIndex oldV oldI
+            dst = oldI + oldI
+
+span ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty)
+span p = break (not . p)
+
+spanEnd ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty)
+spanEnd p = breakEnd (not . p)
+
+map :: (a -> b) -> Array a -> Array b
+map f a = create (sizeCast Proxy $ length a) (\i -> f $ unsafeIndex a (offsetCast Proxy i))
+
+mapFromUnboxed :: PrimType a => (a -> b) -> UArray a -> Array b
+mapFromUnboxed f arr = vFromListN (sizeCast Proxy $ UArray.length arr) . fmap f . toList $ arr
+
+mapToUnboxed :: PrimType b => (a -> b) -> Array a -> UArray b
+mapToUnboxed f arr = UArray.vFromListN (sizeCast Proxy $ length arr) . fmap f . toList $ arr
+
+{-
+mapIndex :: (Int -> a -> b) -> Array a -> Array b
+mapIndex f a = create (length a) (\i -> f i $ unsafeIndex a i)
+-}
+
+singleton :: ty -> Array ty
+singleton e = runST $ do
+    a <- new 1
+    unsafeWrite a 0 e
+    unsafeFreeze a
+
+replicate :: CountOf ty -> ty -> Array ty
+replicate sz ty = create sz (const ty)
+
+cons :: ty -> Array ty -> Array ty
+cons e vec
+    | len == CountOf 0 = singleton e
+    | otherwise     = runST $ do
+        mv <- new (len + CountOf 1)
+        unsafeWrite mv 0 e
+        unsafeCopyAtRO mv (Offset 1) vec (Offset 0) len
+        unsafeFreeze mv
+  where
+    !len = length vec
+
+snoc ::  Array ty -> ty -> Array ty
+snoc vec e
+    | len == 0  = singleton e
+    | otherwise = runST $ do
+        mv <- new (len + 1)
+        unsafeCopyAtRO mv 0 vec 0 len
+        unsafeWrite mv (sizeAsOffset len) e
+        unsafeFreeze mv
+  where
+    !len = length vec
+
+uncons :: Array ty -> Maybe (ty, Array ty)
+uncons vec
+    | len == 0  = Nothing
+    | otherwise = Just (unsafeIndex vec 0, drop 1 vec)
+  where
+    !len = length vec
+
+unsnoc :: Array ty -> Maybe (Array ty, ty)
+unsnoc vec = case len - 1 of
+    Nothing -> Nothing
+    Just newLen -> Just (take newLen vec, unsafeIndex vec (sizeLastOffset len))
+  where
+    !len = length vec
+
+elem :: Eq ty => ty -> Array ty -> Bool
+elem !ty arr = loop 0
+  where
+    !sz = length arr
+    loop !i | i .==# sz = False
+            | t == ty   = True
+            | otherwise = loop (i+1)
+      where t = unsafeIndex arr i
+
+find :: (ty -> Bool) -> Array ty -> Maybe ty
+find predicate vec = loop 0
+  where
+    !len = length vec
+    loop i
+        | i .==# len = Nothing
+        | otherwise  =
+            let e = unsafeIndex vec i
+             in if predicate e then Just e else loop (i+1)
+
+instance (PrimMonad prim, st ~ PrimState prim) 
+         => Alg.RandomAccess (MArray ty st) prim ty where
+    read (MArray _ _ mba) = primMutableArrayRead mba
+    write (MArray _ _ mba) = primMutableArrayWrite mba
+
+sortBy :: forall ty . (ty -> ty -> Ordering) -> Array ty -> Array ty
+sortBy xford vec
+    | len == 0  = empty
+    | otherwise = runST (thaw vec >>= doSort xford)
+  where
+    len = length vec
+    doSort :: PrimMonad prim => (ty -> ty -> Ordering) -> MArray ty (PrimState prim) -> prim (Array ty)
+    doSort ford ma = Alg.inplaceSortBy ford 0 len ma >> unsafeFreeze ma
+
+filter :: forall ty . (ty -> Bool) -> Array ty -> Array ty
+filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec))
+  where
+    !len = length vec
+    copyFilterFreeze :: PrimMonad prim => (ty -> Bool) -> (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty)
+    copyFilterFreeze predi getVec mvec = loop (Offset 0) (Offset 0) >>= freezeUntilIndex mvec
+      where
+        loop d s
+            | s .==# len  = pure d
+            | predi v     = unsafeWrite mvec d v >> loop (d+1) (s+1)
+            | otherwise   = loop d (s+1)
+          where
+            v = getVec s
+
+freezeUntilIndex :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim (Array ty)
+freezeUntilIndex mvec d = do
+    m <- new (offsetAsSize d)
+    copyAt m (Offset 0) mvec (Offset 0) (offsetAsSize d)
+    unsafeFreeze m
+
+unsafeFreezeShrink :: PrimMonad prim => MArray ty (PrimState prim) -> CountOf ty -> prim (Array ty)
+unsafeFreezeShrink (MArray start _ ma) n = unsafeFreeze (MArray start n ma)
+
+reverse :: Array ty -> Array ty
+reverse a = create len toEnd
+  where
+    len@(CountOf s) = length a
+    toEnd (Offset i) = unsafeIndex a (Offset (s - 1 - i))
+
+foldr :: (ty -> a -> a) -> a -> Array ty -> a
+foldr f initialAcc vec = loop 0
+  where
+    len = length vec
+    loop !i
+        | i .==# len = initialAcc
+        | otherwise  = unsafeIndex vec i `f` loop (i+1)
+
+foldl' :: (a -> ty -> a) -> a -> Array ty -> a
+foldl' f initialAcc vec = loop 0 initialAcc
+  where
+    len = length vec
+    loop !i !acc
+        | i .==# len = acc
+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))
+
+foldl1' :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty
+foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr
+               in foldl' f (unsafeIndex initialAcc 0) rest
+
+foldr1 :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty
+foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr
+               in foldr f (unsafeIndex initialAcc 0) rest
+
+all :: (ty -> Bool) -> Array ty -> Bool
+all p ba = loop 0
+  where
+    len = length ba
+    loop !i
+      | i .==# len = True
+      | not $ p (unsafeIndex ba i) = False
+      | otherwise = loop (i + 1)
+
+any :: (ty -> Bool) -> Array ty -> Bool
+any p ba = loop 0
+  where
+    len = length ba
+    loop !i
+      | i .==# len = False
+      | p (unsafeIndex ba i) = True
+      | otherwise = loop (i + 1)
+
+isPrefixOf :: Eq ty => Array ty -> Array ty -> Bool
+isPrefixOf pre arr
+    | pLen > pArr = False
+    | otherwise   = pre == take pLen arr
+  where
+    !pLen = length pre
+    !pArr = length arr
+
+isSuffixOf :: Eq ty => Array ty -> Array ty -> Bool
+isSuffixOf suffix arr
+    | pLen > pArr = False
+    | otherwise   = suffix == revTake pLen arr
+  where
+    !pLen = length suffix
+    !pArr = length arr
+
+builderAppend :: PrimMonad state => ty -> Builder (Array ty) (MArray ty) ty state err ()
+builderAppend v = Builder $ State $ \(i, st, e) ->
+    if i .==# chunkSize st
+        then do
+            cur      <- unsafeFreeze (curChunk st)
+            newChunk <- new (chunkSize st)
+            unsafeWrite newChunk 0 v
+            pure ((), (Offset 1, st { prevChunks     = cur : prevChunks st
+                                      , prevChunksSize = chunkSize st + prevChunksSize st
+                                      , curChunk       = newChunk
+                                      }, e))
+        else do
+            unsafeWrite (curChunk st) i v
+            pure ((), (i+1, st, e))
+
+builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m err () -> m (Either err (Array ty))
+builderBuild sizeChunksI ab
+    | sizeChunksI <= 0 = builderBuild 64 ab
+    | otherwise        = do
+        first      <- new sizeChunks
+        (i, st, e) <- snd <$> runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing)
+        case e of
+          Just err -> pure (Left err)
+          Nothing -> do
+            cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)
+            -- Build final array
+            let totalSize = prevChunksSize st + offsetAsSize i
+            bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze
+            pure (Right bytes)
+  where
+    sizeChunks = CountOf sizeChunksI
+
+    fillFromEnd _    []     mua = pure mua
+    fillFromEnd !end (x:xs) mua = do
+        let sz = length x
+        let start = end `sizeSub` sz
+        unsafeCopyAtRO mua (sizeAsOffset start) x (Offset 0) sz
+        fillFromEnd start xs mua
+
+builderBuild_ :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m () () -> m (Array ty)
+builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab

bundled/Basement/Cast.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE DefaultSignatures     #-}
+{-# LANGUAGE MagicHash             #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators         #-}
+-- |
+-- Module      : Basement.Cast
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+--
+module Basement.Cast
+    ( Cast(..)
+    ) where
+
+#include "MachDeps.h"
+
+import qualified Basement.Block.Base as Block
+import           Basement.Compat.Base
+import           Basement.Compat.Natural
+import           Basement.Compat.Primitive
+import           Basement.Numerical.Number
+import           Basement.Numerical.Conversion
+import           Basement.PrimType
+
+import           Data.Proxy (Proxy(..))
+
+import           GHC.Int
+import           GHC.Prim
+import           GHC.Types
+import           GHC.ST
+import           GHC.Word
+
+-- | `Cast` an object of type a to b.
+--
+-- Do not add instance of this class if the source type is not of the same
+-- size of the destination type. Also keep in mind this is casting a value
+-- of a given type into a destination type. The value won't be changed to
+-- fit the destination represention.
+--
+-- If you wish to convert a value of a given type into another type, look at
+-- `From` and `TryFrom`.
+--
+-- @
+-- cast (-10 :: Int) :: Word === 18446744073709551606
+-- @
+--
+class Cast source destination where
+    cast :: source -> destination
+
+    default cast :: ( PrimType source
+                    , PrimType destination
+                    , PrimSize source ~ PrimSize destination
+                    )
+                 => source -> destination
+    cast a = runST $ do
+        mba <- Block.new 1
+        Block.unsafeWrite mba 0 a
+        Block.unsafeRead (Block.unsafeRecast mba) 0
+
+instance Cast Int8  Word8 where
+    cast (I8# i) = W8# (wordToWord8# (int2Word# (int8ToInt# i)))
+instance Cast Int16 Word16 where
+    cast (I16# i) = W16# (wordToWord16# (int2Word# (int16ToInt# i)))
+instance Cast Int32 Word32 where
+    cast (I32# i) = W32# (wordToWord32# (int2Word# (int32ToInt# i)))
+instance Cast Int64 Word64 where
+    cast = int64ToWord64
+instance Cast Int   Word where
+    cast (I# i) = W# (int2Word# i)
+
+instance Cast Word8  Int8 where
+    cast (W8# i) = I8# (intToInt8# (word2Int# (word8ToWord# i)))
+instance Cast Word16 Int16 where
+    cast (W16# i) = I16# (intToInt16# (word2Int# (word16ToWord# i)))
+instance Cast Word32 Int32 where
+    cast (W32# i) = I32# (intToInt32# (word2Int# (word32ToWord# i)))
+instance Cast Word64 Int64 where
+    cast = word64ToInt64
+instance Cast Word   Int where
+    cast (W# w) = I# (word2Int# w)
+
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+instance Cast Word   Word64 where
+    cast (W# w) = W64# (wordToWord64# w)
+instance Cast Word64 Word where
+    cast (W64# w) = W# (GHC.Prim.word64ToWord# w)
+
+instance Cast Word   Int64 where
+    cast (W# w) = I64# (intToInt64# (word2Int# w))
+instance Cast Int64  Word where
+    cast (I64# i) = W# (int2Word# (int64ToInt# i))
+
+instance Cast Int    Int64 where
+    cast (I# i) = I64# (intToInt64# i)
+instance Cast Int64  Int where
+    cast (I64# i) = I# (int64ToInt# i)
+
+instance Cast Int    Word64 where
+    cast (I# i) = W64# (wordToWord64# (int2Word# i))
+instance Cast Word64 Int where
+    cast (W64# w) = I# (word2Int# (GHC.Prim.word64ToWord# w))
+#else
+instance Cast Word   Word64 where
+    cast (W# w) = W64# w
+instance Cast Word64 Word where
+    cast (W64# w) = W# w
+
+instance Cast Word   Int64 where
+    cast (W# w) = I64# (word2Int# w)
+instance Cast Int64  Word where
+    cast (I64# i) = W# (int2Word# i)
+
+instance Cast Int    Int64 where
+    cast (I# i) = I64# i
+instance Cast Int64  Int where
+    cast (I64# i) = I# i
+
+instance Cast Int    Word64 where
+    cast (I# i) = W64# (int2Word# i)
+instance Cast Word64 Int where
+    cast (W64# w) = I# (word2Int# w)
+#endif
+#else
+instance Cast Word   Word32 where
+    cast (W# w) = W32# (wordToWord32# w)
+instance Cast Word32 Word where
+    cast (W32# w) = W# (word32ToWord# w)
+
+instance Cast Word   Int32 where
+    cast (W# w) = I32# (intToInt32# (word2Int# w))
+instance Cast Int32  Word where
+    cast (I32# i) = W# (int2Word# (int32ToInt# i))
+
+instance Cast Int    Int32 where
+    cast (I# i) = I32# (intToInt32# i)
+instance Cast Int32  Int where
+    cast (I32# i) = I# (int32ToInt# i)
+
+instance Cast Int    Word32 where
+    cast (I# i) = W32# (wordToWord32# (int2Word# i))
+instance Cast Word32 Int where
+    cast (W32# w) = I# (word2Int# (word32ToWord# w))
+#endif
+
+instance Cast (Block.Block a) (Block.Block Word8) where
+    cast (Block.Block ba) = Block.Block ba

bundled/Basement/Compat/AMP.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE ConstraintKinds #-}
+-- a compat module for ghc < 7.10 to handle the AMP change smoothly
+module Basement.Compat.AMP
+    ( AMPMonad
+    ) where
+
+import Basement.Compat.Base
+
+{-# DEPRECATED AMPMonad "use Monad" #-}
+type AMPMonad m = Monad m

bundled/Basement/Compat/Base.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Base
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- internal re-export of all the good base bits
+module Basement.Compat.Base
+    ( (Prelude.$)
+    , (Prelude.$!)
+    , (Prelude.&&)
+    , (Prelude.||)
+    , (Control.Category..)
+    , (Control.Applicative.<$>)
+    , Prelude.not
+    , Prelude.otherwise
+    , Prelude.fst
+    , Prelude.snd
+    , Control.Category.id
+    , Prelude.maybe
+    , Prelude.either
+    , Prelude.flip
+    , Prelude.const
+    , Prelude.error
+    , Prelude.and
+    , Prelude.undefined
+    , Prelude.seq
+    , Prelude.Show (..)
+    , Prelude.Ord (..)
+    , Prelude.Eq (..)
+    , Prelude.Bounded (..)
+    , Prelude.Enum (..)
+    , Prelude.Functor (..)
+    , Control.Applicative.Applicative (..)
+    , Prelude.Monad (..)
+    , Control.Monad.when
+    , Control.Monad.unless
+    , Prelude.Maybe (..)
+    , Prelude.Ordering (..)
+    , Prelude.Bool (..)
+    , Prelude.Int
+    , Prelude.Integer
+    , Prelude.Char
+    , Basement.Compat.NumLiteral.Integral (..)
+    , Basement.Compat.NumLiteral.Fractional (..)
+    , Basement.Compat.NumLiteral.HasNegation (..)
+    , Data.Int.Int8, Data.Int.Int16, Data.Int.Int32, Data.Int.Int64
+    , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word
+    , Prelude.Double, Prelude.Float
+    , Prelude.IO
+    , Basement.Compat.IsList.IsList (..)
+    , GHC.Exts.IsString (..)
+    , GHC.Generics.Generic
+    , Prelude.Either (..)
+    , Data.Data.Data (..)
+    , Data.Data.mkNoRepType
+    , Data.Data.DataType
+    , Basement.Compat.Typeable.Typeable
+    , Data.Monoid.Monoid (..)
+    , (Data.Monoid.<>)
+    , Control.Exception.Exception
+    , Control.Exception.throw
+    , Control.Exception.throwIO
+    , GHC.Ptr.Ptr(..)
+    , ifThenElse
+    , internalError
+    ) where
+
+import qualified Prelude
+import qualified Control.Category
+import qualified Control.Applicative
+import qualified Control.Exception
+import qualified Control.Monad
+import qualified Data.Monoid
+import qualified Data.Data
+import qualified Data.Word
+import qualified Data.Int
+import qualified Basement.Compat.IsList
+import qualified Basement.Compat.NumLiteral
+import qualified Basement.Compat.Typeable
+import qualified GHC.Exts
+import qualified GHC.Generics
+import qualified GHC.Ptr
+import           GHC.Exts (fromString)
+
+-- | Only to use internally for internal error cases
+internalError :: [Prelude.Char] -> a
+internalError s = Prelude.error ("Internal Error: the impossible happened: " Prelude.++ s)
+
+-- | for support of if .. then .. else
+ifThenElse :: Prelude.Bool -> a -> a -> a
+ifThenElse Prelude.True  e1 _  = e1
+ifThenElse Prelude.False _  e2 = e2

bundled/Basement/Compat/Bifunctor.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Bifunctor
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A bifunctor is a type constructor that takes
+-- two type arguments and is a functor in /both/ arguments. That
+-- is, unlike with 'Functor', a type constructor such as 'Either'
+-- does not need to be partially applied for a 'Bifunctor'
+-- instance, and the methods in this class permit mapping
+-- functions over the 'Left' value or the 'Right' value,
+-- or both at the same time.
+--
+-- Formally, the class 'Bifunctor' represents a bifunctor
+-- from @Hask@ -> @Hask@.
+--
+-- Intuitively it is a bifunctor where both the first and second
+-- arguments are covariant.
+--
+-- You can define a 'Bifunctor' by either defining 'bimap' or by
+-- defining both 'first' and 'second'.
+--
+{-# LANGUAGE CPP #-}
+module Basement.Compat.Bifunctor
+  ( Bifunctor(..)
+  ) where
+
+#if MIN_VERSION_base(4,8,0)
+
+import Data.Bifunctor (Bifunctor(..))
+
+#else
+
+import           Control.Applicative ( Const(..) )
+import           GHC.Generics ( K1(..) )
+import qualified Prelude as P
+
+class Bifunctor p where
+    {-# MINIMAL bimap | first, second #-}
+
+    -- | Map over both arguments at the same time.
+    --
+    -- @'bimap' f g ≡ 'first' f '.' 'second' g@
+    --
+    -- ==== __Examples__
+    --
+    -- >>> bimap toUpper (+1) ('j', 3)
+    -- ('J',4)
+    --
+    -- >>> bimap toUpper (+1) (Left 'j')
+    -- Left 'J'
+    --
+    -- >>> bimap toUpper (+1) (Right 3)
+    -- Right 4
+    bimap :: (a -> b) -> (c -> d) -> p a c -> p b d
+    bimap f g = first f P.. second g
+
+    -- | Map covariantly over the first argument.
+    --
+    -- @'first' f ≡ 'bimap' f 'id'@
+    --
+    -- ==== __Examples__
+    --
+    -- >>> first toUpper ('j', 3)
+    -- ('J',3)
+    --
+    -- >>> first toUpper (Left 'j')
+    -- Left 'J'
+    first :: (a -> b) -> p a c -> p b c
+    first f = bimap f P.id
+
+    -- | Map covariantly over the second argument.
+    --
+    -- @'second' ≡ 'bimap' 'id'@
+    --
+    -- ==== __Examples__
+    -- >>> second (+1) ('j', 3)
+    -- ('j',4)
+    --
+    -- >>> second (+1) (Right 3)
+    -- Right 4
+    second :: (b -> c) -> p a b -> p a c
+    second = bimap P.id
+
+
+instance Bifunctor (,) where
+    bimap f g ~(a, b) = (f a, g b)
+
+instance Bifunctor ((,,) x1) where
+    bimap f g ~(x1, a, b) = (x1, f a, g b)
+
+instance Bifunctor ((,,,) x1 x2) where
+    bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b)
+
+instance Bifunctor ((,,,,) x1 x2 x3) where
+    bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b)
+
+instance Bifunctor ((,,,,,) x1 x2 x3 x4) where
+    bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b)
+
+instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where
+    bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b)
+
+
+instance Bifunctor P.Either where
+    bimap f _ (P.Left a) = P.Left (f a)
+    bimap _ g (P.Right b) = P.Right (g b)
+
+instance Bifunctor Const where
+    bimap f _ (Const a) = Const (f a)
+
+instance Bifunctor (K1 i) where
+    bimap f _ (K1 c) = K1 (f c)
+
+#endif

bundled/Basement/Compat/C/Types.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# Language CPP #-}
+-- |
+-- Module      : Basement.Compat.C.Types
+-- License     : BSD-style
+-- Maintainer  : Foundation
+--
+-- Literal support for Integral and Fractional
+-- {-# LANGUAGE TypeSynonymInstances #-}
+-- {-# LANGUAGE FlexibleInstances #-}
+module Basement.Compat.C.Types
+    ( CChar(..), CSChar(..), CUChar(..)
+    , CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..)
+    , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..), CLLong(..), CULLong(..)
+#if MIN_VERSION_base(4,10,0)
+    , CBool(..)
+#endif
+    , CIntPtr(..), CUIntPtr(..), CIntMax(..), CUIntMax(..)
+    , CClock(..), CTime(..), CUSeconds(..), CSUSeconds(..), CFloat(..), CDouble
+    , COff(..), CMode(..)
+    ) where
+
+import Foreign.C.Types
+import System.Posix.Types

bundled/Basement/Compat/CallStack.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ConstraintKinds #-}
+module Basement.Compat.CallStack
+    ( HasCallStack
+    ) where
+
+#if MIN_VERSION_base(4,9,0)
+
+import GHC.Stack (HasCallStack)
+
+#elif MIN_VERSION_base(4,8,1)
+
+import qualified GHC.Stack
+
+type HasCallStack = (?callStack :: GHC.Stack.CallStack)
+
+#else
+
+import GHC.Exts (Constraint)
+
+type HasCallStack = (() :: Constraint)
+
+#endif

bundled/Basement/Compat/ExtList.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+module Basement.Compat.ExtList
+    ( length
+    , null
+    , sum
+    , reverse
+    , (!!)
+    ) where
+
+import Basement.Compat.Base
+import Basement.Numerical.Additive
+import Basement.Types.OffsetSize
+import qualified GHC.List as List
+
+-- | Compute the size of the list
+length :: [a] -> CountOf a
+#if MIN_VERSION_base(4,8,0)
+length = CountOf . List.foldl' (\c _ -> c+1) 0
+#else
+length = CountOf . loop 0
+  where loop !acc []     = acc
+        loop !acc (_:xs) = loop (1+acc) xs
+#endif
+
+null :: [a] -> Bool
+null []    = True
+null (_:_) = False
+
+-- | Sum the element in a list
+sum :: Additive n => [n] -> n
+sum []     = azero
+sum (i:is) = loop i is
+  where
+    loop !acc [] = acc
+    loop !acc (x:xs) = loop (acc+x) xs
+    {-# INLINE loop #-}
+
+reverse :: [a] -> [a]
+reverse l =  go l []
+  where
+    go []     acc = acc
+    go (x:xs) acc = go xs (x:acc)
+
+(!!) :: [a] -> Offset a -> a
+[]    !! _  = error "invalid offset for !!"
+(x:_) !! 0  = x
+(_:xs) !! i = xs !! pred i

bundled/Basement/Compat/Identity.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Identity
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Identity re-export, with a compat wrapper for older version of base that
+-- do not have Data.Functor.Identity
+{-# LANGUAGE CPP #-}
+module Basement.Compat.Identity
+    ( Identity(..)
+    ) where
+
+#if MIN_VERSION_base(4,8,0)
+
+import Data.Functor.Identity
+
+#else
+
+import Basement.Compat.Base
+
+newtype Identity a = Identity { runIdentity :: a }
+    deriving (Eq, Ord)
+
+instance Functor Identity where
+    fmap f (Identity a) = Identity (f a)
+
+instance Applicative Identity where
+    pure a = Identity a
+    (<*>) fab fa = Identity $ runIdentity fab (runIdentity fa)
+
+instance Monad Identity where
+    return    = pure
+    ma >>= mb = mb (runIdentity ma)
+
+#endif

bundled/Basement/Compat/IsList.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.IsList
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- compat friendly version of IsList
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+module Basement.Compat.IsList
+    ( IsList(..)
+    ) where
+
+#if MIN_VERSION_base(4,7,0)
+
+import           GHC.Exts
+
+#else
+
+import qualified Prelude
+
+class IsList l where
+  type Item l
+  fromList  :: [Item l] -> l
+  toList    :: l -> [Item l]
+
+  fromListN :: Prelude.Int -> [Item l] -> l
+  fromListN _ = fromList
+
+instance IsList [a] where
+    type Item [a] = a
+    fromList = Prelude.id
+    toList   = Prelude.id
+
+#endif

bundled/Basement/Compat/MonadTrans.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.MonadTrans
+-- License     : BSD-style
+-- Maintainer  : Psychohistorians
+-- Stability   : experimental
+-- Portability : portable
+--
+-- An internal and really simple monad transformers,
+-- without any bells and whistse.
+module Basement.Compat.MonadTrans
+    ( State(..)
+    , Reader(..)
+    ) where
+
+import Basement.Compat.Base
+import Control.Monad ((>=>))
+
+-- | Simple State monad
+newtype State s m a = State { runState :: s -> m (a, s) }
+
+instance Monad m => Functor (State s m) where
+    fmap f fa = State $ runState fa >=> (\(a, s2) -> return (f a, s2))
+instance Monad m => Applicative (State s m) where
+    pure a = State $ \st -> return (a,st)
+    fab <*> fa = State $ \s1 -> do
+        (ab,s2) <- runState fab s1
+        (a,s3)  <- runState fa s2
+        return (ab a, s3)
+instance Monad m => Monad (State r m) where
+    return = pure
+    ma >>= mb = State $ \s1 -> do
+        (a,s2) <- runState ma s1
+        runState (mb a) s2
+
+-- | Simple Reader monad
+newtype Reader r m a = Reader { runReader :: r -> m a }
+
+instance Monad m => Functor (Reader r m) where
+    fmap f fa = Reader $ runReader fa >=> (\a -> return (f a))
+instance Monad m => Applicative (Reader r m) where
+    pure a = Reader $ \_ -> return a
+    fab <*> fa = Reader $ \r -> do
+        a  <- runReader fa r
+        ab <- runReader fab r
+        return $ ab a
+instance Monad m => Monad (Reader r m) where
+    return = pure
+    ma >>= mb = Reader $ \r -> do
+        a <- runReader ma r
+        runReader (mb a) r

bundled/Basement/Compat/Natural.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Basement.Compat.Natural
+    ( Natural
+    , integerToNatural
+    , naturalToInteger
+    ) where
+
+#if MIN_VERSION_base(4,8,0)
+
+import Numeric.Natural
+import Prelude (Integer, abs, fromInteger, toInteger)
+
+#else
+
+import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise, toInteger)
+import Data.Bits
+import Data.Typeable
+
+newtype Natural = Natural Integer
+    deriving (Eq,Ord,Enum,Typeable,Bits)
+
+instance Show Natural where
+    show (Natural i) = show i
+
+-- re-create the buggy Num instance for Natural
+instance Num Natural where
+    fromInteger n
+        | n < 0     = error "natural should be positive: "
+        | otherwise = Natural n
+    (+) (Natural a) (Natural b) = Natural (a + b)
+    (-) (Natural a) (Natural b)
+        | r < 0     = error "natural should be positve"
+        | otherwise = Natural (a - b)
+      where r = (a - b)
+    (*) (Natural a) (Natural b) = Natural (a * b)
+    abs n = n
+    negate n = n
+    signum (Natural n)
+        | n > 0     = 1
+        | otherwise = 0
+
+instance Real Natural where
+    toRational (Natural n) = toRational n
+
+instance Integral Natural where
+    toInteger (Natural n) = n
+    divMod (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b)
+    quotRem (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b)
+    quot (Natural n) (Natural e) = Natural (n `quot` e)
+    rem (Natural n) (Natural e) = Natural (n `rem` e)
+    div = quot
+    mod = rem
+
+#endif
+
+integerToNatural :: Integer -> Natural
+integerToNatural i = fromInteger (abs i)
+
+naturalToInteger :: Natural -> Integer
+naturalToInteger n = toInteger n

bundled/Basement/Compat/NumLiteral.hs

@@ -0,0 +1,200 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# Language CPP #-}
+-- |
+-- Module      : Basement.Compat.NumLiteral
+-- License     : BSD-style
+-- Maintainer  : Foundation
+--
+-- Literal support for Integral and Fractional
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Basement.Compat.NumLiteral
+    ( Integral(..)
+    , Fractional(..)
+    , HasNegation(..)
+    ) where
+
+import           Prelude (Int, Integer, Rational, Float, Double)
+import           Data.Word (Word8, Word16, Word32, Word64, Word)
+import           Data.Int (Int8, Int16, Int32, Int64)
+import           Basement.Compat.C.Types
+import qualified Prelude
+import           Basement.Compat.Natural
+import           Foreign.Ptr (IntPtr)
+
+-- | Integral Literal support
+--
+-- e.g. 123 :: Integer
+--      123 :: Word8
+class Integral a where
+    fromInteger :: Integer -> a
+
+-- | Fractional Literal support
+--
+-- e.g. 1.2  :: Double
+--      0.03 :: Float
+class Fractional a where
+    fromRational :: Rational -> a
+
+-- | Negation support
+--
+-- e.g. -(f x)
+class HasNegation a where
+    negate :: a -> a
+
+instance Integral Integer where
+    fromInteger a = a
+instance Integral Natural where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word8 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word16 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word32 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word64 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int8 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int16 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int32 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int64 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral IntPtr where
+    fromInteger a = Prelude.fromInteger a
+
+instance Integral Float where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Double where
+    fromInteger a = Prelude.fromInteger a
+
+instance Integral CChar where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CSChar where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUChar where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CShort where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUShort where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CInt where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUInt where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CLong where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CULong where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CPtrdiff where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CSize where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CWchar where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CSigAtomic where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CLLong where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CULLong where
+    fromInteger a = Prelude.fromInteger a
+#if MIN_VERSION_base(4, 10, 0)
+instance Integral CBool where
+    fromInteger a = Prelude.fromInteger a
+#endif
+instance Integral CIntPtr where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUIntPtr where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CIntMax where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUIntMax where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CClock where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CTime where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUSeconds where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CSUSeconds where
+    fromInteger a = Prelude.fromInteger a
+instance Integral COff where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CFloat where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CDouble where
+    fromInteger a = Prelude.fromInteger a
+
+instance HasNegation Integer where
+    negate = Prelude.negate
+instance HasNegation Int where
+    negate = Prelude.negate
+instance HasNegation Int8 where
+    negate = Prelude.negate
+instance HasNegation Int16 where
+    negate = Prelude.negate
+instance HasNegation Int32 where
+    negate = Prelude.negate
+instance HasNegation Int64 where
+    negate = Prelude.negate
+instance HasNegation Word where
+    negate = Prelude.negate
+instance HasNegation Word8 where
+    negate = Prelude.negate
+instance HasNegation Word16 where
+    negate = Prelude.negate
+instance HasNegation Word32 where
+    negate = Prelude.negate
+instance HasNegation Word64 where
+    negate = Prelude.negate
+
+instance HasNegation Float where
+    negate = Prelude.negate
+instance HasNegation Double where
+    negate = Prelude.negate
+
+instance HasNegation CChar where
+    negate = Prelude.negate
+instance HasNegation CSChar where
+    negate = Prelude.negate
+instance HasNegation CShort where
+    negate = Prelude.negate
+instance HasNegation CInt where
+    negate = Prelude.negate
+instance HasNegation CLong where
+    negate = Prelude.negate
+instance HasNegation CPtrdiff where
+    negate = Prelude.negate
+instance HasNegation CWchar where
+    negate = Prelude.negate
+instance HasNegation CLLong where
+    negate = Prelude.negate
+instance HasNegation CIntMax where
+    negate = Prelude.negate
+
+instance HasNegation CFloat where
+    negate = Prelude.negate
+instance HasNegation CDouble where
+    negate = Prelude.negate
+
+instance Fractional Rational where
+    fromRational a = Prelude.fromRational a
+instance Fractional Float where
+    fromRational a = Prelude.fromRational a
+instance Fractional Double where
+    fromRational a = Prelude.fromRational a
+
+instance Fractional CFloat where
+    fromRational a = Prelude.fromRational a
+instance Fractional CDouble where
+    fromRational a = Prelude.fromRational a

bundled/Basement/Compat/PrimTypes.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.PrimTypes
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+{-# LANGUAGE MagicHash #-}
+module Basement.Compat.PrimTypes
+    ( FileSize#
+    , Offset#
+    , CountOf#
+    , Bool#
+    , Pinned#
+    ) where
+
+import GHC.Prim
+
+-- | File size in bytes
+type FileSize# = Word64#
+
+-- | Offset in a bytearray, string, type alias
+--
+-- for code documentation purpose only, just a simple type alias on Int#
+type Offset# = Int#
+
+-- | CountOf in bytes type alias
+--
+-- for code documentation purpose only, just a simple type alias on Int#
+type CountOf# = Int#
+
+-- | Lowlevel Boolean
+type Bool# = Int#
+
+-- | Pinning status
+type Pinned# = Bool#

bundled/Basement/Compat/Primitive.hs

@@ -0,0 +1,318 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Primitive
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+module Basement.Compat.Primitive
+    ( bool#
+    , PinnedStatus(..), toPinnedStatus#
+    , compatMkWeak#
+    , compatIsByteArrayPinned#
+    , compatIsMutableByteArrayPinned#
+    , unsafeCoerce#
+    , Word(..)
+    , Word8#
+    , Word16#
+    , Word32#
+    , Int8#
+    , Int16#
+    , Int32#
+    -- word upper sizing
+    , word8ToWord16#
+    , word8ToWord32#
+    , word8ToWord#
+    , word16ToWord8#
+    , word16ToWord32#
+    , word16ToWord#
+    , word32ToWord#
+    -- word down sizing
+    , word32ToWord8#
+    , word32ToWord16#
+    , wordToWord32#
+    , wordToWord16#
+    , wordToWord8#
+    -- int upper sizing
+    , int8ToInt16#
+    , int8ToInt32#
+    , int8ToInt#
+    , int16ToInt32#
+    , int16ToInt#
+    , int32ToInt#
+    -- int down sizing
+    , intToInt8#
+    , intToInt16#
+    , intToInt32#
+    -- other
+    , word8ToInt#
+    , word8ToInt16#
+    , word8ToInt32#
+    , charToWord32#
+    , word8ToChar#
+    , word16ToChar#
+    , word32ToChar#
+    , wordToChar#
+
+    -- word8 ops
+    , plusWord8#
+    -- word16 ops
+    , uncheckedShiftRLWord16#
+    , plusWord16#
+    -- word32 ops
+    , uncheckedShiftRLWord32#
+    , plusWord32#
+    -- int8 ops
+    , plusInt8#
+    -- int16 ops
+    , plusInt16#
+    -- int32 ops
+    , plusInt32#
+    ) where
+
+
+import qualified Prelude
+import           GHC.Exts hiding (Word8#, Word16#, Word32#, Int8#, Int16#, Int32#, plusWord8#, plusWord16#, plusInt8#, plusInt16#)
+import           GHC.Prim hiding (Word8#, Word16#, Word32#, Int8#, Int16#, Int32#, plusWord8#, plusWord16#, plusInt8#, plusInt16#)
+import           GHC.Word
+import           GHC.IO
+
+import           Basement.Compat.PrimTypes
+
+#if __GLASGOW_HASKELL__ >= 902
+import           GHC.Exts (Word8#, Word16#, Word32#, Int8#, Int16#, Int32#, plusWord8#, plusWord16#, plusInt8#, plusInt16#)
+#endif
+
+--  GHC 9.2  | Base 4.16
+--  GHC 9.0  | Base 4.15
+--  GHC 8.8  | Base 4.13 4.14
+--  GHC 8.6  | Base 4.12
+--  GHC 8.4  | Base 4.11
+--  GHC 8.2  | Base 4.10
+--  GHC 8.0  | Base 4.9
+--  GHC 7.10 | Base 4.8
+--  GHC 7.8  | Base 4.7
+--  GHC 7.6  | Base 4.6
+--  GHC 7.4  | Base 4.5
+--
+--  More complete list:
+--  https://wiki.haskell.org/Base_package
+
+-- | Flag record whether a specific byte array is pinned or not
+data PinnedStatus = Pinned | Unpinned
+    deriving (Prelude.Eq)
+
+toPinnedStatus# :: Pinned# -> PinnedStatus
+toPinnedStatus# 0# = Unpinned
+toPinnedStatus# _  = Pinned
+
+-- | turn an Int# into a Bool
+bool# :: Int# -> Prelude.Bool
+bool# v = isTrue# v
+{-# INLINE bool# #-}
+
+-- | A mkWeak# version that keep working on 8.0
+--
+-- signature change in ghc-prim:
+-- * 0.4: mkWeak# :: o -> b -> c                                             -> State# RealWorld -> (#State# RealWorld, Weak# b#)
+-- * 0.5 :mkWeak# :: o -> b -> (State# RealWorld -> (#State# RealWorld, c#)) -> State# RealWorld -> (#State# RealWorld, Weak# b#)
+--
+compatMkWeak# :: o -> b -> Prelude.IO () -> State# RealWorld -> (#State# RealWorld, Weak# b #)
+compatMkWeak# o b c s = mkWeak# o b (case c of { IO f -> f }) s
+{-# INLINE compatMkWeak# #-}
+
+#if __GLASGOW_HASKELL__ >= 802
+compatIsByteArrayPinned# :: ByteArray# -> Pinned#
+compatIsByteArrayPinned# ba = isByteArrayPinned# ba
+
+compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned#
+compatIsMutableByteArrayPinned# ba = isMutableByteArrayPinned# ba
+#else
+foreign import ccall unsafe "basement_is_bytearray_pinned"
+    compatIsByteArrayPinned# :: ByteArray# -> Pinned#
+
+foreign import ccall unsafe "basement_is_bytearray_pinned"
+    compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned#
+#endif
+
+#if __GLASGOW_HASKELL__ >= 902
+
+word8ToWord16# :: Word8# -> Word16#
+word8ToWord16# a = wordToWord16# (word8ToWord# a)
+
+word8ToWord32# :: Word8# -> Word32#
+word8ToWord32# a = wordToWord32# (word8ToWord# a)
+
+word16ToWord8# :: Word16# -> Word8#
+word16ToWord8# a = wordToWord8# (word16ToWord# a)
+
+word16ToWord32# :: Word16# -> Word32#
+word16ToWord32# a = wordToWord32# (word16ToWord# a)
+
+word32ToWord8# :: Word32# -> Word8#
+word32ToWord8# a = wordToWord8# (word32ToWord# a)
+
+word32ToWord16# :: Word32# -> Word16#
+word32ToWord16# a = wordToWord16# (word32ToWord# a)
+
+int8ToInt16# :: Int8# -> Int16#
+int8ToInt16# i = intToInt16# (int8ToInt# i)
+
+int8ToInt32# :: Int8# -> Int32#
+int8ToInt32# i = intToInt32# (int8ToInt# i)
+
+int16ToInt32# :: Int16# -> Int32#
+int16ToInt32# i = intToInt32# (int16ToInt# i)
+
+word8ToInt16# :: Word8# -> Int16#
+word8ToInt16# i = intToInt16# (word2Int# (word8ToWord# i))
+
+word8ToInt32# :: Word8# -> Int32#
+word8ToInt32# i = intToInt32# (word2Int# (word8ToWord# i))
+
+word8ToInt# :: Word8# -> Int#
+word8ToInt# i = word2Int# (word8ToWord# i)
+
+charToWord32# :: Char# -> Word32#
+charToWord32# ch = wordToWord32# (int2Word# (ord# ch))
+
+word8ToChar# :: Word8# -> Char#
+word8ToChar# ch = chr# (word2Int# (word8ToWord# ch))
+
+word16ToChar# :: Word16# -> Char#
+word16ToChar# ch = chr# (word2Int# (word16ToWord# ch))
+
+word32ToChar# :: Word32# -> Char#
+word32ToChar# ch = chr# (word2Int# (word32ToWord# ch))
+
+wordToChar# :: Word# -> Char#
+wordToChar# ch = chr# (word2Int# ch)
+
+#else
+type Word8# = Word#
+type Word16# = Word#
+type Word32# = Word#
+
+type Int8# = Int#
+type Int16# = Int#
+type Int32# = Int#
+
+word8ToWord16# :: Word8# -> Word16#
+word8ToWord16# a = a
+
+word8ToWord32# :: Word8# -> Word32#
+word8ToWord32# a = a
+
+word8ToWord# :: Word8# -> Word#
+word8ToWord# a = a
+
+word16ToWord32# :: Word16# -> Word32#
+word16ToWord32# a = a
+
+word16ToWord8# :: Word16# -> Word8#
+word16ToWord8# w = narrow8Word# w
+
+word16ToWord# :: Word16# -> Word#
+word16ToWord# a = a
+
+word32ToWord8# :: Word32# -> Word8#
+word32ToWord8# w = narrow8Word# w
+
+word32ToWord16# :: Word32# -> Word16#
+word32ToWord16# w = narrow16Word# w
+
+word32ToWord# :: Word32# -> Word#
+word32ToWord# a = a
+
+wordToWord32# :: Word# -> Word32#
+wordToWord32# w = narrow32Word# w
+
+wordToWord16# :: Word# -> Word16#
+wordToWord16# w = narrow16Word# w
+
+wordToWord8# :: Word# -> Word8#
+wordToWord8# w = narrow8Word# w
+
+charToWord32# :: Char# -> Word32#
+charToWord32# ch = int2Word# (ord# ch)
+
+word8ToInt16# :: Word8# -> Int16#
+word8ToInt16# w = word2Int# w
+
+word8ToInt32# :: Word8# -> Int32#
+word8ToInt32# w = word2Int# w
+
+word8ToInt# :: Word8# -> Int#
+word8ToInt# w = word2Int# w
+
+word8ToChar# :: Word8# -> Char#
+word8ToChar# w = chr# (word2Int# w)
+
+word16ToChar# :: Word16# -> Char#
+word16ToChar# w = chr# (word2Int# w)
+
+word32ToChar# :: Word32# -> Char#
+word32ToChar# w = chr# (word2Int# w)
+
+wordToChar# :: Word# -> Char#
+wordToChar# ch = chr# (word2Int# ch)
+
+int8ToInt16# :: Int8# -> Int16#
+int8ToInt16# a = a
+
+int8ToInt32# :: Int8# -> Int32#
+int8ToInt32# a = a
+
+int8ToInt# :: Int8# -> Int#
+int8ToInt# a = a
+
+int16ToInt32# :: Int16# -> Int32#
+int16ToInt32# a = a
+
+int16ToInt# :: Int16# -> Int#
+int16ToInt# a = a
+
+int32ToInt# :: Int32# -> Int#
+int32ToInt# a = a
+
+intToInt8# :: Int# -> Int8#
+intToInt8# i = narrow8Int# i
+
+intToInt16# :: Int# -> Int16#
+intToInt16# i = narrow16Int# i
+
+intToInt32# :: Int# -> Int32#
+intToInt32# i = narrow32Int# i
+
+uncheckedShiftRLWord16# = uncheckedShiftRL#
+
+uncheckedShiftRLWord32# = uncheckedShiftRL#
+
+plusWord8# :: Word8# -> Word8# -> Word8#
+plusWord8# a b = narrow8Word# (plusWord# a b)
+
+plusWord16# :: Word16# -> Word16# -> Word16#
+plusWord16# a b = narrow16Word# (plusWord# a b)
+
+plusWord32# :: Word32# -> Word32# -> Word32#
+plusWord32# a b = narrow32Word# (plusWord# a b)
+
+plusInt8# :: Int8# -> Int8# -> Int8#
+plusInt8# a b = narrow8Int# (a +# b)
+
+plusInt16# :: Int16# -> Int16# -> Int16#
+plusInt16# a b = narrow16Int# (a +# b)
+
+plusInt32# :: Int32# -> Int32# -> Int32#
+plusInt32# a b = narrow32Int# (a +# b)
+
+#endif

bundled/Basement/Compat/Semigroup.hs

@@ -0,0 +1,170 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+#if !(MIN_VERSION_base(4,9,0))
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+#endif
+module Basement.Compat.Semigroup
+    ( Semigroup(..)
+    , ListNonEmpty(..)
+    ) where
+
+#if MIN_VERSION_base(4,9,0)
+import           Data.Semigroup
+import qualified Data.List.NonEmpty as LNE
+
+type ListNonEmpty = LNE.NonEmpty
+#else
+import Prelude
+import Data.Data (Data)
+import Data.Monoid (Monoid(..))
+import GHC.Generics (Generic)
+import Data.Typeable
+
+-- errorWithoutStackTrace
+
+infixr 6 <>
+infixr 5 :|
+
+data ListNonEmpty a = a :| [a]
+  deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic )
+
+-- | The class of semigroups (types with an associative binary operation).
+--
+-- @since 4.9.0.0
+class Semigroup a where
+  -- | An associative operation.
+  --
+  -- @
+  -- (a '<>' b) '<>' c = a '<>' (b '<>' c)
+  -- @
+  --
+  -- If @a@ is also a 'Monoid' we further require
+  --
+  -- @
+  -- ('<>') = 'mappend'
+  -- @
+  (<>) :: a -> a -> a
+
+  default (<>) :: Monoid a => a -> a -> a
+  (<>) = mappend
+
+  -- | Reduce a non-empty list with @\<\>@
+  --
+  -- The default definition should be sufficient, but this can be
+  -- overridden for efficiency.
+  --
+  sconcat :: ListNonEmpty a -> a
+  sconcat (a :| as) = go a as where
+    go b (c:cs) = b <> go c cs
+    go b []     = b
+
+  -- | Repeat a value @n@ times.
+  --
+  -- Given that this works on a 'Semigroup' it is allowed to fail if
+  -- you request 0 or fewer repetitions, and the default definition
+  -- will do so.
+  --
+  -- By making this a member of the class, idempotent semigroups and monoids can
+  -- upgrade this to execute in /O(1)/ by picking
+  -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@
+  -- respectively.
+  stimes :: Integral b => b -> a -> a
+  stimes y0 x0
+    | y0 <= 0   = errorWithoutStackTrace "stimes: positive multiplier expected"
+    | otherwise = f x0 y0
+    where
+      f x y
+        | even y = f (x <> x) (y `quot` 2)
+        | y == 1 = x
+        | otherwise = g (x <> x) (pred y  `quot` 2) x
+      g x y z
+        | even y = g (x <> x) (y `quot` 2) z
+        | y == 1 = x <> z
+        | otherwise = g (x <> x) (pred y `quot` 2) (x <> z)
+
+instance Semigroup a => Semigroup (Maybe a) where
+  Nothing <> b       = b
+  a       <> Nothing = a
+  Just a  <> Just b  = Just (a <> b)
+  stimes _ Nothing  = Nothing
+  stimes n (Just a) = case compare n 0 of
+    LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"
+    EQ -> Nothing
+    GT -> Just (stimes n a)
+
+instance Semigroup [a] where
+    (<>) = (++)
+
+instance Semigroup (Either a b) where
+  Left _ <> b = b
+  a      <> _ = a
+  stimes = stimesIdempotent
+
+instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
+  (a,b) <> (a',b') = (a<>a',b<>b')
+  stimes n (a,b) = (stimes n a, stimes n b)
+
+instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where
+  (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')
+  stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c)
+
+instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)
+         => Semigroup (a, b, c, d) where
+  (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')
+  stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d)
+
+instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)
+         => Semigroup (a, b, c, d, e) where
+  (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')
+  stimes n (a,b,c,d,e) =
+      (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)
+
+-- | This is a valid definition of 'stimes' for a 'Monoid'.
+--
+-- Unlike the default definition of 'stimes', it is defined for 0
+-- and so it should be preferred where possible.
+stimesMonoid :: (Integral b, Monoid a) => b -> a -> a
+stimesMonoid n x0 = case compare n 0 of
+  LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier"
+  EQ -> mempty
+  GT -> f x0 n
+    where
+      f x y
+        | even y = f (x `mappend` x) (y `quot` 2)
+        | y == 1 = x
+        | otherwise = g (x `mappend` x) (pred y  `quot` 2) x
+      g x y z
+        | even y = g (x `mappend` x) (y `quot` 2) z
+        | y == 1 = x `mappend` z
+        | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z)
+
+-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'.
+--
+-- When @mappend x x = x@, this definition should be preferred, because it
+-- works in /O(1)/ rather than /O(log n)/
+stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a
+stimesIdempotentMonoid n x = case compare n 0 of
+  LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier"
+  EQ -> mempty
+  GT -> x
+
+-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'.
+--
+-- When @x <> x = x@, this definition should be preferred, because it
+-- works in /O(1)/ rather than /O(log n)/.
+stimesIdempotent :: Integral b => b -> a -> a
+stimesIdempotent n x
+  | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"
+  | otherwise = x
+
+#if !MIN_VERSION_base(4,9,0)
+errorWithoutStackTrace = error
+#endif
+
+#endif

bundled/Basement/Compat/Typeable.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Typeable
+-- License     : BSD-style
+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>
+-- Stability   : statble
+-- Portability : portable
+--
+-- conveniently provide support for legacy and modern base
+--
+
+{-# LANGUAGE CPP #-}
+
+module Basement.Compat.Typeable
+    (
+#if MIN_VERSION_base(4,7,0)
+      Typeable
+#else
+      Typeable(..)
+    , typeRep
+#endif
+    ) where
+
+#if !MIN_VERSION_base(4,7,0)
+import Data.Proxy (Proxy(..))
+import qualified Prelude (undefined)
+#endif
+import Data.Typeable
+
+#if !MIN_VERSION_base(4,7,0)
+-- this function does not exist prior base 4.7
+typeRep :: Typeable a => Proxy a -> TypeRep
+typeRep = typeRep' Prelude.undefined
+  where
+    typeRep' :: Typeable a => a -> Proxy a -> TypeRep
+    typeRep' a _ = typeOf a
+    {-# INLINE typeRep' #-}
+#endif

bundled/Basement/Endianness.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Endianness
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Set endianness tag to a given primitive. This will help for serialising
+-- data for protocols (such as the network protocols).
+--
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Basement.Endianness
+    (
+      ByteSwap
+      -- * Big Endian
+    , BE(..), toBE, fromBE
+      -- * Little Endian
+    , LE(..), toLE, fromLE
+      -- * System Endianness
+    , Endianness(..)
+    , endianness
+    ) where
+
+import Basement.Compat.Base
+import Data.Word (byteSwap16, byteSwap32, byteSwap64)
+
+#if defined(ARCH_IS_LITTLE_ENDIAN) || defined(ARCH_IS_BIG_ENDIAN)
+#else
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr (castPtr)
+import Foreign.Storable (poke, peek)
+import Data.Word (Word8, Word32)
+import System.IO.Unsafe (unsafePerformIO)
+#endif
+
+import Data.Bits
+
+
+-- #if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)
+-- import Foundation.System.Info (endianness, Endianness(..))
+-- #endif
+
+data Endianness =
+      LittleEndian
+    | BigEndian
+    deriving (Eq, Show)
+
+-- | Little Endian value
+newtype LE a = LE { unLE :: a }
+  deriving (Show, Eq, Typeable, Bits)
+instance (ByteSwap a, Ord a) => Ord (LE a) where
+    compare e1 e2 = compare (fromLE e1) (fromLE e2)
+
+-- | Big Endian value
+newtype BE a = BE { unBE :: a }
+  deriving (Show, Eq, Typeable, Bits)
+instance (ByteSwap a, Ord a) => Ord (BE a) where
+    compare e1 e2 = compare (fromBE e1) (fromBE e2)
+
+-- | Convert a value in cpu endianess to big endian
+toBE :: ByteSwap a => a -> BE a
+#ifdef ARCH_IS_LITTLE_ENDIAN
+toBE = BE . byteSwap
+#elif ARCH_IS_BIG_ENDIAN
+toBE = BE
+#else
+toBE = BE . (if endianness == LittleEndian then byteSwap else id)
+#endif
+{-# INLINE toBE #-}
+
+-- | Convert from a big endian value to the cpu endianness
+fromBE :: ByteSwap a => BE a -> a
+#ifdef ARCH_IS_LITTLE_ENDIAN
+fromBE (BE a) = byteSwap a
+#elif ARCH_IS_BIG_ENDIAN
+fromBE (BE a) = a
+#else
+fromBE (BE a) = if endianness == LittleEndian then byteSwap a else a
+#endif
+{-# INLINE fromBE #-}
+
+-- | Convert a value in cpu endianess to little endian
+toLE :: ByteSwap a => a -> LE a
+#ifdef ARCH_IS_LITTLE_ENDIAN
+toLE = LE
+#elif ARCH_IS_BIG_ENDIAN
+toLE = LE . byteSwap
+#else
+toLE = LE . (if endianness == LittleEndian then id else byteSwap)
+#endif
+{-# INLINE toLE #-}
+
+-- | Convert from a little endian value to the cpu endianness
+fromLE :: ByteSwap a => LE a -> a
+#ifdef ARCH_IS_LITTLE_ENDIAN
+fromLE (LE a) = a
+#elif ARCH_IS_BIG_ENDIAN
+fromLE (LE a) = byteSwap a
+#else
+fromLE (LE a) = if endianness == LittleEndian then a else byteSwap a
+#endif
+{-# INLINE fromLE #-}
+
+-- | endianness of the current architecture
+endianness :: Endianness
+#ifdef ARCH_IS_LITTLE_ENDIAN
+endianness = LittleEndian
+#elif ARCH_IS_BIG_ENDIAN
+endianness = BigEndian
+#else
+-- ! ARCH_IS_UNKNOWN_ENDIAN
+endianness = unsafePerformIO $ bytesToEndianness <$> word32ToByte input
+  where
+    input :: Word32
+    input = 0x01020304
+{-# NOINLINE endianness #-}
+
+word32ToByte :: Word32 -> IO Word8
+word32ToByte word = alloca $ \wordPtr -> do
+         poke wordPtr word
+         peek (castPtr wordPtr)
+
+bytesToEndianness :: Word8 -> Endianness
+bytesToEndianness 1 = BigEndian
+bytesToEndianness _ = LittleEndian
+#endif
+
+-- | Class of types that can be byte-swapped.
+--
+-- e.g. Word16, Word32, Word64
+class ByteSwap a where
+    byteSwap :: a -> a
+instance ByteSwap Word16 where
+    byteSwap = byteSwap16
+instance ByteSwap Word32 where
+    byteSwap = byteSwap32
+instance ByteSwap Word64 where
+    byteSwap = byteSwap64

bundled/Basement/Environment.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Basement.Environment
+    ( getArgs
+    , lookupEnv
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.UTF8.Base (String)
+import qualified System.Environment as Sys (getArgs, lookupEnv)
+
+-- | Returns a list of the program's command line arguments (not including the program name).
+getArgs :: IO [String]
+getArgs = fmap fromList <$> Sys.getArgs
+
+-- | Lookup variable in the environment
+lookupEnv :: String -> IO (Maybe String)
+lookupEnv s = fmap fromList <$> Sys.lookupEnv (toList s)

bundled/Basement/Error.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 800
+{-# LANGUAGE TypeInType #-}
+#endif
+module Basement.Error
+    ( error
+    ) where
+
+import           GHC.Prim
+import           Basement.UTF8.Base
+import           Basement.Compat.CallStack
+
+#if MIN_VERSION_base(4,9,0)
+
+import           GHC.Types (RuntimeRep)
+import           GHC.Exception (errorCallWithCallStackException)
+
+-- | stop execution and displays an error message
+error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => String -> a
+error s = raise# (errorCallWithCallStackException (sToList s) ?callstack)
+
+#elif MIN_VERSION_base(4,7,0)
+
+import           GHC.Exception (errorCallException)
+
+error :: String -> a
+error s = raise# (errorCallException (sToList s))
+
+#else
+
+import           GHC.Types
+import           GHC.Exception
+
+error :: String -> a
+error s = throw (ErrorCall (sToList s))
+
+#endif

bundled/Basement/Exception.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Exception
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Common part for vectors
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+module Basement.Exception
+    ( OutOfBound(..)
+    , OutOfBoundOperation(..)
+    , isOutOfBound
+    , outOfBound
+    , primOutOfBound
+    , InvalidRecast(..)
+    , RecastSourceSize(..)
+    , RecastDestinationSize(..)
+    , NonEmptyCollectionIsEmpty(..)
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+
+-- | The type of operation that triggers an OutOfBound exception.
+--
+-- * OOB_Index: reading an immutable vector
+-- * OOB_Read: reading a mutable vector
+-- * OOB_Write: write a mutable vector
+-- * OOB_MemCopy: copying a vector
+-- * OOB_MemSet: initializing a mutable vector
+data OutOfBoundOperation = OOB_Read | OOB_Write | OOB_MemSet | OOB_MemCopy | OOB_Index
+    deriving (Show,Eq,Typeable)
+
+-- | Exception during an operation accessing the vector out of bound
+--
+-- Represent the type of operation, the index accessed, and the total length of the vector.
+data OutOfBound = OutOfBound OutOfBoundOperation Int Int
+    deriving (Show,Typeable)
+
+instance Exception OutOfBound
+
+outOfBound :: OutOfBoundOperation -> Offset ty -> CountOf ty -> a
+outOfBound oobop (Offset ofs) (CountOf sz) = throw (OutOfBound oobop ofs sz)
+{-# INLINE outOfBound #-}
+
+primOutOfBound :: PrimMonad prim => OutOfBoundOperation -> Offset ty -> CountOf ty -> prim a
+primOutOfBound oobop (Offset ofs) (CountOf sz) = primThrow (OutOfBound oobop ofs sz)
+{-# INLINE primOutOfBound #-}
+
+isOutOfBound :: Offset ty -> CountOf ty -> Bool
+isOutOfBound (Offset ty) (CountOf sz) = ty < 0 || ty >= sz
+{-# INLINE isOutOfBound #-}
+
+newtype RecastSourceSize      = RecastSourceSize Int
+    deriving (Show,Eq,Typeable)
+newtype RecastDestinationSize = RecastDestinationSize Int
+    deriving (Show,Eq,Typeable)
+
+data InvalidRecast = InvalidRecast RecastSourceSize RecastDestinationSize
+    deriving (Show,Typeable)
+
+instance Exception InvalidRecast
+
+-- | Exception for using NonEmpty assertion with an empty collection
+data NonEmptyCollectionIsEmpty = NonEmptyCollectionIsEmpty
+    deriving (Show,Typeable)
+
+instance Exception NonEmptyCollectionIsEmpty

bundled/Basement/FinalPtr.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.FinalPtr
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A smaller ForeignPtr reimplementation that work in any prim monad.
+--
+-- Here be dragon.
+--
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE CPP #-}
+module Basement.FinalPtr
+    ( FinalPtr(..)
+    , finalPtrSameMemory
+    , castFinalPtr
+    , toFinalPtr
+    , toFinalPtrForeign
+    , touchFinalPtr
+    , withFinalPtr
+    , withUnsafeFinalPtr
+    , withFinalPtrNoTouch
+    ) where
+
+import GHC.Ptr
+import qualified GHC.ForeignPtr as GHCF
+import GHC.IO
+import Basement.Monad
+import Basement.Compat.Primitive
+import Basement.Compat.Base
+
+import Control.Monad.ST (runST)
+
+-- | Create a pointer with an associated finalizer
+data FinalPtr a = FinalPtr (Ptr a)
+                | FinalForeign (GHCF.ForeignPtr a)
+instance Show (FinalPtr a) where
+    show f = runST $ withFinalPtr f (pure . show)
+instance Eq (FinalPtr a) where
+    (==) f1 f2 = runST (equal f1 f2)
+instance Ord (FinalPtr a) where
+    compare f1 f2 = runST (compare_ f1 f2)
+
+-- | Check if 2 final ptr points on the same memory bits
+--
+-- it stand to reason that provided a final ptr that is still being referenced
+-- and thus have the memory still valid, if 2 final ptrs have the
+-- same address, they should be the same final ptr
+finalPtrSameMemory :: FinalPtr a -> FinalPtr b -> Bool
+finalPtrSameMemory (FinalPtr p1)     (FinalPtr p2)     = p1 == castPtr p2
+finalPtrSameMemory (FinalForeign p1) (FinalForeign p2) = p1 == GHCF.castForeignPtr p2
+finalPtrSameMemory (FinalForeign _)  (FinalPtr _)      = False
+finalPtrSameMemory (FinalPtr _)      (FinalForeign _)  = False
+
+-- | create a new FinalPtr from a Pointer
+toFinalPtr :: PrimMonad prim => Ptr a -> (Ptr a -> IO ()) -> prim (FinalPtr a)
+toFinalPtr ptr finalizer = unsafePrimFromIO (primitive makeWithFinalizer)
+  where
+    makeWithFinalizer s =
+        case compatMkWeak# ptr () (finalizer ptr) s of { (# s2, _ #) -> (# s2, FinalPtr ptr #) }
+
+-- | Create a new FinalPtr from a ForeignPtr
+toFinalPtrForeign :: GHCF.ForeignPtr a -> FinalPtr a
+toFinalPtrForeign fptr = FinalForeign fptr
+
+-- | Cast a finalized pointer from type a to type b
+castFinalPtr :: FinalPtr a -> FinalPtr b
+castFinalPtr (FinalPtr a)     = FinalPtr (castPtr a)
+castFinalPtr (FinalForeign a) = FinalForeign (GHCF.castForeignPtr a)
+
+withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a
+withFinalPtrNoTouch (FinalPtr ptr) f = f ptr
+withFinalPtrNoTouch (FinalForeign fptr) f = f (GHCF.unsafeForeignPtrToPtr fptr)
+{-# INLINE withFinalPtrNoTouch #-}
+
+-- | Looks at the raw pointer inside a FinalPtr, making sure the
+-- data pointed by the pointer is not finalized during the call to 'f'
+withFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> prim a
+withFinalPtr (FinalPtr ptr) f = do
+    r <- f ptr
+    primTouch ptr
+    pure r
+withFinalPtr (FinalForeign fptr) f = do
+    r <- f (GHCF.unsafeForeignPtrToPtr fptr)
+    unsafePrimFromIO (GHCF.touchForeignPtr fptr)
+    pure r
+{-# INLINE withFinalPtr #-}
+
+touchFinalPtr :: PrimMonad prim => FinalPtr p -> prim ()
+touchFinalPtr (FinalPtr ptr) = primTouch ptr
+touchFinalPtr (FinalForeign fptr) = unsafePrimFromIO (GHCF.touchForeignPtr fptr)
+
+-- | Unsafe version of 'withFinalPtr'
+withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a
+withUnsafeFinalPtr fptr f = unsafePerformIO (unsafePrimToIO (withFinalPtr fptr f))
+{-# NOINLINE withUnsafeFinalPtr #-}
+
+equal :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Bool
+equal f1 f2 =
+    withFinalPtr f1 $ \ptr1 ->
+    withFinalPtr f2 $ \ptr2 ->
+        pure $ ptr1 == ptr2
+{-# INLINE equal #-}
+
+compare_ :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Ordering
+compare_ f1 f2 =
+    withFinalPtr f1 $ \ptr1 ->
+    withFinalPtr f2 $ \ptr2 ->
+        pure $ ptr1 `compare` ptr2
+{-# INLINE compare_ #-}

bundled/Basement/Floating.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
+module Basement.Floating
+    ( integerToDouble
+    , naturalToDouble
+    , doubleExponant
+    , integerToFloat
+    , naturalToFloat
+    , wordToFloat
+    , floatToWord
+    , wordToDouble
+    , doubleToWord
+    ) where
+
+import           GHC.Types
+import           GHC.Prim
+import           GHC.Float
+import           GHC.Word
+import           GHC.ST
+import           Basement.Compat.Base
+import           Basement.Compat.Natural
+import qualified Prelude (fromInteger, toInteger, (^^))
+
+integerToDouble :: Integer -> Double
+integerToDouble = Prelude.fromInteger
+-- this depends on integer-gmp
+--integerToDouble i = D# (doubleFromInteger i)
+
+naturalToDouble :: Natural -> Double
+naturalToDouble = integerToDouble . Prelude.toInteger
+
+doubleExponant :: Double -> Int -> Double
+doubleExponant = (Prelude.^^)
+
+integerToFloat :: Integer -> Float
+integerToFloat = Prelude.fromInteger
+
+naturalToFloat :: Natural -> Float
+naturalToFloat = integerToFloat . Prelude.toInteger
+
+wordToFloat :: Word32 -> Float
+wordToFloat (W32# x) = runST $ ST $ \s1 ->
+    case newByteArray# 4# s1             of { (# s2, mbarr #) ->
+    case writeWord32Array# mbarr 0# x s2 of { s3              ->
+    case readFloatArray# mbarr 0# s3     of { (# s4, f #)     ->
+        (# s4, F# f #) }}}
+{-# INLINE wordToFloat #-}
+
+floatToWord :: Float -> Word32
+floatToWord (F# x) = runST $ ST $ \s1 ->
+    case newByteArray# 4# s1            of { (# s2, mbarr #) ->
+    case writeFloatArray# mbarr 0# x s2 of { s3              ->
+    case readWord32Array# mbarr 0# s3   of { (# s4, w #)     ->
+        (# s4, W32# w #) }}}
+{-# INLINE floatToWord #-}
+
+wordToDouble :: Word64 -> Double
+wordToDouble (W64# x) = runST $ ST $ \s1 ->
+    case newByteArray# 8# s1             of { (# s2, mbarr #) ->
+    case writeWord64Array# mbarr 0# x s2 of { s3              ->
+    case readDoubleArray# mbarr 0# s3    of { (# s4, f #)     ->
+        (# s4, D# f #) }}}
+{-# INLINE wordToDouble #-}
+
+doubleToWord :: Double -> Word64
+doubleToWord (D# x) = runST $ ST $ \s1 ->
+    case newByteArray# 8# s1             of { (# s2, mbarr #) ->
+    case writeDoubleArray# mbarr 0# x s2 of { s3              ->
+    case readWord64Array# mbarr 0# s3    of { (# s4, w #)     ->
+        (# s4, W64# w #) }}}
+{-# INLINE doubleToWord #-}

bundled/Basement/From.hs

@@ -0,0 +1,336 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE MagicHash             #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE TypeOperators         #-}
+-- |
+-- Module      : Basement.From
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+--
+-- Flexible Type convertion
+--
+-- From is multi parameter type class that allow converting
+-- from a to b.
+--
+-- Only type that are valid to convert to another type
+-- should be From instance; otherwise TryFrom should be used.
+--
+-- Into (resp TryInto) allows the contrary instances to be able
+-- to specify the destination type before the source. This is
+-- practical with TypeApplication
+module Basement.From
+    ( From(..)
+    , Into
+    , TryFrom(..)
+    , TryInto
+    , into
+    , tryInto
+    ) where
+
+import           Basement.Compat.Base
+
+-- basic instances
+import           GHC.Types
+import           GHC.Prim hiding (word64ToWord#)
+import qualified GHC.Prim
+import           GHC.Int
+import           GHC.Word
+import           Basement.Numerical.Number
+import           Basement.Numerical.Conversion
+import qualified Basement.Block as Block
+import qualified Basement.BoxedArray as BoxArray
+import           Basement.Cast (cast)
+import qualified Basement.UArray as UArray
+import qualified Basement.String as String
+import qualified Basement.Types.AsciiString as AsciiString
+import           Basement.Types.Word128 (Word128(..))
+import           Basement.Types.Word256 (Word256(..))
+import qualified Basement.Types.Word128 as Word128
+import qualified Basement.Types.Word256 as Word256
+import           Basement.These
+import           Basement.PrimType (PrimType, PrimSize)
+import           Basement.Types.OffsetSize
+import           Basement.Compat.Natural
+import           Basement.Compat.Primitive
+import qualified Prelude (fromIntegral)
+
+-- nat instances
+#if __GLASGOW_HASKELL__ >= 800
+import           Basement.Nat
+import qualified Basement.Sized.Block as BlockN
+import           Basement.Bounded
+#endif
+
+-- | Class of things that can be converted from a to b.
+--
+-- In a valid instance, the source should be always representable by the destination,
+-- otherwise the instance should be using 'TryFrom'
+class From a b where
+    from :: a -> b
+
+type Into b a = From a b
+
+-- | Same as from but reverse the type variable so that the destination type can be specified first
+--
+-- e.g. converting:
+--
+-- from @_ @Word (10 :: Int)
+--
+-- into @Word (10 :: Int)
+--
+into :: Into b a => a -> b
+into = from
+
+-- | Class of things that can mostly be converted from a to b, but with possible error cases.
+class TryFrom a b where
+    tryFrom :: a -> Maybe b
+
+type TryInto b a = TryFrom a b
+
+-- | same as tryFrom but reversed
+tryInto :: TryInto b a => a -> Maybe b
+tryInto = tryFrom
+
+instance From a a where
+    from = id
+
+instance IsNatural n => From n Natural where
+    from = toNatural
+instance IsIntegral n => From n Integer where
+    from = toInteger
+
+instance From Int8 Int16 where
+    from (I8# i) = I16# (int8ToInt16# i)
+instance From Int8 Int32 where
+    from (I8# i) = I32# (int8ToInt32# i)
+instance From Int8 Int64 where
+    from (I8# i) = intToInt64 (I# (int8ToInt# i))
+instance From Int8 Int where
+    from (I8# i) = I# (int8ToInt# i)
+
+instance From Int16 Int32 where
+    from (I16# i) = I32# (int16ToInt32# i)
+instance From Int16 Int64 where
+    from (I16# i) = intToInt64 (I# (int16ToInt# i))
+instance From Int16 Int where
+    from (I16# i) = I# (int16ToInt# i)
+
+instance From Int32 Int64 where
+    from (I32# i) = intToInt64 (I# (int32ToInt# i))
+instance From Int32 Int where
+    from (I32# i) = I# (int32ToInt# i)
+
+instance From Int Int64 where
+    from = intToInt64
+
+instance From Word8 Word16 where
+    from (W8# i) = W16# (word8ToWord16# i)
+instance From Word8 Word32 where
+    from (W8# i) = W32# (word8ToWord32# i)
+instance From Word8 Word64 where
+    from (W8# i) = wordToWord64 (W# (word8ToWord# i))
+instance From Word8 Word128 where
+    from (W8# i) = Word128 0 (wordToWord64 $ W# (word8ToWord# i))
+instance From Word8 Word256 where
+    from (W8# i) = Word256 0 0 0 (wordToWord64 $ W# (word8ToWord# i))
+instance From Word8 Word where
+    from (W8# i) = W# (word8ToWord# i)
+instance From Word8 Int16 where
+    from (W8# w) = I16# (intToInt16# (word2Int# (word8ToWord# w)))
+instance From Word8 Int32 where
+    from (W8# w) = I32# (intToInt32# (word2Int# (word8ToWord# w)))
+instance From Word8 Int64 where
+    from (W8# w) = intToInt64 (I# (word2Int# (word8ToWord# w)))
+instance From Word8 Int where
+    from (W8# w) = I# (word2Int# (word8ToWord# w))
+
+instance From Word16 Word32 where
+    from (W16# i) = W32# (word16ToWord32# i)
+instance From Word16 Word64 where
+    from (W16# i) = wordToWord64 (W# (word16ToWord# i))
+instance From Word16 Word128 where
+    from (W16# i) = Word128 0 (wordToWord64 $ W# (word16ToWord# i))
+instance From Word16 Word256 where
+    from (W16# i) = Word256 0 0 0 (wordToWord64 $ W# (word16ToWord# i))
+instance From Word16 Word where
+    from (W16# i) = W# (word16ToWord# i)
+instance From Word16 Int32 where
+    from (W16# w) = I32# (intToInt32# (word2Int# (word16ToWord# w)))
+instance From Word16 Int64 where
+    from (W16# w) = intToInt64 (I# (word2Int# (word16ToWord# w)))
+instance From Word16 Int where
+    from (W16# w) = I# (word2Int# (word16ToWord# w))
+
+instance From Word32 Word64 where
+    from (W32# i) = wordToWord64 (W# (word32ToWord# i))
+instance From Word32 Word128 where
+    from (W32# i) = Word128 0 (wordToWord64 $ W# (word32ToWord# i))
+instance From Word32 Word256 where
+    from (W32# i) = Word256 0 0 0 (wordToWord64 $ W# (word32ToWord# i))
+instance From Word32 Word where
+    from (W32# i) = W# (word32ToWord# i)
+instance From Word32 Int64 where
+    from (W32# w) = intToInt64 (I# (word2Int# (word32ToWord# w)))
+instance From Word32 Int where
+    from (W32# w) = I# (word2Int# (word32ToWord# w))
+
+instance From Word64 Word128 where
+    from w = Word128 0 w
+instance From Word64 Word256 where
+    from w = Word256 0 0 0 w
+
+instance From Word Word64 where
+    from = wordToWord64
+
+-- Simple prelude types
+instance From (Maybe a) (Either () a) where
+    from (Just x) = Right x
+    from Nothing  = Left ()
+
+-- basic basement types
+instance From (CountOf ty) Int where
+    from (CountOf n) = n
+instance From (CountOf ty) Word where
+    -- here it is ok to cast the underlying `Int` held by `CountOf` to a `Word`
+    -- as the `Int` should never hold a negative value.
+    from (CountOf n) = cast n
+instance From Word (Offset ty) where
+    from w = Offset (cast w)
+instance TryFrom Int (Offset ty) where
+    tryFrom i
+        | i < 0     = Nothing
+        | otherwise = Just (Offset i)
+instance TryFrom Int (CountOf ty) where
+    tryFrom i
+        | i < 0     = Nothing
+        | otherwise = Just (CountOf i)
+instance From Word (CountOf ty) where
+    from w = CountOf (cast w)
+
+instance From (Either a b) (These a b) where
+    from (Left a) = This a
+    from (Right b) = That b
+
+instance From Word128 Word256 where
+    from (Word128 a b) = Word256 0 0 a b
+
+-- basement instances
+
+-- uarrays
+instance PrimType ty => From (Block.Block ty) (UArray.UArray ty) where
+    from = UArray.fromBlock
+instance PrimType ty => From (BoxArray.Array ty) (UArray.UArray ty) where
+    from = BoxArray.mapToUnboxed id
+
+-- blocks
+instance PrimType ty => From (UArray.UArray ty) (Block.Block ty) where
+    from = UArray.toBlock
+instance PrimType ty => From (BoxArray.Array ty) (Block.Block ty) where
+    from = UArray.toBlock . BoxArray.mapToUnboxed id
+
+-- boxed array
+instance PrimType ty => From (UArray.UArray ty) (BoxArray.Array ty) where
+    from = BoxArray.mapFromUnboxed id
+
+
+instance From String.String (UArray.UArray Word8) where
+    from = String.toBytes String.UTF8
+
+instance From AsciiString.AsciiString String.String where
+    from = String.fromBytesUnsafe . UArray.unsafeRecast . AsciiString.toBytes
+instance From AsciiString.AsciiString (UArray.UArray Word8) where
+    from = UArray.unsafeRecast . AsciiString.toBytes
+
+instance TryFrom (UArray.UArray Word8) String.String where
+    tryFrom arr = case String.fromBytes String.UTF8 arr of
+                    (s, Nothing, _) -> Just s
+                    (_, Just _, _)  -> Nothing
+
+#if __GLASGOW_HASKELL__ >= 800
+instance From (BlockN.BlockN n ty) (Block.Block ty) where
+    from = BlockN.toBlock
+instance (PrimType a, PrimType b, KnownNat n, KnownNat m, ((PrimSize b) Basement.Nat.* m) ~ ((PrimSize a) Basement.Nat.* n))
+      => From (BlockN.BlockN n a) (BlockN.BlockN m b) where
+    from = BlockN.cast
+instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (UArray.UArray ty) where
+    from = UArray.fromBlock . BlockN.toBlock
+instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (BoxArray.Array ty) where
+    from = BoxArray.mapFromUnboxed id . UArray.fromBlock . BlockN.toBlock
+
+instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty)
+      => TryFrom (Block.Block ty) (BlockN.BlockN n ty) where
+    tryFrom = BlockN.toBlockN
+instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty)
+      => TryFrom (UArray.UArray ty) (BlockN.BlockN n ty) where
+    tryFrom = BlockN.toBlockN . UArray.toBlock
+instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty)
+      => TryFrom (BoxArray.Array ty) (BlockN.BlockN n ty) where
+    tryFrom = BlockN.toBlockN . UArray.toBlock . BoxArray.mapToUnboxed id
+
+instance (KnownNat n, NatWithinBound Word8 n) => From (Zn64 n) Word8 where
+#if __GLASGOW_HASKELL__ >= 904
+    from = narrow . unZn64 where narrow (W64# w) = W8# (wordToWord8# (word64ToWord# (GHC.Prim.word64ToWord# w)))
+#else
+    from = narrow . unZn64 where narrow (W64# w) = W8# (wordToWord8# (word64ToWord# w))
+#endif
+instance (KnownNat n, NatWithinBound Word16 n) => From (Zn64 n) Word16 where
+#if __GLASGOW_HASKELL__ >= 904
+    from = narrow . unZn64 where narrow (W64# w) = W16# (wordToWord16# (word64ToWord# (GHC.Prim.word64ToWord# w)))
+#else
+    from = narrow . unZn64 where narrow (W64# w) = W16# (wordToWord16# (word64ToWord# w))
+#endif
+instance (KnownNat n, NatWithinBound Word32 n) => From (Zn64 n) Word32 where
+#if __GLASGOW_HASKELL__ >= 904
+    from = narrow . unZn64 where narrow (W64# w) = W32# (wordToWord32# (word64ToWord# (GHC.Prim.word64ToWord# w)))
+#else
+    from = narrow . unZn64 where narrow (W64# w) = W32# (wordToWord32# (word64ToWord# w))
+#endif
+instance From (Zn64 n) Word64 where
+    from = unZn64
+instance From (Zn64 n) Word128 where
+    from = from . unZn64
+instance From (Zn64 n) Word256 where
+    from = from . unZn64
+
+instance (KnownNat n, NatWithinBound Word8 n) => From (Zn n) Word8 where
+#if __GLASGOW_HASKELL__ >= 904
+    from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W8# (wordToWord8# (word64ToWord# (GHC.Prim.word64ToWord# w)))
+#else
+    from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W8# (wordToWord8# (word64ToWord# w))
+#endif
+instance (KnownNat n, NatWithinBound Word16 n) => From (Zn n) Word16 where
+#if __GLASGOW_HASKELL__ >= 904
+    from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W16# (wordToWord16# (word64ToWord# (GHC.Prim.word64ToWord# w)))
+#else
+    from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W16# (wordToWord16# (word64ToWord# w))
+#endif
+instance (KnownNat n, NatWithinBound Word32 n) => From (Zn n) Word32 where
+#if __GLASGOW_HASKELL__ >= 904
+    from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W32# (wordToWord32# (word64ToWord# (GHC.Prim.word64ToWord# w)))
+#else
+    from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W32# (wordToWord32# (word64ToWord# w))
+#endif
+instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) Word64 where
+    from = naturalToWord64 . unZn
+instance (KnownNat n, NatWithinBound Word128 n) => From (Zn n) Word128 where
+    from = Word128.fromNatural . unZn
+instance (KnownNat n, NatWithinBound Word256 n) => From (Zn n) Word256 where
+    from = Word256.fromNatural . unZn
+
+instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) (Zn64 n) where
+    from = zn64 . naturalToWord64 . unZn
+instance KnownNat n => From (Zn64 n) (Zn n) where
+    from = zn . from . unZn64
+
+naturalToWord64 :: Natural -> Word64
+naturalToWord64 = Prelude.fromIntegral
+#endif

bundled/Basement/Imports.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Imports
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- re-export of all the base prelude and basic primitive stuffs
+{-# LANGUAGE CPP #-}
+module Basement.Imports
+    ( (Prelude.$)
+    , (Prelude.$!)
+    , (Prelude.&&)
+    , (Prelude.||)
+    , (Control.Category..)
+    , (Control.Applicative.<$>)
+    , Prelude.not
+    , Prelude.otherwise
+    , Prelude.fst
+    , Prelude.snd
+    , Control.Category.id
+    , Prelude.maybe
+    , Prelude.either
+    , Prelude.flip
+    , Prelude.const
+    , Basement.Error.error
+    , Prelude.and
+    , Prelude.undefined
+    , Prelude.seq
+    , Prelude.Show
+    , Basement.Show.show
+    , Prelude.Ord (..)
+    , Prelude.Eq (..)
+    , Prelude.Bounded (..)
+    , Prelude.Enum (..)
+    , Prelude.Functor (..)
+    , Control.Applicative.Applicative (..)
+    , Prelude.Monad (..)
+    , Control.Monad.when
+    , Control.Monad.unless
+    , Prelude.Maybe (..)
+    , Prelude.Ordering (..)
+    , Prelude.Bool (..)
+    , Prelude.Int
+    , Prelude.Integer
+    , Basement.Compat.Natural.Natural
+    , Basement.Types.OffsetSize.Offset
+    , Basement.Types.OffsetSize.CountOf
+    , Prelude.Char
+    , Basement.PrimType.PrimType
+    , Basement.Types.Char7.Char7
+    , Basement.Types.AsciiString.AsciiString
+    , Basement.UTF8.Base.String
+    , Basement.UArray.UArray
+    , Basement.BoxedArray.Array
+    , Basement.Compat.NumLiteral.Integral (..)
+    , Basement.Compat.NumLiteral.Fractional (..)
+    , Basement.Compat.NumLiteral.HasNegation (..)
+    , Data.Int.Int8, Data.Int.Int16, Data.Int.Int32, Data.Int.Int64
+    , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word
+    , Prelude.Double, Prelude.Float
+    , Prelude.IO
+    , FP32
+    , FP64
+    , Basement.Compat.IsList.IsList (..)
+    , GHC.Exts.IsString (..)
+    , GHC.Generics.Generic (..)
+    , Prelude.Either (..)
+    , Data.Data.Data (..)
+    , Data.Data.mkNoRepType
+    , Data.Data.DataType
+    , Data.Typeable.Typeable
+    , Data.Monoid.Monoid (..)
+#if MIN_VERSION_base(4,10,0)
+    -- , (Basement.Compat.Semigroup.<>)
+    , Basement.Compat.Semigroup.Semigroup(..)
+#else
+    , (Data.Monoid.<>)
+    , Basement.Compat.Semigroup.Semigroup
+#endif
+    , Control.Exception.Exception
+    , Control.Exception.throw
+    , Control.Exception.throwIO
+    , GHC.Ptr.Ptr(..)
+    , ifThenElse
+    ) where
+
+import qualified Prelude
+import qualified Control.Category
+import qualified Control.Applicative
+import qualified Control.Exception
+import qualified Control.Monad
+import qualified Data.Monoid
+import qualified Data.Data
+import qualified Data.Typeable
+import qualified Data.Word
+import qualified Data.Int
+import qualified Basement.Compat.IsList
+import qualified Basement.Compat.Natural
+import qualified Basement.Compat.NumLiteral
+import qualified Basement.Compat.Semigroup
+import qualified Basement.UArray
+import qualified Basement.BoxedArray
+import qualified Basement.UTF8.Base
+import qualified Basement.Error
+import qualified Basement.Show
+import qualified Basement.PrimType
+import qualified Basement.Types.OffsetSize
+import qualified Basement.Types.AsciiString
+import qualified Basement.Types.Char7
+import qualified GHC.Exts
+import qualified GHC.Generics
+import qualified GHC.Ptr
+import           GHC.Exts (fromString)
+
+-- | for support of if .. then .. else
+ifThenElse :: Prelude.Bool -> a -> a -> a
+ifThenElse Prelude.True  e1 _  = e1
+ifThenElse Prelude.False _  e2 = e2
+
+-- | IEEE754 Floating point Binary32, simple precision (Also known as Float)
+type FP32 = Prelude.Float
+
+-- | IEEE754 Floating point Binary64, double precision (Also known as Double)
+type FP64 = Prelude.Double

bundled/Basement/IntegralConv.hs

@@ -0,0 +1,235 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash             #-}
+{-# LANGUAGE DefaultSignatures     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE UnboxedTuples         #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE TypeOperators         #-}
+module Basement.IntegralConv
+    ( IntegralDownsize(..)
+    , IntegralUpsize(..)
+    , intToInt64
+    , int64ToInt
+    , wordToWord64
+    , word64ToWord32s
+    , Word32x2(..)
+    , word64ToWord
+    , wordToChar
+    , wordToInt
+    , charToInt
+    ) where
+
+import GHC.Types
+import GHC.Prim hiding (word64ToWord#)
+import qualified GHC.Prim
+import GHC.Int
+import GHC.Word
+import Prelude (Integer, fromIntegral)
+import Basement.Compat.Base
+import Basement.Compat.Natural
+import Basement.Compat.Primitive
+import Basement.Numerical.Number
+import Basement.Numerical.Conversion
+
+-- | Downsize an integral value
+class IntegralDownsize a b where
+    integralDownsize :: a -> b
+    default integralDownsize :: a ~ b => a -> b
+    integralDownsize = id
+
+    integralDownsizeCheck :: a -> Maybe b
+
+-- | Upsize an integral value
+--
+-- The destination type 'b' size need to be greater or equal
+-- than the size type of 'a'
+class IntegralUpsize a b where
+    integralUpsize      :: a -> b
+
+integralDownsizeBounded :: forall a b . (Ord a, Bounded b, IntegralDownsize a b, IntegralUpsize b a)
+                        => (a -> b)
+                        -> a
+                        -> Maybe b
+integralDownsizeBounded aToB x
+    | x < integralUpsize (minBound :: b) && x > integralUpsize (maxBound :: b) = Nothing
+    | otherwise                                                                = Just (aToB x)
+
+instance IsIntegral a => IntegralUpsize a Integer where
+    integralUpsize = toInteger
+instance IsNatural a => IntegralUpsize a Natural where
+    integralUpsize = toNatural
+
+instance IntegralUpsize Int8 Int16 where
+    integralUpsize (I8# i) = I16# (int8ToInt16# i)
+instance IntegralUpsize Int8 Int32 where
+    integralUpsize (I8# i) = I32# (int8ToInt32# i)
+instance IntegralUpsize Int8 Int64 where
+    integralUpsize (I8# i) = intToInt64 (I# (int8ToInt# i))
+instance IntegralUpsize Int8 Int where
+    integralUpsize (I8# i) = I# (int8ToInt# i)
+
+instance IntegralUpsize Int16 Int32 where
+    integralUpsize (I16# i) = I32# (int16ToInt32# i)
+instance IntegralUpsize Int16 Int64 where
+    integralUpsize (I16# i) = intToInt64 (I# (int16ToInt# i))
+instance IntegralUpsize Int16 Int where
+    integralUpsize (I16# i) = I# (int16ToInt# i)
+
+instance IntegralUpsize Int32 Int64 where
+    integralUpsize (I32# i) = intToInt64 (I# (int32ToInt# i))
+instance IntegralUpsize Int32 Int where
+    integralUpsize (I32# i) = I# (int32ToInt# i)
+
+instance IntegralUpsize Int Int64 where
+    integralUpsize = intToInt64
+
+instance IntegralUpsize Word8 Word16 where
+    integralUpsize (W8# i) = W16# (word8ToWord16# i)
+instance IntegralUpsize Word8 Word32 where
+    integralUpsize (W8# i) = W32# (word8ToWord32# i)
+instance IntegralUpsize Word8 Word64 where
+    integralUpsize (W8# i) = wordToWord64 (W# (word8ToWord# i))
+instance IntegralUpsize Word8 Word where
+    integralUpsize (W8# i) = W# (word8ToWord# i)
+instance IntegralUpsize Word8 Int16 where
+    integralUpsize (W8# w) = I16# (word8ToInt16# w)
+instance IntegralUpsize Word8 Int32 where
+    integralUpsize (W8# w) = I32# (word8ToInt32# w)
+instance IntegralUpsize Word8 Int64 where
+    integralUpsize (W8# w) = intToInt64 (I# (word2Int# (word8ToWord# w)))
+instance IntegralUpsize Word8 Int where
+    integralUpsize (W8# w) = I# (word2Int# (word8ToWord# w))
+
+instance IntegralUpsize Word16 Word32 where
+    integralUpsize (W16# i) = W32# (word16ToWord32# i)
+instance IntegralUpsize Word16 Word64 where
+    integralUpsize (W16# i) = wordToWord64 (W# (word16ToWord# i))
+instance IntegralUpsize Word16 Word where
+    integralUpsize (W16# i) = W# (word16ToWord# i)
+
+instance IntegralUpsize Word32 Word64 where
+    integralUpsize (W32# i) = wordToWord64 (W# (word32ToWord# i))
+instance IntegralUpsize Word32 Word where
+    integralUpsize (W32# i) = W# (word32ToWord# i)
+
+instance IntegralUpsize Word Word64 where
+    integralUpsize = wordToWord64
+
+instance IntegralDownsize Int Int8 where
+    integralDownsize      (I# i) = I8# (intToInt8# i)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Int Int16 where
+    integralDownsize      (I# i) = I16# (intToInt16# i)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Int Int32 where
+    integralDownsize      (I# i) = I32# (intToInt32# i)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+
+instance IntegralDownsize Int64 Int8 where
+    integralDownsize      i = integralDownsize (int64ToInt i)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Int64 Int16 where
+    integralDownsize      i = integralDownsize (int64ToInt i)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Int64 Int32 where
+    integralDownsize      i = integralDownsize (int64ToInt i)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Int64 Int where
+    integralDownsize      i = int64ToInt i
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+
+instance IntegralDownsize Word64 Word8 where
+#if __GLASGOW_HASKELL__ >= 904
+    integralDownsize      (W64# i) = W8# (wordToWord8# (GHC.Prim.word64ToWord# i))
+#else
+    integralDownsize      (W64# i) = W8# (wordToWord8# (word64ToWord# i))
+#endif
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Word64 Word16 where
+#if __GLASGOW_HASKELL__ >= 904
+    integralDownsize      (W64# i) = W16# (wordToWord16# (GHC.Prim.word64ToWord# i))
+#else
+    integralDownsize      (W64# i) = W16# (wordToWord16# (word64ToWord# i))
+#endif
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Word64 Word32 where
+#if __GLASGOW_HASKELL__ >= 904
+    integralDownsize      (W64# i) = W32# (wordToWord32# (GHC.Prim.word64ToWord# i))
+#else
+    integralDownsize      (W64# i) = W32# (wordToWord32# (word64ToWord# i))
+#endif
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+
+instance IntegralDownsize Word Word8 where
+    integralDownsize (W# w) = W8# (wordToWord8# w)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Word Word16 where
+    integralDownsize (W# w) = W16# (wordToWord16# w)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Word Word32 where
+    integralDownsize (W# w) = W32# (wordToWord32# w)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+
+instance IntegralDownsize Word32 Word8 where
+    integralDownsize      (W32# i) = W8# (word32ToWord8# i)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Word32 Word16 where
+    integralDownsize      (W32# i) = W16# (word32ToWord16# i)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+
+instance IntegralDownsize Word16 Word8 where
+    integralDownsize      (W16# i) = W8# (word16ToWord8# i)
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+
+instance IntegralDownsize Integer Int8 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Integer Int16 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Integer Int32 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Integer Int64 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+
+instance IntegralDownsize Integer Word8 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Integer Word16 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Integer Word32 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Integer Word64 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Integer Natural where
+    integralDownsize i
+        | i >= 0    = fromIntegral i
+        | otherwise = 0
+    integralDownsizeCheck i
+        | i >= 0    = Just (fromIntegral i)
+        | otherwise = Nothing
+
+instance IntegralDownsize Natural Word8 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Natural Word16 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Natural Word32 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize
+instance IntegralDownsize Natural Word64 where
+    integralDownsize = fromIntegral
+    integralDownsizeCheck = integralDownsizeBounded integralDownsize

bundled/Basement/Monad.hs

@@ -0,0 +1,144 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Monad
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Allow to run operation in ST and IO, without having to
+-- distinguinsh between the two. Most operations exposes
+-- the bare nuts and bolts of how IO and ST actually
+-- works, and relatively easy to shoot yourself in the foot
+--
+-- this is highly similar to the Control.Monad.Primitive
+-- in the primitive package
+--
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module Basement.Monad
+    ( PrimMonad(..)
+    , MonadFailure(..)
+    , unPrimMonad_
+    , unsafePrimCast
+    , unsafePrimToST
+    , unsafePrimToIO
+    , unsafePrimFromIO
+    , primTouch
+    ) where
+
+import qualified Prelude
+import           GHC.ST
+import           GHC.STRef
+import           GHC.IORef
+import           GHC.IO
+import           GHC.Prim
+import           Basement.Compat.Base (Exception, (.), ($), Applicative, Monad)
+import           Basement.Compat.Primitive
+
+-- | Primitive monad that can handle mutation.
+--
+-- For example: IO and ST.
+class (Prelude.Functor m, Applicative m, Prelude.Monad m) => PrimMonad m where
+    -- | type of state token associated with the PrimMonad m
+    type PrimState m
+    -- | type of variable associated with the PrimMonad m
+    type PrimVar m :: * -> *
+    -- | Unwrap the State# token to pass to a function a primitive function that returns an unboxed state and a value.
+    primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
+    -- | Throw Exception in the primitive monad
+    primThrow :: Exception e => e -> m a
+    -- | Run a Prim monad from a dedicated state#
+    unPrimMonad  :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
+
+    -- | Build a new variable in the Prim Monad
+    primVarNew :: a -> m (PrimVar m a)
+    -- | Read the variable in the Prim Monad
+    primVarRead :: PrimVar m a -> m a
+    -- | Write the variable in the Prim Monad
+    primVarWrite :: PrimVar m a -> a -> m ()
+
+-- | just like `unwrapPrimMonad` but throw away the result and return just the new State#
+unPrimMonad_ :: PrimMonad m => m () -> State# (PrimState m) -> State# (PrimState m)
+unPrimMonad_ p st =
+    case unPrimMonad p st of
+        (# st', () #) -> st'
+{-# INLINE unPrimMonad_ #-}
+
+instance PrimMonad IO where
+    type PrimState IO = RealWorld
+    type PrimVar IO = IORef
+    primitive = IO
+    {-# INLINE primitive #-}
+    primThrow = throwIO
+    unPrimMonad (IO p) = p
+    {-# INLINE unPrimMonad #-}
+    primVarNew = newIORef
+    primVarRead = readIORef
+    primVarWrite = writeIORef
+
+instance PrimMonad (ST s) where
+    type PrimState (ST s) = s
+    type PrimVar (ST s) = STRef s
+    primitive = ST
+    {-# INLINE primitive #-}
+    primThrow = unsafeIOToST . throwIO
+    unPrimMonad (ST p) = p
+    {-# INLINE unPrimMonad #-}
+    primVarNew = newSTRef
+    primVarRead = readSTRef
+    primVarWrite = writeSTRef
+
+-- | Convert a prim monad to another prim monad.
+--
+-- The net effect is that it coerce the state repr to another,
+-- so the runtime representation should be the same, otherwise
+-- hilary ensues.
+unsafePrimCast :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a
+unsafePrimCast m = primitive (unsafeCoerce# (unPrimMonad m))
+{-# INLINE unsafePrimCast #-}
+
+-- | Convert any prim monad to an ST monad
+unsafePrimToST :: PrimMonad prim => prim a -> ST s a
+unsafePrimToST = unsafePrimCast
+{-# INLINE unsafePrimToST #-}
+
+-- | Convert any prim monad to an IO monad
+unsafePrimToIO :: PrimMonad prim => prim a -> IO a
+unsafePrimToIO = unsafePrimCast
+{-# INLINE unsafePrimToIO #-}
+
+-- | Convert any IO monad to a prim monad
+unsafePrimFromIO :: PrimMonad prim => IO a -> prim a
+unsafePrimFromIO = unsafePrimCast
+{-# INLINE unsafePrimFromIO #-}
+
+-- | Touch primitive lifted to any prim monad
+primTouch :: PrimMonad m => a -> m ()
+primTouch x = unsafePrimFromIO $ primitive $ \s -> case touch# x s of { s2 -> (# s2, () #) }
+{-# INLINE primTouch #-}
+
+-- | Monad that can represent failure
+--
+-- Similar to MonadFail but with a parametrized Failure linked to the Monad
+class Monad m => MonadFailure m where
+    -- | The associated type with the MonadFailure, representing what
+    -- failure can be encoded in this monad
+    type Failure m
+
+    -- | Raise a Failure through a monad.
+    mFail :: Failure m -> m ()
+
+instance MonadFailure Prelude.Maybe where
+    type Failure Prelude.Maybe = ()
+    mFail _ = Prelude.Nothing
+instance MonadFailure (Prelude.Either a) where
+    type Failure (Prelude.Either a) = a
+    mFail a = Prelude.Left a

bundled/Basement/MutableBuilder.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Basement.MutableBuilder
+    ( Builder(..)
+    , BuildingState(..)
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Compat.MonadTrans
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+
+newtype Builder collection mutCollection step state err a = Builder
+    { runBuilder :: State (Offset step, BuildingState collection mutCollection step (PrimState state), Maybe err) state a }
+    deriving (Functor, Applicative, Monad)
+
+-- | The in-progress state of a building operation.
+--
+-- The previous buffers are in reverse order, and
+-- this contains the current buffer and the state of
+-- progress packing the elements inside.
+data BuildingState collection mutCollection step state = BuildingState
+    { prevChunks     :: [collection]
+    , prevChunksSize :: !(CountOf step)
+    , curChunk       :: mutCollection state
+    , chunkSize      :: !(CountOf step)
+    }
+
+instance Monad state => MonadFailure (Builder collection mutCollection step state err) where
+    type Failure (Builder collection mutCollection step state err) = err
+    mFail builderError = Builder $ State $ \(offset, bs, _)  ->
+        return ((), (offset, bs, Just builderError))

bundled/Basement/Nat.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE KindSignatures            #-}
+{-# LANGUAGE DataKinds                 #-}
+{-# LANGUAGE GADTs                     #-}
+{-# LANGUAGE TypeOperators             #-}
+{-# LANGUAGE TypeFamilies              #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE UndecidableInstances      #-}
+{-# LANGUAGE ConstraintKinds           #-}
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE NoStarIsType              #-}
+#endif
+module Basement.Nat
+    ( Nat
+    , KnownNat
+    , natVal
+    , type (<=), type (<=?), type (+), type (*), type (^), type (-)
+    , CmpNat
+    -- * Nat convertion
+    , natValNatural
+    , natValInt
+    , natValInt8
+    , natValInt16
+    , natValInt32
+    , natValInt64
+    , natValWord
+    , natValWord8
+    , natValWord16
+    , natValWord32
+    , natValWord64
+    -- * Maximum bounds
+    , NatNumMaxBound
+    -- * Constraint
+    , NatInBoundOf
+    , NatWithinBound
+    ) where
+
+#include "MachDeps.h"
+
+import           GHC.TypeLits
+import           Basement.Compat.Base
+import           Basement.Compat.Natural
+import           Basement.Types.Char7 (Char7)
+import           Basement.Types.Word128 (Word128)
+import           Basement.Types.Word256 (Word256)
+import           Data.Int (Int8, Int16, Int32, Int64)
+import           Data.Word (Word8, Word16, Word32, Word64)
+import qualified Prelude (fromIntegral)
+
+#if __GLASGOW_HASKELL__ >= 800
+import           Data.Type.Bool
+#endif
+
+natValNatural :: forall n proxy . KnownNat n => proxy n -> Natural
+natValNatural n = Prelude.fromIntegral (natVal n)
+
+natValInt :: forall n proxy . (KnownNat n, NatWithinBound Int n) => proxy n -> Int
+natValInt n = Prelude.fromIntegral (natVal n)
+
+natValInt64 :: forall n proxy . (KnownNat n, NatWithinBound Int64 n) => proxy n -> Int64
+natValInt64 n = Prelude.fromIntegral (natVal n)
+
+natValInt32 :: forall n proxy . (KnownNat n, NatWithinBound Int32 n) => proxy n -> Int32
+natValInt32 n = Prelude.fromIntegral (natVal n)
+
+natValInt16 :: forall n proxy . (KnownNat n, NatWithinBound Int16 n) => proxy n -> Int16
+natValInt16 n = Prelude.fromIntegral (natVal n)
+
+natValInt8 :: forall n proxy . (KnownNat n, NatWithinBound Int8 n) => proxy n -> Int8
+natValInt8 n = Prelude.fromIntegral (natVal n)
+
+natValWord :: forall n proxy . (KnownNat n, NatWithinBound Word n) => proxy n -> Word
+natValWord n = Prelude.fromIntegral (natVal n)
+
+natValWord64 :: forall n proxy . (KnownNat n, NatWithinBound Word64 n) => proxy n -> Word64
+natValWord64 n = Prelude.fromIntegral (natVal n)
+
+natValWord32 :: forall n proxy . (KnownNat n, NatWithinBound Word32 n) => proxy n -> Word32
+natValWord32 n = Prelude.fromIntegral (natVal n)
+
+natValWord16 :: forall n proxy . (KnownNat n, NatWithinBound Word16 n) => proxy n -> Word16
+natValWord16 n = Prelude.fromIntegral (natVal n)
+
+natValWord8 :: forall n proxy . (KnownNat n, NatWithinBound Word8 n) => proxy n -> Word8
+natValWord8 n = Prelude.fromIntegral (natVal n)
+
+-- | Get Maximum bounds of different Integral / Natural types related to Nat
+type family NatNumMaxBound ty :: Nat
+
+type instance NatNumMaxBound Char   = 0x10ffff
+type instance NatNumMaxBound Char7  = 0x7f
+type instance NatNumMaxBound Int64  = 0x7fffffffffffffff
+type instance NatNumMaxBound Int32  = 0x7fffffff
+type instance NatNumMaxBound Int16  = 0x7fff
+type instance NatNumMaxBound Int8   = 0x7f
+type instance NatNumMaxBound Word256 = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+type instance NatNumMaxBound Word128 = 0xffffffffffffffffffffffffffffffff
+type instance NatNumMaxBound Word64 = 0xffffffffffffffff
+type instance NatNumMaxBound Word32 = 0xffffffff
+type instance NatNumMaxBound Word16 = 0xffff
+type instance NatNumMaxBound Word8  = 0xff
+#if WORD_SIZE_IN_BITS == 64
+type instance NatNumMaxBound Int    = NatNumMaxBound Int64
+type instance NatNumMaxBound Word   = NatNumMaxBound Word64
+#else
+type instance NatNumMaxBound Int    = NatNumMaxBound Int32
+type instance NatNumMaxBound Word   = NatNumMaxBound Word32
+#endif
+
+-- | Check if a Nat is in bounds of another integral / natural types
+type family NatInBoundOf ty n where
+    NatInBoundOf Integer n = 'True
+    NatInBoundOf Natural n = 'True
+    NatInBoundOf ty      n = n <=? NatNumMaxBound ty
+
+-- | Constraint to check if a natural is within a specific bounds of a type.
+--
+-- i.e. given a Nat `n`, is it possible to convert it to `ty` without losing information
+#if __GLASGOW_HASKELL__ >= 800
+type family NatWithinBound ty (n :: Nat) where
+    NatWithinBound ty n = If (NatInBoundOf ty n)
+        (() ~ ())
+        (TypeError ('Text "Natural " ':<>: 'ShowType n ':<>: 'Text " is out of bounds for " ':<>: 'ShowType ty))
+#else
+type NatWithinBound ty n = NatInBoundOf ty n ~ 'True
+#endif

bundled/Basement/NonEmpty.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.NonEmpty
+-- License     : BSD-style
+-- Maintainer  : Foundation
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A newtype wrapper around a non-empty Collection.
+
+module Basement.NonEmpty
+    ( NonEmpty(..)
+    ) where
+
+import           Basement.Exception
+import           Basement.Compat.Base
+
+-- | NonEmpty property for any Collection
+newtype NonEmpty a = NonEmpty { getNonEmpty :: a }
+    deriving (Show,Eq)
+
+instance IsList c => IsList (NonEmpty c) where
+    type Item (NonEmpty c) = Item c
+    toList      = toList . getNonEmpty
+    fromList [] = throw NonEmptyCollectionIsEmpty
+    fromList l  = NonEmpty . fromList $ l

bundled/Basement/NormalForm.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Basement.NormalForm
+    ( NormalForm(..)
+    , deepseq
+    , force
+    ) where
+
+import Basement.Compat.Base
+import Basement.Compat.C.Types
+import Basement.Compat.Natural
+import Basement.Types.OffsetSize
+import Basement.Types.Char7
+import Basement.Types.Word128 (Word128)
+import Basement.Types.Word256 (Word256)
+import Basement.Bounded
+import Basement.Endianness
+
+-- | Data that can be fully evaluated in Normal Form
+--
+class NormalForm a where
+    toNormalForm :: a -> ()
+
+deepseq :: NormalForm a => a -> b -> b
+deepseq a b = toNormalForm a `seq` b
+
+force :: NormalForm a => a -> a
+force a = toNormalForm a `seq` a
+
+-----
+-- GHC / base types
+
+instance NormalForm Int8    where toNormalForm !_ = ()
+instance NormalForm Int16   where toNormalForm !_ = ()
+instance NormalForm Int32   where toNormalForm !_ = ()
+instance NormalForm Int64   where toNormalForm !_ = ()
+instance NormalForm Int     where toNormalForm !_ = ()
+instance NormalForm Integer where toNormalForm !_ = ()
+
+instance NormalForm Word8   where toNormalForm !_ = ()
+instance NormalForm Word16  where toNormalForm !_ = ()
+instance NormalForm Word32  where toNormalForm !_ = ()
+instance NormalForm Word64  where toNormalForm !_ = ()
+instance NormalForm Word    where toNormalForm !_ = ()
+instance NormalForm Natural where toNormalForm !_ = ()
+
+instance NormalForm Float  where toNormalForm !_ = ()
+instance NormalForm Double where toNormalForm !_ = ()
+
+instance NormalForm Char where toNormalForm !_ = ()
+instance NormalForm Bool where toNormalForm !_ = ()
+instance NormalForm ()   where toNormalForm !_ = ()
+
+-----
+-- C Types
+instance NormalForm CChar  where toNormalForm !_ = ()
+instance NormalForm CUChar where toNormalForm !_ = ()
+instance NormalForm CSChar where toNormalForm !_ = ()
+
+instance NormalForm CShort  where toNormalForm !_ = ()
+instance NormalForm CUShort where toNormalForm !_ = ()
+instance NormalForm CInt    where toNormalForm !_ = ()
+instance NormalForm CUInt   where toNormalForm !_ = ()
+instance NormalForm CLong   where toNormalForm !_ = ()
+instance NormalForm CULong  where toNormalForm !_ = ()
+instance NormalForm CLLong  where toNormalForm !_ = ()
+instance NormalForm CULLong where toNormalForm !_ = ()
+
+instance NormalForm CFloat  where toNormalForm !_ = ()
+instance NormalForm CDouble where toNormalForm !_ = ()
+
+instance NormalForm (Ptr a) where toNormalForm !_ = ()
+
+-----
+-- Basic Foundation primitive types
+instance NormalForm (Offset a) where toNormalForm !_ = ()
+instance NormalForm (CountOf a) where toNormalForm !_ = ()
+
+instance NormalForm Char7 where toNormalForm !_ = ()
+instance NormalForm Word128 where toNormalForm !_ = ()
+instance NormalForm Word256 where toNormalForm !_ = ()
+instance NormalForm (Zn n) where toNormalForm = toNormalForm . unZn
+instance NormalForm (Zn64 n) where toNormalForm = toNormalForm . unZn64
+
+-----
+-- composed type
+
+instance NormalForm a => NormalForm (Maybe a) where
+    toNormalForm Nothing  = ()
+    toNormalForm (Just a) = toNormalForm a `seq` ()
+instance (NormalForm l, NormalForm r) => NormalForm (Either l r) where
+    toNormalForm (Left l)  = toNormalForm l `seq` ()
+    toNormalForm (Right r) = toNormalForm r `seq` ()
+instance NormalForm a => NormalForm (LE a) where
+    toNormalForm (LE a) = toNormalForm a `seq` ()
+instance NormalForm a => NormalForm (BE a) where
+    toNormalForm (BE a) = toNormalForm a `seq` ()
+
+instance NormalForm a => NormalForm [a] where
+    toNormalForm []     = ()
+    toNormalForm (x:xs) = toNormalForm x `seq` toNormalForm xs
+
+instance (NormalForm a, NormalForm b) => NormalForm (a,b) where
+    toNormalForm (a,b) = toNormalForm a `seq` toNormalForm b
+
+instance (NormalForm a, NormalForm b, NormalForm c) => NormalForm (a,b,c) where
+    toNormalForm (a,b,c) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c
+
+instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d) => NormalForm (a,b,c,d) where
+    toNormalForm (a,b,c,d) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d
+
+instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e)
+      => NormalForm (a,b,c,d,e) where
+    toNormalForm (a,b,c,d,e) =
+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`
+        toNormalForm e
+
+instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f)
+      => NormalForm (a,b,c,d,e,f) where
+    toNormalForm (a,b,c,d,e,f) =
+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`
+        toNormalForm e `seq` toNormalForm f
+
+instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g)
+      => NormalForm (a,b,c,d,e,f,g) where
+    toNormalForm (a,b,c,d,e,f,g) =
+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`
+        toNormalForm e `seq` toNormalForm f `seq` toNormalForm g
+instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g, NormalForm h)
+      => NormalForm (a,b,c,d,e,f,g,h) where
+    toNormalForm (a,b,c,d,e,f,g,h) =
+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`
+        toNormalForm e `seq` toNormalForm f `seq` toNormalForm g `seq` toNormalForm h

bundled/Basement/Numerical/Additive.hs

@@ -0,0 +1,271 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MagicHash         #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# OPTIONS_GHC -fno-prof-auto #-}
+module Basement.Numerical.Additive
+    ( Additive(..)
+    ) where
+
+#include "MachDeps.h"
+
+import           Basement.Compat.Base
+import           Basement.Compat.C.Types
+import           Basement.Compat.Natural
+import           Basement.Compat.Primitive
+import           Basement.Numerical.Number
+import qualified Prelude
+import           GHC.Types (Float(..), Double(..))
+import           GHC.Prim (plusWord#, plusFloat#, (+#), (+##))
+import qualified GHC.Prim
+import           GHC.Int
+import           GHC.Word
+import           Basement.Bounded
+import           Basement.Nat
+import           Basement.Types.Word128 (Word128)
+import           Basement.Types.Word256 (Word256)
+import qualified Basement.Types.Word128 as Word128
+import qualified Basement.Types.Word256 as Word256
+
+#if WORD_SIZE_IN_BITS < 64
+import           GHC.IntWord64
+#endif
+
+-- | Represent class of things that can be added together,
+-- contains a neutral element and is commutative.
+--
+-- > x + azero = x
+-- > azero + x = x
+-- > x + y = y + x
+--
+class Additive a where
+    {-# MINIMAL azero, (+) #-}
+    azero :: a           -- the identity element over addition
+    (+)   :: a -> a -> a -- the addition
+
+    scale :: IsNatural n => n -> a -> a -- scale: repeated addition
+    default scale :: (Enum n, IsNatural n) => n -> a -> a
+    scale = scaleEnum
+
+scaleEnum :: (Enum n, IsNatural n, Additive a) => n -> a -> a
+scaleEnum 0 _ = azero
+scaleEnum 1 a = a
+scaleEnum 2 a = a + a
+scaleEnum n a = a + scaleEnum (pred n) a -- TODO optimise. define by group of 2.
+
+infixl 6 +
+
+instance Additive Integer where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive Int where
+    azero = 0
+    (I# a) + (I# b) = I# (a +# b)
+    scale = scaleNum
+instance Additive Int8 where
+    azero = 0
+    (I8# a) + (I8# b) = I8# (a `plusInt8#` b)
+    scale = scaleNum
+instance Additive Int16 where
+    azero = 0
+    (I16# a) + (I16# b) = I16# (a `plusInt16#` b)
+    scale = scaleNum
+instance Additive Int32 where
+    azero = 0
+    (I32# a) + (I32# b) = I32# (a `plusInt32#` b)
+    scale = scaleNum
+instance Additive Int64 where
+    azero = 0
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+    (I64# a) + (I64# b) = I64# (GHC.Prim.intToInt64# (GHC.Prim.int64ToInt# a +# GHC.Prim.int64ToInt# b))
+
+#else
+    (I64# a) + (I64# b) = I64# (a +# b)
+
+#endif
+#else
+    (I64# a) + (I64# b) = I64# (a `plusInt64#` b)
+#endif
+    scale = scaleNum
+instance Additive Word where
+    azero = 0
+    (W# a) + (W# b) = W# (a `plusWord#` b)
+    scale = scaleNum
+instance Additive Natural where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive Word8 where
+    azero = 0
+    (W8# a) + (W8# b) = W8# (a `plusWord8#` b)
+    scale = scaleNum
+instance Additive Word16 where
+    azero = 0
+    (W16# a) + (W16# b) = W16# (a `plusWord16#` b)
+    scale = scaleNum
+instance Additive Word32 where
+    azero = 0
+    (W32# a) + (W32# b) = W32# (a `plusWord32#` b)
+    scale = scaleNum
+instance Additive Word64 where
+    azero = 0
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+    (W64# a) + (W64# b) = W64# (GHC.Prim.wordToWord64# (GHC.Prim.word64ToWord# a `plusWord#` GHC.Prim.word64ToWord# b))
+
+#else
+    (W64# a) + (W64# b) = W64# (a `plusWord#` b)
+
+#endif
+#else
+    (W64# a) + (W64# b) = W64# (int64ToWord64# (word64ToInt64# a `plusInt64#` word64ToInt64# b))
+#endif
+    scale = scaleNum
+instance Additive Word128 where
+    azero = 0
+    (+) = (Word128.+)
+    scale = scaleNum
+instance Additive Word256 where
+    azero = 0
+    (+) = (Word256.+)
+    scale = scaleNum
+
+instance Additive Prelude.Float where
+    azero = 0.0
+    (F# a) + (F# b) = F# (a `plusFloat#` b)
+    scale = scaleNum
+instance Additive Prelude.Double where
+    azero = 0.0
+    (D# a) + (D# b) = D# (a +## b)
+    scale = scaleNum
+instance Additive Prelude.Rational where
+    azero = 0.0
+    (+) = (Prelude.+)
+    scale = scaleNum
+
+instance (KnownNat n, NatWithinBound Word64 n) => Additive (Zn64 n) where
+    azero = zn64 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance KnownNat n => Additive (Zn n) where
+    azero = zn 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+
+instance Additive CChar where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CSChar where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CUChar where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CShort where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CUShort where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CInt where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CUInt where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CLong where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CULong where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CPtrdiff where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CSize where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CWchar where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CSigAtomic where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CLLong where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CULLong where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CIntPtr where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CUIntPtr where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CIntMax where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CUIntMax where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CClock where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CTime where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CUSeconds where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CSUSeconds where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive COff where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+
+instance Additive CFloat where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+instance Additive CDouble where
+    azero = 0
+    (+) = (Prelude.+)
+    scale = scaleNum
+
+scaleNum :: (Prelude.Num a, IsNatural n) => n -> a -> a
+scaleNum n a = (Prelude.fromIntegral $ toNatural n) Prelude.* a

bundled/Basement/Numerical/Conversion.hs

@@ -0,0 +1,135 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE MagicHash             #-}
+module Basement.Numerical.Conversion
+    ( intToInt64
+    , int64ToInt
+    , intToWord
+    , wordToWord64
+    , word64ToWord
+    , Word32x2(..)
+    , word64ToWord32s
+    , wordToChar
+    , wordToInt
+    , word64ToWord#
+    , charToInt
+    , int64ToWord64
+    , word64ToInt64
+    ) where
+
+#include "MachDeps.h"
+
+import GHC.Types
+import GHC.Prim hiding (word64ToWord#)
+import qualified GHC.Prim
+import GHC.Int
+import GHC.Word
+import Basement.Compat.Primitive
+
+#if WORD_SIZE_IN_BITS < 64
+import GHC.IntWord64
+#endif
+
+intToInt64 :: Int -> Int64
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+intToInt64 (I# i) = I64# (intToInt64# i)
+#else
+intToInt64 (I# i) = I64# i
+#endif
+#else
+intToInt64 (I# i) = I64# (intToInt64# i)
+#endif
+
+int64ToInt :: Int64 -> Int
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+int64ToInt (I64# i) = I# (int64ToInt# i)
+#else
+int64ToInt (I64# i) = I# i
+#endif
+#else
+int64ToInt (I64# i) = I# (int64ToInt# i)
+#endif
+
+wordToWord64 :: Word -> Word64
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+wordToWord64 (W# i) = W64# (wordToWord64# i)
+#else
+wordToWord64 (W# i) = W64# i
+#endif
+#else
+wordToWord64 (W# i) = W64# (wordToWord64# i)
+#endif
+
+word64ToWord :: Word64 -> Word
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+word64ToWord (W64# i) = W# (GHC.Prim.word64ToWord# i)
+#else
+word64ToWord (W64# i) = W# i
+#endif
+#else
+word64ToWord (W64# i) = W# (word64ToWord# i)
+#endif
+
+word64ToInt64 :: Word64 -> Int64
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+word64ToInt64 (W64# i) = I64# (word64ToInt64# i)
+#else
+word64ToInt64 (W64# i) = I64# (word2Int# i)
+#endif
+#else
+word64ToInt64 (W64# i) = I64# (word64ToInt64# i)
+#endif
+
+int64ToWord64 :: Int64 -> Word64
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+int64ToWord64 (I64# i) = W64# (int64ToWord64# i)
+#else
+int64ToWord64 (I64# i) = W64# (int2Word# i)
+#endif
+#else
+int64ToWord64 (I64# i) = W64# (int64ToWord64# i)
+#endif
+
+#if WORD_SIZE_IN_BITS == 64
+word64ToWord# :: Word# -> Word#
+word64ToWord# i = i
+{-# INLINE word64ToWord# #-}
+#endif
+
+-- | 2 Word32s
+data Word32x2 = Word32x2 {-# UNPACK #-} !Word32
+                         {-# UNPACK #-} !Word32
+
+#if WORD_SIZE_IN_BITS == 64
+word64ToWord32s :: Word64 -> Word32x2
+#if __GLASGOW_HASKELL__ >= 904
+word64ToWord32s (W64# w64) = Word32x2 (W32# (wordToWord32# (uncheckedShiftRL# (GHC.Prim.word64ToWord# w64 ) 32#))) (W32# (wordToWord32# (GHC.Prim.word64ToWord# w64)))
+#else
+word64ToWord32s (W64# w64) = Word32x2 (W32# (wordToWord32# (uncheckedShiftRL# w64 32#))) (W32# (wordToWord32# w64))
+#endif
+#else
+word64ToWord32s :: Word64 -> Word32x2
+word64ToWord32s (W64# w64) = Word32x2 (W32# (word64ToWord# (uncheckedShiftRL64# w64 32#))) (W32# (word64ToWord# w64))
+#endif
+
+wordToChar :: Word -> Char
+wordToChar (W# word) = C# (chr# (word2Int# word))
+
+wordToInt :: Word -> Int
+wordToInt (W# word) = I# (word2Int# word)
+
+intToWord :: Int -> Word
+intToWord (I# i) = W# (int2Word# i)
+
+charToInt :: Char -> Int
+charToInt (C# x) = I# (ord# x)

bundled/Basement/Numerical/Multiplicative.hs

@@ -0,0 +1,331 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE DefaultSignatures #-}
+module Basement.Numerical.Multiplicative
+    ( Multiplicative(..)
+    , IDivisible(..)
+    , Divisible(..)
+    , recip
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Compat.C.Types
+import           Basement.Compat.Natural
+import           Basement.Compat.NumLiteral
+import           Basement.Numerical.Number
+import           Basement.Numerical.Additive
+import           Basement.Types.Word128 (Word128)
+import           Basement.Types.Word256 (Word256)
+import qualified Basement.Types.Word128 as Word128
+import qualified Basement.Types.Word256 as Word256
+import qualified Prelude
+
+-- | Represent class of things that can be multiplied together
+--
+-- > x * midentity = x
+-- > midentity * x = x
+class Multiplicative a where
+    {-# MINIMAL midentity, (*) #-}
+    -- | Identity element over multiplication
+    midentity :: a
+
+    -- | Multiplication of 2 elements that result in another element
+    (*) :: a -> a -> a
+
+    -- | Raise to power, repeated multiplication
+    -- e.g.
+    -- > a ^ 2 = a * a
+    -- > a ^ 10 = (a ^ 5) * (a ^ 5) ..
+    --(^) :: (IsNatural n) => a -> n -> a
+    (^) :: (IsNatural n, Enum n, IDivisible n) => a -> n -> a
+    (^) = power
+
+-- | Represent types that supports an euclidian division
+--
+-- > (x ‘div‘ y) * y + (x ‘mod‘ y) == x
+class (Additive a, Multiplicative a) => IDivisible a where
+    {-# MINIMAL (div, mod) | divMod #-}
+    div :: a -> a -> a
+    div a b = fst $ divMod a b
+    mod :: a -> a -> a
+    mod a b = snd $ divMod a b
+    divMod :: a -> a -> (a, a)
+    divMod a b = (div a b, mod a b)
+
+-- | Support for division between same types
+--
+-- This is likely to change to represent specific mathematic divisions
+class Multiplicative a => Divisible a where
+    {-# MINIMAL (/) #-}
+    (/) :: a -> a -> a
+
+infixl 7  *, /
+infixr 8  ^
+
+instance Multiplicative Integer where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Int where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Int8 where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Int16 where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Int32 where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Int64 where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Natural where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Word where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Word8 where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Word16 where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Word32 where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Word64 where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative Word128 where
+    midentity = 1
+    (*) = (Word128.*)
+instance Multiplicative Word256 where
+    midentity = 1
+    (*) = (Word256.*)
+
+instance Multiplicative Prelude.Float where
+    midentity = 1.0
+    (*) = (Prelude.*)
+instance Multiplicative Prelude.Double where
+    midentity = 1.0
+    (*) = (Prelude.*)
+instance Multiplicative Prelude.Rational where
+    midentity = 1.0
+    (*) = (Prelude.*)
+
+instance Multiplicative CChar where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CSChar where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CUChar where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CShort where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CUShort where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CInt where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CUInt where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CLong where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CULong where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CPtrdiff where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CSize where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CWchar where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CSigAtomic where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CLLong where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CULLong where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CIntPtr where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CUIntPtr where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CIntMax where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CUIntMax where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CClock where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CTime where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CUSeconds where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative CSUSeconds where
+    midentity = 1
+    (*) = (Prelude.*)
+instance Multiplicative COff where
+    midentity = 1
+    (*) = (Prelude.*)
+
+instance Multiplicative CFloat where
+    midentity = 1.0
+    (*) = (Prelude.*)
+instance Multiplicative CDouble where
+    midentity = 1.0
+    (*) = (Prelude.*)
+
+instance IDivisible Integer where
+    div = Prelude.div
+    mod = Prelude.mod
+instance IDivisible Int where
+    div = Prelude.div
+    mod = Prelude.mod
+instance IDivisible Int8 where
+    div = Prelude.div
+    mod = Prelude.mod
+instance IDivisible Int16 where
+    div = Prelude.div
+    mod = Prelude.mod
+instance IDivisible Int32 where
+    div = Prelude.div
+    mod = Prelude.mod
+instance IDivisible Int64 where
+    div = Prelude.div
+    mod = Prelude.mod
+instance IDivisible Natural where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible Word where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible Word8 where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible Word16 where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible Word32 where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible Word64 where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible Word128 where
+    div = Word128.quot
+    mod = Word128.rem
+instance IDivisible Word256 where
+    div = Word256.quot
+    mod = Word256.rem
+
+instance IDivisible CChar where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CSChar where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CUChar where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CShort where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CUShort where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CInt where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CUInt where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CLong where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CULong where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CPtrdiff where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CSize where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CWchar where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CSigAtomic where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CLLong where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CULLong where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CIntPtr where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CUIntPtr where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CIntMax where
+    div = Prelude.quot
+    mod = Prelude.rem
+instance IDivisible CUIntMax where
+    div = Prelude.quot
+    mod = Prelude.rem
+
+instance Divisible Prelude.Rational where
+    (/) = (Prelude./)
+instance Divisible Float where
+    (/) = (Prelude./)
+instance Divisible Double where
+    (/) = (Prelude./)
+
+instance Divisible CFloat where
+    (/) = (Prelude./)
+instance Divisible CDouble where
+    (/) = (Prelude./)
+
+recip :: Divisible a => a -> a
+recip x = midentity / x
+
+power :: (Enum n, IsNatural n, IDivisible n, Multiplicative a) => a -> n -> a
+power a n
+    | n == 0    = midentity
+    | otherwise = squaring midentity a n
+  where
+    squaring y x i
+        | i == 0    = y
+        | i == 1    = x * y
+        | even i    = squaring y (x*x) (i`div`2)
+        | otherwise = squaring (x*y) (x*x) (pred i`div` 2)
+
+even :: (IDivisible n, IsIntegral n) => n -> Bool
+even n = (n `mod` 2) == 0

bundled/Basement/Numerical/Number.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# Language CPP #-}
+module Basement.Numerical.Number
+    ( IsIntegral(..)
+    , IsNatural(..)
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Compat.C.Types
+import           Basement.Compat.Natural
+import           Basement.Compat.NumLiteral
+import           Data.Bits
+import qualified Prelude
+
+-- | Number literals, convertible through the generic Integer type.
+--
+-- all number are Enum'erable, meaning that you can move to
+-- next element
+class (Integral a, Eq a, Ord a) => IsIntegral a where
+    {-# MINIMAL toInteger #-}
+    toInteger :: a -> Integer
+
+-- | Non Negative Number literals, convertible through the generic Natural type
+class IsIntegral a => IsNatural a where
+    {-# MINIMAL toNatural #-}
+    toNatural :: a -> Natural
+
+instance IsIntegral Integer where
+    toInteger i = i
+instance IsIntegral Int where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Int8 where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Int16 where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Int32 where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Int64 where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Natural where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Word where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Word8 where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Word16 where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Word32 where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral Word64 where
+    toInteger i = Prelude.toInteger i
+
+instance IsIntegral CChar where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CSChar where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CUChar where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CShort where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CUShort where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CInt where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CUInt where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CLong where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CULong where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CPtrdiff where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CSize where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CWchar where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CSigAtomic where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CLLong where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CULLong where
+    toInteger i = Prelude.toInteger i
+#if MIN_VERSION_base(4,10,0)
+instance IsIntegral CBool where
+    toInteger i = Prelude.toInteger i
+#endif
+instance IsIntegral CIntPtr where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CUIntPtr where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CIntMax where
+    toInteger i = Prelude.toInteger i
+instance IsIntegral CUIntMax where
+    toInteger i = Prelude.toInteger i
+
+instance IsNatural Natural where
+    toNatural i = i
+instance IsNatural Word where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural Word8 where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural Word16 where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural Word32 where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural Word64 where
+    toNatural i = Prelude.fromIntegral i
+
+instance IsNatural CUChar where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural CUShort where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural CUInt where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural CULong where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural CSize where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural CULLong where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural CUIntPtr where
+    toNatural i = Prelude.fromIntegral i
+instance IsNatural CUIntMax where
+    toNatural i = Prelude.fromIntegral i

bundled/Basement/Numerical/Subtractive.hs

@@ -0,0 +1,186 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP, UndecidableInstances, TypeFamilies #-}
+module Basement.Numerical.Subtractive
+    ( Subtractive(..)
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Compat.C.Types
+import           Basement.Compat.Natural
+import           Basement.IntegralConv
+import           Basement.Bounded
+import           Basement.Nat
+import           Basement.Types.Word128 (Word128)
+import           Basement.Types.Word256 (Word256)
+import qualified Basement.Types.Word128 as Word128
+import qualified Basement.Types.Word256 as Word256
+import qualified Prelude
+
+-- | Represent class of things that can be subtracted.
+--
+--
+-- Note that the result is not necessary of the same type
+-- as the operand depending on the actual type.
+--
+-- For example:
+--
+-- > (-) :: Int -> Int -> Int
+-- > (-) :: DateTime -> DateTime -> Seconds
+-- > (-) :: Ptr a -> Ptr a -> PtrDiff
+-- > (-) :: Natural -> Natural -> Maybe Natural
+class Subtractive a where
+    type Difference a
+    (-) :: a -> a -> Difference a
+
+infixl 6 -
+
+instance Subtractive Integer where
+    type Difference Integer = Integer
+    (-) = (Prelude.-)
+instance Subtractive Int where
+    type Difference Int = Int
+    (-) = (Prelude.-)
+instance Subtractive Int8 where
+    type Difference Int8 = Int8
+    (-) = (Prelude.-)
+instance Subtractive Int16 where
+    type Difference Int16 = Int16
+    (-) = (Prelude.-)
+instance Subtractive Int32 where
+    type Difference Int32 = Int32
+    (-) = (Prelude.-)
+instance Subtractive Int64 where
+    type Difference Int64 = Int64
+    (-) = (Prelude.-)
+instance Subtractive Natural where
+    type Difference Natural = Maybe Natural
+    (-) a b
+        | b > a     = Nothing
+        | otherwise = Just (a Prelude.- b)
+instance Subtractive Word where
+    type Difference Word = Word
+    (-) = (Prelude.-)
+instance Subtractive Word8 where
+    type Difference Word8 = Word8
+    (-) = (Prelude.-)
+instance Subtractive Word16 where
+    type Difference Word16 = Word16
+    (-) = (Prelude.-)
+instance Subtractive Word32 where
+    type Difference Word32 = Word32
+    (-) = (Prelude.-)
+instance Subtractive Word64 where
+    type Difference Word64 = Word64
+    (-) = (Prelude.-)
+instance Subtractive Word128 where
+    type Difference Word128 = Word128
+    (-) = (Word128.-)
+instance Subtractive Word256 where
+    type Difference Word256 = Word256
+    (-) = (Word256.-)
+
+instance Subtractive Prelude.Float where
+    type Difference Prelude.Float = Prelude.Float
+    (-) = (Prelude.-)
+instance Subtractive Prelude.Double where
+    type Difference Prelude.Double = Prelude.Double
+    (-) = (Prelude.-)
+
+instance Subtractive Prelude.Char where
+    type Difference Prelude.Char = Prelude.Int
+    (-) a b = (Prelude.-) (charToInt a) (charToInt b)
+instance (KnownNat n, NatWithinBound Word64 n) => Subtractive (Zn64 n) where
+    type Difference (Zn64 n) = Zn64 n
+    (-) a b = (Prelude.-) a b
+instance KnownNat n => Subtractive (Zn n) where
+    type Difference (Zn n) = Zn n
+    (-) a b = (Prelude.-) a b
+
+instance Subtractive CChar where
+    type Difference CChar = CChar
+    (-) = (Prelude.-)
+instance Subtractive CSChar where
+    type Difference CSChar = CSChar
+    (-) = (Prelude.-)
+instance Subtractive CUChar where
+    type Difference CUChar = CUChar
+    (-) = (Prelude.-)
+instance Subtractive CShort where
+    type Difference CShort = CShort
+    (-) = (Prelude.-)
+instance Subtractive CUShort where
+    type Difference CUShort = CUShort
+    (-) = (Prelude.-)
+instance Subtractive CInt where
+    type Difference CInt = CInt
+    (-) = (Prelude.-)
+instance Subtractive CUInt where
+    type Difference CUInt = CUInt
+    (-) = (Prelude.-)
+instance Subtractive CLong where
+    type Difference CLong = CLong
+    (-) = (Prelude.-)
+instance Subtractive CULong where
+    type Difference CULong = CULong
+    (-) = (Prelude.-)
+instance Subtractive CPtrdiff where
+    type Difference CPtrdiff = CPtrdiff
+    (-) = (Prelude.-)
+instance Subtractive CSize where
+    type Difference CSize = CSize
+    (-) = (Prelude.-)
+instance Subtractive CWchar where
+    type Difference CWchar = CWchar
+    (-) = (Prelude.-)
+instance Subtractive CSigAtomic where
+    type Difference CSigAtomic = CSigAtomic
+    (-) = (Prelude.-)
+instance Subtractive CLLong where
+    type Difference CLLong = CLLong
+    (-) = (Prelude.-)
+instance Subtractive CULLong where
+    type Difference CULLong = CULLong
+    (-) = (Prelude.-)
+#if MIN_VERSION_base(4,10,0)
+instance Subtractive CBool where
+    type Difference CBool = CBool
+    (-) = (Prelude.-)
+#endif
+instance Subtractive CIntPtr where
+    type Difference CIntPtr = CIntPtr
+    (-) = (Prelude.-)
+instance Subtractive CUIntPtr where
+    type Difference CUIntPtr = CUIntPtr
+    (-) = (Prelude.-)
+instance Subtractive CIntMax where
+    type Difference CIntMax = CIntMax
+    (-) = (Prelude.-)
+instance Subtractive CUIntMax where
+    type Difference CUIntMax = CUIntMax
+    (-) = (Prelude.-)
+instance Subtractive CClock where
+    type Difference CClock = CClock
+    (-) = (Prelude.-)
+instance Subtractive CTime where
+    type Difference CTime = CTime
+    (-) = (Prelude.-)
+instance Subtractive CUSeconds where
+    type Difference CUSeconds = CUSeconds
+    (-) = (Prelude.-)
+instance Subtractive CSUSeconds where
+    type Difference CSUSeconds = CSUSeconds
+    (-) = (Prelude.-)
+instance Subtractive COff where
+    type Difference COff = COff
+    (-) = (Prelude.-)
+
+instance Subtractive CFloat where
+    type Difference CFloat = CFloat
+    (-) = (Prelude.-)
+instance Subtractive CDouble where
+    type Difference CDouble = CDouble
+    (-) = (Prelude.-)

bundled/Basement/PrimType.hs

@@ -0,0 +1,768 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- Module      : Basement.PrimType
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+module Basement.PrimType
+    ( PrimType(..)
+    , PrimMemoryComparable
+    , primBaIndex
+    , primMbaRead
+    , primMbaWrite
+    , primArrayIndex
+    , primMutableArrayRead
+    , primMutableArrayWrite
+    , primOffsetOfE
+    , primOffsetRecast
+    , sizeRecast
+    , offsetAsSize
+    , sizeAsOffset
+    , sizeInBytes
+    , offsetInBytes
+    , offsetInElements
+    , offsetIsAligned
+    , primWordGetByteAndShift
+    , primWord64GetByteAndShift
+    , primWord64GetHiLo
+    ) where
+
+#include "MachDeps.h"
+
+import           GHC.Prim
+import           GHC.Int
+import           GHC.Types
+import           GHC.Word
+import           Data.Bits
+import           Data.Proxy
+import           Basement.Compat.Base
+import           Basement.Compat.C.Types
+import           Basement.Numerical.Subtractive
+import           Basement.Types.OffsetSize
+import           Basement.Types.Char7 (Char7(..))
+import           Basement.Endianness
+import           Basement.Types.Word128 (Word128(..))
+import           Basement.Types.Word256 (Word256(..))
+import           Basement.Monad
+import           Basement.Nat
+import qualified Prelude (quot)
+
+#if WORD_SIZE_IN_BITS < 64
+import           GHC.IntWord64
+#endif
+
+#ifdef FOUNDATION_BOUNDS_CHECK
+
+divBytes :: PrimType ty => Offset ty -> (Int -> Int)
+divBytes ofs = \x -> x `Prelude.quot` (getSize Proxy ofs)
+  where
+    getSize :: PrimType ty => Proxy ty -> Offset ty -> Int
+    getSize p _ = let (CountOf sz) = primSizeInBytes p in sz
+
+baLength :: PrimType ty => Offset ty -> ByteArray# -> Int
+baLength ofs ba = divBytes ofs (I# (sizeofByteArray# ba))
+
+mbaLength :: PrimType ty => Offset ty -> MutableByteArray# st -> Int
+mbaLength ofs ba = divBytes ofs (I# (sizeofMutableByteArray# ba))
+
+aLength :: Array# ty -> Int
+aLength ba = I# (sizeofArray# ba)
+
+maLength :: MutableArray# st ty -> Int
+maLength ba = I# (sizeofMutableArray# ba)
+
+boundCheckError :: [Char] -> Offset ty -> Int -> a
+boundCheckError ty (Offset ofs) len =
+    error (ty <> " offset=" <> show ofs <> " len=" <> show len)
+
+baCheck :: PrimType ty => ByteArray# -> Offset ty -> Bool
+baCheck ba ofs@(Offset o) = o < 0 || o >= baLength ofs ba
+
+mbaCheck :: PrimType ty => MutableByteArray# st -> Offset ty -> Bool
+mbaCheck mba ofs@(Offset o) = o < 0 || o >= mbaLength ofs mba
+
+aCheck :: Array# ty -> Offset ty -> Bool
+aCheck ba (Offset o) = o < 0 || o >= aLength ba
+
+maCheck :: MutableArray# st ty -> Offset ty -> Bool
+maCheck ma (Offset o) = o < 0 || o >= maLength ma
+
+primBaIndex :: PrimType ty => ByteArray# -> Offset ty -> ty
+primBaIndex ba ofs
+    | baCheck ba ofs = boundCheckError "bytearray-index" ofs (baLength ofs ba)
+    | otherwise      = primBaUIndex ba ofs
+{-# NOINLINE primBaIndex #-}
+
+primMbaRead :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> prim ty
+primMbaRead mba ofs
+    | mbaCheck mba ofs = boundCheckError "mutablebytearray-read" ofs (mbaLength ofs mba)
+    | otherwise        = primMbaURead mba ofs
+{-# NOINLINE primMbaRead #-}
+
+primMbaWrite :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> ty -> prim ()
+primMbaWrite mba ofs ty
+    | mbaCheck mba ofs = boundCheckError "mutablebytearray-write" ofs (mbaLength ofs mba)
+    | otherwise        = primMbaUWrite mba ofs ty
+{-# NOINLINE primMbaWrite #-}
+
+primArrayIndex :: Array# ty -> Offset ty -> ty
+primArrayIndex a o@(Offset (I# ofs))
+    | aCheck a o = boundCheckError "array-index" o (aLength a)
+    | otherwise  = let !(# v #) = indexArray# a ofs in v
+{-# NOINLINE primArrayIndex #-}
+
+primMutableArrayRead :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> prim ty
+primMutableArrayRead ma o@(Offset (I# ofs))
+    | maCheck ma o = boundCheckError "array-read" o (maLength ma)
+    | otherwise    = primitive $ \s1 -> readArray# ma ofs s1
+{-# NOINLINE primMutableArrayRead #-}
+
+primMutableArrayWrite :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> ty -> prim ()
+primMutableArrayWrite ma o@(Offset (I# ofs)) v
+    | maCheck ma o = boundCheckError "array-write" o (maLength ma)
+    | otherwise    = primitive $ \s1 -> let !s2 = writeArray# ma ofs v s1 in (# s2, () #)
+{-# NOINLINE primMutableArrayWrite #-}
+
+#else
+
+primBaIndex :: PrimType ty => ByteArray# -> Offset ty -> ty
+primBaIndex = primBaUIndex
+{-# INLINE primBaIndex #-}
+
+primMbaRead :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> prim ty
+primMbaRead = primMbaURead
+{-# INLINE primMbaRead #-}
+
+primMbaWrite :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> ty -> prim ()
+primMbaWrite = primMbaUWrite
+{-# INLINE primMbaWrite #-}
+
+primArrayIndex :: Array# ty -> Offset ty -> ty
+primArrayIndex a (Offset (I# ofs)) = let !(# v #) = indexArray# a ofs in v
+{-# INLINE primArrayIndex #-}
+
+primMutableArrayRead :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> prim ty
+primMutableArrayRead ma (Offset (I# ofs)) = primitive $ \s1 -> readArray# ma ofs s1
+{-# INLINE primMutableArrayRead #-}
+
+primMutableArrayWrite :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> ty -> prim ()
+primMutableArrayWrite ma (Offset (I# ofs)) v =
+    primitive $ \s1 -> let !s2 = writeArray# ma ofs v s1 in (# s2, () #)
+{-# INLINE primMutableArrayWrite #-}
+
+#endif
+
+-- | Represent the accessor for types that can be stored in the UArray and MUArray.
+--
+-- Types need to be a instance of storable and have fixed sized.
+class Eq ty => PrimType ty where
+    -- | type level size of the given `ty`
+    type PrimSize ty :: Nat
+
+    -- | get the size in bytes of a ty element
+    primSizeInBytes :: Proxy ty -> CountOf Word8
+
+    -- | get the shift size
+    primShiftToBytes :: Proxy ty -> Int
+
+    -----
+    -- ByteArray section
+    -----
+
+    -- | return the element stored at a specific index
+    primBaUIndex :: ByteArray# -> Offset ty -> ty
+
+    -----
+    -- MutableByteArray section
+    -----
+
+    -- | Read an element at an index in a mutable array
+    primMbaURead :: PrimMonad prim
+                => MutableByteArray# (PrimState prim) -- ^ mutable array to read from
+                -> Offset ty                         -- ^ index of the element to retrieve
+                -> prim ty                           -- ^ the element returned
+
+    -- | Write an element to a specific cell in a mutable array.
+    primMbaUWrite :: PrimMonad prim
+                 => MutableByteArray# (PrimState prim) -- ^ mutable array to modify
+                 -> Offset ty                         -- ^ index of the element to modify
+                 -> ty                                 -- ^ the new value to store
+                 -> prim ()
+
+    -----
+    -- Addr# section
+    -----
+
+    -- | Read from Address, without a state. the value read should be considered a constant for all
+    -- pratical purpose, otherwise bad thing will happens.
+    primAddrIndex :: Addr# -> Offset ty -> ty
+
+    -- | Read a value from Addr in a specific primitive monad
+    primAddrRead :: PrimMonad prim
+                 => Addr#
+                 -> Offset ty
+                 -> prim ty
+    -- | Write a value to Addr in a specific primitive monad
+    primAddrWrite :: PrimMonad prim
+                  => Addr#
+                  -> Offset ty
+                  -> ty
+                  -> prim ()
+
+sizeInt, sizeWord :: CountOf Word8
+shiftInt, shiftWord :: Int
+#if WORD_SIZE_IN_BITS == 64
+sizeInt = CountOf 8
+sizeWord = CountOf 8
+shiftInt = 3
+shiftWord = 3
+#else
+sizeInt = CountOf 4
+sizeWord = CountOf 4
+shiftInt = 2
+shiftWord = 2
+#endif
+
+{-# SPECIALIZE [3] primBaUIndex :: ByteArray# -> Offset Word8 -> Word8 #-}
+
+instance PrimType Int where
+#if WORD_SIZE_IN_BITS == 64
+    type PrimSize Int = 8
+#else
+    type PrimSize Int = 4
+#endif
+    primSizeInBytes _ = sizeInt
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = shiftInt
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = I# (indexIntArray# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readIntArray# mba n s1 in (# s2, I# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntArray# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = I# (indexIntOffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readIntOffAddr# addr n s1 in (# s2, I# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntOffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+
+instance PrimType Word where
+#if WORD_SIZE_IN_BITS == 64
+    type PrimSize Word = 8
+#else
+    type PrimSize Word = 4
+#endif
+    primSizeInBytes _ = sizeWord
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = shiftWord
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = W# (indexWordArray# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWordArray# mba n s1 in (# s2, W# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordArray# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = W# (indexWordOffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWordOffAddr# addr n s1 in (# s2, W# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordOffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+
+instance PrimType Word8 where
+    type PrimSize Word8 = 1
+    primSizeInBytes _ = CountOf 1
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 0
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord8Array# mba n s1 in (# s2, W8# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8Array# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = W8# (indexWord8OffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord8OffAddr# addr n s1 in (# s2, W8# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8OffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+
+instance PrimType Word16 where
+    type PrimSize Word16 = 2
+    primSizeInBytes _ = CountOf 2
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 1
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord16Array# mba n s1 in (# s2, W16# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16Array# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = W16# (indexWord16OffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord16OffAddr# addr n s1 in (# s2, W16# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16OffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+instance PrimType Word32 where
+    type PrimSize Word32 = 4
+    primSizeInBytes _ = CountOf 4
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 2
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = W32# (indexWord32Array# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord32Array# mba n s1 in (# s2, W32# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32Array# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = W32# (indexWord32OffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord32OffAddr# addr n s1 in (# s2, W32# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32OffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+instance PrimType Word64 where
+    type PrimSize Word64 = 8
+    primSizeInBytes _ = CountOf 8
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 3
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = W64# (indexWord64Array# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord64Array# mba n s1 in (# s2, W64# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64Array# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = W64# (indexWord64OffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWord64OffAddr# addr n s1 in (# s2, W64# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64OffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+instance PrimType Word128 where
+    type PrimSize Word128 = 16
+    primSizeInBytes _ = CountOf 16
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 4
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba n =
+        Word128 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2))
+      where (# n1, n2 #) = offset128_64 n
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1
+                                                !(# s3, r2 #) = readWord64Array# mba n2 s2
+                                             in (# s3, Word128 (W64# r1) (W64# r2) #)
+      where (# n1, n2 #) = offset128_64 n
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 ->
+        let !s2 = writeWord64Array# mba n1 w1 s1
+         in (# writeWord64Array# mba n2 w2 s2, () #)
+      where (# n1, n2 #) = offset128_64 n
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr n = Word128 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2))
+      where (# n1, n2 #) = offset128_64 n
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1
+                                                 !(# s3, r2 #) = readWord64OffAddr# addr n2 s2
+                                              in (# s3, Word128 (W64# r1) (W64# r2) #)
+      where (# n1, n2 #) = offset128_64 n
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 ->
+        let !s2 = writeWord64OffAddr# addr n1 w1 s1
+         in (# writeWord64OffAddr# addr n2 w2 s2, () #)
+      where (# n1, n2 #) = offset128_64 n
+    {-# INLINE primAddrWrite #-}
+instance PrimType Word256 where
+    type PrimSize Word256 = 32
+    primSizeInBytes _ = CountOf 32
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 5
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba n =
+        Word256 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2))
+                (W64# (indexWord64Array# ba n3)) (W64# (indexWord64Array# ba n4))
+      where (# n1, n2, n3, n4 #) = offset256_64 n
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1
+                                                !(# s3, r2 #) = readWord64Array# mba n2 s2
+                                                !(# s4, r3 #) = readWord64Array# mba n3 s3
+                                                !(# s5, r4 #) = readWord64Array# mba n4 s4
+                                             in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #)
+      where (# n1, n2, n3, n4 #) = offset256_64 n
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 ->
+        let !s2 = writeWord64Array# mba n1 w1 s1
+            !s3 = writeWord64Array# mba n2 w2 s2
+            !s4 = writeWord64Array# mba n3 w3 s3
+         in (# writeWord64Array# mba n4 w4 s4, () #)
+      where (# n1, n2, n3, n4 #) = offset256_64 n
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr n = Word256 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2))
+                                   (W64# (indexWord64OffAddr# addr n3)) (W64# (indexWord64OffAddr# addr n4))
+      where (# n1, n2, n3, n4 #) = offset256_64 n
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1
+                                                 !(# s3, r2 #) = readWord64OffAddr# addr n2 s2
+                                                 !(# s4, r3 #) = readWord64OffAddr# addr n3 s3
+                                                 !(# s5, r4 #) = readWord64OffAddr# addr n4 s4
+                                              in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #)
+      where (# n1, n2, n3, n4 #) = offset256_64 n
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 ->
+        let !s2 = writeWord64OffAddr# addr n1 w1 s1
+            !s3 = writeWord64OffAddr# addr n2 w2 s2
+            !s4 = writeWord64OffAddr# addr n3 w3 s3
+         in (# writeWord64OffAddr# addr n4 w4 s4, () #)
+      where (# n1, n2, n3, n4 #) = offset256_64 n
+    {-# INLINE primAddrWrite #-}
+instance PrimType Int8 where
+    type PrimSize Int8 = 1
+    primSizeInBytes _ = CountOf 1
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 0
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = I8# (indexInt8Array# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt8Array# mba n s1 in (# s2, I8# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8Array# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = I8# (indexInt8OffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt8OffAddr# addr n s1 in (# s2, I8# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8OffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+instance PrimType Int16 where
+    type PrimSize Int16 = 2
+    primSizeInBytes _ = CountOf 2
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 1
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = I16# (indexInt16Array# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt16Array# mba n s1 in (# s2, I16# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16Array# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = I16# (indexInt16OffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt16OffAddr# addr n s1 in (# s2, I16# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16OffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+instance PrimType Int32 where
+    type PrimSize Int32 = 4
+    primSizeInBytes _ = CountOf 4
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 2
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = I32# (indexInt32Array# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt32Array# mba n s1 in (# s2, I32# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32Array# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = I32# (indexInt32OffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt32OffAddr# addr n s1 in (# s2, I32# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32OffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+instance PrimType Int64 where
+    type PrimSize Int64 = 8
+    primSizeInBytes _ = CountOf 8
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 3
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = I64# (indexInt64Array# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt64Array# mba n s1 in (# s2, I64# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64Array# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = I64# (indexInt64OffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readInt64OffAddr# addr n s1 in (# s2, I64# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64OffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+
+instance PrimType Float where
+    type PrimSize Float = 4
+    primSizeInBytes _ = CountOf 4
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 2
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = F# (indexFloatArray# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readFloatArray# mba n s1 in (# s2, F# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatArray# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = F# (indexFloatOffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readFloatOffAddr# addr n s1 in (# s2, F# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatOffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+instance PrimType Double where
+    type PrimSize Double = 8
+    primSizeInBytes _ = CountOf 8
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 3
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = D# (indexDoubleArray# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readDoubleArray# mba n s1 in (# s2, D# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleArray# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = D# (indexDoubleOffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readDoubleOffAddr# addr n s1 in (# s2, D# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleOffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+
+instance PrimType Char where
+    type PrimSize Char = 4
+    primSizeInBytes _ = CountOf 4
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 2
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset (I# n)) = C# (indexWideCharArray# ba n)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWideCharArray# mba n s1 in (# s2, C# r #)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharArray# mba n w s1, () #)
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset (I# n)) = C# (indexWideCharOffAddr# addr n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let !(# s2, r #) = readWideCharOffAddr# addr n s1 in (# s2, C# r #)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharOffAddr# addr n w s1, () #)
+    {-# INLINE primAddrWrite #-}
+
+instance PrimType CChar where
+    type PrimSize CChar = 1
+    primSizeInBytes _ = CountOf 1
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 0
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset n) = CChar (primBaUIndex ba (Offset n))
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset n) = CChar <$> primMbaURead mba (Offset n)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset n) (CChar int8) = primMbaUWrite mba (Offset n) int8
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset n) = CChar $ primAddrIndex addr (Offset n)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset n) = CChar <$> primAddrRead addr (Offset n)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset n) (CChar int8) = primAddrWrite addr (Offset n) int8
+    {-# INLINE primAddrWrite #-}
+instance PrimType CUChar where
+    type PrimSize CUChar = 1
+    primSizeInBytes _ = CountOf 1
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 0
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset n) = CUChar (primBaUIndex ba (Offset n :: Offset Word8))
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset n) = CUChar <$> primMbaURead mba (Offset n :: Offset Word8)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset n) (CUChar w8) = primMbaUWrite mba (Offset n) w8
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset n) = CUChar $ primAddrIndex addr (Offset n :: Offset Word8)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset n) = CUChar <$> primAddrRead addr (Offset n :: Offset Word8)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset n) (CUChar w8) = primAddrWrite addr (Offset n) w8
+    {-# INLINE primAddrWrite #-}
+
+instance PrimType Char7 where
+    type PrimSize Char7 = 1
+    primSizeInBytes _ = CountOf 1
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = 0
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset n) = Char7 (primBaUIndex ba (Offset n :: Offset Word8))
+    {-# INLINE primBaUIndex #-}
+    primMbaURead mba (Offset n) = Char7 <$> primMbaURead mba (Offset n :: Offset Word8)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset n) (Char7 w8) = primMbaUWrite mba (Offset n) w8
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset n) = Char7 $ primAddrIndex addr (Offset n :: Offset Word8)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset n) = Char7 <$> primAddrRead addr (Offset n :: Offset Word8)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset n) (Char7 w8) = primAddrWrite addr (Offset n) w8
+    {-# INLINE primAddrWrite #-}
+
+instance PrimType a => PrimType (LE a) where
+    type PrimSize (LE a) = PrimSize a
+    primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a)
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a)
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset a) = LE $ primBaUIndex ba (Offset a)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead ba (Offset a) = LE <$> primMbaURead ba (Offset a)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset a) (LE w) = primMbaUWrite mba (Offset a) w
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset a) = LE $ primAddrIndex addr (Offset a)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset a) = LE <$> primAddrRead addr (Offset a)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset a) (LE w) = primAddrWrite addr (Offset a) w
+    {-# INLINE primAddrWrite #-}
+instance PrimType a => PrimType (BE a) where
+    type PrimSize (BE a) = PrimSize a
+    primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a)
+    {-# INLINE primSizeInBytes #-}
+    primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a)
+    {-# INLINE primShiftToBytes #-}
+    primBaUIndex ba (Offset a) = BE $ primBaUIndex ba (Offset a)
+    {-# INLINE primBaUIndex #-}
+    primMbaURead ba (Offset a) = BE <$> primMbaURead ba (Offset a)
+    {-# INLINE primMbaURead #-}
+    primMbaUWrite mba (Offset a) (BE w) = primMbaUWrite mba (Offset a) w
+    {-# INLINE primMbaUWrite #-}
+    primAddrIndex addr (Offset a) = BE $ primAddrIndex addr (Offset a)
+    {-# INLINE primAddrIndex #-}
+    primAddrRead addr (Offset a) = BE <$> primAddrRead addr (Offset a)
+    {-# INLINE primAddrRead #-}
+    primAddrWrite addr (Offset a) (BE w) = primAddrWrite addr (Offset a) w
+    {-# INLINE primAddrWrite #-}
+
+-- | A constraint class for serializable type that have an unique
+-- memory compare representation
+--
+-- e.g. Float and Double have -0.0 and 0.0 which are Eq individual,
+-- yet have a different memory representation which doesn't allow
+-- for memcmp operation
+class PrimMemoryComparable ty where
+
+instance PrimMemoryComparable Int where
+instance PrimMemoryComparable Word where
+instance PrimMemoryComparable Word8 where
+instance PrimMemoryComparable Word16 where
+instance PrimMemoryComparable Word32 where
+instance PrimMemoryComparable Word64 where
+instance PrimMemoryComparable Word128 where
+instance PrimMemoryComparable Word256 where
+instance PrimMemoryComparable Int8 where
+instance PrimMemoryComparable Int16 where
+instance PrimMemoryComparable Int32 where
+instance PrimMemoryComparable Int64 where
+instance PrimMemoryComparable Char where
+instance PrimMemoryComparable CChar where
+instance PrimMemoryComparable CUChar where
+instance PrimMemoryComparable a => PrimMemoryComparable (LE a) where
+instance PrimMemoryComparable a => PrimMemoryComparable (BE a) where
+
+offset128_64 :: Offset Word128 -> (# Int#, Int# #)
+offset128_64 (Offset (I# i)) = (# n , n +# 1# #)
+  where !n = uncheckedIShiftL# i 1#
+
+offset256_64 :: Offset Word256 -> (# Int#, Int#, Int#, Int# #)
+offset256_64 (Offset (I# i)) = (# n , n +# 1#, n +# 2#, n +# 3# #)
+  where !n = uncheckedIShiftL# i 2#
+
+-- | Cast a CountOf linked to type A (CountOf A) to a CountOf linked to type B (CountOf B)
+sizeRecast :: forall a b . (PrimType a, PrimType b) => CountOf a -> CountOf b
+sizeRecast sz = CountOf (bytes `Prelude.quot` szB)
+  where !szA             = primSizeInBytes (Proxy :: Proxy a)
+        !(CountOf szB)   = primSizeInBytes (Proxy :: Proxy b)
+        !(CountOf bytes) = sizeOfE szA sz
+{-# INLINE [1] sizeRecast #-}
+{-# RULES "sizeRecast from Word8" [2] forall a . sizeRecast a = sizeRecastBytes a #-}
+
+sizeRecastBytes :: forall b . PrimType b => CountOf Word8 -> CountOf b
+sizeRecastBytes (CountOf w) = CountOf (w `Prelude.quot` szB)
+  where !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b)
+{-# INLINE [1] sizeRecastBytes #-}
+
+sizeInBytes :: forall a . PrimType a => CountOf a -> CountOf Word8
+sizeInBytes sz = sizeOfE (primSizeInBytes (Proxy :: Proxy a)) sz
+
+offsetInBytes :: forall a . PrimType a => Offset a -> Offset Word8
+offsetInBytes ofs = offsetShiftL (primShiftToBytes (Proxy :: Proxy a)) ofs
+{-# INLINE [2] offsetInBytes #-}
+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-}
+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-}
+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-}
+{-# RULES "offsetInBytes Bytes" [3] forall x . offsetInBytes x = x #-}
+
+offsetInElements :: forall a . PrimType a => Offset Word8 -> Offset a
+offsetInElements ofs = offsetShiftR (primShiftToBytes (Proxy :: Proxy a)) ofs
+{-# INLINE [2] offsetInElements #-}
+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-}
+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-}
+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-}
+{-# RULES "offsetInElements Bytes" [3] forall x . offsetInElements x = x #-}
+
+primOffsetRecast :: forall a b . (PrimType a, PrimType b) => Offset a -> Offset b
+primOffsetRecast !ofs =
+    let !(Offset bytes) = offsetOfE szA ofs
+     in Offset (bytes `Prelude.quot` szB)
+  where
+    !szA        = primSizeInBytes (Proxy :: Proxy a)
+    !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b)
+{-# INLINE [1] primOffsetRecast #-}
+{-# RULES "primOffsetRecast W8" [3] forall a . primOffsetRecast a = primOffsetRecastBytes a #-}
+
+offsetIsAligned :: forall a . PrimType a => Proxy a -> Offset Word8 -> Bool
+offsetIsAligned _ (Offset ofs) = (ofs .&. mask) == 0
+   where (CountOf sz) = primSizeInBytes (Proxy :: Proxy a)
+         mask = sz - 1
+{-# INLINE [1] offsetIsAligned #-}
+{-# SPECIALIZE [3] offsetIsAligned :: Proxy Word64 -> Offset Word8 -> Bool #-}
+{-# RULES "offsetInAligned Bytes" [3] forall (prx :: Proxy Word8) x . offsetIsAligned prx x = True #-}
+
+primOffsetRecastBytes :: forall b . PrimType b => Offset Word8 -> Offset b
+primOffsetRecastBytes (Offset 0) = Offset 0
+primOffsetRecastBytes (Offset o) = Offset (szA `Prelude.quot` o)
+  where !(CountOf szA) = primSizeInBytes (Proxy :: Proxy b)
+{-# INLINE [1] primOffsetRecastBytes #-}
+
+primOffsetOfE :: forall a . PrimType a => Offset a -> Offset Word8
+primOffsetOfE = offsetInBytes
+{-# DEPRECATED primOffsetOfE "use offsetInBytes" #-}
+
+primWordGetByteAndShift :: Word# -> (# Word#, Word# #)
+primWordGetByteAndShift w = (# and# w 0xff##, uncheckedShiftRL# w 8# #)
+{-# INLINE primWordGetByteAndShift #-}
+
+#if WORD_SIZE_IN_BITS == 64
+primWord64GetByteAndShift :: Word# -> (# Word#, Word# #)
+primWord64GetByteAndShift = primWord64GetByteAndShift
+
+primWord64GetHiLo :: Word# -> (# Word#, Word# #)
+primWord64GetHiLo w = (# uncheckedShiftRL# w 32# , and# w 0xffffffff## #)
+#else
+primWord64GetByteAndShift :: Word64# -> (# Word#, Word64# #)
+primWord64GetByteAndShift w = (# and# (word64ToWord# w) 0xff##, uncheckedShiftRL64# w 8# #)
+
+primWord64GetHiLo :: Word64# -> (# Word#, Word# #)
+primWord64GetHiLo w = (# word64ToWord# (uncheckedShiftRL64# w 32#), word64ToWord# w #)
+#endif
+{-# INLINE primWord64GetByteAndShift #-}

bundled/Basement/Runtime.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Runtime
+-- License     : BSD-style
+-- Maintainer  : foundation
+--
+-- Global configuration environment
+module Basement.Runtime
+    where
+
+import           Basement.Compat.Base
+import           Basement.Types.OffsetSize
+import           System.Environment
+import           System.IO.Unsafe (unsafePerformIO)
+import           Text.Read        (readMaybe)
+
+-- | Defines the maximum size in bytes of unpinned arrays.
+--
+-- You can change this value by setting the environment variable
+-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@ to an unsigned integer number.
+--
+-- Note: We use 'unsafePerformIO' here. If the environment variable
+-- changes during runtime and the runtime system decides to recompute
+-- this value, referential transparency is violated (like the First
+-- Order violated the Galactic Concordance!).
+--
+-- TODO The default value of 1024 bytes is arbitrarily chosen for now.
+unsafeUArrayUnpinnedMaxSize :: CountOf Word8
+unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do
+    maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX"
+    pure $ maybe (CountOf 1024) CountOf maxSize
+{-# NOINLINE unsafeUArrayUnpinnedMaxSize #-}

bundled/Basement/Show.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Basement.Show
+    where
+
+import qualified Prelude
+import           Basement.Compat.Base
+import           Basement.UTF8.Base (String)
+
+-- | Use the Show class to create a String.
+--
+-- Note that this is not efficient, since
+-- an intermediate [Char] is going to be
+-- created before turning into a real String.
+show :: Prelude.Show a => a -> String
+show = fromList . Prelude.show

bundled/Basement/Sized/Block.hs

@@ -0,0 +1,283 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Sized.Block
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+--
+-- A Nat-sized version of Block
+{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeOperators              #-}
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE NoStarIsType               #-}
+#endif
+
+module Basement.Sized.Block
+    ( BlockN
+    , MutableBlockN
+    , length
+    , lengthBytes
+    , toBlockN
+    , toBlock
+    , new
+    , newPinned
+    , singleton
+    , replicate
+    , thaw
+    , freeze
+    , index
+    , indexStatic
+    , map
+    , foldl'
+    , foldr
+    , cons
+    , snoc
+    , elem
+    , sub
+    , uncons
+    , unsnoc
+    , splitAt
+    , all
+    , any
+    , find
+    , reverse
+    , sortBy
+    , intersperse
+    , withPtr
+    , withMutablePtr
+    , withMutablePtrHint
+    , cast
+    , mutableCast
+    ) where
+
+import           Data.Proxy (Proxy(..))
+import           Basement.Compat.Base
+import           Basement.Numerical.Additive (scale)
+import           Basement.Block (Block, MutableBlock(..), unsafeIndex)
+import qualified Basement.Block as B
+import qualified Basement.Block.Base as B
+import           Basement.Monad (PrimMonad, PrimState)
+import           Basement.Nat
+import           Basement.Types.OffsetSize
+import           Basement.NormalForm
+import           Basement.PrimType (PrimType, PrimSize, primSizeInBytes)
+
+-- | Sized version of 'Block'
+--
+newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a }
+  deriving (NormalForm, Eq, Show, Data, Ord)
+
+newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st }
+
+toBlockN :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => Block ty -> Maybe (BlockN n ty)
+toBlockN b
+    | expected == B.length b = Just (BlockN b)
+    | otherwise = Nothing
+  where
+    expected = toCount @n
+
+length :: forall n ty
+        . (KnownNat n, Countable ty n)
+       => BlockN n ty
+       -> CountOf ty
+length _ = toCount @n
+
+lengthBytes :: forall n ty
+             . PrimType ty
+            => BlockN n ty
+            -> CountOf Word8
+lengthBytes = B.lengthBytes . unBlock
+
+toBlock :: BlockN n ty -> Block ty
+toBlock = unBlock
+
+cast :: forall n m a b
+      . ( PrimType a, PrimType b
+        , KnownNat n, KnownNat m
+        , ((PrimSize b) * m) ~ ((PrimSize a) * n)
+        )
+      => BlockN n a
+      -> BlockN m b
+cast (BlockN b) = BlockN (B.unsafeCast b)
+
+mutableCast :: forall n m a b st
+             . ( PrimType a, PrimType b
+             , KnownNat n, KnownNat m
+             , ((PrimSize b) * m) ~ ((PrimSize a) * n)
+             )
+            => MutableBlockN n a st
+            -> MutableBlockN m b st
+mutableCast (MutableBlockN b) = MutableBlockN (B.unsafeRecast b)
+
+-- | Create a new unpinned mutable block of a specific N size of 'ty' elements
+--
+-- If the size exceeds a GHC-defined threshold, then the memory will be
+-- pinned. To be certain about pinning status with small size, use 'newPinned'
+new :: forall n ty prim
+     . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim)
+    => prim (MutableBlockN n ty (PrimState prim))
+new = MutableBlockN <$> B.new (toCount @n)
+
+-- | Create a new pinned mutable block of a specific N size of 'ty' elements
+newPinned :: forall n ty prim
+           . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim)
+          => prim (MutableBlockN n ty (PrimState prim))
+newPinned = MutableBlockN <$> B.newPinned (toCount @n)
+
+singleton :: PrimType ty => ty -> BlockN 1 ty
+singleton a = BlockN (B.singleton a)
+
+replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> BlockN n ty
+replicate a = BlockN (B.replicate (toCount @n) a)
+
+thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => BlockN n ty -> prim (MutableBlockN n ty (PrimState prim))
+thaw b = MutableBlockN <$> B.thaw (unBlock b)
+
+freeze ::  (PrimMonad prim, PrimType ty, Countable ty n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty)
+freeze b = BlockN <$> B.freeze (unMBlock b)
+
+indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => BlockN n ty -> ty
+indexStatic b = unsafeIndex (unBlock b) (toOffset @i)
+
+index :: forall i n ty . PrimType ty => BlockN n ty -> Offset ty -> ty
+index b ofs = B.index (unBlock b) ofs
+
+map :: (PrimType a, PrimType b) => (a -> b) -> BlockN n a -> BlockN n b
+map f b = BlockN (B.map f (unBlock b))
+
+foldl' :: PrimType ty => (a -> ty -> a) -> a -> BlockN n ty -> a
+foldl' f acc b = B.foldl' f acc (unBlock b)
+
+foldr :: PrimType ty => (ty -> a -> a) -> a -> BlockN n ty -> a
+foldr f acc b = B.foldr f acc (unBlock b)
+
+cons :: PrimType ty => ty -> BlockN n ty -> BlockN (n+1) ty
+cons e = BlockN . B.cons e . unBlock
+
+snoc :: PrimType ty => BlockN n ty -> ty -> BlockN (n+1) ty
+snoc b = BlockN . B.snoc (unBlock b)
+
+sub :: forall i j n ty
+     . ( (i <=? n) ~ 'True
+       , (j <=? n) ~ 'True
+       , (i <=? j) ~ 'True
+       , PrimType ty
+       , KnownNat i
+       , KnownNat j
+       , Offsetable ty i
+       , Offsetable ty j )
+    => BlockN n ty
+    -> BlockN (j-i) ty
+sub block = BlockN (B.sub (unBlock block) (toOffset @i) (toOffset @j))
+
+uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n)
+       => BlockN n ty
+       -> (ty, BlockN (n-1) ty)
+uncons b = (indexStatic @0 b, BlockN (B.sub (unBlock b) 1 (toOffset @n)))
+
+unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n)
+       => BlockN n ty
+       -> (BlockN (n-1) ty, ty)
+unsnoc b =
+    ( BlockN (B.sub (unBlock b) 0 (toOffset @n `offsetSub` 1))
+    , unsafeIndex (unBlock b) (toOffset @n `offsetSub` 1))
+
+splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty)
+splitAt b =
+    let (left, right) = B.splitAt (toCount @i) (unBlock b)
+     in (BlockN left, BlockN right)
+
+elem :: PrimType ty => ty -> BlockN n ty -> Bool
+elem e b = B.elem e (unBlock b)
+
+all :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool
+all p b = B.all p (unBlock b)
+
+any :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool
+any p b = B.any p (unBlock b)
+
+find :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Maybe ty
+find p b = B.find p (unBlock b)
+
+reverse :: PrimType ty => BlockN n ty -> BlockN n ty
+reverse = BlockN . B.reverse . unBlock
+
+sortBy :: PrimType ty => (ty -> ty -> Ordering) -> BlockN n ty -> BlockN n ty
+sortBy f b = BlockN (B.sortBy f (unBlock b))
+
+intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> BlockN n ty -> BlockN (n+n-1) ty
+intersperse sep b = BlockN (B.intersperse sep (unBlock b))
+
+toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty
+toCount = natValCountOf (Proxy @n)
+
+toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty
+toOffset = natValOffset (Proxy @n)
+
+-- | Get a Ptr pointing to the data in the Block.
+--
+-- Since a Block is immutable, this Ptr shouldn't be
+-- to use to modify the contents
+--
+-- If the Block is pinned, then its address is returned as is,
+-- however if it's unpinned, a pinned copy of the Block is made
+-- before getting the address.
+withPtr :: (PrimMonad prim, KnownNat n)
+        => BlockN n ty
+        -> (Ptr ty -> prim a)
+        -> prim a
+withPtr b = B.withPtr (unBlock b)
+
+-- | Create a pointer on the beginning of the MutableBlock
+-- and call a function 'f'.
+--
+-- The mutable block can be mutated by the 'f' function
+-- and the change will be reflected in the mutable block
+--
+-- If the mutable block is unpinned, a trampoline buffer
+-- is created and the data is only copied when 'f' return.
+--
+-- it is all-in-all highly inefficient as this cause 2 copies
+withMutablePtr :: (PrimMonad prim, KnownNat n)
+               => MutableBlockN n ty (PrimState prim)
+               -> (Ptr ty -> prim a)
+               -> prim a
+withMutablePtr mb = B.withMutablePtr (unMBlock mb)
+
+-- | Same as 'withMutablePtr' but allow to specify 2 optimisations
+-- which is only useful when the MutableBlock is unpinned and need
+-- a pinned trampoline to be called safely.
+--
+-- If skipCopy is True, then the first copy which happen before
+-- the call to 'f', is skipped. The Ptr is now effectively
+-- pointing to uninitialized data in a new mutable Block.
+--
+-- If skipCopyBack is True, then the second copy which happen after
+-- the call to 'f', is skipped. Then effectively in the case of a
+-- trampoline being used the memory changed by 'f' will not
+-- be reflected in the original Mutable Block.
+--
+-- If using the wrong parameters, it will lead to difficult to
+-- debug issue of corrupted buffer which only present themselves
+-- with certain Mutable Block that happened to have been allocated
+-- unpinned.
+--
+-- If unsure use 'withMutablePtr', which default to *not* skip
+-- any copy.
+withMutablePtrHint :: forall n ty prim a . (PrimMonad prim, KnownNat n)
+                   => Bool -- ^ hint that the buffer doesn't need to have the same value as the mutable block when calling f
+                   -> Bool -- ^ hint that the buffer is not supposed to be modified by call of f
+                   -> MutableBlockN n ty (PrimState prim)
+                   -> (Ptr ty -> prim a)
+                   -> prim a
+withMutablePtrHint skipCopy skipCopyBack (MutableBlockN mb) f =
+    B.withMutablePtrHint skipCopy skipCopyBack mb f

bundled/Basement/Sized/List.hs

@@ -0,0 +1,389 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Sized.List
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A Nat-sized list abstraction
+--
+-- Using this module is limited to GHC 7.10 and above.
+--
+{-# LANGUAGE KindSignatures            #-}
+{-# LANGUAGE DataKinds                 #-}
+{-# LANGUAGE GADTs                     #-}
+{-# LANGUAGE TypeOperators             #-}
+{-# LANGUAGE TypeFamilies              #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE UndecidableInstances      #-}
+{-# LANGUAGE AllowAmbiguousTypes       #-}
+{-# LANGUAGE DeriveDataTypeable        #-}
+{-# LANGUAGE DeriveGeneric             #-}
+{-# LANGUAGE FlexibleContexts          #-}
+module Basement.Sized.List
+    ( ListN
+    , toListN
+    , toListN_
+    , unListN
+    , length
+    , create
+    , createFrom
+    , empty
+    , singleton
+    , uncons
+    , cons
+    , unsnoc
+    , snoc
+    , index
+    , indexStatic
+    , updateAt
+    , map
+    , mapi
+    , elem
+    , foldl
+    , foldl'
+    , foldl1'
+    , scanl'
+    , scanl1'
+    , foldr
+    , foldr1
+    , reverse
+    , append
+    , minimum
+    , maximum
+    , head
+    , tail
+    , init
+    , take
+    , drop
+    , splitAt
+    , zip, zip3, zip4, zip5
+    , unzip
+    , zipWith, zipWith3, zipWith4, zipWith5
+    , replicate
+    -- * Applicative And Monadic
+    , replicateM
+    , sequence
+    , sequence_
+    , mapM
+    , mapM_
+    ) where
+
+import           Data.Proxy
+import qualified Data.List
+import           Basement.Compat.Base
+import           Basement.Compat.CallStack
+import           Basement.Compat.Natural
+import           Basement.Nat
+import           Basement.NormalForm
+import           Basement.Numerical.Additive
+import           Basement.Numerical.Subtractive
+import           Basement.Types.OffsetSize
+import           Basement.Compat.ExtList ((!!))
+import qualified Prelude
+import qualified Control.Monad as M (replicateM, mapM, mapM_, sequence, sequence_)
+
+impossible :: HasCallStack => a
+impossible = error "ListN: internal error: the impossible happened"
+
+-- | A Typed-level sized List equivalent to [a]
+newtype ListN (n :: Nat) a = ListN { unListN :: [a] }
+    deriving (Eq,Ord,Typeable,Generic)
+
+instance Show a => Show (ListN n a) where
+    show (ListN l) = show l
+
+instance NormalForm a => NormalForm (ListN n a) where
+    toNormalForm (ListN l) = toNormalForm l
+
+-- | Try to create a ListN from a List, succeeding if the length is correct
+toListN :: forall (n :: Nat) a . (KnownNat n, NatWithinBound Int n) => [a] -> Maybe (ListN n a)
+toListN l
+    | expected == Prelude.fromIntegral (Prelude.length l) = Just (ListN l)
+    | otherwise                                           = Nothing
+  where
+    expected = natValInt (Proxy :: Proxy n)
+
+-- | Create a ListN from a List, expecting a given length
+--
+-- If this list contains more or less than the expected length of the resulting type,
+-- then an asynchronous error is raised. use 'toListN' for a more friendly functions
+toListN_ :: forall n a . (HasCallStack, NatWithinBound Int n, KnownNat n) => [a] -> ListN n a
+toListN_ l
+    | expected == got = ListN l
+    | otherwise       = error ("toListN_: expecting list of " <> show expected <> " elements, got " <> show got <> " elements")
+  where
+    expected = natValInt (Proxy :: Proxy n)
+    got      = Prelude.length l
+
+-- | performs a monadic action n times, gathering the results in a List of size n.
+replicateM :: forall (n :: Nat) m a . (NatWithinBound Int n, Monad m, KnownNat n) => m a -> m (ListN n a)
+replicateM action = ListN <$> M.replicateM (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) action
+
+-- | Evaluate each monadic action in the list sequentially, and collect the results.
+sequence :: Monad m => ListN n (m a) -> m (ListN n a)
+sequence (ListN l) = ListN <$> M.sequence l
+
+-- | Evaluate each monadic action in the list sequentially, and ignore the results.
+sequence_ :: Monad m => ListN n (m a) -> m ()
+sequence_ (ListN l) = M.sequence_ l
+
+-- | Map each element of a List to a monadic action, evaluate these
+-- actions sequentially and collect the results
+mapM :: Monad m => (a -> m b) -> ListN n a -> m (ListN n b)
+mapM f (ListN l) = ListN <$> M.mapM f l
+
+-- | Map each element of a List to a monadic action, evaluate these
+-- actions sequentially and ignore the results
+mapM_ :: Monad m => (a -> m b) -> ListN n a -> m ()
+mapM_ f (ListN l) = M.mapM_ f l
+
+-- | Create a list of n elements where each element is the element in argument
+replicate :: forall (n :: Nat) a . (NatWithinBound Int n, KnownNat n) => a -> ListN n a
+replicate a = ListN $ Prelude.replicate (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) a
+
+-- | Decompose a list into its head and tail.
+uncons :: (1 <= n) => ListN n a -> (a, ListN (n-1) a)
+uncons (ListN (x:xs)) = (x, ListN xs)
+uncons _ = impossible
+
+-- | prepend an element to the list
+cons :: a -> ListN n a -> ListN (n+1) a
+cons a (ListN l) = ListN (a : l)
+
+-- | Decompose a list into its first elements and the last.
+unsnoc :: (1 <= n) => ListN n a -> (ListN (n-1) a, a)
+unsnoc (ListN l) = (ListN $ Data.List.init l, Data.List.last l)
+
+-- | append an element to the list
+snoc :: ListN n a -> a -> ListN (n+1) a
+snoc (ListN l) a = ListN (l Prelude.++ [a])
+
+-- | Create an empty list of a
+empty :: ListN 0 a
+empty = ListN []
+
+-- | Get the length of a list
+length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> CountOf a
+length _ = CountOf $ natValInt (Proxy :: Proxy n)
+
+-- | Create a new list of size n, repeately calling f from 0 to n-1
+create :: forall a (n :: Nat) . KnownNat n => (Natural -> a) -> ListN n a
+create f = ListN $ Prelude.map (f . Prelude.fromIntegral) [0..(len-1)]
+  where
+    len = natVal (Proxy :: Proxy n)
+
+-- | Same as create but apply an offset
+createFrom :: forall a (n :: Nat) (start :: Nat) . (KnownNat n, KnownNat start)
+           => Proxy start -> (Natural -> a) -> ListN n a
+createFrom p f = ListN $ Prelude.map (f . Prelude.fromIntegral) [idx..(idx+len-1)]
+  where
+    len = natVal (Proxy :: Proxy n)
+    idx = natVal p
+
+-- | create a list of 1 element
+singleton :: a -> ListN 1 a
+singleton a = ListN [a]
+
+-- | Check if a list contains the element a
+elem :: Eq a => a -> ListN n a -> Bool
+elem a (ListN l) = Prelude.elem a l
+
+-- | Append 2 list together returning the new list
+append :: ListN n a -> ListN m a -> ListN (n+m) a
+append (ListN l1) (ListN l2) = ListN (l1 <> l2)
+
+-- | Get the maximum element of a list
+maximum :: (Ord a, 1 <= n) => ListN n a -> a
+maximum (ListN l) = Prelude.maximum l
+
+-- | Get the minimum element of a list
+minimum :: (Ord a, 1 <= n) => ListN n a -> a
+minimum (ListN l) = Prelude.minimum l
+
+-- | Get the head element of a list
+head :: (1 <= n) => ListN n a -> a
+head (ListN (x:_)) = x
+head _ = impossible
+
+-- | Get the tail of a list
+tail :: (1 <= n) => ListN n a -> ListN (n-1) a
+tail (ListN (_:xs)) = ListN xs
+tail _ = impossible
+
+-- | Get the list with the last element missing
+init :: (1 <= n) => ListN n a -> ListN (n-1) a
+init (ListN l) = ListN $ Data.List.init l
+
+-- | Take m elements from the beggining of the list.
+--
+-- The number of elements need to be less or equal to the list in argument
+take :: forall a (m :: Nat) (n :: Nat) . (KnownNat m, NatWithinBound Int m, m <= n) => ListN n a -> ListN m a
+take (ListN l) = ListN (Prelude.take n l)
+  where n = natValInt (Proxy :: Proxy m)
+
+-- | Drop elements from a list keeping the m remaining elements
+drop :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> ListN m a
+drop (ListN l) = ListN (Prelude.drop n l)
+  where n = natValInt (Proxy :: Proxy d)
+
+-- | Split a list into two, returning 2 lists
+splitAt :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> (ListN m a, ListN (n-m) a)
+splitAt (ListN l) = let (l1, l2) = Prelude.splitAt n l in (ListN l1, ListN l2)
+  where n = natValInt (Proxy :: Proxy d)
+
+-- | Get the i'th elements
+--
+-- This only works with TypeApplication:
+--
+-- > indexStatic @1 (toListN_ [1,2,3] :: ListN 3 Int)
+indexStatic :: forall i n a . (KnownNat i, CmpNat i n ~ 'LT, Offsetable a i) => ListN n a -> a
+indexStatic (ListN l) = l !! (natValOffset (Proxy :: Proxy i))
+
+-- | Get the i'the element
+index :: ListN n ty -> Offset ty -> ty
+index (ListN l) ofs = l !! ofs
+
+-- | Update the value in a list at a specific location
+updateAt :: forall n a
+         .  Offset a
+         -> (a -> a)
+         -> ListN n a
+         -> ListN n a
+updateAt o f (ListN l) = ListN (doUpdate 0 l)
+  where doUpdate _ []     = []
+        doUpdate i (x:xs)
+            | i == o      = f x : xs
+            | otherwise   = x : doUpdate (i+1) xs
+
+-- | Map all elements in a list
+map :: (a -> b) -> ListN n a -> ListN n b
+map f (ListN l) = ListN (Prelude.map f l)
+
+-- | Map all elements in a list with an additional index
+mapi :: (Natural -> a -> b) -> ListN n a -> ListN n b
+mapi f (ListN l) = ListN . loop 0 $ l
+  where loop _ []     = []
+        loop i (x:xs) = f i x : loop (i+1) xs
+
+-- | Fold all elements from left
+foldl :: (b -> a -> b) -> b -> ListN n a -> b
+foldl f acc (ListN l) = Prelude.foldl f acc l
+
+-- | Fold all elements from left strictly
+foldl' :: (b -> a -> b) -> b -> ListN n a -> b
+foldl' f acc (ListN l) = Data.List.foldl' f acc l
+
+-- | Fold all elements from left strictly with a first element
+-- as the accumulator
+foldl1' :: (1 <= n) => (a -> a -> a) -> ListN n a -> a
+foldl1' f (ListN l) = Data.List.foldl1' f l
+
+-- | Fold all elements from right
+foldr :: (a -> b -> b) -> b -> ListN n a -> b
+foldr f acc (ListN l) = Prelude.foldr f acc l
+
+-- | Fold all elements from right assuming at least one element is in the list.
+foldr1 :: (1 <= n) => (a -> a -> a) -> ListN n a -> a
+foldr1 f (ListN l) = Prelude.foldr1 f l
+
+-- | 'scanl' is similar to 'foldl', but returns a list of successive
+-- reduced values from the left
+--
+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
+scanl' :: (b -> a -> b) -> b -> ListN n a -> ListN (n+1) b
+scanl' f initialAcc (ListN start) = ListN (go initialAcc start)
+  where
+    go !acc l = acc : case l of
+                        []     -> []
+                        (x:xs) -> go (f acc x) xs
+
+-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
+--
+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
+scanl1' :: (a -> a -> a) -> ListN n a -> ListN n a
+scanl1' f (ListN l) = case l of
+                        []     -> ListN []
+                        (x:xs) -> ListN $ Data.List.scanl' f x xs
+
+-- | Reverse a list
+reverse :: ListN n a -> ListN n a
+reverse (ListN l) = ListN (Prelude.reverse l)
+
+-- | Zip 2 lists of the same size, returning a new list of
+-- the tuple of each elements
+zip :: ListN n a -> ListN n b -> ListN n (a,b)
+zip (ListN l1) (ListN l2) = ListN (Prelude.zip l1 l2)
+
+-- | Unzip a list of tuple, to 2 List of the deconstructed tuples
+unzip :: ListN n (a,b) -> (ListN n a, ListN n b)
+unzip l = (map fst l, map snd l)
+
+-- | Zip 3 lists of the same size
+zip3 :: ListN n a -> ListN n b -> ListN n c -> ListN n (a,b,c)
+zip3 (ListN x1) (ListN x2) (ListN x3) = ListN (loop x1 x2 x3)
+  where loop (l1:l1s) (l2:l2s) (l3:l3s) = (l1,l2,l3) : loop l1s l2s l3s
+        loop []       _        _        = []
+        loop _        _        _        = impossible
+
+-- | Zip 4 lists of the same size
+zip4 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n (a,b,c,d)
+zip4 (ListN x1) (ListN x2) (ListN x3) (ListN x4) = ListN (loop x1 x2 x3 x4)
+  where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) = (l1,l2,l3,l4) : loop l1s l2s l3s l4s
+        loop []       _        _        _        = []
+        loop _        _        _        _        = impossible
+
+-- | Zip 5 lists of the same size
+zip5 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n e -> ListN n (a,b,c,d,e)
+zip5 (ListN x1) (ListN x2) (ListN x3) (ListN x4) (ListN x5) = ListN (loop x1 x2 x3 x4 x5)
+  where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) (l5:l5s) = (l1,l2,l3,l4,l5) : loop l1s l2s l3s l4s l5s
+        loop []       _        _        _        _        = []
+        loop _        _        _        _        _        = impossible
+
+-- | Zip 2 lists using a function
+zipWith :: (a -> b -> x) -> ListN n a -> ListN n b -> ListN n x
+zipWith f (ListN (v1:vs)) (ListN (w1:ws)) = ListN (f v1 w1 : unListN (zipWith f (ListN vs) (ListN ws)))
+zipWith _ (ListN [])       _ = ListN []
+zipWith _ _                _ = impossible
+
+-- | Zip 3 lists using a function
+zipWith3 :: (a -> b -> c -> x)
+         -> ListN n a
+         -> ListN n b
+         -> ListN n c
+         -> ListN n x
+zipWith3 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) =
+    ListN (f v1 w1 x1 : unListN (zipWith3 f (ListN vs) (ListN ws) (ListN xs)))
+zipWith3 _ (ListN []) _       _ = ListN []
+zipWith3 _ _          _       _ = impossible
+
+-- | Zip 4 lists using a function
+zipWith4 :: (a -> b -> c -> d -> x)
+         -> ListN n a
+         -> ListN n b
+         -> ListN n c
+         -> ListN n d
+         -> ListN n x
+zipWith4 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) =
+    ListN (f v1 w1 x1 y1 : unListN (zipWith4 f (ListN vs) (ListN ws) (ListN xs) (ListN ys)))
+zipWith4 _ (ListN []) _       _       _ = ListN []
+zipWith4 _ _          _       _       _ = impossible
+
+-- | Zip 5 lists using a function
+zipWith5 :: (a -> b -> c -> d -> e -> x)
+         -> ListN n a
+         -> ListN n b
+         -> ListN n c
+         -> ListN n d
+         -> ListN n e
+         -> ListN n x
+zipWith5 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) (ListN (z1:zs)) =
+    ListN (f v1 w1 x1 y1 z1 : unListN (zipWith5 f (ListN vs) (ListN ws) (ListN xs) (ListN ys) (ListN zs)))
+zipWith5 _ (ListN []) _       _       _       _ = ListN []
+zipWith5 _ _          _       _       _       _ = impossible

bundled/Basement/Sized/UVect.hs

@@ -0,0 +1,164 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ConstraintKinds            #-}
+module Basement.Sized.UVect
+    ( UVect
+    , MUVect
+    , unUVect
+    , toUVect
+    , empty
+    , singleton
+    , replicate
+    , thaw
+    , freeze
+    , index
+    , map
+    , foldl'
+    , foldr
+    , cons
+    , snoc
+    , elem
+    , sub
+    , uncons
+    , unsnoc
+    , splitAt
+    , all
+    , any
+    , find
+    , reverse
+    , sortBy
+    , intersperse
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Nat
+import           Basement.NormalForm
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+import           Basement.PrimType (PrimType)
+import qualified Basement.UArray as A
+import qualified Basement.UArray.Mutable as A hiding (sub)
+import           Data.Proxy
+
+newtype UVect (n :: Nat) a = UVect { unUVect :: A.UArray a } deriving (NormalForm, Eq, Show)
+newtype MUVect (n :: Nat) ty st = MUVect { unMUVect :: A.MUArray ty st }
+
+toUVect :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => A.UArray ty -> Maybe (UVect n ty)
+toUVect b
+    | expected == A.length b = Just (UVect b)
+    | otherwise              = Nothing
+  where
+    expected = toCount @n
+
+empty :: PrimType ty => UVect 0 ty
+empty = UVect mempty
+
+singleton :: PrimType ty => ty -> UVect 1 ty
+singleton a = UVect (A.singleton a)
+
+create :: forall ty (n :: Nat) . (PrimType ty, Countable ty n, KnownNat n) => (Offset ty -> ty) -> UVect n ty
+create f = UVect $ A.create sz f
+  where
+    sz = natValCountOf (Proxy :: Proxy n)
+
+replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> UVect n ty
+replicate a = UVect (A.replicate (toCount @n) a)
+
+thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => UVect n ty -> prim (MUVect n ty (PrimState prim))
+thaw b = MUVect <$> A.thaw (unUVect b)
+
+freeze ::  (PrimMonad prim, PrimType ty, Countable ty n) => MUVect n ty (PrimState prim) -> prim (UVect n ty)
+freeze b = UVect <$> A.freeze (unMUVect b)
+
+write :: (PrimMonad prim, PrimType ty) => MUVect n ty (PrimState prim) -> Offset ty -> ty -> prim ()
+write (MUVect ma) ofs v = A.write ma ofs v
+
+read :: (PrimMonad prim, PrimType ty) => MUVect n ty (PrimState prim) -> Offset ty -> prim ty
+read (MUVect ma) ofs = A.read ma ofs
+
+indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => UVect n ty -> ty
+indexStatic b = A.unsafeIndex (unUVect b) (toOffset @i)
+
+index :: forall i n ty . PrimType ty => UVect n ty -> Offset ty -> ty
+index b ofs = A.index (unUVect b) ofs
+
+map :: (PrimType a, PrimType b) => (a -> b) -> UVect n a -> UVect n b
+map f b = UVect (A.map f (unUVect b))
+
+foldl' :: PrimType ty => (a -> ty -> a) -> a -> UVect n ty -> a
+foldl' f acc b = A.foldl' f acc (unUVect b)
+
+foldr :: PrimType ty => (ty -> a -> a) -> a -> UVect n ty -> a
+foldr f acc b = A.foldr f acc (unUVect b)
+
+cons :: PrimType ty => ty -> UVect n ty -> UVect (n+1) ty
+cons e = UVect . A.cons e . unUVect
+
+snoc :: PrimType ty => UVect n ty -> ty -> UVect (n+1) ty
+snoc b = UVect . A.snoc (unUVect b)
+
+sub :: forall i j n ty
+     . ( (i <=? n) ~ 'True
+       , (j <=? n) ~ 'True
+       , (i <=? j) ~ 'True
+       , PrimType ty
+       , KnownNat i
+       , KnownNat j
+       , Offsetable ty i
+       , Offsetable ty j )
+    => UVect n ty
+    -> UVect (j-i) ty
+sub block = UVect (A.sub (unUVect block) (toOffset @i) (toOffset @j))
+
+uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n)
+       => UVect n ty
+       -> (ty, UVect (n-1) ty)
+uncons b = (indexStatic @0 b, UVect (A.sub (unUVect b) 1 (toOffset @n)))
+
+unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n)
+       => UVect n ty
+       -> (UVect (n-1) ty, ty)
+unsnoc b =
+    ( UVect (A.sub (unUVect b) 0 (toOffset @n `offsetSub` 1))
+    , A.unsafeIndex (unUVect b) (toOffset @n `offsetSub` 1))
+
+splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => UVect n ty -> (UVect i ty, UVect (n-i) ty)
+splitAt b =
+    let (left, right) = A.splitAt (toCount @i) (unUVect b)
+     in (UVect left, UVect right)
+
+elem :: PrimType ty => ty -> UVect n ty -> Bool
+elem e b = A.elem e (unUVect b)
+
+all :: PrimType ty => (ty -> Bool) -> UVect n ty -> Bool
+all p b = A.all p (unUVect b)
+
+any :: PrimType ty => (ty -> Bool) -> UVect n ty -> Bool
+any p b = A.any p (unUVect b)
+
+find :: PrimType ty => (ty -> Bool) -> UVect n ty -> Maybe ty
+find p b = A.find p (unUVect b)
+
+reverse :: PrimType ty => UVect n ty -> UVect n ty
+reverse = UVect . A.reverse . unUVect
+
+sortBy :: PrimType ty => (ty -> ty -> Ordering) -> UVect n ty -> UVect n ty
+sortBy f b = UVect (A.sortBy f (unUVect b))
+
+intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> UVect n ty -> UVect (n+n-1) ty
+intersperse sep b = UVect (A.intersperse sep (unUVect b))
+
+toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty
+toCount = natValCountOf (Proxy @n)
+
+toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty
+toOffset = natValOffset (Proxy @n)

bundled/Basement/Sized/Vect.hs

@@ -0,0 +1,166 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ConstraintKinds            #-}
+module Basement.Sized.Vect
+    ( Vect
+    , MVect
+    , unVect
+    , toVect
+    , empty
+    , singleton
+    , replicate
+    , thaw
+    , freeze
+    , index
+    , map
+    , foldl'
+    , foldr
+    , cons
+    , snoc
+    , elem
+    , sub
+    , uncons
+    , unsnoc
+    , splitAt
+    , all
+    , any
+    , find
+    , reverse
+    , sortBy
+    , intersperse
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Nat
+import           Basement.NormalForm
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+import           Basement.PrimType (PrimType)
+import qualified Basement.BoxedArray as A
+--import qualified Basement.BoxedArray.Mutable as A hiding (sub)
+import           Data.Proxy
+
+newtype Vect (n :: Nat) a = Vect { unVect :: A.Array a } deriving (NormalForm, Eq, Show)
+newtype MVect (n :: Nat) ty st = MVect { unMVect :: A.MArray ty st }
+
+instance Functor (Vect n) where
+    fmap = map
+
+toVect :: forall n ty . (KnownNat n, Countable ty n) => A.Array ty -> Maybe (Vect n ty)
+toVect b
+    | expected == A.length b = Just (Vect b)
+    | otherwise = Nothing
+  where
+    expected = toCount @n
+
+empty :: Vect 0 ty
+empty = Vect A.empty
+
+singleton :: ty -> Vect 1 ty
+singleton a = Vect (A.singleton a)
+
+create :: forall a (n :: Nat) . (Countable a n, KnownNat n) => (Offset a -> a) -> Vect n a
+create f = Vect $ A.create sz f
+  where
+    sz = natValCountOf (Proxy :: Proxy n)
+
+replicate :: forall n ty . (KnownNat n, Countable ty n) => ty -> Vect n ty
+replicate a = Vect (A.replicate (toCount @n) a)
+
+thaw :: (KnownNat n, PrimMonad prim) => Vect n ty -> prim (MVect n ty (PrimState prim))
+thaw b = MVect <$> A.thaw (unVect b)
+
+freeze ::  (PrimMonad prim, Countable ty n) => MVect n ty (PrimState prim) -> prim (Vect n ty)
+freeze b = Vect <$> A.freeze (unMVect b)
+
+write :: PrimMonad prim => MVect n ty (PrimState prim) -> Offset ty -> ty -> prim ()
+write (MVect ma) ofs v = A.write ma ofs v
+
+read :: PrimMonad prim => MVect n ty (PrimState prim) -> Offset ty -> prim ty
+read (MVect ma) ofs = A.read ma ofs
+
+indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, Offsetable ty i) => Vect n ty -> ty
+indexStatic b = A.unsafeIndex (unVect b) (toOffset @i)
+
+index :: Vect n ty -> Offset ty -> ty
+index b ofs = A.index (unVect b) ofs
+
+map :: (a -> b) -> Vect n a -> Vect n b
+map f b = Vect (fmap f (unVect b))
+
+foldl' :: (a -> ty -> a) -> a -> Vect n ty -> a
+foldl' f acc b = A.foldl' f acc (unVect b)
+
+foldr :: (ty -> a -> a) -> a -> Vect n ty -> a
+foldr f acc b = A.foldr f acc (unVect b)
+
+cons :: ty -> Vect n ty -> Vect (n+1) ty
+cons e = Vect . A.cons e . unVect
+
+snoc :: Vect n ty -> ty -> Vect (n+1) ty
+snoc b = Vect . A.snoc (unVect b)
+
+sub :: forall i j n ty
+     . ( (i <=? n) ~ 'True
+       , (j <=? n) ~ 'True
+       , (i <=? j) ~ 'True
+       , KnownNat i
+       , KnownNat j
+       , Offsetable ty i
+       , Offsetable ty j )
+    => Vect n ty
+    -> Vect (j-i) ty
+sub block = Vect (A.sub (unVect block) (toOffset @i) (toOffset @j))
+
+uncons :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, Offsetable ty n)
+       => Vect n ty
+       -> (ty, Vect (n-1) ty)
+uncons b = (indexStatic @0 b, Vect (A.sub (unVect b) 1 (toOffset @n)))
+
+unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, Offsetable ty n)
+       => Vect n ty
+       -> (Vect (n-1) ty, ty)
+unsnoc b =
+    ( Vect (A.sub (unVect b) 0 (toOffset @n `offsetSub` 1))
+    , A.unsafeIndex (unVect b) (toOffset @n `offsetSub` 1))
+
+splitAt :: forall i n ty . (CmpNat i n ~ 'LT, KnownNat i, Countable ty i) => Vect n ty -> (Vect i ty, Vect (n-i) ty)
+splitAt b =
+    let (left, right) = A.splitAt (toCount @i) (unVect b)
+     in (Vect left, Vect right)
+
+elem :: Eq ty => ty -> Vect n ty -> Bool
+elem e b = A.elem e (unVect b)
+
+all :: (ty -> Bool) -> Vect n ty -> Bool
+all p b = A.all p (unVect b)
+
+any :: (ty -> Bool) -> Vect n ty -> Bool
+any p b = A.any p (unVect b)
+
+find :: (ty -> Bool) -> Vect n ty -> Maybe ty
+find p b = A.find p (unVect b)
+
+reverse :: Vect n ty -> Vect n ty
+reverse = Vect . A.reverse . unVect
+
+sortBy :: (ty -> ty -> Ordering) -> Vect n ty -> Vect n ty
+sortBy f b = Vect (A.sortBy f (unVect b))
+
+intersperse :: (CmpNat n 1 ~ 'GT) => ty -> Vect n ty -> Vect (n+n-1) ty
+intersperse sep b = Vect (A.intersperse sep (unVect b))
+
+toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty
+toCount = natValCountOf (Proxy @n)
+
+toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty
+toOffset = natValOffset (Proxy @n)

bundled/Basement/String/Builder.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.String.Builder
+-- License     : BSD-style
+-- Maintainer  : Foundation
+--
+-- String builder
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Basement.String.Builder
+    ( Builder
+    , run
+    , runUnsafe
+
+    -- * Emit functions
+    , emit
+    , emitChar
+
+    -- * unsafe
+    , unsafeStringBuilder
+    ) where
+
+
+import qualified Basement.Block.Base as Block (length)
+import qualified Basement.Block.Builder as Block
+import           Basement.Compat.Base
+import           Basement.Compat.Semigroup
+import           Basement.Monad
+import           Basement.String (String, ValidationFailure, Encoding (UTF8), fromBytes)
+import           Basement.UArray.Base (UArray)
+import qualified Basement.UArray.Base as A
+
+newtype Builder = Builder Block.Builder
+  deriving (Semigroup, Monoid)
+
+unsafeStringBuilder :: Block.Builder -> Builder
+unsafeStringBuilder = Builder
+{-# INLINE unsafeStringBuilder #-}
+
+run :: PrimMonad prim => Builder -> prim (String, Maybe ValidationFailure, UArray Word8)
+run (Builder builder) = do
+    block <- Block.run builder
+    let array = A.UArray 0 (Block.length block) (A.UArrayBA block)
+    pure $ fromBytes UTF8 array
+
+-- | run the given builder and return the generated String
+--
+-- prefer `run`
+runUnsafe :: PrimMonad prim => Builder -> prim String
+runUnsafe (Builder builder) = Block.unsafeRunString builder
+
+-- | add a string in the builder
+emit :: String -> Builder
+emit = Builder . Block.emitString
+
+-- | emit a UTF8 char in the builder
+emitChar :: Char -> Builder
+emitChar = Builder . Block.emitUTF8Char

bundled/Basement/String/Encoding/ASCII7.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.String.Encoding.ASCII7
+-- License     : BSD-style
+-- Maintainer  : Foundation
+-- Stability   : experimental
+-- Portability : portable
+--
+
+{-# LANGUAGE MagicHash #-}
+
+module Basement.String.Encoding.ASCII7
+    ( ASCII7(..)
+    , ASCII7_Invalid(..)
+    ) where
+
+import Basement.Compat.Base
+import Basement.Compat.Primitive
+import Basement.Types.OffsetSize
+import Basement.Numerical.Additive
+import Basement.Monad
+import Basement.Bits
+
+import GHC.Prim (int2Word#, ord#)
+import GHC.Word
+import GHC.Types
+import Basement.UArray
+import Basement.UArray.Mutable (MUArray)
+import Basement.MutableBuilder
+
+import Basement.String.Encoding.Encoding
+
+-- | validate a given byte is within ASCII characters encoring size
+--
+-- This function check the 8th bit is set to 0
+--
+isAscii :: Word8 -> Bool
+isAscii w = (w .&. 0x80) == 0
+{-# INLINE isAscii #-}
+
+data ASCII7_Invalid
+    = ByteOutOfBound Word8
+    | CharNotAscii   Char
+  deriving (Typeable, Show, Eq)
+instance Exception ASCII7_Invalid
+
+data ASCII7 = ASCII7
+
+instance Encoding ASCII7 where
+    type Unit ASCII7 = Word8
+    type Error ASCII7 = ASCII7_Invalid
+    encodingNext  _ = next
+    encodingWrite _ = write
+
+-- | consume an Ascii7 char and return the Unicode point and the position
+-- of the next possible Ascii7 char
+--
+next :: (Offset Word8 -> Word8)
+          -- ^ method to access a given byte
+     -> Offset Word8
+          -- ^ index of the byte
+     -> Either ASCII7_Invalid (Char, Offset Word8)
+          -- ^ either successfully validated the ASCII char and returned the
+          -- next index or fail with an error
+next getter off
+    | isAscii w8 = Right (toChar w, off + 1)
+    | otherwise  = Left $ ByteOutOfBound w8
+  where
+    !w8@(W8# w) = getter off
+    toChar :: Word8# -> Char
+    toChar a = C# (word8ToChar# w)
+
+-- Write ascii char
+--
+-- > build 64 $ sequence_ write "this is a simple list of char..."
+--
+write :: (PrimMonad st, Monad st)
+      => Char
+           -- ^ expecting it to be a valid Ascii character.
+           -- otherwise this function will throw an exception
+      -> Builder (UArray Word8) (MUArray Word8) Word8 st err ()
+write c
+    | c < toEnum 0x80 = builderAppend $ w8 c
+    | otherwise       = throw $ CharNotAscii c
+  where
+    w8 :: Char -> Word8
+    w8 (C# ch) = W8# (wordToWord8# (int2Word# (ord# ch)))

bundled/Basement/String/Encoding/Encoding.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.String.Encoding.Encoding
+-- License     : BSD-style
+-- Maintainer  : Foundation
+-- Stability   : experimental
+-- Portability : portable
+--
+
+{-# LANGUAGE FlexibleContexts #-}
+
+module Basement.String.Encoding.Encoding
+    ( Encoding(..)
+    , convertFromTo
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+import           Basement.PrimType
+import           Basement.MutableBuilder
+import           Basement.Numerical.Additive
+import           Basement.UArray (UArray)
+import           Basement.UArray.Mutable (MUArray)
+import qualified Basement.UArray as Vec
+
+class Encoding encoding where
+    -- | the unit element use for the encoding.
+    -- i.e. Word8 for ASCII7 or UTF8, Word16 for UTF16...
+    --
+    type Unit encoding
+
+    -- | define the type of error handling you want to use for the
+    -- next function.
+    --
+    -- > type Error UTF8 = Either UTF8_Invalid
+    --
+    type Error encoding
+
+    -- | consume an `Unit encoding` and return the Unicode point and the position
+    -- of the next possible `Unit encoding`
+    --
+    encodingNext :: encoding
+                      -- ^ only used for type deduction
+                -> (Offset (Unit encoding) -> Unit encoding)
+                      -- ^ method to access a given `Unit encoding`
+                      -- (see `unsafeIndexer`)
+                -> Offset (Unit encoding)
+                      -- ^ offset of the `Unit encoding` where starts the
+                      -- encoding of a given unicode
+                -> Either (Error encoding) (Char, Offset (Unit encoding)) -- ^ either successfully validated the `Unit encoding`
+                      -- and returned the next offset or fail with an
+                      -- `Error encoding`
+
+    -- Write a unicode point encoded into one or multiple `Unit encoding`
+    --
+    -- > build 64 $ sequence_ (write UTF8) "this is a simple list of char..."
+    --
+    encodingWrite :: (PrimMonad st, Monad st)
+                  => encoding
+                      -- ^ only used for type deduction
+                  -> Char
+                      -- ^ the unicode character to encode
+                  -> Builder (UArray (Unit encoding))
+                             (MUArray (Unit encoding))
+                             (Unit encoding) st err ()
+
+-- | helper to convert a given Array in a given encoding into an array
+-- with another encoding.
+--
+-- This is a helper to convert from one String encoding to another.
+-- This function is (quite) slow and needs some work.
+--
+-- ```
+-- let s16 = ... -- string in UTF16
+-- -- create s8, a UTF8 String
+-- let s8  = runST $ convertWith UTF16 UTF8 (toBytes s16)
+--
+-- print s8
+-- ```
+--
+convertFromTo :: ( PrimMonad st, Monad st
+                 , Encoding input, PrimType (Unit input)
+                 , Encoding output, PrimType (Unit output)
+                 )
+              => input
+                -- ^ Input's encoding type
+              -> output
+                -- ^ Output's encoding type
+              -> UArray (Unit input)
+                -- ^ the input raw array
+              -> st (Either (Offset (Unit input), Error input) (UArray (Unit output)))
+convertFromTo inputEncodingTy outputEncodingTy bytes
+    | Vec.null bytes = return . return $ mempty
+    | otherwise      = Vec.unsafeIndexer bytes $ \t -> Vec.builderBuild 64 (loop azero t)
+  where
+    lastUnit = Vec.length bytes
+
+    loop off getter
+      | off .==# lastUnit = return ()
+      | otherwise = case encodingNext inputEncodingTy getter off of
+          Left err -> mFail (off, err)
+          Right (c, noff) -> encodingWrite outputEncodingTy c >> loop noff getter

bundled/Basement/String/Encoding/ISO_8859_1.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.String.Encoding.ISO_8859_1
+-- License     : BSD-style
+-- Maintainer  : Foundation
+-- Stability   : experimental
+-- Portability : portable
+--
+
+{-# LANGUAGE MagicHash #-}
+
+module Basement.String.Encoding.ISO_8859_1
+    ( ISO_8859_1(..)
+    , ISO_8859_1_Invalid(..)
+    ) where
+
+import Basement.Compat.Base
+import Basement.Compat.Primitive
+import Basement.Types.OffsetSize
+import Basement.Numerical.Additive
+import Basement.Monad
+
+import GHC.Prim (int2Word#, ord#)
+import GHC.Word
+import GHC.Types
+import Basement.UArray
+import Basement.UArray.Mutable (MUArray)
+import Basement.MutableBuilder
+
+import Basement.String.Encoding.Encoding
+
+-- offset of size one
+aone :: Offset Word8
+aone = Offset 1
+
+data ISO_8859_1_Invalid
+    = NotISO_8859_1 Char
+  deriving (Typeable, Show, Eq)
+instance Exception ISO_8859_1_Invalid
+
+data ISO_8859_1 = ISO_8859_1
+
+instance Encoding ISO_8859_1 where
+    type Unit ISO_8859_1 = Word8
+    type Error ISO_8859_1 = ISO_8859_1_Invalid
+    encodingNext  _ = next
+    encodingWrite _ = write
+
+next :: (Offset Word8 -> Word8)
+     -> Offset Word8
+     -> Either ISO_8859_1_Invalid (Char, Offset Word8)
+next getter off = Right (toChar w, off + aone)
+  where
+    !(W8# w) = getter off
+    toChar :: Word8# -> Char
+    toChar a = C# (word8ToChar# w)
+
+write :: (PrimMonad st, Monad st)
+      => Char
+      -> Builder (UArray Word8) (MUArray Word8) Word8 st err ()
+write c@(C# ch)
+    | c <= toEnum 0xFF = builderAppend (W8# x)
+    | otherwise        = throw $ NotISO_8859_1 c
+  where
+    x :: Word8#
+    !x = wordToWord8# (int2Word# (ord# ch))

bundled/Basement/String/Encoding/UTF16.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.String.Encoding.UTF16
+-- License     : BSD-style
+-- Maintainer  : Foundation
+-- Stability   : experimental
+-- Portability : portable
+--
+{-# LANGUAGE MagicHash #-}
+module Basement.String.Encoding.UTF16
+    ( UTF16(..)
+    , UTF16_Invalid(..)
+    ) where
+
+import GHC.Prim
+import GHC.Word
+import GHC.Types
+import qualified Prelude
+import Basement.Compat.Base
+import Basement.Compat.Primitive
+import Basement.IntegralConv
+import Basement.Bits
+import Basement.Types.OffsetSize
+import Basement.Monad
+import Basement.Numerical.Additive
+import Basement.Numerical.Subtractive
+import Basement.UArray
+import Basement.UArray.Mutable (MUArray)
+import Basement.MutableBuilder
+
+import Basement.String.Encoding.Encoding
+
+data UTF16_Invalid
+    = InvalidContinuation
+    | InvalidUnicode Char
+  deriving (Show, Eq, Typeable)
+instance Exception UTF16_Invalid
+
+data UTF16 = UTF16
+
+instance Encoding UTF16 where
+    type Unit UTF16 = Word16
+    type Error UTF16 = UTF16_Invalid
+    encodingNext  _ = next
+    encodingWrite _ = write
+
+
+--
+-- U+0000 to U+D7FF and U+E000 to U+FFFF : 1 bytes
+-- U+10000 to U+10FFFF :
+--    * 0x010000 is subtracted from the code point, leaving a 20-bit number in the range 0..0x0FFFFF.
+--    * The top ten bits (a number in the range 0..0x03FF) are added to 0xD800 to give the first 16-bit code unit
+--      or high surrogate, which will be in the range 0xD800..0xDBFF.
+--    * The low ten bits (also in the range 0..0x03FF) are added to 0xDC00 to give the second 16-bit code unit
+--      or low surrogate, which will be in the range 0xDC00..0xDFFF.
+
+next :: (Offset Word16 -> Word16)
+     -> Offset Word16
+     -> Either UTF16_Invalid (Char, Offset Word16)
+next getter off
+    | h <  0xd800 = Right (toChar16 h, off + Offset 1)
+    | h >= 0xe000 = Right (toChar16 h, off + Offset 1)
+    | otherwise   = nextContinuation
+  where
+    h :: Word16
+    !h = getter off
+
+    to32 :: Word16 -> Word32
+    to32 (W16# w) = W32# (word16ToWord32# w)
+
+    toChar16 :: Word16 -> Char
+    toChar16 (W16# w) = C# (word32ToChar# (word16ToWord32# w))
+
+    nextContinuation
+        | cont >= 0xdc00 && cont < 0xe00 =
+            let !(W32# w) = ((to32 h .&. 0x3ff) .<<. 10) .|. (to32 cont .&. 0x3ff)
+             in Right (C# (word32ToChar# w), off + Offset 2)
+        | otherwise = Left InvalidContinuation
+      where
+        cont :: Word16
+        !cont = getter $ off + Offset 1
+
+write :: (PrimMonad st, Monad st)
+      => Char
+      -> Builder (UArray Word16) (MUArray Word16) Word16 st err ()
+write c
+    | c < toEnum 0xd800   = builderAppend $ w16 c
+    | c > toEnum 0x10000  = let (w1, w2) = wHigh c in builderAppend w1 >> builderAppend w2
+    | c > toEnum 0x10ffff = throw $ InvalidUnicode c
+    | c >= toEnum 0xe000  = builderAppend $ w16 c
+    | otherwise = throw $ InvalidUnicode c
+  where
+    w16 :: Char -> Word16
+    w16 (C# ch) = W16# (wordToWord16# (int2Word# (ord# ch)))
+
+    to16 :: Word32 -> Word16
+    to16 = Prelude.fromIntegral
+
+    wHigh :: Char -> (Word16, Word16)
+    wHigh (C# ch) =
+        let v = W32# (charToWord32# ch) - 0x10000
+         in (0xdc00 .|. to16 (v .>>. 10), 0xd800 .|. to16 (v .&. 0x3ff))

bundled/Basement/String/Encoding/UTF32.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.String.Encoding.UTF32
+-- License     : BSD-style
+-- Maintainer  : Foundation
+-- Stability   : experimental
+-- Portability : portable
+--
+{-# LANGUAGE MagicHash #-}
+module Basement.String.Encoding.UTF32
+    ( UTF32(..)
+    , UTF32_Invalid
+    ) where
+
+import GHC.Prim
+import GHC.Word
+import GHC.Types
+import Basement.Compat.Base
+import Basement.Compat.Primitive
+import Basement.Types.OffsetSize
+import Basement.Monad
+import Basement.Numerical.Additive
+import Basement.UArray
+import Basement.UArray.Mutable (MUArray)
+import Basement.MutableBuilder
+
+import Basement.String.Encoding.Encoding
+
+data UTF32 = UTF32
+
+data UTF32_Invalid = UTF32_Invalid
+  deriving (Typeable, Show, Eq, Ord, Enum, Bounded)
+instance Exception UTF32_Invalid
+
+instance Encoding UTF32 where
+    type Unit UTF32 = Word32
+    type Error UTF32 = UTF32_Invalid
+    encodingNext  _ = next
+    encodingWrite _ = write
+
+next :: (Offset Word32 -> Word32)
+     -> Offset Word32
+     -> Either UTF32_Invalid (Char, Offset Word32)
+next getter off = Right (char, off + Offset 1)
+  where
+    !(W32# hh) = getter off
+    char :: Char
+    char = C# (word32ToChar# hh)
+
+write :: (PrimMonad st, Monad st)
+      => Char
+      -> Builder (UArray Word32) (MUArray Word32) Word32 st err ()
+write c = builderAppend w32
+  where
+    !(C# ch) = c
+    w32 :: Word32
+    w32 = W32# (charToWord32# ch)

bundled/Basement/Terminal.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+module Basement.Terminal
+    ( initialize
+    , getDimensions
+    ) where
+
+import Basement.Compat.Base
+import Basement.Terminal.Size (getDimensions)
+#ifdef mingw32_HOST_OS
+import System.IO (hSetEncoding, utf8, hPutStrLn, stderr, stdin, stdout)
+import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)
+#endif
+
+initialize :: IO ()
+initialize = do
+#ifdef mingw32_HOST_OS
+    query getConsoleOutputCP (\e -> setConsoleOutputCP e >> hSetEncoding stdout utf8 >> hSetEncoding stderr utf8) utf8Code
+    query getConsoleCP (\e -> setConsoleCP e >> hSetEncoding stdin utf8) utf8Code
+  where
+    utf8Code = 65001
+    query get set expected = do
+        v <- get
+        if v == expected then pure () else set expected
+#else
+    pure ()
+#endif

bundled/Basement/Terminal/ANSI.hs

@@ -0,0 +1,175 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Terminal.ANSI
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+--
+-- ANSI Terminal escape for cursor and attributes manipulations
+--
+-- On Unix system, it should be supported by most terminal emulators.
+--
+-- On Windows system, all escape sequences are empty for maximum
+-- compatibility purpose, and easy implementation. newer version
+-- of Windows 10 supports ANSI escape now, but we'll need
+-- some kind of detection.
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Basement.Terminal.ANSI
+    (
+    -- * Types
+      Escape
+    , Displacement
+    , ColorComponent
+    , GrayComponent
+    , RGBComponent
+    -- * Simple ANSI escape factory functions
+    , cursorUp
+    , cursorDown
+    , cursorForward
+    , cursorBack
+    , cursorNextLine
+    , cursorPrevLine
+    , cursorHorizontalAbsolute
+    , cursorPosition
+    , eraseScreenFromCursor
+    , eraseScreenToCursor
+    , eraseScreenAll
+    , eraseLineFromCursor
+    , eraseLineToCursor
+    , eraseLineAll
+    , scrollUp
+    , scrollDown
+    , sgrReset
+    , sgrForeground
+    , sgrBackground
+    , sgrForegroundGray24
+    , sgrBackgroundGray24
+    , sgrForegroundColor216
+    , sgrBackgroundColor216
+    ) where
+
+import Basement.String
+import Basement.Bounded
+import Basement.Imports
+import Basement.Numerical.Multiplicative
+import Basement.Numerical.Additive
+
+#ifndef mingw32_HOST_OS
+#define SUPPORT_ANSI_ESCAPE
+#endif
+
+type Escape = String
+
+type Displacement = Word64
+
+-- | Simple color component on 8 color terminal (maximum compatibility)
+type ColorComponent = Zn64 8
+
+-- | Gray color compent on 256colors terminals
+type GrayComponent = Zn64 24
+
+-- | Color compent on 256colors terminals
+type RGBComponent = Zn64 6
+
+cursorUp, cursorDown, cursorForward, cursorBack
+    , cursorNextLine, cursorPrevLine
+    , cursorHorizontalAbsolute :: Displacement -> Escape
+cursorUp n = csi1 n "A"
+cursorDown n = csi1 n "B"
+cursorForward n = csi1 n "C"
+cursorBack n = csi1 n "D"
+cursorNextLine n = csi1 n "E"
+cursorPrevLine n = csi1 n "F"
+cursorHorizontalAbsolute n = csi1 n "G"
+
+cursorPosition :: Displacement -> Displacement -> Escape
+cursorPosition row col = csi2 row col "H"
+
+eraseScreenFromCursor
+    , eraseScreenToCursor
+    , eraseScreenAll
+    , eraseLineFromCursor
+    , eraseLineToCursor
+    , eraseLineAll :: Escape
+eraseScreenFromCursor = csi1 0 "J"
+eraseScreenToCursor = csi1 1 "J"
+eraseScreenAll = csi1 2 "J"
+eraseLineFromCursor = csi1 0 "K"
+eraseLineToCursor = csi1 1 "K"
+eraseLineAll = csi1 2 "K"
+
+scrollUp, scrollDown :: Displacement -> Escape
+scrollUp n = csi1 n "S"
+scrollDown n = csi1 n "T"
+
+-- | All attribute off
+sgrReset :: Escape
+sgrReset = csi1 0 "m"
+
+-- | 8 Colors + Bold attribute for foreground
+sgrForeground :: ColorComponent -> Bool -> Escape
+sgrForeground n bold
+    | bold      = csi2 (30+unZn64 n) 1 "m"
+    | otherwise = csi1 (30+unZn64 n) "m"
+
+-- | 8 Colors + Bold attribute for background
+sgrBackground :: ColorComponent -> Bool -> Escape
+sgrBackground n bold
+    | bold      = csi2 (40+unZn64 n) 1 "m" 
+    | otherwise = csi1 (40+unZn64 n) "m"
+
+-- 256 colors mode
+
+sgrForegroundGray24, sgrBackgroundGray24 :: GrayComponent -> Escape
+sgrForegroundGray24 v = csi3 38 5 (0xE8 + unZn64 v) "m"
+sgrBackgroundGray24 v = csi3 48 5 (0xE8 + unZn64 v) "m"
+
+sgrForegroundColor216 :: RGBComponent -- ^ Red component
+                      -> RGBComponent -- ^ Green component
+                      -> RGBComponent -- ^ Blue component
+                      -> Escape
+sgrForegroundColor216 r g b = csi3 38 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m"
+
+sgrBackgroundColor216 :: RGBComponent -- ^ Red component
+                      -> RGBComponent -- ^ Green component
+                      -> RGBComponent -- ^ Blue component
+                      -> Escape
+sgrBackgroundColor216 r g b = csi3 48 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m"
+
+#ifdef SUPPORT_ANSI_ESCAPE
+
+csi0 :: String -> String
+csi0 suffix = mconcat ["\ESC[", suffix]
+
+csi1 :: Displacement -> String -> String
+csi1 p1 suffix = mconcat ["\ESC[", pshow p1, suffix]
+
+csi2 :: Displacement -> Displacement -> String -> String
+csi2 p1 p2 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, suffix]
+
+csi3 :: Displacement -> Displacement -> Displacement -> String -> String
+csi3 p1 p2 p3 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, ";", pshow p3, suffix]
+
+pshow = show
+
+#else
+
+csi0 :: String -> String
+csi0 _ = ""
+
+csi1 :: Displacement -> String -> String
+csi1 _ _ = ""
+
+csi2 :: Displacement -> Displacement -> String -> String
+csi2 _ _ _ = ""
+
+csi3 :: Displacement -> Displacement -> Displacement -> String -> String
+csi3 _ _ _ _ = ""
+
+#endif

bundled/Basement/Terminal/Size.hsc

@@ -0,0 +1,190 @@
+{-# LANGUAGE CApiFFI #-}
+module Basement.Terminal.Size 
+    ( getDimensions
+    ) where
+        
+import           Foreign
+import           Foreign.C
+import           Basement.Compat.Base
+import           Basement.Types.OffsetSize
+import           Basement.Numerical.Subtractive
+import           Basement.Numerical.Additive
+import           Prelude (fromIntegral)
+
+#include "foundation_system.h"
+#ifdef FOUNDATION_SYSTEM_WINDOWS
+
+import           System.Win32.Types (HANDLE, BOOL)
+import           Graphics.Win32.Misc (getStdHandle, sTD_OUTPUT_HANDLE, StdHandleId)
+
+#include <windows.h>
+#elif defined FOUNDATION_SYSTEM_UNIX
+#include <sys/ioctl.h>
+#ifdef __sun
+#include <sys/termios.h>
+#endif
+#endif 
+
+#include <stdio.h>
+
+#if __GLASGOW_HASKELL__ < 800
+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
+#endif
+
+#ifdef FOUNDATION_SYSTEM_UNIX
+data Winsize = Winsize
+    { ws_row    :: !Word16
+    , ws_col    :: !Word16
+    , ws_xpixel :: !Word16
+    , ws_ypixel :: !Word16
+    }
+
+instance Storable Winsize where
+    sizeOf _ = #{size struct winsize}
+    alignment _ = #{alignment struct winsize}
+    peek ptr = do
+        r <- #{peek struct winsize, ws_row} ptr
+        c <- #{peek struct winsize, ws_col} ptr
+        x <- #{peek struct winsize, ws_xpixel} ptr
+        y <- #{peek struct winsize, ws_ypixel} ptr
+        return (Winsize r c x y)
+    poke ptr (Winsize r c x y) = do
+        #{poke struct winsize, ws_row} ptr r
+        #{poke struct winsize, ws_col} ptr c
+        #{poke struct winsize, ws_xpixel} ptr x
+        #{poke struct winsize, ws_ypixel} ptr y
+        
+#elif defined FOUNDATION_SYSTEM_WINDOWS
+type Handle = Ptr CChar  -- void *
+
+data SmallRect = SmallRect 
+    { left   :: !Int16
+    , top    :: !Int16
+    , right  :: !Int16
+    , bottom :: !Int16
+    } deriving (Show)
+
+instance Storable SmallRect where
+    sizeOf _ = #{size SMALL_RECT}
+    alignment _ = #{alignment SMALL_RECT}
+    peek ptr = do
+        l <- #{peek SMALL_RECT, Left} ptr
+        r <- #{peek SMALL_RECT, Right} ptr
+        t <- #{peek SMALL_RECT, Top} ptr
+        b <- #{peek SMALL_RECT, Bottom} ptr
+        return (SmallRect l t r b)
+    poke ptr (SmallRect l t r b) = do
+        #{poke SMALL_RECT, Left} ptr l
+        #{poke SMALL_RECT, Top} ptr t
+        #{poke SMALL_RECT, Right} ptr r
+        #{poke SMALL_RECT, Bottom} ptr b
+        
+data Coord = Coord 
+    { x :: !Int16
+    , y :: !Int16
+    } deriving (Show)
+
+instance Storable Coord where
+    sizeOf _ = #{size COORD}
+    alignment _ = #{alignment COORD}
+    peek ptr = do
+        x <- #{peek COORD, X} ptr
+        y <- #{peek COORD, Y} ptr
+        return (Coord x y)
+    poke ptr (Coord x y) = do
+        #{poke COORD, X} ptr x
+        #{poke COORD, Y} ptr y
+
+data ConsoleScreenBufferInfo = ConsoleScreenBufferInfo 
+    { dwSize              :: !Coord
+    , dwCursorPosition    :: !Coord
+    , wAttributes         :: !Word16
+    , srWindow            :: !SmallRect
+    , dwMaximumWindowSize :: !Coord
+    } deriving (Show)
+
+instance Storable ConsoleScreenBufferInfo where
+    sizeOf _ = #{size CONSOLE_SCREEN_BUFFER_INFO}
+    alignment _ = #{alignment CONSOLE_SCREEN_BUFFER_INFO}
+    peek ptr = do
+        s <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr
+        c <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr
+        a <- #{peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr
+        w <- #{peek CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr
+        m <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr
+        return (ConsoleScreenBufferInfo s c a w m)
+    poke ptr (ConsoleScreenBufferInfo s c a w m) = do
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr s
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr c
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr a
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr w
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr m
+    
+invalidHandleValue :: IntPtr
+invalidHandleValue = #{const INVALID_HANDLE_VALUE}
+
+stdOutputHandle :: CULong
+stdOutputHandle = #{const STD_OUTPUT_HANDLE}
+#endif
+-- defined FOUNDATION_SYSTEM_WINDOWS
+
+#ifdef FOUNDATION_SYSTEM_UNIX
+
+foreign import capi "sys/ioctl.h ioctl" c_ioctl :: CInt -> CULong -> Ptr a -> IO CInt
+
+-- | Get the terminal windows size
+tiocgwinsz :: CULong
+tiocgwinsz = Prelude.fromIntegral (#{const TIOCGWINSZ} :: Word)
+
+#elif defined FOUNDATION_SYSTEM_WINDOWS
+foreign import ccall "GetConsoleScreenBufferInfo" c_get_console_screen_buffer_info 
+  :: HANDLE -> Ptr ConsoleScreenBufferInfo -> IO BOOL
+#endif
+
+#ifdef FOUNDATION_SYSTEM_UNIX
+ioctlWinsize :: CInt -> IO (Maybe (CountOf Char, CountOf Char))
+ioctlWinsize fd = alloca $ \winsizePtr -> do
+    status <- c_ioctl fd tiocgwinsz winsizePtr
+    if status == (-1 :: CInt)
+        then pure Nothing
+        else Just . toDimensions <$> peek winsizePtr
+  where
+    toDimensions winsize =
+        ( CountOf . Prelude.fromIntegral . ws_col $ winsize
+        , CountOf . Prelude.fromIntegral . ws_row $ winsize)
+       
+#elif defined FOUNDATION_SYSTEM_WINDOWS
+getConsoleScreenBufferInfo :: HANDLE -> IO (Maybe ConsoleScreenBufferInfo)
+getConsoleScreenBufferInfo handle = alloca $ \infoPtr -> do
+    status <- c_get_console_screen_buffer_info handle infoPtr
+    if status
+        then Just <$> peek infoPtr
+        else pure Nothing
+       
+winWinsize :: StdHandleId -> IO (Maybe (CountOf Char, CountOf Char))
+winWinsize handleRef = (infoToDimensions <$>) <$>
+    (getStdHandle handleRef >>= getConsoleScreenBufferInfo)
+  where
+    infoToDimensions info =
+        let window = srWindow info
+            width = Prelude.fromIntegral (right window - left window + 1)
+            height = Prelude.fromIntegral (bottom window - top window + 1)
+         in (CountOf width, CountOf height)
+#endif
+-- defined FOUNDATION_SYSTEM_WINDOWS
+
+-- | Return the size of the current terminal
+--
+-- If the system is not supported or that querying the system result in an error
+-- then a default size of (80, 24) will be given back.
+getDimensions :: IO (CountOf Char, CountOf Char)
+getDimensions =
+#if defined FOUNDATION_SYSTEM_WINDOWS
+    maybe defaultSize id <$> winWinsize sTD_OUTPUT_HANDLE
+#elif defined FOUNDATION_SYSTEM_UNIX
+    maybe defaultSize id <$> ioctlWinsize 0
+#else
+    pure defaultSize
+#endif
+  where
+    defaultSize = (80, 24)

bundled/Basement/These.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.These
+-- License     : BSD-style
+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>
+-- Stability   : stable
+-- Portability : portable
+--
+-- @These a b@, sum type to represent either @a@ or @b@ or both.
+--
+module Basement.These
+    ( These(..)
+    ) where
+
+import Basement.Compat.Base
+import Basement.NormalForm
+
+-- | Either a or b or both.
+data These a b
+    = This a
+    | That b
+    | These a b
+  deriving (Eq, Ord, Show, Typeable)
+
+instance (NormalForm a, NormalForm b) => NormalForm (These a b) where
+    toNormalForm (This a) = toNormalForm a
+    toNormalForm (That b) = toNormalForm b
+    toNormalForm (These a b) = toNormalForm a `seq` toNormalForm b

bundled/Basement/Types/AsciiString.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Foundation.Primitives.Types.AsciiString
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A AsciiString type backed by a `ASCII` encoded byte array and all the necessary
+-- functions to manipulate the string.
+--
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+module Basement.Types.AsciiString
+    ( AsciiString(..)
+    , MutableAsciiString(..)
+    -- * Binary conversion
+    , fromBytesUnsafe
+    , fromBytes
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Compat.Semigroup
+import           Basement.Types.Char7
+import           Basement.UArray.Base
+import qualified Basement.Types.Char7 as Char7
+import qualified Basement.UArray as A (all, unsafeRecast)
+
+-- | Opaque packed array of characters in the ASCII encoding
+newtype AsciiString = AsciiString { toBytes :: UArray Char7 }
+    deriving (Typeable, Semigroup, Monoid, Eq, Ord)
+
+newtype MutableAsciiString st = MutableAsciiString (MUArray Char7 st)
+    deriving (Typeable)
+
+instance Show AsciiString where
+    show = fmap Char7.toChar . toList
+instance IsString AsciiString where
+    fromString = fromList . fmap Char7.fromCharMask
+instance IsList AsciiString where
+    type Item AsciiString = Char7
+    fromList = AsciiString . fromList
+    toList (AsciiString chars) = toList chars
+
+-- | Convert a Byte Array representing ASCII data directly to an AsciiString without checking for ASCII validity
+--
+-- If the input contains invalid Char7 value (anything above 0x7f),
+-- it will trigger runtime async errors when processing data.
+--
+-- In doubt, use 'fromBytes'
+fromBytesUnsafe :: UArray Word8 -> AsciiString
+fromBytesUnsafe = AsciiString . A.unsafeRecast
+
+-- | Convert a Byte Array representing ASCII checking validity.
+--
+-- If the byte array is not valid, then Nothing is returned
+fromBytes :: UArray Word8 -> Maybe AsciiString
+fromBytes arr
+    | A.all (\x -> x < 0x80) arr = Just $ AsciiString $ A.unsafeRecast arr
+    | otherwise                  = Nothing

bundled/Basement/Types/Char7.hs

@@ -0,0 +1,121 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE BangPatterns               #-}
+module Basement.Types.Char7
+    ( Char7(..)
+    , toChar
+    , fromCharMask
+    , fromChar
+    , fromByteMask
+    , fromByte
+    -- * individual ASCII Characters
+    , c7_LF
+    , c7_CR
+    , c7_minus
+    , c7_a
+    , c7_A
+    , c7_z
+    , c7_Z
+    , c7_0
+    , c7_1
+    , c7_2
+    , c7_3
+    , c7_4
+    , c7_5
+    , c7_6
+    , c7_7
+    , c7_8
+    , c7_9
+    -- * Upper / Lower With ASCII
+    , c7Upper
+    , c7Lower
+    ) where
+
+import GHC.Prim
+import GHC.Word
+import GHC.Types
+import Data.Bits
+import Data.Maybe
+import Basement.Compat.Base
+import Basement.Compat.Primitive
+
+-- | ASCII value between 0x0 and 0x7f
+newtype Char7 = Char7 { toByte :: Word8 }
+    deriving (Show,Eq,Ord,Typeable)
+
+-- | Convert a 'Char7' to a unicode code point 'Char'
+toChar :: Char7 -> Char
+toChar !(Char7 (W8# w)) = C# (chr# (word2Int# (word8ToWord# w)))
+
+-- | Try to convert a 'Char' to a 'Char7'
+-- 
+-- If the code point is non ascii, then Nothing is returned.
+fromChar :: Char -> Maybe Char7
+fromChar !(C# c#)
+    | bool# (ltChar# c# (chr# 0x80#)) = Just $ Char7 $ W8# (wordToWord8# (int2Word# (ord# c#)))
+    | otherwise                       = Nothing
+
+-- | Try to convert 'Word8' to a 'Char7'
+--
+-- If the byte got higher bit set, then Nothing is returned.
+fromByte :: Word8 -> Maybe Char7
+fromByte !w
+    | (w .&. 0x80) == 0 = Just $ Char7 w
+    | otherwise         = Nothing
+
+-- | Convert a 'Char' to a 'Char7' ignoring all higher bits
+fromCharMask :: Char -> Char7
+fromCharMask !(C# c#) = Char7 $ W8# (wordToWord8# (and# (int2Word# (ord# c#)) 0x7f##))
+
+-- | Convert a 'Byte' to a 'Char7' ignoring the higher bit
+fromByteMask :: Word8 -> Char7
+fromByteMask !w = Char7 (w .&. 0x7f)
+
+c7_LF :: Char7
+c7_LF = Char7 0xa
+
+c7_CR :: Char7
+c7_CR = Char7 0xd
+
+c7_minus :: Char7
+c7_minus = Char7 0x2d
+
+c7_a :: Char7
+c7_a = Char7 0x61
+
+c7_A :: Char7
+c7_A = Char7 0x41
+
+c7_z :: Char7
+c7_z = Char7 0x7a
+
+c7_Z :: Char7
+c7_Z = Char7 0x5a
+
+c7_0, c7_1, c7_2, c7_3, c7_4, c7_5, c7_6, c7_7, c7_8, c7_9 :: Char7
+c7_0 = Char7 0x30
+c7_1 = Char7 0x31
+c7_2 = Char7 0x32
+c7_3 = Char7 0x33
+c7_4 = Char7 0x34
+c7_5 = Char7 0x35
+c7_6 = Char7 0x36
+c7_7 = Char7 0x37
+c7_8 = Char7 0x38
+c7_9 = Char7 0x39
+
+c7Lower :: Char7 -> Char7
+c7Lower c@(Char7 w)
+    | c <  c7_A = c
+    | c <= c7_Z = Char7 (w .|. 0x20)
+    | otherwise = c
+
+c7Upper :: Char7 -> Char7
+c7Upper c@(Char7 w)
+    | c <  c7_a = c
+    | c <= c7_z = Char7 (w .&. 0xdf)
+    | otherwise = c

bundled/Basement/Types/CharUTF8.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Basement.Types.CharUTF8
+    ( CharUTF8(..)
+    , encodeCharUTF8
+    , decodeCharUTF8
+    ) where
+
+import Basement.UTF8.Types
+import Basement.UTF8.Helper

bundled/Basement/Types/OffsetSize.hs

@@ -0,0 +1,288 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Types.OffsetSize
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE ConstraintKinds            #-}
+{-# OPTIONS_GHC -fno-prof-auto          #-}
+module Basement.Types.OffsetSize
+    ( FileSize(..)
+    , Offset(..)
+    , Offset8
+    , sentinel
+    , offsetOfE
+    , offsetPlusE
+    , offsetMinusE
+    , offsetRecast
+    , offsetCast
+    , offsetSub
+    , offsetShiftL
+    , offsetShiftR
+    , sizeCast
+    , sizeLastOffset
+    , sizeAsOffset
+    , sizeSub
+    , countOfRoundUp
+    , offsetAsSize
+    , (+.)
+    , (.==#)
+    , CountOf(..)
+    , sizeOfE
+    , csizeOfOffset
+    , csizeOfSize
+    , sizeOfCSSize
+    , sizeOfCSize
+    , Countable
+    , Offsetable
+    , natValCountOf
+    , natValOffset
+    ) where
+
+#include "MachDeps.h"
+
+import GHC.Types
+import GHC.Word
+import GHC.Int
+import GHC.Prim
+import qualified GHC.Prim
+import System.Posix.Types (CSsize (..))
+import Data.Bits
+import Basement.Compat.Base
+import Basement.Compat.C.Types
+import Basement.Compat.Semigroup
+import Data.Proxy
+import Basement.Numerical.Number
+import Basement.Numerical.Additive
+import Basement.Numerical.Subtractive
+import Basement.Numerical.Multiplicative
+import Basement.Numerical.Conversion (intToWord)
+import Basement.Nat
+import Basement.IntegralConv
+import Data.List (foldl')
+import qualified Prelude
+
+#if WORD_SIZE_IN_BITS < 64
+import GHC.IntWord64
+#endif
+
+-- | File size in bytes
+newtype FileSize = FileSize Word64
+    deriving (Show,Eq,Ord)
+
+-- | Offset in bytes used for memory addressing (e.g. in a vector, string, ..)
+type Offset8 = Offset Word8
+
+-- | Offset in a data structure consisting of elements of type 'ty'.
+--
+-- Int is a terrible backing type which is hard to get away from,
+-- considering that GHC/Haskell are mostly using this for offset.
+-- Trying to bring some sanity by a lightweight wrapping.
+newtype Offset ty = Offset Int
+    deriving (Show,Eq,Ord,Enum,Additive,Typeable,Integral,Prelude.Num)
+
+sentinel = Offset (-1)
+
+instance IsIntegral (Offset ty) where
+    toInteger (Offset i) = toInteger i
+instance IsNatural (Offset ty) where
+    toNatural (Offset i) = toNatural (intToWord i)
+instance Subtractive (Offset ty) where
+    type Difference (Offset ty) = CountOf ty
+    (Offset a) - (Offset b) = CountOf (a-b)
+
+(+.) :: Offset ty -> Int -> Offset ty
+(+.) (Offset a) b = Offset (a + b)
+{-# INLINE (+.) #-}
+
+-- . is offset (as a pointer from a beginning), and # is the size (amount of data)
+(.==#) :: Offset ty -> CountOf ty -> Bool
+(.==#) (Offset ofs) (CountOf sz) = ofs == sz
+{-# INLINE (.==#) #-}
+
+offsetOfE :: CountOf Word8 -> Offset ty -> Offset8
+offsetOfE (CountOf sz) (Offset ty) = Offset (ty * sz)
+
+offsetPlusE :: Offset ty -> CountOf ty -> Offset ty
+offsetPlusE (Offset ofs) (CountOf sz) = Offset (ofs + sz)
+
+offsetMinusE :: Offset ty -> CountOf ty -> Offset ty
+offsetMinusE (Offset ofs) (CountOf sz) = Offset (ofs - sz)
+
+-- | subtract 2 CountOf values of the same type.
+--
+-- m need to be greater than n, otherwise negative count error ensue
+-- use the safer (-) version if unsure.
+offsetSub :: Offset a -> Offset a -> Offset a
+offsetSub (Offset m) (Offset n) = Offset (m - n)
+
+offsetRecast :: CountOf Word8 -> CountOf Word8 -> Offset ty -> Offset ty2
+offsetRecast szTy (CountOf szTy2) ofs =
+    let (Offset bytes) = offsetOfE szTy ofs
+     in Offset (bytes `div` szTy2)
+
+offsetShiftR :: Int -> Offset ty -> Offset ty2
+offsetShiftR n (Offset o) = Offset (o `unsafeShiftR` n)
+
+offsetShiftL :: Int -> Offset ty -> Offset ty2
+offsetShiftL n (Offset o) = Offset (o `unsafeShiftL` n)
+
+offsetCast :: Proxy (a -> b) -> Offset a -> Offset b
+offsetCast _ (Offset o) = Offset o
+{-# INLINE offsetCast #-}
+
+sizeCast :: Proxy (a -> b) -> CountOf a -> CountOf b
+sizeCast _ (CountOf sz) = CountOf sz
+{-# INLINE sizeCast #-}
+
+-- | subtract 2 CountOf values of the same type.
+--
+-- m need to be greater than n, otherwise negative count error ensue
+-- use the safer (-) version if unsure.
+sizeSub :: CountOf a -> CountOf a -> CountOf a
+sizeSub (CountOf m) (CountOf n)
+    | diff >= 0 = CountOf diff
+    | otherwise = error "sizeSub negative size"
+  where
+    diff = m - n
+
+-- TODO add a callstack, or a construction to prevent size == 0 error
+sizeLastOffset :: CountOf a -> Offset a
+sizeLastOffset (CountOf s)
+    | s > 0     = Offset (pred s)
+    | otherwise = error "last offset on size 0"
+
+sizeAsOffset :: CountOf a -> Offset a
+sizeAsOffset (CountOf a) = Offset a
+{-# INLINE sizeAsOffset #-}
+
+offsetAsSize :: Offset a -> CountOf a
+offsetAsSize (Offset a) = CountOf a
+{-# INLINE offsetAsSize #-}
+
+-- | CountOf of a data structure.
+--
+-- More specifically, it represents the number of elements of type `ty` that fit
+-- into the data structure.
+--
+-- >>> length (fromList ['a', 'b', 'c', '🌟']) :: CountOf Char
+-- CountOf 4
+--
+-- Same caveats as 'Offset' apply here.
+newtype CountOf ty = CountOf Int
+    deriving (Show,Eq,Ord,Enum,Typeable,Integral)
+
+instance Prelude.Num (CountOf ty) where
+    fromInteger a = CountOf (fromInteger a)
+    (+) (CountOf a) (CountOf b) = CountOf (a+b)
+    (-) (CountOf a) (CountOf b)
+        | b > a     = CountOf 0
+        | otherwise = CountOf (a - b)
+    (*) (CountOf a) (CountOf b) = CountOf (a*b)
+    abs a = a
+    negate _ = error "cannot negate CountOf: use Foundation Numerical hierarchy for this function to not be exposed to CountOf"
+    signum (CountOf a) = CountOf (Prelude.signum a)
+
+instance IsIntegral (CountOf ty) where
+    toInteger (CountOf i) = toInteger i
+instance IsNatural (CountOf ty) where
+    toNatural (CountOf i) = toNatural (intToWord i)
+
+instance Additive (CountOf ty) where
+    azero = CountOf 0
+    (+) (CountOf a) (CountOf b) = CountOf (a+b)
+    scale n (CountOf a) = CountOf (scale n a)
+
+instance Subtractive (CountOf ty) where
+    type Difference (CountOf ty) = Maybe (CountOf ty)
+    (CountOf a) - (CountOf b) | a >= b    = Just . CountOf $ a - b
+                              | otherwise = Nothing
+
+instance Semigroup (CountOf ty) where
+    (<>) = (+)
+
+instance Monoid (CountOf ty) where
+    mempty = azero
+    mconcat = foldl' (+) 0
+
+sizeOfE :: CountOf Word8 -> CountOf ty -> CountOf Word8
+sizeOfE (CountOf sz) (CountOf ty) = CountOf (ty * sz)
+
+-- | alignment need to be a power of 2
+countOfRoundUp :: Int -> CountOf ty -> CountOf ty
+countOfRoundUp alignment (CountOf n) = CountOf ((n + (alignment-1)) .&. complement (alignment-1))
+
+-- when #if WORD_SIZE_IN_BITS < 64 the 2 following are wrong
+-- instead of using FromIntegral and being silently wrong
+-- explicit pattern match to sort it out.
+
+csizeOfSize :: CountOf Word8 -> CSize
+#if WORD_SIZE_IN_BITS < 64
+csizeOfSize (CountOf (I# sz)) = CSize (W32# (int2Word# sz))
+#else
+#if __GLASGOW_HASKELL__ >= 904
+csizeOfSize (CountOf (I# sz)) = CSize (W64# (wordToWord64# (int2Word# sz)))
+
+#else
+csizeOfSize (CountOf (I# sz)) = CSize (W64# (int2Word# sz))
+
+#endif
+#endif
+
+csizeOfOffset :: Offset8 -> CSize
+#if WORD_SIZE_IN_BITS < 64
+csizeOfOffset (Offset (I# sz)) = CSize (W32# (int2Word# sz))
+#else
+#if __GLASGOW_HASKELL__ >= 904
+csizeOfOffset (Offset (I# sz)) = CSize (W64# (wordToWord64# (int2Word# sz)))
+#else
+csizeOfOffset (Offset (I# sz)) = CSize (W64# (int2Word# sz))
+#endif
+#endif
+
+sizeOfCSSize :: CSsize -> CountOf Word8
+sizeOfCSSize (CSsize (-1))      = error "invalid size: CSSize is -1"
+#if WORD_SIZE_IN_BITS < 64
+sizeOfCSSize (CSsize (I32# sz)) = CountOf (I# sz)
+#else
+#if __GLASGOW_HASKELL__ >= 904
+sizeOfCSSize (CSsize (I64# sz)) = CountOf (I# (int64ToInt# sz))
+#else
+sizeOfCSSize (CSsize (I64# sz)) = CountOf (I# sz)
+#endif
+#endif
+
+sizeOfCSize :: CSize -> CountOf Word8
+#if WORD_SIZE_IN_BITS < 64
+sizeOfCSize (CSize (W32# sz)) = CountOf (I# (word2Int# sz))
+#else
+#if __GLASGOW_HASKELL__ >= 904
+sizeOfCSize (CSize (W64# sz)) = CountOf (I# (word2Int# (word64ToWord# sz)))
+#else
+sizeOfCSize (CSize (W64# sz)) = CountOf (I# (word2Int# sz))
+#endif
+#endif
+
+natValCountOf :: forall n ty proxy . (KnownNat n, NatWithinBound (CountOf ty) n) => proxy n -> CountOf ty
+natValCountOf n = CountOf $ Prelude.fromIntegral (natVal n)
+
+natValOffset :: forall n ty proxy . (KnownNat n, NatWithinBound (Offset ty) n) => proxy n -> Offset ty
+natValOffset n = Offset $ Prelude.fromIntegral (natVal n)
+
+type instance NatNumMaxBound (CountOf x) = NatNumMaxBound Int
+type instance NatNumMaxBound (Offset x) = NatNumMaxBound Int
+
+type Countable ty n = NatWithinBound (CountOf ty) n
+type Offsetable ty n = NatWithinBound (Offset ty) n

bundled/Basement/Types/Ptr.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash #-}
+module Basement.Types.Ptr
+    ( Addr(..)
+    , addrPlus
+    , addrPlusSz
+    , addrPlusCSz
+    , Ptr(..)
+    , ptrPlus
+    , ptrPlusSz
+    , ptrPlusCSz
+    , castPtr
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Compat.C.Types
+import           Basement.Types.OffsetSize
+import           GHC.Ptr
+import           GHC.Prim
+import           GHC.Types
+
+data Addr = Addr Addr#
+    deriving (Eq,Ord)
+
+addrPlus :: Addr -> Offset Word8 -> Addr
+addrPlus (Addr addr) (Offset (I# i)) = Addr (plusAddr# addr i)
+
+addrPlusSz :: Addr -> CountOf Word8 -> Addr
+addrPlusSz (Addr addr) (CountOf (I# i)) = Addr (plusAddr# addr i)
+
+addrPlusCSz :: Addr -> CSize -> Addr
+addrPlusCSz addr = addrPlusSz addr . sizeOfCSize
+
+ptrPlus :: Ptr a -> Offset Word8 -> Ptr a
+ptrPlus (Ptr addr) (Offset (I# i)) = Ptr (plusAddr# addr i)
+
+ptrPlusSz :: Ptr a -> CountOf Word8 -> Ptr a
+ptrPlusSz (Ptr addr) (CountOf (I# i)) = Ptr (plusAddr# addr i)
+
+ptrPlusCSz :: Ptr a -> CSize -> Ptr a
+ptrPlusCSz ptr = ptrPlusSz ptr . sizeOfCSize

bundled/Basement/Types/Word128.hs

@@ -0,0 +1,262 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE MagicHash          #-}
+{-# LANGUAGE UnboxedTuples      #-}
+{-# LANGUAGE BangPatterns       #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Basement.Types.Word128
+    ( Word128(..)
+    , (+)
+    , (-)
+    , (*)
+    , quot
+    , rem
+    , bitwiseAnd
+    , bitwiseOr
+    , bitwiseXor
+    , complement
+    , shiftL
+    , shiftR
+    , rotateL
+    , rotateR
+    , popCount
+    , fromNatural
+    ) where
+
+import           GHC.Prim
+import           GHC.Word
+import           GHC.Types
+import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod)
+import           Data.Bits hiding (complement, popCount, bit, testBit
+                                  , rotateL, rotateR, shiftL, shiftR)
+import qualified Data.Bits as Bits
+import           Data.Function (on)
+import           Foreign.C
+import           Foreign.Ptr
+import           Foreign.Storable
+
+import           Basement.Compat.Base
+import           Basement.Compat.Natural
+import           Basement.Compat.Primitive (bool#)
+import           Basement.Numerical.Conversion
+import           Basement.Numerical.Number
+
+#include "MachDeps.h"
+
+-- | 128 bits Word
+data Word128 = Word128 {-# UNPACK #-} !Word64
+                       {-# UNPACK #-} !Word64
+    deriving (Eq, Typeable)
+
+instance Show Word128 where
+    show w = Prelude.show (toNatural w)
+instance Enum Word128 where
+    toEnum i = Word128 0 $ int64ToWord64 (intToInt64 i)
+    fromEnum (Word128 _ a0) = wordToInt (word64ToWord a0)
+    succ (Word128 a1 a0)
+        | a0 == maxBound = Word128 (succ a1) 0
+        | otherwise      = Word128 a1        (succ a0)
+    pred (Word128 a1 a0)
+        | a0 == minBound = Word128 (pred a1) maxBound
+        | otherwise      = Word128 a1        (pred a0)
+instance Bounded Word128 where
+    minBound = Word128 minBound minBound
+    maxBound = Word128 maxBound maxBound
+instance Ord Word128 where
+    compare (Word128 a1 a0) (Word128 b1 b0) =
+        case compare a1 b1 of
+            EQ -> compare a0 b0
+            r  -> r
+    (<) (Word128 a1 a0) (Word128 b1 b0) =
+        case compare a1 b1 of
+            EQ -> a0 < b0
+            r  -> r == LT
+    (<=) (Word128 a1 a0) (Word128 b1 b0) =
+        case compare a1 b1 of
+            EQ -> a0 <= b0
+            r  -> r == LT
+instance Storable Word128 where
+    sizeOf _ = 16
+    alignment _ = 16
+    peek p = Word128 <$> peek (castPtr p            )
+                     <*> peek (castPtr p `plusPtr` 8)
+    poke p (Word128 a1 a0) = do
+        poke (castPtr p            ) a1
+        poke (castPtr p `plusPtr` 8) a0
+
+instance Integral Word128 where
+    fromInteger = literal
+instance HasNegation Word128 where
+    negate = complement
+
+instance IsIntegral Word128 where
+    toInteger (Word128 a1 a0) =
+        (toInteger a1 `unsafeShiftL` 64) .|.
+        toInteger a0
+instance IsNatural Word128 where
+    toNatural (Word128 a1 a0) =
+        (toNatural a1 `unsafeShiftL` 64) .|.
+        toNatural a0
+
+instance Prelude.Num Word128 where
+    abs w = w
+    signum w@(Word128 a1 a0)
+        | a1 == 0 && a0 == 0 = w
+        | otherwise          = Word128 0 1
+    fromInteger = literal
+    (+) = (+)
+    (-) = (-)
+    (*) = (*)
+
+instance Bits.Bits Word128 where
+    (.&.) = bitwiseAnd
+    (.|.) = bitwiseOr
+    xor   = bitwiseXor
+    complement = complement
+    shiftL = shiftL
+    shiftR = shiftR
+    rotateL = rotateL
+    rotateR = rotateR
+    bitSize _ = 128
+    bitSizeMaybe _ = Just 128
+    isSigned _ = False
+    testBit = testBit
+    bit = bit
+    popCount = popCount
+
+-- | Add 2 Word128
+(+) :: Word128 -> Word128 -> Word128
+#if WORD_SIZE_IN_BITS < 64
+(+) = applyBiWordOnNatural (Prelude.+)
+#else
+#if __GLASGOW_HASKELL__ >= 904
+(+) (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = Word128 (W64# s1) (W64# (wordToWord64# s0))
+  where
+    !(# carry, s0 #) = plusWord2# (GHC.Prim.word64ToWord# a0) (GHC.Prim.word64ToWord# b0)
+    s1               = wordToWord64# (plusWord# (plusWord# (GHC.Prim.word64ToWord# a1) (GHC.Prim.word64ToWord# b1)) carry)
+#else
+(+) (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = Word128 (W64# s1) (W64# s0)
+  where
+    !(# carry, s0 #) = plusWord2# a0 b0
+    s1               = plusWord# (plusWord# a1 b1) carry
+#endif
+#endif
+
+-- temporary available until native operation available
+applyBiWordOnNatural :: (Natural -> Natural -> Natural)
+                     -> Word128
+                     -> Word128
+                     -> Word128
+applyBiWordOnNatural f a b = fromNatural $ f (toNatural a) (toNatural b)
+
+-- | Subtract 2 Word128
+(-) :: Word128 -> Word128 -> Word128
+(-) a b
+    | a >= b    = applyBiWordOnNatural (Prelude.-) a b
+    | otherwise = complement (applyBiWordOnNatural (Prelude.-) b a) + 1
+
+-- | Multiplication
+(*) :: Word128 -> Word128 -> Word128
+(*) = applyBiWordOnNatural (Prelude.*)
+
+-- | Division
+quot :: Word128 -> Word128 -> Word128
+quot = applyBiWordOnNatural Prelude.quot
+
+-- | Modulo
+rem :: Word128 -> Word128 -> Word128
+rem = applyBiWordOnNatural Prelude.rem
+
+-- | Bitwise and
+bitwiseAnd :: Word128 -> Word128 -> Word128
+bitwiseAnd (Word128 a1 a0) (Word128 b1 b0) =
+    Word128 (a1 .&. b1) (a0 .&. b0)
+
+-- | Bitwise or
+bitwiseOr :: Word128 -> Word128 -> Word128
+bitwiseOr (Word128 a1 a0) (Word128 b1 b0) =
+    Word128 (a1 .|. b1) (a0 .|. b0)
+
+-- | Bitwise xor
+bitwiseXor :: Word128 -> Word128 -> Word128
+bitwiseXor (Word128 a1 a0) (Word128 b1 b0) =
+    Word128 (a1 `Bits.xor` b1) (a0 `Bits.xor` b0)
+
+-- | Bitwise complement
+complement :: Word128 -> Word128
+complement (Word128 a1 a0) = Word128 (Bits.complement a1) (Bits.complement a0)
+
+-- | Population count
+popCount :: Word128 -> Int
+popCount (Word128 a1 a0) = Bits.popCount a1 Prelude.+ Bits.popCount a0
+
+-- | Bitwise Shift Left
+shiftL :: Word128 -> Int -> Word128
+shiftL w@(Word128 a1 a0) n
+    | n < 0 || n > 127 = Word128 0 0
+    | n == 64          = Word128 a0 0
+    | n == 0           = w
+    | n >  64          = Word128 (a0 `Bits.unsafeShiftL` (n Prelude.- 64)) 0
+    | otherwise        = Word128 ((a1 `Bits.unsafeShiftL` n) .|. (a0 `Bits.unsafeShiftR` (64 Prelude.- n)))
+                                 (a0 `Bits.unsafeShiftL` n)
+
+-- | Bitwise Shift Right
+shiftR :: Word128 -> Int -> Word128
+shiftR w@(Word128 a1 a0) n
+    | n < 0 || n > 127 = Word128 0 0
+    | n == 64          = Word128 0 a1
+    | n == 0           = w
+    | n >  64          = Word128 0 (a1 `Bits.unsafeShiftR` (n Prelude.- 64))
+    | otherwise        = Word128 (a1 `Bits.unsafeShiftR` n)
+                                 ((a1 `Bits.unsafeShiftL` (inv64 n)) .|. (a0 `Bits.unsafeShiftR` n))
+
+-- | Bitwise rotate Left
+rotateL :: Word128 -> Int -> Word128
+rotateL (Word128 a1 a0) n'
+    | n == 0    = Word128 a1 a0
+    | n == 64   = Word128 a0 a1
+    | n < 64    = Word128 (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a1 (inv64 n))
+    | otherwise = let nx = n Prelude.- 64 in Word128 (comb64 a0 nx a1 (inv64 nx)) (comb64 a1 n' a0 (inv64 nx))
+  where
+    n :: Int
+    n | n' >= 0   = n' `Prelude.mod` 128
+      | otherwise = 128 Prelude.- (n' `Prelude.mod` 128)
+
+-- | Bitwise rotate Left
+rotateR :: Word128 -> Int -> Word128
+rotateR w n = rotateL w (128 Prelude.- n)
+
+inv64 :: Int -> Int
+inv64 i = 64 Prelude.- i
+
+comb64 :: Word64 -> Int -> Word64 -> Int -> Word64
+comb64 x i y j =
+    (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j)
+
+-- | Test bit
+testBit :: Word128 -> Int -> Bool
+testBit (Word128 a1 a0) n
+    | n < 0 || n > 127 = False
+    | n > 63           = Bits.testBit a1 (n Prelude.- 64)
+    | otherwise        = Bits.testBit a0 n
+
+-- | bit
+bit :: Int -> Word128
+bit n
+    | n < 0 || n > 127 = Word128 0 0
+    | n > 63           = Word128 (Bits.bit (n Prelude.- 64)) 0
+    | otherwise        = Word128 0 (Bits.bit n)
+
+literal :: Integer -> Word128
+literal i = Word128
+    (Prelude.fromInteger (i `Bits.unsafeShiftR` 64))
+    (Prelude.fromInteger i)
+
+fromNatural :: Natural -> Word128
+fromNatural n = Word128
+    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64))
+    (Prelude.fromInteger $ naturalToInteger n)

bundled/Basement/Types/Word256.hs

@@ -0,0 +1,351 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE MagicHash          #-}
+{-# LANGUAGE UnboxedTuples      #-}
+{-# LANGUAGE BangPatterns       #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Basement.Types.Word256
+    ( Word256(..)
+    , (+)
+    , (-)
+    , (*)
+    , quot
+    , rem
+    , bitwiseAnd
+    , bitwiseOr
+    , bitwiseXor
+    , complement
+    , shiftL
+    , shiftR
+    , rotateL
+    , rotateR
+    , popCount
+    , fromNatural
+    ) where
+
+import           GHC.Prim hiding (word64ToWord#)
+import qualified GHC.Prim
+import           GHC.Word
+import           GHC.Types
+import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod)
+import           Data.Bits hiding (complement, popCount, bit, testBit
+                                  , rotateL, rotateR, shiftL, shiftR)
+import qualified Data.Bits as Bits
+import           Data.Function (on)
+import           Foreign.C
+import           Foreign.Ptr
+import           Foreign.Storable
+
+import           Basement.Compat.Base
+import           Basement.Compat.Natural
+import           Basement.Compat.Primitive (bool#)
+import           Basement.Numerical.Conversion
+import           Basement.Numerical.Number
+
+#include "MachDeps.h"
+
+-- | 256 bits Word
+data Word256 = Word256 {-# UNPACK #-} !Word64
+                       {-# UNPACK #-} !Word64
+                       {-# UNPACK #-} !Word64
+                       {-# UNPACK #-} !Word64
+    deriving (Eq, Typeable)
+
+instance Show Word256 where
+    show w = Prelude.show (toNatural w)
+instance Enum Word256 where
+    toEnum i = Word256 0 0 0 $ int64ToWord64 (intToInt64 i)
+    fromEnum (Word256 _ _ _ a0) = wordToInt (word64ToWord a0)
+    succ (Word256 a3 a2 a1 a0)
+        | a0 == maxBound =
+            if a1 == maxBound
+                then if a2 == maxBound
+                        then Word256 (succ a3) 0 0 0
+                        else Word256 a3 (succ a2) 0 0
+                else Word256 a3 a2 (succ a1) 0
+        | otherwise      = Word256 a3 a2 a1        (succ a0)
+    pred (Word256 a3 a2 a1 a0)
+        | a0 == minBound =
+            if a1 == minBound
+                then if a2 == minBound
+                        then Word256 (pred a3) maxBound maxBound maxBound
+                        else Word256 a3 (pred a2) maxBound maxBound
+                else Word256 a3 a2 (pred a1) maxBound
+        | otherwise      = Word256 a3 a2 a1        (pred a0)
+instance Bounded Word256 where
+    minBound = Word256 minBound minBound minBound minBound
+    maxBound = Word256 maxBound maxBound maxBound maxBound
+instance Ord Word256 where
+    compare (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
+        compareEq a3 b3 $ compareEq a2 b2 $ compareEq a1 b1 $ compare a0 b0
+      where compareEq x y next =
+                case compare x y of
+                    EQ -> next
+                    r  -> r
+    (<) (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
+        compareLt a3 b3 $ compareLt a2 b2 $ compareLt a1 b1 (a0 < b0)
+      where compareLt x y next =
+                case compare x y of
+                    EQ -> next
+                    r  -> r == LT
+instance Storable Word256 where
+    sizeOf _ = 32
+    alignment _ = 32
+    peek p = Word256 <$> peek (castPtr p            )
+                     <*> peek (castPtr p `plusPtr` 8)
+                     <*> peek (castPtr p `plusPtr` 16)
+                     <*> peek (castPtr p `plusPtr` 24)
+    poke p (Word256 a3 a2 a1 a0) = do
+        poke (castPtr p             ) a3
+        poke (castPtr p `plusPtr` 8 ) a2
+        poke (castPtr p `plusPtr` 16) a1
+        poke (castPtr p `plusPtr` 24) a0
+
+instance Integral Word256 where
+    fromInteger = literal
+instance HasNegation Word256 where
+    negate = complement
+
+instance IsIntegral Word256 where
+    toInteger (Word256 a3 a2 a1 a0) =
+        (toInteger a3 `Bits.unsafeShiftL` 192) Bits..|.
+        (toInteger a2 `Bits.unsafeShiftL` 128) Bits..|.
+        (toInteger a1 `Bits.unsafeShiftL` 64) Bits..|.
+        toInteger a0
+instance IsNatural Word256 where
+    toNatural (Word256 a3 a2 a1 a0) =
+        (toNatural a3 `Bits.unsafeShiftL` 192) Bits..|.
+        (toNatural a2 `Bits.unsafeShiftL` 128) Bits..|.
+        (toNatural a1 `Bits.unsafeShiftL` 64) Bits..|.
+        toNatural a0
+
+instance Prelude.Num Word256 where
+    abs w = w
+    signum w@(Word256 a3 a2 a1 a0)
+        | a3 == 0 && a2 == 0 && a1 == 0 && a0 == 0 = w
+        | otherwise                                = Word256 0 0 0 1
+    fromInteger = literal
+    (+) = (+)
+    (-) = (-)
+    (*) = (*)
+
+instance Bits.Bits Word256 where
+    (.&.) = bitwiseAnd
+    (.|.) = bitwiseOr
+    xor   = bitwiseXor
+    complement = complement
+    shiftL = shiftL
+    shiftR = shiftR
+    rotateL = rotateL
+    rotateR = rotateR
+    bitSize _ = 256
+    bitSizeMaybe _ = Just 256
+    isSigned _ = False
+    testBit = testBit
+    bit = bit
+    popCount = popCount
+
+-- | Add 2 Word256
+(+) :: Word256 -> Word256 -> Word256
+#if WORD_SIZE_IN_BITS < 64
+(+) = applyBiWordOnNatural (Prelude.+)
+#else
+(+) (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0))
+    (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) =
+#if __GLASGOW_HASKELL__ >= 904
+    Word256 (W64# (wordToWord64# s3)) (W64# (wordToWord64# s2)) (W64# (wordToWord64# s1)) (W64# (wordToWord64# s0))
+  where
+    !(# c0, s0 #) = plusWord2# (GHC.Prim.word64ToWord# a0) (GHC.Prim.word64ToWord#  b0)
+    !(# c1, s1 #) = plusWord3# (GHC.Prim.word64ToWord# a1) (GHC.Prim.word64ToWord# b1) (c0)
+    !(# c2, s2 #) = plusWord3# (GHC.Prim.word64ToWord# a2) (GHC.Prim.word64ToWord# b2) c1
+    !s3           = plusWord3NoCarry# (GHC.Prim.word64ToWord# a3) (GHC.Prim.word64ToWord# b3) c2
+
+    plusWord3NoCarry# a b c = plusWord# (plusWord# a b) c
+    plusWord3# a b c
+        | bool# (eqWord# carry 0##) = plusWord2# x c
+        | otherwise                 =
+            case plusWord2# x c of
+                (# carry2, x' #)
+                    | bool# (eqWord# carry2 0##) -> (# carry, x' #)
+                    | otherwise                  -> (# plusWord# carry carry2, x' #)
+      where
+        (# carry, x #) = plusWord2# a b
+#else
+    Word256 (W64# s3) (W64# s2) (W64# s1) (W64# s0)
+  where
+    !(# c0, s0 #) = plusWord2# a0 b0
+    !(# c1, s1 #) = plusWord3# a1 b1 c0
+    !(# c2, s2 #) = plusWord3# a2 b2 c1
+    !s3           = plusWord3NoCarry# a3 b3 c2
+
+    plusWord3NoCarry# a b c = plusWord# (plusWord# a b) c
+    plusWord3# a b c
+        | bool# (eqWord# carry 0##) = plusWord2# x c
+        | otherwise                 =
+            case plusWord2# x c of
+                (# carry2, x' #)
+                    | bool# (eqWord# carry2 0##) -> (# carry, x' #)
+                    | otherwise                  -> (# plusWord# carry carry2, x' #)
+      where
+        (# carry, x #) = plusWord2# a b
+#endif
+#endif
+
+-- temporary available until native operation available
+applyBiWordOnNatural :: (Natural -> Natural -> Natural)
+                     -> Word256
+                     -> Word256
+                     -> Word256
+applyBiWordOnNatural f = (fromNatural .) . (f `on` toNatural)
+
+-- | Subtract 2 Word256
+(-) :: Word256 -> Word256 -> Word256
+(-) a b
+    | a >= b    = applyBiWordOnNatural (Prelude.-) a b
+    | otherwise = complement (applyBiWordOnNatural (Prelude.-) b a) + 1
+
+-- | Multiplication
+(*) :: Word256 -> Word256 -> Word256
+(*) = applyBiWordOnNatural (Prelude.*)
+
+-- | Division
+quot :: Word256 -> Word256 -> Word256
+quot = applyBiWordOnNatural Prelude.quot
+
+-- | Modulo
+rem :: Word256 -> Word256 -> Word256
+rem = applyBiWordOnNatural Prelude.rem
+
+-- | Bitwise and
+bitwiseAnd :: Word256 -> Word256 -> Word256
+bitwiseAnd (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
+    Word256 (a3 Bits..&. b3) (a2 Bits..&. b2)  (a1 Bits..&. b1) (a0 Bits..&. b0)
+
+-- | Bitwise or
+bitwiseOr :: Word256 -> Word256 -> Word256
+bitwiseOr (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
+    Word256 (a3 Bits..|. b3) (a2 Bits..|. b2)  (a1 Bits..|. b1) (a0 Bits..|. b0)
+
+-- | Bitwise xor
+bitwiseXor :: Word256 -> Word256 -> Word256
+bitwiseXor (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
+    Word256 (a3 `Bits.xor` b3) (a2 `Bits.xor` b2)  (a1 `Bits.xor` b1) (a0 `Bits.xor` b0)
+
+-- | Bitwise complement
+complement :: Word256 -> Word256
+complement (Word256 a3 a2 a1 a0) =
+    Word256 (Bits.complement a3) (Bits.complement a2) (Bits.complement a1) (Bits.complement a0)
+
+-- | Population count
+popCount :: Word256 -> Int
+popCount (Word256 a3 a2 a1 a0) =
+    Bits.popCount a3 Prelude.+
+    Bits.popCount a2 Prelude.+
+    Bits.popCount a1 Prelude.+
+    Bits.popCount a0
+
+-- | Bitwise Shift Left
+shiftL :: Word256 -> Int -> Word256
+shiftL w@(Word256 a3 a2 a1 a0) n
+    | n < 0 || n > 255 = Word256 0 0 0 0
+    | n == 0           = w
+    | n == 64          = Word256 a2 a1 a0 0
+    | n == 128         = Word256 a1 a0 0 0
+    | n == 192         = Word256 a0 0 0 0
+    | n < 64           = mkWordShift a3 a2 a1 a0 n
+    | n < 128          = mkWordShift a2 a1 a0 0  (n Prelude.- 64)
+    | n < 192          = mkWordShift a1 a0 0  0  (n Prelude.- 128)
+    | otherwise        = mkWordShift a0 0  0  0  (n Prelude.- 192)
+  where
+    mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256
+    mkWordShift w x y z s =
+        Word256 (comb64 w s x s') (comb64 x s y s') (comb64 y s z s') (z `Bits.unsafeShiftL` s)
+      where s' = inv64 s
+
+-- | Bitwise Shift Right
+shiftR :: Word256 -> Int -> Word256
+shiftR w@(Word256 a3 a2 a1 a0) n
+    | n < 0 || n > 255 = Word256 0 0 0 0
+    | n == 0           = w
+    | n == 64          = Word256 0 a3 a2 a1
+    | n == 128         = Word256 0 0 a3 a2
+    | n == 192         = Word256 0 0 0 a3
+    | n <  64          = mkWordShift a3 a2 a1 a0 n
+    | n < 128          = mkWordShift  0 a3 a2 a1 (n Prelude.- 64)
+    | n < 192          = mkWordShift  0  0 a3 a2 (n Prelude.- 128)
+    | otherwise        = Word256 0 0 0 (a3 `Bits.unsafeShiftR` (n Prelude.- 192))
+  where
+    mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256
+    mkWordShift w x y z s =
+        Word256 (w `Bits.unsafeShiftR` s) (comb64 w s' x s) (comb64 x s' y s) (comb64 y s' z s)
+      where s' = inv64 s
+
+-- | Bitwise rotate Left
+rotateL :: Word256 -> Int -> Word256
+rotateL (Word256 a3 a2 a1 a0) n'
+    | n == 0    = Word256 a3 a2 a1 a0
+    | n == 192  = Word256 a0 a3 a2 a1
+    | n == 128  = Word256 a1 a0 a3 a2
+    | n == 64   = Word256 a2 a1 a0 a3
+    | n < 64    = Word256 (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n))
+                          (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n))
+    | n < 128   = let n = n Prelude.- 64 in Word256
+                          (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n))
+                          (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n))
+    | n < 192   = let n = n Prelude.- 128 in Word256
+                          (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n))
+                          (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n))
+    | otherwise = let n = n Prelude.- 192 in Word256
+                          (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n))
+                          (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n))
+  where
+    n :: Int
+    n | n' >= 0   = n' `Prelude.mod` 256
+      | otherwise = 256 Prelude.- (n' `Prelude.mod` 256)
+
+-- | Bitwise rotate Left
+rotateR :: Word256 -> Int -> Word256
+rotateR w n = rotateL w (256 Prelude.- n)
+
+inv64 :: Int -> Int
+inv64 i = 64 Prelude.- i
+
+comb64 :: Word64 -> Int -> Word64 -> Int -> Word64
+comb64 x i y j =
+    (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j)
+
+-- | Test bit
+testBit :: Word256 -> Int -> Bool
+testBit (Word256 a3 a2 a1 a0) n
+    | n < 0 || n > 255 = False
+    | n > 191          = Bits.testBit a3 (n Prelude.- 192)
+    | n > 127          = Bits.testBit a2 (n Prelude.- 128)
+    | n > 63           = Bits.testBit a1 (n Prelude.- 64)
+    | otherwise        = Bits.testBit a0 n
+
+-- | bit
+bit :: Int -> Word256
+bit n
+    | n < 0 || n > 255 = Word256 0 0 0 0
+    | n > 191          = Word256 (Bits.bit (n Prelude.- 192)) 0 0 0
+    | n > 127          = Word256 0 (Bits.bit (n Prelude.- 128)) 0 0
+    | n > 63           = Word256 0 0 (Bits.bit (n Prelude.- 64)) 0
+    | otherwise        = Word256 0 0 0 (Bits.bit n)
+
+literal :: Integer -> Word256
+literal i = Word256
+    (Prelude.fromInteger (i `Bits.unsafeShiftR` 192))
+    (Prelude.fromInteger (i `Bits.unsafeShiftR` 128))
+    (Prelude.fromInteger (i `Bits.unsafeShiftR` 64))
+    (Prelude.fromInteger i)
+
+fromNatural :: Natural -> Word256
+fromNatural n = Word256
+    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 192))
+    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 128))
+    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64))
+    (Prelude.fromInteger $ naturalToInteger n)

bundled/Basement/UArray.hs

@@ -0,0 +1,947 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.UArray
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- An unboxed array of primitive types
+--
+-- All the cells in the array are in one chunk of contiguous
+-- memory.
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Basement.UArray
+    ( UArray(..)
+    , PrimType(..)
+    -- * methods
+    , copy
+    , unsafeCopyAtRO
+    -- * internal methods
+    -- , copyAddr
+    , recast
+    , unsafeRecast
+    , length
+    , freeze
+    , unsafeFreeze
+    , thaw
+    , unsafeThaw
+    -- * Creation
+    , vFromListN
+    , new
+    , create
+    , createFromIO
+    , createFromPtr
+    , sub
+    , copyToPtr
+    , withPtr
+    , withMutablePtr
+    , unsafeFreezeShrink
+    , freezeShrink
+    , fromBlock
+    , toBlock
+    -- * accessors
+    , update
+    , unsafeUpdate
+    , unsafeIndex
+    , unsafeIndexer
+    , unsafeDewrap
+    , unsafeRead
+    , unsafeWrite
+    -- * Functions
+    , equalMemcmp
+    , singleton
+    , replicate
+    , map
+    , mapIndex
+    , findIndex
+    , revFindIndex
+    , index
+    , null
+    , take
+    , unsafeTake
+    , drop
+    , unsafeDrop
+    , splitAt
+    , revDrop
+    , revTake
+    , revSplitAt
+    , splitOn
+    , break
+    , breakEnd
+    , breakElem
+    , breakLine
+    , elem
+    , indices
+    , intersperse
+    , span
+    , spanEnd
+    , cons
+    , snoc
+    , uncons
+    , unsnoc
+    , find
+    , sortBy
+    , filter
+    , reverse
+    , replace
+    , foldr
+    , foldl'
+    , foldr1
+    , foldl1'
+    , all
+    , any
+    , isPrefixOf
+    , isSuffixOf
+    , foreignMem
+    , fromForeignPtr
+    , builderAppend
+    , builderBuild
+    , builderBuild_
+    , toHexadecimal
+    , toBase64Internal
+    ) where
+
+import           GHC.Prim
+import           GHC.Types
+import           GHC.Word
+import           GHC.ST
+import           GHC.Ptr
+import           GHC.ForeignPtr (ForeignPtr)
+import           Foreign.Marshal.Utils (copyBytes)
+import           Basement.Compat.Base
+import           Basement.Compat.Primitive
+import           Data.Proxy
+import           Basement.Types.OffsetSize
+import           Basement.Compat.MonadTrans
+import           Basement.NonEmpty
+import           Basement.Monad
+import           Basement.PrimType
+import           Basement.FinalPtr
+import           Basement.Exception
+import           Basement.UArray.Base
+import           Basement.Bits
+import           Basement.Block (Block(..), MutableBlock(..))
+import qualified Basement.Block as BLK
+import qualified Basement.Block.Base as BLK (withPtr, unsafeWrite)
+import           Basement.UArray.Mutable hiding (sub, copyToPtr)
+import           Basement.Numerical.Additive
+import           Basement.Numerical.Subtractive
+import           Basement.Numerical.Multiplicative
+import           Basement.MutableBuilder
+import           Basement.Bindings.Memory (sysHsMemFindByteBa, sysHsMemFindByteAddr)
+import qualified Basement.Compat.ExtList as List
+import qualified Basement.Base16 as Base16
+import qualified Basement.Alg.Mutable as Alg
+import qualified Basement.Alg.Class as Alg
+import qualified Basement.Alg.PrimArray as Alg
+
+-- | Return the element at a specific index from an array.
+--
+-- If the index @n is out of bounds, an error is raised.
+index :: PrimType ty => UArray ty -> Offset ty -> ty
+index array n
+    | isOutOfBound n len = outOfBound OOB_Index n len
+    | otherwise          = unsafeIndex array n
+  where
+    !len = length array
+{-# INLINE index #-}
+
+foreignMem :: PrimType ty
+           => FinalPtr ty -- ^ the start pointer with a finalizer
+           -> CountOf ty  -- ^ the number of elements (in elements, not bytes)
+           -> UArray ty
+foreignMem fptr nb = UArray (Offset 0) nb (UArrayAddr fptr)
+
+-- | Create a foreign UArray from foreign memory and given offset/size
+--
+-- No check are performed to make sure this is valid, so this is unsafe.
+--
+-- This is particularly useful when dealing with foreign memory and
+-- 'ByteString'
+fromForeignPtr :: PrimType ty
+               => (ForeignPtr ty, Int, Int) -- ForeignPtr, an offset in prim elements, a size in prim elements
+               -> UArray ty
+fromForeignPtr (fptr, ofs, len) = UArray (Offset ofs) (CountOf len) (UArrayAddr $ toFinalPtrForeign fptr)
+
+
+-- | Create a UArray from a Block
+--
+-- The block is still used by the uarray
+fromBlock :: PrimType ty
+          => Block ty
+          -> UArray ty
+fromBlock blk = UArray 0 (BLK.length blk) (UArrayBA blk)
+
+-- | Allocate a new array with a fill function that has access to the elements of
+--   the source array.
+unsafeCopyFrom :: (PrimType a, PrimType b)
+               => UArray a -- ^ Source array
+               -> CountOf b -- ^ Length of the destination array
+               -> (UArray a -> Offset a -> MUArray b s -> ST s ())
+               -- ^ Function called for each element in the source array
+               -> ST s (UArray b) -- ^ Returns the filled new array
+unsafeCopyFrom v' newLen f = new newLen >>= fill 0 >>= unsafeFreeze
+  where len = length v'
+        fill i r'
+            | i .==# len = pure r'
+            | otherwise  = do f v' i r'
+                              fill (i + 1) r'
+
+-- | Freeze a MUArray into a UArray by copying all the content is a pristine new buffer
+--
+-- The MUArray in parameter can be still be used after the call without
+-- changing the resulting frozen data.
+freeze :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> prim (UArray ty)
+freeze ma = do
+    ma' <- new len
+    copyAt ma' (Offset 0) ma (Offset 0) len
+    unsafeFreeze ma'
+  where len = mutableLength ma
+
+-- | Just like 'freeze' but copy only the first n bytes
+--
+-- The size requested need to be smaller or equal to the length
+-- of the MUArray, otherwise a Out of Bounds exception is raised
+freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty)
+freezeShrink ma n = do
+    when (n > mutableLength ma) $ primOutOfBound OOB_MemCopy (sizeAsOffset n) (mutableLength ma)
+    ma' <- new n
+    copyAt ma' (Offset 0) ma (Offset 0) n
+    unsafeFreeze ma'
+
+-- | Create a new array of size @n by settings each cells through the
+-- function @f.
+create :: forall ty . PrimType ty
+       => CountOf ty           -- ^ the size of the array
+       -> (Offset ty -> ty) -- ^ the function that set the value at the index
+       -> UArray ty         -- ^ the array created
+create n initializer
+    | n == 0    = mempty
+    | otherwise = runST (new n >>= iter initializer)
+  where
+    iter :: (PrimType ty, PrimMonad prim) => (Offset ty -> ty) -> MUArray ty (PrimState prim) -> prim (UArray ty)
+    iter f ma = loop 0
+      where
+        loop i
+            | i .==# n  = unsafeFreeze ma
+            | otherwise = unsafeWrite ma i (f i) >> loop (i+1)
+        {-# INLINE loop #-}
+    {-# INLINE iter #-}
+
+-- | Create a pinned array that is filled by a 'filler' function (typically an IO call like hGetBuf)
+createFromIO :: PrimType ty
+             => CountOf ty                  -- ^ the size of the array
+             -> (Ptr ty -> IO (CountOf ty)) -- ^ filling function that
+             -> IO (UArray ty)
+createFromIO size filler
+    | size == 0 = pure mempty
+    | otherwise = do
+        mba <- newPinned size
+        r   <- withMutablePtr mba $ \p -> filler p
+        case r of
+            0             -> pure mempty -- make sure we don't keep our array referenced by using empty
+            _ | r < 0     -> error "filler returned negative number"
+              | otherwise -> unsafeFreezeShrink mba r
+
+-- | Freeze a chunk of memory pointed, of specific size into a new unboxed array
+createFromPtr :: PrimType ty
+              => Ptr ty
+              -> CountOf ty
+              -> IO (UArray ty)
+createFromPtr p s = do
+    ma <- new s
+    copyFromPtr p s ma
+    unsafeFreeze ma
+
+-----------------------------------------------------------------------
+-- higher level collection implementation
+-----------------------------------------------------------------------
+
+singleton :: PrimType ty => ty -> UArray ty
+singleton ty = create 1 (const ty)
+
+replicate :: PrimType ty => CountOf ty -> ty -> UArray ty
+replicate sz ty = create sz (const ty)
+
+-- | update an array by creating a new array with the updates.
+--
+-- the operation copy the previous array, modify it in place, then freeze it.
+update :: PrimType ty
+       => UArray ty
+       -> [(Offset ty, ty)]
+       -> UArray ty
+update array modifiers = runST (thaw array >>= doUpdate modifiers)
+  where doUpdate l ma = loop l
+          where loop []         = unsafeFreeze ma
+                loop ((i,v):xs) = write ma i v >> loop xs
+                {-# INLINE loop #-}
+        {-# INLINE doUpdate #-}
+
+unsafeUpdate :: PrimType ty
+             => UArray ty
+             -> [(Offset ty, ty)]
+             -> UArray ty
+unsafeUpdate array modifiers = runST (thaw array >>= doUpdate modifiers)
+  where doUpdate l ma = loop l
+          where loop []         = unsafeFreeze ma
+                loop ((i,v):xs) = unsafeWrite ma i v >> loop xs
+                {-# INLINE loop #-}
+        {-# INLINE doUpdate #-}
+
+-- | Copy all the block content to the memory starting at the destination address
+copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim)
+          => UArray ty -- ^ the source array to copy
+          -> Ptr ty    -- ^ The destination address where the copy is going to start
+          -> prim ()
+copyToPtr arr dst@(Ptr dst#) = onBackendPrim copyBa copyPtr arr
+  where
+    !(Offset os@(I# os#)) = offsetInBytes $ offset arr
+    !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ length arr
+    copyBa (Block ba) = primitive $ \s1 -> (# copyByteArrayToAddr# ba os# dst# szBytes# s1, () #)
+    copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes
+
+-- | Get a Ptr pointing to the data in the UArray.
+--
+-- Since a UArray is immutable, this Ptr shouldn't be
+-- to use to modify the contents
+--
+-- If the UArray is pinned, then its address is returned as is,
+-- however if it's unpinned, a pinned copy of the UArray is made
+-- before getting the address.
+withPtr :: forall ty prim a . (PrimMonad prim, PrimType ty)
+        => UArray ty
+        -> (Ptr ty -> prim a)
+        -> prim a
+withPtr a f =
+    onBackendPrim (\blk  -> BLK.withPtr  blk  $ \ptr -> f (ptr `plusPtr` os))
+                  (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os))
+                  a
+  where
+    !sz          = primSizeInBytes (Proxy :: Proxy ty)
+    !(Offset os) = offsetOfE sz $ offset a
+{-# INLINE withPtr #-}
+
+-- | Recast an array of type a to an array of b
+--
+-- a and b need to have the same size otherwise this
+-- raise an async exception
+recast :: forall a b . (PrimType a, PrimType b) => UArray a -> UArray b
+recast array
+    | aTypeSize == bTypeSize = unsafeRecast array
+    | missing   == 0         = unsafeRecast array
+    | otherwise = throw $ InvalidRecast
+                      (RecastSourceSize      alen)
+                      (RecastDestinationSize $ alen + missing)
+  where
+    aTypeSize = primSizeInBytes (Proxy :: Proxy a)
+    bTypeSize@(CountOf bs) = primSizeInBytes (Proxy :: Proxy b)
+    (CountOf alen) = sizeInBytes (length array)
+    missing = alen `mod` bs
+
+-- | Unsafely recast an UArray containing 'a' to an UArray containing 'b'
+--
+-- The offset and size are converted from units of 'a' to units of 'b',
+-- but no check are performed to make sure this is compatible.
+--
+-- use 'recast' if unsure.
+unsafeRecast :: (PrimType a, PrimType b) => UArray a -> UArray b
+unsafeRecast (UArray start len backend) = UArray (primOffsetRecast start) (sizeRecast len) $
+    case backend of
+        UArrayAddr fptr     -> UArrayAddr (castFinalPtr fptr)
+        UArrayBA (Block ba) -> UArrayBA (Block ba)
+{-# INLINE [1] unsafeRecast #-}
+{-# SPECIALIZE [3] unsafeRecast :: PrimType a => UArray Word8 -> UArray a #-}
+
+null :: UArray ty -> Bool
+null arr = length arr == 0
+
+-- | Take a count of elements from the array and create an array with just those elements
+take :: CountOf ty -> UArray ty -> UArray ty
+take n arr@(UArray start len backend)
+    | n <= 0    = empty
+    | n >= len  = arr
+    | otherwise = UArray start n backend
+
+unsafeTake :: CountOf ty -> UArray ty -> UArray ty
+unsafeTake sz (UArray start _ ba) = UArray start sz ba
+
+-- | Drop a count of elements from the array and return the new array minus those dropped elements
+drop :: CountOf ty -> UArray ty -> UArray ty
+drop n arr@(UArray start len backend)
+    | n <= 0                             = arr
+    | Just newLen <- len - n, newLen > 0 = UArray (start `offsetPlusE` n) newLen backend
+    | otherwise                          = empty
+
+unsafeDrop :: CountOf ty -> UArray ty -> UArray ty
+unsafeDrop n (UArray start sz backend) = UArray (start `offsetPlusE` n) (sz `sizeSub` n) backend
+
+-- | Split an array into two, with a count of at most N elements in the first one
+-- and the remaining in the other.
+splitAt :: CountOf ty -> UArray ty -> (UArray ty, UArray ty)
+splitAt nbElems arr@(UArray start len backend)
+    | nbElems <= 0                               = (empty, arr)
+    | Just nbTails <- len - nbElems, nbTails > 0 = (UArray start                         nbElems backend
+                                                   ,UArray (start `offsetPlusE` nbElems) nbTails backend)
+    | otherwise                                  = (arr, empty)
+
+
+breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty)
+breakElem !ty arr@(UArray start len backend)
+    | k == sentinel = (arr, empty)
+    | k == start    = (empty, arr)
+    | otherwise     = (UArray start (offsetAsSize l1)       backend
+                     , UArray k     (sizeAsOffset len - l1) backend)
+  where
+    !k = onBackendPure' arr $ Alg.findIndexElem ty
+    l1 = k `offsetSub` start
+{-# NOINLINE [3] breakElem #-}
+{-# RULES "breakElem Word8" [4] breakElem = breakElemByte #-}
+{-# SPECIALIZE [3] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-}
+
+breakElemByte :: Word8 -> UArray Word8 -> (UArray Word8, UArray Word8)
+breakElemByte !ty arr@(UArray start len backend)
+    | k == end   = (arr, empty)
+    | k == start = (empty, arr)
+    | otherwise  = ( UArray start (offsetAsSize k `sizeSub` offsetAsSize start) backend
+                   , UArray k     (len `sizeSub` (offsetAsSize k `sizeSub` offsetAsSize start)) backend)
+  where
+    !end = start `offsetPlusE` len
+    !k = onBackendPure goBa goAddr arr
+    goBa (Block ba) = sysHsMemFindByteBa ba start end ty
+    goAddr (Ptr addr) = sysHsMemFindByteAddr addr start end ty
+
+-- | Similar to breakElem specialized to split on linefeed
+--
+-- it either returns:
+-- * Left. no line has been found, and whether the last character is a CR
+-- * Right, a line has been found with an optional CR, and it returns
+--   the array of bytes on the left of the CR/LF, and the
+--   the array of bytes on the right of the LF.
+--
+breakLine :: UArray Word8 -> Either Bool (UArray Word8, UArray Word8)
+breakLine arr@(UArray start len backend)
+    | end == start = Left False
+    | k2 == end    = Left (k1 /= k2)
+    | otherwise    = let newArray start' len' = if len' == 0 then empty else UArray start' len' backend
+                      in Right (newArray start (k1-start), newArray (k2+1) (end - (k2+1)))
+  where
+    !end = start `offsetPlusE` len
+    -- return (offset of CR, offset of LF, whether the last element was a carriage return
+    !(k1, k2) = onBackendPure goBa goAddr arr
+    lineFeed = 0xa
+    carriageReturn = 0xd
+    goBa (Block ba) =
+        let k = sysHsMemFindByteBa ba start end lineFeed
+            cr = k > start && primBaIndex ba (k `offsetSub` 1) == carriageReturn
+         in (if cr then k `offsetSub` 1 else k, k)
+    goAddr (Ptr addr) =
+        let k = sysHsMemFindByteAddr addr start end lineFeed
+            cr = k > start && primAddrIndex addr (k `offsetSub` 1) == carriageReturn
+         in (if cr then k `offsetSub` 1 else k, k)
+
+-- inverse a CountOf that is specified from the end (e.g. take n elements from the end)
+countFromStart :: UArray ty -> CountOf ty -> CountOf ty
+countFromStart v sz@(CountOf sz')
+    | sz >= len = CountOf 0
+    | otherwise = CountOf (len' - sz')
+  where len@(CountOf len') = length v
+
+-- | Take the N elements from the end of the array
+revTake :: CountOf ty -> UArray ty -> UArray ty
+revTake n v = drop (countFromStart v n) v
+
+-- | Drop the N elements from the end of the array
+revDrop :: CountOf ty -> UArray ty -> UArray ty
+revDrop n v = take (countFromStart v n) v
+
+-- | Split an array at the N element from the end, and return
+-- the last N elements in the first part of the tuple, and whatever first
+-- elements remaining in the second
+revSplitAt :: CountOf ty -> UArray ty -> (UArray ty, UArray ty)
+revSplitAt n v = (drop sz v, take sz v) where sz = countFromStart v n
+
+splitOn :: PrimType ty => (ty -> Bool) -> UArray ty -> [UArray ty]
+splitOn xpredicate ivec
+    | len == 0  = [mempty]
+    | otherwise = runST $ unsafeIndexer ivec (pureST . go ivec xpredicate)
+  where
+    !len = length ivec
+    go v predicate getIdx = loop 0 0
+      where
+        loop !prevIdx !idx
+            | idx .==# len = [sub v prevIdx idx]
+            | otherwise    =
+                let e = getIdx idx
+                    idx' = idx + 1
+                 in if predicate e
+                        then sub v prevIdx idx : loop idx' idx'
+                        else loop prevIdx idx'
+    {-# INLINE go #-}
+
+sub :: PrimType ty => UArray ty -> Offset ty -> Offset ty -> UArray ty
+sub (UArray start len backend) startIdx expectedEndIdx
+    | startIdx >= endIdx = mempty
+    | otherwise          = UArray (start + startIdx) newLen backend
+  where
+    newLen = endIdx - startIdx
+    endIdx = min expectedEndIdx (0 `offsetPlusE` len)
+
+findIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty)
+findIndex ty arr
+    | k == sentinel  = Nothing
+    | otherwise      = Just (k `offsetSub` offset arr)
+  where
+    !k = onBackendPure' arr $ Alg.findIndexElem ty
+{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}
+
+revFindIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty)
+revFindIndex ty arr
+    | k == sentinel = Nothing
+    | otherwise     = Just (k `offsetSub` offset arr)
+  where
+    !k = onBackendPure' arr $ Alg.revFindIndexElem ty
+{-# SPECIALIZE [3] revFindIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}
+
+break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)
+break predicate arr
+    | k == sentinel = (arr, mempty)
+    | otherwise     = splitAt (k - offset arr) arr
+  where
+    !k = onBackendPure' arr $ Alg.findIndexPredicate predicate
+
+{-
+{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}
+    | len == 0  = (mempty, mempty)
+    | otherwise = runST $ unsafeIndexer xv (go xv xpredicate)
+  where
+    !len = length xv
+    go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s (UArray ty, UArray ty)
+    go v predicate getIdx = pure (findBreak $ Offset 0)
+      where
+        findBreak !i
+            | i .==# len           = (v, mempty)
+            | predicate (getIdx i) = splitAt (offsetAsSize i) v
+            | otherwise            = findBreak (i + Offset 1)
+        {-# INLINE findBreak #-}
+    {-# INLINE go #-}
+    -}
+{-# NOINLINE [2] break #-}
+{-# SPECIALIZE [2] break :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-}
+
+{-
+{-# RULES "break (== ty)" [3] forall (x :: forall ty . PrimType ty => ty) . break (== x) = breakElem x #-}
+{-# RULES "break (ty ==)" [3] forall (x :: forall ty . PrimType ty => ty) . break (x ==) = breakElem x #-}
+{-# RULES "break (== ty)" [3] forall (x :: Word8) . break (== x) = breakElem x #-}
+-}
+
+-- | Similar to break but start the search of the breakpoint from the end
+--
+-- > breakEnd (> 0) [1,2,3,0,0,0]
+-- ([1,2,3], [0,0,0])
+breakEnd :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)
+breakEnd predicate arr
+    | k == sentinel = (arr, mempty)
+    | otherwise     = splitAt ((k+1) - offset arr) arr
+  where
+    !k = onBackendPure' arr $ Alg.revFindIndexPredicate predicate
+{-# SPECIALIZE [3] breakEnd :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-}
+
+elem :: PrimType ty => ty -> UArray ty -> Bool
+elem !ty arr = onBackendPure' arr (Alg.findIndexElem ty) /= sentinel
+{-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-}
+
+intersperse :: forall ty . PrimType ty => ty -> UArray ty -> UArray ty
+intersperse sep v = case len - 1 of
+    Nothing -> v
+    Just 0 -> v
+    Just gaps -> runST $ unsafeCopyFrom v (len + gaps) go
+  where
+    len = length v
+
+    go :: PrimType ty => UArray ty -> Offset ty -> MUArray ty s -> ST s ()
+    go oldV oldI newV
+        | (oldI + 1) .==# len = unsafeWrite newV newI e
+        | otherwise           = do
+            unsafeWrite newV newI e
+            unsafeWrite newV (newI + 1) sep
+      where
+        e = unsafeIndex oldV oldI
+        newI = scale (2 :: Word) oldI
+
+span :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)
+span p = break (not . p)
+
+spanEnd :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)
+spanEnd p = breakEnd (not . p)
+
+map :: (PrimType a, PrimType b) => (a -> b) -> UArray a -> UArray b
+map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))
+  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a)
+
+mapIndex :: (PrimType a, PrimType b) => (Offset b -> a -> b) -> UArray a -> UArray b
+mapIndex f a = create (sizeCast Proxy $ length a) (\i -> f i $ unsafeIndex a (offsetCast Proxy i))
+
+cons :: PrimType ty => ty -> UArray ty -> UArray ty
+cons e vec
+    | len == CountOf 0 = singleton e
+    | otherwise     = runST $ do
+        muv <- new (len + 1)
+        unsafeCopyAtRO muv 1 vec 0 len
+        unsafeWrite muv 0 e
+        unsafeFreeze muv
+  where
+    !len = length vec
+
+snoc :: PrimType ty => UArray ty -> ty -> UArray ty
+snoc vec e
+    | len == CountOf 0 = singleton e
+    | otherwise     = runST $ do
+        muv <- new (len + CountOf 1)
+        unsafeCopyAtRO muv (Offset 0) vec (Offset 0) len
+        unsafeWrite muv (0 `offsetPlusE` length vec) e
+        unsafeFreeze muv
+  where
+     !len = length vec
+
+uncons :: PrimType ty => UArray ty -> Maybe (ty, UArray ty)
+uncons vec
+    | nbElems == 0 = Nothing
+    | otherwise    = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems))
+  where
+    !nbElems = length vec
+
+unsnoc :: PrimType ty => UArray ty -> Maybe (UArray ty, ty)
+unsnoc vec = case length vec - 1 of
+    Nothing -> Nothing
+    Just newLen -> Just (sub vec 0 lastElem, unsafeIndex vec lastElem)
+                     where !lastElem = 0 `offsetPlusE` newLen
+
+find :: PrimType ty => (ty -> Bool) -> UArray ty -> Maybe ty
+find predicate vec = loop 0
+  where
+    !len = length vec
+    loop i
+        | i .==# len = Nothing
+        | otherwise  =
+            let e = unsafeIndex vec i
+             in if predicate e then Just e else loop (i+1)
+
+sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty
+sortBy ford vec = runST $ do
+    mvec <- thaw vec
+    onMutableBackend goNative (\fptr -> withFinalPtr fptr goAddr) mvec
+    unsafeFreeze mvec
+  where
+    !len = length vec
+    !start = offset vec
+
+    goNative :: MutableBlock ty s -> ST s ()
+    goNative mb = Alg.inplaceSortBy ford start len mb
+    goAddr :: Ptr ty -> ST s ()
+    goAddr (Ptr addr) = Alg.inplaceSortBy ford start len (Ptr addr :: Ptr ty)
+{-# SPECIALIZE [3] sortBy :: (Word8 -> Word8 -> Ordering) -> UArray Word8 -> UArray Word8 #-}
+
+filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty
+filter predicate arr = runST $ do
+    (newLen, ma) <- newNative (length arr) $ \(MutableBlock mba) ->
+            onBackendPrim (\block -> Alg.filter predicate mba block start end)
+                          (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) ->
+                                        Alg.filter predicate mba ptr start end)
+                          arr
+    unsafeFreezeShrink ma newLen
+  where
+    !len   = length arr
+    !start = offset arr
+    !end   = start `offsetPlusE` len
+
+reverse :: forall ty . PrimType ty => UArray ty -> UArray ty
+reverse a
+    | len == 0  = mempty
+    | otherwise = runST $ do
+        a <- newNative_ len $ \mba -> onBackendPrim (goNative mba)
+                                                    (\fptr -> withFinalPtr fptr $ goAddr mba)
+                                                    a
+        unsafeFreeze a
+  where
+    !len = length a
+    !end = 0 `offsetPlusE` len
+    !start = offset a
+    !endI = sizeAsOffset ((start + end) - Offset 1)
+
+    goNative :: MutableBlock ty s -> Block ty -> ST s ()
+    goNative !ma (Block !ba) = loop 0
+      where
+        loop !i
+            | i == end  = pure ()
+            | otherwise = BLK.unsafeWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1)
+    goAddr :: MutableBlock ty s -> Ptr ty -> ST s ()
+    goAddr !ma (Ptr addr) = loop 0
+      where
+        loop !i
+            | i == end  = pure ()
+            | otherwise = BLK.unsafeWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1)
+{-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-}
+{-# SPECIALIZE [3] reverse :: UArray Word32 -> UArray Word32 #-}
+{-# SPECIALIZE [3] reverse :: UArray Char -> UArray Char #-}
+
+-- Finds where are the insertion points when we search for a `needle`
+-- within an `haystack`.
+-- Throws an error in case `needle` is empty.
+indices :: PrimType ty => UArray ty -> UArray ty -> [Offset ty]
+indices needle hy
+  | needleLen <= 0 = error "Basement.UArray.indices: needle is empty."
+  | otherwise = case haystackLen < needleLen of
+                  True  -> []
+                  False -> go (Offset 0) []
+  where
+    !haystackLen = length hy
+
+    !needleLen = length needle
+
+    go currentOffset ipoints
+      | (currentOffset `offsetPlusE` needleLen) > (sizeAsOffset haystackLen) = ipoints
+      | otherwise =
+        let matcher = take needleLen . drop (offsetAsSize currentOffset) $ hy
+        in case matcher == needle of
+             -- TODO: Move away from right-appending as it's gonna be slow.
+             True  -> go (currentOffset `offsetPlusE` needleLen) (ipoints <> [currentOffset])
+             False -> go (currentOffset + 1) ipoints
+
+-- | Replace all the occurrencies of `needle` with `replacement` in
+-- the `haystack` string.
+replace :: PrimType ty => UArray ty -> UArray ty -> UArray ty -> UArray ty
+replace (needle :: UArray ty) replacement haystack = runST $ do
+    case null needle of
+      True -> error "Basement.UArray.replace: empty needle"
+      False -> do
+        let insertionPoints = indices needle haystack
+        let !(CountOf occs) = List.length insertionPoints
+        let !newLen         = haystackLen `sizeSub` (multBy needleLen occs) + (multBy replacementLen occs)
+        ms <- new newLen
+        loop ms (Offset 0) (Offset 0) insertionPoints
+  where
+
+    multBy (CountOf x) y = CountOf (x * y)
+
+    !needleLen = length needle
+
+    !replacementLen = length replacement
+
+    !haystackLen = length haystack
+
+    -- Go through each insertion point and copy things over.
+    -- We keep around the offset to the original string to
+    -- be able to copy bytes which didn't change.
+    loop :: PrimMonad prim
+         => MUArray ty (PrimState prim)
+         -> Offset ty
+         -> Offset ty
+         -> [Offset ty]
+         -> prim (UArray ty)
+    loop mba currentOffset offsetInOriginalString [] = do
+      -- Finalise the string
+      let !unchangedDataLen = sizeAsOffset haystackLen - offsetInOriginalString
+      unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen
+      freeze mba
+    loop mba currentOffset offsetInOriginalString (x:xs) = do
+        -- 1. Copy from the old string.
+        let !unchangedDataLen = (x - offsetInOriginalString)
+        unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen
+        let !newOffset = currentOffset `offsetPlusE` unchangedDataLen
+        -- 2. Copy the replacement.
+        unsafeCopyAtRO mba newOffset replacement (Offset 0) replacementLen
+        let !offsetInOriginalString' = offsetInOriginalString `offsetPlusE` unchangedDataLen `offsetPlusE` needleLen
+        loop mba (newOffset `offsetPlusE` replacementLen) offsetInOriginalString' xs
+{-# SPECIALIZE [3] replace :: UArray Word8 -> UArray Word8 -> UArray Word8 -> UArray Word8 #-}
+
+foldr :: PrimType ty => (ty -> a -> a) -> a -> UArray ty -> a
+foldr f initialAcc vec = loop 0
+  where
+    !len = length vec
+    loop i
+        | i .==# len = initialAcc
+        | otherwise  = unsafeIndex vec i `f` loop (i+1)
+
+foldl' :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a
+foldl' f initialAcc arr = onBackendPure' arr (Alg.foldl f initialAcc)
+{-# SPECIALIZE [3] foldl' :: (a -> Word8 -> a) -> a -> UArray Word8 -> a #-}
+
+foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty
+foldl1' f (NonEmpty arr) = onBackendPure' arr (Alg.foldl1 f)
+{-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (UArray Word8) -> Word8 #-}
+
+foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty
+foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr
+               in foldr f (unsafeIndex initialAcc 0) rest
+
+all :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool
+all predicate arr = onBackendPure' arr $ Alg.all predicate
+{-# SPECIALIZE [3] all :: (Word8 -> Bool) -> UArray Word8 -> Bool #-}
+
+any :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool
+any predicate arr = onBackendPure' arr $ Alg.any predicate
+{-# SPECIALIZE [3] any :: (Word8 -> Bool) -> UArray Word8 -> Bool #-}
+
+builderAppend :: (PrimType ty, PrimMonad state) => ty -> Builder (UArray ty) (MUArray ty) ty state err ()
+builderAppend v = Builder $ State $ \(i, st, e) ->
+    if offsetAsSize i == chunkSize st
+        then do
+            cur      <- unsafeFreeze (curChunk st)
+            newChunk <- new (chunkSize st)
+            unsafeWrite newChunk 0 v
+            pure ((), (Offset 1, st { prevChunks     = cur : prevChunks st
+                                    , prevChunksSize = chunkSize st + prevChunksSize st
+                                    , curChunk       = newChunk
+                                    }, e))
+        else do
+            unsafeWrite (curChunk st) i v
+            pure ((), (i + 1, st, e))
+
+builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m err () -> m (Either err (UArray ty))
+builderBuild sizeChunksI ab
+    | sizeChunksI <= 0 = builderBuild 64 ab
+    | otherwise        = do
+        first      <- new sizeChunks
+        (i, st, e) <- snd <$> runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing)
+        case e of
+          Just err -> pure (Left err)
+          Nothing -> do
+            cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)
+            -- Build final array
+            let totalSize = prevChunksSize st + offsetAsSize i
+            bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze
+            pure (Right bytes)
+  where
+      sizeChunks = CountOf sizeChunksI
+
+      fillFromEnd _    []     mua = pure mua
+      fillFromEnd !end (x:xs) mua = do
+          let sz = length x
+          let start = end `sizeSub` sz
+          unsafeCopyAtRO mua (sizeAsOffset start) x (Offset 0) sz
+          fillFromEnd start xs mua
+
+builderBuild_ :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m () () -> m (UArray ty)
+builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab
+
+toHexadecimal :: PrimType ty => UArray ty -> UArray Word8
+toHexadecimal ba
+    | len == CountOf 0 = mempty
+    | otherwise     = runST $ do
+        ma <- new (len `scale` 2)
+        unsafeIndexer b8 (go ma)
+        unsafeFreeze ma
+  where
+    b8 = unsafeRecast ba
+    !len = length b8
+    !endOfs = Offset 0 `offsetPlusE` len
+
+    go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s ()
+    go !ma !getAt = loop 0 0
+      where
+        loop !dIdx !sIdx
+            | sIdx == endOfs = pure ()
+            | otherwise      = do
+                let !(W8# !w)       = getAt sIdx
+                    !(# wHi, wLo #) = Base16.unsafeConvertByte w
+                unsafeWrite ma dIdx     (W8# wHi)
+                unsafeWrite ma (dIdx+1) (W8# wLo)
+                loop (dIdx + 2) (sIdx+1)
+
+toBase64Internal :: PrimType ty => Addr# -> UArray ty -> Bool -> UArray Word8
+toBase64Internal table src padded
+    | len == CountOf 0 = mempty
+    | otherwise = runST $ do
+        ma <- new dstLen
+        unsafeIndexer b8 (go ma)
+        unsafeFreeze ma
+  where
+    b8 = unsafeRecast src
+    !len = length b8
+    !dstLen = outputLengthBase64 padded len
+    !endOfs = Offset 0 `offsetPlusE` len
+    !dstEndOfs = Offset 0 `offsetPlusE` dstLen
+
+    go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s ()
+    go !ma !getAt = loop 0 0
+      where
+        eqChar = 0x3d :: Word8
+
+        loop !sIdx !dIdx
+            | sIdx == endOfs = when padded $ do
+                when (dIdx `offsetPlusE` CountOf 1 <= dstEndOfs) $ unsafeWrite ma dIdx eqChar
+                when (dIdx `offsetPlusE` CountOf 2 == dstEndOfs) $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) eqChar
+            | otherwise = do
+                let !b2Idx = sIdx `offsetPlusE` CountOf 1
+                    !b3Idx = sIdx `offsetPlusE` CountOf 2
+
+                    !b2Available = b2Idx < endOfs
+                    !b3Available = b3Idx < endOfs
+
+                    !b1 = getAt sIdx
+                    !b2 = if b2Available then getAt b2Idx else 0
+                    !b3 = if b3Available then getAt b3Idx else 0
+
+                    (w,x,y,z) = convert3 table b1 b2 b3
+
+                    sNextIncr = 1 + fromEnum b2Available + fromEnum b3Available
+                    dNextIncr = 1 + sNextIncr
+
+                unsafeWrite ma dIdx w
+                unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) x
+
+                when b2Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 2) y
+                when b3Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 3) z
+
+                loop (sIdx `offsetPlusE` CountOf sNextIncr) (dIdx `offsetPlusE` CountOf dNextIncr)
+
+outputLengthBase64 :: Bool -> CountOf Word8 -> CountOf Word8
+outputLengthBase64 padding (CountOf inputLenInt) = outputLength
+  where
+    outputLength = if padding then CountOf lenWithPadding else CountOf lenWithoutPadding
+    lenWithPadding
+        | m == 0    = 4 * d
+        | otherwise = 4 * (d + 1)
+    lenWithoutPadding
+        | m == 0    = 4 * d
+        | otherwise = 4 * d + m + 1
+    (d,m) = inputLenInt `divMod` 3
+
+convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8)
+convert3 table a b c =
+    let !w = a .>>. 2
+        !x = ((a .<<. 4) .&. 0x30) .|. (b .>>. 4)
+        !y = ((b .<<. 2) .&. 0x3c) .|. (c .>>. 6)
+        !z = c .&. 0x3f
+     in (idx w, idx x, idx y, idx z)
+  where
+    idx :: Word8 -> Word8
+    idx (W8# i) = W8# (indexWord8OffAddr# table (word2Int# (word8ToWord# i)))
+
+isPrefixOf :: PrimType ty => UArray ty -> UArray ty -> Bool
+isPrefixOf pre arr
+    | pLen > pArr = False
+    | otherwise   = pre == unsafeTake pLen arr
+  where
+    !pLen = length pre
+    !pArr = length arr
+{-# SPECIALIZE [3] isPrefixOf :: UArray Word8 -> UArray Word8 -> Bool #-}
+
+isSuffixOf :: PrimType ty => UArray ty -> UArray ty -> Bool
+isSuffixOf suffix arr
+    | pLen > pArr = False
+    | otherwise   = suffix == revTake pLen arr
+  where
+    !pLen = length suffix
+    !pArr = length arr
+{-# SPECIALIZE [3] isSuffixOf :: UArray Word8 -> UArray Word8 -> Bool #-}

bundled/Basement/UArray/Base.hs

@@ -0,0 +1,655 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+module Basement.UArray.Base
+    ( MUArray(..)
+    , UArray(..)
+    , MUArrayBackend(..)
+    , UArrayBackend(..)
+    -- * New mutable array creation
+    , newUnpinned
+    , newPinned
+    , newNative
+    , newNative_
+    , new
+    -- * Pinning status
+    , isPinned
+    , isMutablePinned
+    -- * Mutable array accessor
+    , unsafeRead
+    , unsafeWrite
+    -- * Freezing routines
+    , unsafeFreezeShrink
+    , unsafeFreeze
+    , unsafeThaw
+    , thaw
+    , copy
+    -- * Array accessor
+    , unsafeIndex
+    , unsafeIndexer
+    , onBackend
+    , onBackendPure
+    , onBackendPure'
+    , onBackendPrim
+    , onMutableBackend
+    , unsafeDewrap
+    , unsafeDewrap2
+    -- * Basic lowlevel functions
+    , vFromListN
+    , empty
+    , length
+    , offset
+    , ValidRange(..)
+    , offsetsValidRange
+    , equal
+    , equalMemcmp
+    , compare
+    , copyAt
+    , unsafeCopyAtRO
+    , toBlock
+    -- * temporary
+    , pureST
+    ) where
+
+import           GHC.Prim
+import           GHC.Types
+import           GHC.Ptr
+import           GHC.ST
+import           Basement.Compat.Primitive
+import           Basement.Monad
+import           Basement.PrimType
+import           Basement.Compat.Base
+import           Basement.Compat.C.Types
+import           Basement.Compat.Semigroup
+import qualified Basement.Runtime as Runtime
+import           Data.Proxy
+import qualified Basement.Compat.ExtList as List
+import qualified Basement.Alg.Class as Alg
+import           Basement.Types.OffsetSize
+import           Basement.FinalPtr
+import           Basement.NormalForm
+import           Basement.Block (MutableBlock(..), Block(..))
+import qualified Basement.Block as BLK
+import qualified Basement.Block.Mutable as MBLK
+import           Basement.Numerical.Additive
+import           Basement.Bindings.Memory
+import           System.IO.Unsafe (unsafeDupablePerformIO)
+
+-- | A Mutable array of types built on top of GHC primitive.
+--
+-- Element in this array can be modified in place.
+data MUArray ty st = MUArray {-# UNPACK #-} !(Offset ty)
+                             {-# UNPACK #-} !(CountOf ty)
+                                            !(MUArrayBackend ty st)
+
+data MUArrayBackend ty st = MUArrayMBA (MutableBlock ty st) | MUArrayAddr (FinalPtr ty)
+
+
+instance PrimType ty => Alg.Indexable (Ptr ty) ty where
+    index (Ptr addr) = primAddrIndex addr
+
+instance Alg.Indexable (Ptr Word8) Word64 where
+    index (Ptr addr) = primAddrIndex addr
+
+instance (PrimMonad prim, PrimType ty) => Alg.RandomAccess (Ptr ty) prim ty where
+    read (Ptr addr) = primAddrRead addr
+    write (Ptr addr) = primAddrWrite addr
+
+-- | An array of type built on top of GHC primitive.
+--
+-- The elements need to have fixed sized and the representation is a
+-- packed contiguous array in memory that can easily be passed
+-- to foreign interface
+data UArray ty = UArray {-# UNPACK #-} !(Offset ty)
+                        {-# UNPACK #-} !(CountOf ty)
+                                       !(UArrayBackend ty)
+    deriving (Typeable)
+
+data UArrayBackend ty = UArrayBA !(Block ty) | UArrayAddr !(FinalPtr ty)
+    deriving (Typeable)
+
+instance Data ty => Data (UArray ty) where
+    dataTypeOf _ = arrayType
+    toConstr _   = error "toConstr"
+    gunfold _ _  = error "gunfold"
+
+arrayType :: DataType
+arrayType = mkNoRepType "Basement.UArray"
+
+instance NormalForm (UArray ty) where
+    toNormalForm (UArray _ _ !_) = ()
+instance (PrimType ty, Show ty) => Show (UArray ty) where
+    show v = show (toList v)
+instance (PrimType ty, Eq ty) => Eq (UArray ty) where
+    (==) = equal
+instance (PrimType ty, Ord ty) => Ord (UArray ty) where
+    {-# SPECIALIZE instance Ord (UArray Word8) #-}
+    compare = vCompare
+
+instance PrimType ty => Semigroup (UArray ty) where
+    (<>) = append
+instance PrimType ty => Monoid (UArray ty) where
+    mempty  = empty
+    mconcat = concat
+
+instance PrimType ty => IsList (UArray ty) where
+    type Item (UArray ty) = ty
+    fromList = vFromList
+    fromListN len = vFromListN (CountOf len)
+    toList = vToList
+
+length :: UArray ty -> CountOf ty
+length (UArray _ len _) = len
+{-# INLINE[1] length #-}
+
+offset :: UArray ty -> Offset ty
+offset (UArray ofs _ _) = ofs
+{-# INLINE[1] offset #-}
+
+data ValidRange ty = ValidRange {-# UNPACK #-} !(Offset ty) {-# UNPACK #-} !(Offset ty)
+
+offsetsValidRange :: UArray ty -> ValidRange ty
+offsetsValidRange (UArray ofs len _) = ValidRange ofs (ofs `offsetPlusE` len)
+
+-- | Return if the array is pinned in memory
+--
+-- note that Foreign array are considered pinned
+isPinned :: UArray ty -> PinnedStatus
+isPinned (UArray _ _ (UArrayAddr {})) = Pinned
+isPinned (UArray _ _ (UArrayBA blk))  = BLK.isPinned blk
+
+-- | Return if a mutable array is pinned in memory
+isMutablePinned :: MUArray ty st -> PinnedStatus
+isMutablePinned (MUArray _ _ (MUArrayAddr {})) = Pinned
+isMutablePinned (MUArray _ _ (MUArrayMBA mb))  = BLK.isMutablePinned mb
+
+-- | Create a new pinned mutable array of size @n.
+--
+-- all the cells are uninitialized and could contains invalid values.
+--
+-- All mutable arrays are allocated on a 64 bits aligned addresses
+newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))
+newPinned n = MUArray 0 n . MUArrayMBA <$> MBLK.newPinned n
+
+-- | Create a new unpinned mutable array of size @n elements.
+--
+-- If the size exceeds a GHC-defined threshold, then the memory will be
+-- pinned. To be certain about pinning status with small size, use 'newPinned'
+newUnpinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))
+newUnpinned n = MUArray 0 n . MUArrayMBA <$> MBLK.new n
+
+newNative :: (PrimMonad prim, PrimType ty)
+          => CountOf ty
+          -> (MutableBlock ty (PrimState prim) -> prim a)
+          -> prim (a, MUArray ty (PrimState prim))
+newNative n f = do
+    mb <- MBLK.new n
+    a  <- f mb
+    pure (a, MUArray 0 n (MUArrayMBA mb))
+
+-- | Same as newNative but expect no extra return value from f
+newNative_ :: (PrimMonad prim, PrimType ty)
+           => CountOf ty
+           -> (MutableBlock ty (PrimState prim) -> prim ())
+           -> prim (MUArray ty (PrimState prim))
+newNative_ n f = do
+    mb <- MBLK.new n
+    f mb
+    pure (MUArray 0 n (MUArrayMBA mb))
+
+-- | Create a new mutable array of size @n.
+--
+-- When memory for a new array is allocated, we decide if that memory region
+-- should be pinned (will not be copied around by GC) or unpinned (can be
+-- moved around by GC) depending on its size.
+--
+-- You can change the threshold value used by setting the environment variable
+-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@.
+new :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))
+new sz
+    | sizeRecast sz <= maxSizeUnpinned = newUnpinned sz
+    | otherwise                        = newPinned sz
+  where
+    -- Safe to use here: If the value changes during runtime, this will only
+    -- have an impact on newly created arrays.
+    maxSizeUnpinned = Runtime.unsafeUArrayUnpinnedMaxSize
+{-# INLINE new #-}
+
+-- | read from a cell in a mutable array without bounds checking.
+--
+-- Reading from invalid memory can return unpredictable and invalid values.
+-- use 'read' if unsure.
+unsafeRead :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty
+unsafeRead (MUArray start _ (MUArrayMBA (MutableBlock mba))) i = primMbaRead mba (start + i)
+unsafeRead (MUArray start _ (MUArrayAddr fptr)) i = withFinalPtr fptr $ \(Ptr addr) -> primAddrRead addr (start + i)
+{-# INLINE unsafeRead #-}
+
+
+-- | write to a cell in a mutable array without bounds checking.
+--
+-- Writing with invalid bounds will corrupt memory and your program will
+-- become unreliable. use 'write' if unsure.
+unsafeWrite :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim ()
+unsafeWrite (MUArray start _ (MUArrayMBA mb)) i v = MBLK.unsafeWrite mb (start+i) v
+unsafeWrite (MUArray start _ (MUArrayAddr fptr)) i v = withFinalPtr fptr $ \(Ptr addr) -> primAddrWrite addr (start+i) v
+{-# INLINE unsafeWrite #-}
+
+-- | Return the element at a specific index from an array without bounds checking.
+--
+-- Reading from invalid memory can return unpredictable and invalid values.
+-- use 'index' if unsure.
+unsafeIndex :: forall ty . PrimType ty => UArray ty -> Offset ty -> ty
+unsafeIndex (UArray start _ (UArrayBA ba)) n = BLK.unsafeIndex ba (start + n)
+unsafeIndex (UArray start _ (UArrayAddr fptr)) n = withUnsafeFinalPtr fptr (\(Ptr addr) -> return (primAddrIndex addr (start+n)) :: IO ty)
+{-# INLINE unsafeIndex #-}
+
+unsafeIndexer :: (PrimMonad prim, PrimType ty) => UArray ty -> ((Offset ty -> ty) -> prim a) -> prim a
+unsafeIndexer (UArray start _ (UArrayBA ba)) f = f (\n -> BLK.unsafeIndex ba (start + n))
+unsafeIndexer (UArray start _ (UArrayAddr fptr)) f = withFinalPtr fptr $ \(Ptr addr) -> f (\n -> primAddrIndex addr (start + n))
+{-# INLINE unsafeIndexer #-}
+
+-- | Freeze a mutable array into an array.
+--
+-- the MUArray must not be changed after freezing.
+unsafeFreeze :: PrimMonad prim => MUArray ty (PrimState prim) -> prim (UArray ty)
+unsafeFreeze (MUArray start len (MUArrayMBA mba)) =
+    UArray start len . UArrayBA <$> MBLK.unsafeFreeze mba
+unsafeFreeze (MUArray start len (MUArrayAddr fptr)) =
+    pure $ UArray start len (UArrayAddr fptr)
+{-# INLINE unsafeFreeze #-}
+
+unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty)
+unsafeFreezeShrink (MUArray start _ backend) n = unsafeFreeze (MUArray start n backend)
+{-# INLINE unsafeFreezeShrink #-}
+
+-- | Thaw an immutable array.
+--
+-- The UArray must not be used after thawing.
+unsafeThaw :: (PrimType ty, PrimMonad prim) => UArray ty -> prim (MUArray ty (PrimState prim))
+unsafeThaw (UArray start len (UArrayBA blk)) = MUArray start len . MUArrayMBA <$> BLK.unsafeThaw blk
+unsafeThaw (UArray start len (UArrayAddr fptr)) = pure $ MUArray start len (MUArrayAddr fptr)
+{-# INLINE unsafeThaw #-}
+
+-- | Thaw an array to a mutable array.
+--
+-- the array is not modified, instead a new mutable array is created
+-- and every values is copied, before returning the mutable array.
+thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim))
+thaw array = do
+    ma <- new (length array)
+    unsafeCopyAtRO ma azero array (Offset 0) (length array)
+    pure ma
+{-# INLINE thaw #-}
+
+-- | Copy every cells of an existing array to a new array
+copy :: PrimType ty => UArray ty -> UArray ty
+copy array = runST (thaw array >>= unsafeFreeze)
+
+
+onBackend :: (Block ty -> a)
+          -> (FinalPtr ty -> Ptr ty -> ST s a)
+          -> UArray ty
+          -> a
+onBackend onBa _      (UArray _ _ (UArrayBA ba))     = onBa ba
+onBackend _    onAddr (UArray _ _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr $ \ptr@(Ptr !_) -> 
+                                                           onAddr fptr ptr
+{-# INLINE onBackend #-}
+
+onBackendPure :: (Block ty -> a)
+              -> (Ptr ty -> a)
+              -> UArray ty
+              -> a
+onBackendPure goBA goAddr arr = onBackend goBA (\_ -> pureST . goAddr) arr
+{-# INLINE onBackendPure #-}
+
+onBackendPure' :: forall ty a . PrimType  ty
+               => UArray ty
+               -> (forall container. Alg.Indexable container ty 
+                   => container -> Offset ty -> Offset ty -> a)
+               -> a
+onBackendPure' arr f = onBackendPure f' f' arr
+  where f' :: Alg.Indexable container ty => container -> a
+        f' c = f c start end
+          where (ValidRange !start !end) = offsetsValidRange arr
+{-# INLINE onBackendPure' #-}
+
+onBackendPrim :: PrimMonad prim
+              => (Block ty -> prim a)
+              -> (FinalPtr ty -> prim a)
+              -> UArray ty
+              -> prim a
+onBackendPrim onBa _      (UArray _ _ (UArrayBA ba))     = onBa ba
+onBackendPrim _    onAddr (UArray _ _ (UArrayAddr fptr)) = onAddr fptr
+{-# INLINE onBackendPrim #-}
+
+onMutableBackend :: PrimMonad prim
+                 => (MutableBlock ty (PrimState prim) -> prim a)
+                 -> (FinalPtr ty -> prim a)
+                 -> MUArray ty (PrimState prim)
+                 -> prim a
+onMutableBackend onMba _      (MUArray _ _ (MUArrayMBA mba))   = onMba mba
+onMutableBackend _     onAddr (MUArray _ _ (MUArrayAddr fptr)) = onAddr fptr
+{-# INLINE onMutableBackend #-}
+
+
+unsafeDewrap :: (Block ty -> Offset ty -> a)
+             -> (Ptr ty -> Offset ty -> ST s a)
+             -> UArray ty
+             -> a
+unsafeDewrap _ g (UArray start _ (UArrayAddr fptr))     = withUnsafeFinalPtr fptr $ \ptr -> g ptr start
+unsafeDewrap f _ (UArray start _ (UArrayBA ba)) = f ba start
+{-# INLINE unsafeDewrap #-}
+
+unsafeDewrap2 :: (ByteArray# -> ByteArray# -> a)
+              -> (Ptr ty -> Ptr ty -> ST s a)
+              -> (ByteArray# -> Ptr ty -> ST s a)
+              -> (Ptr ty -> ByteArray# -> ST s a)
+              -> UArray ty
+              -> UArray ty
+              -> a
+unsafeDewrap2 f g h i (UArray _ _ back1) (UArray _ _ back2) =
+    case (back1, back2) of
+        (UArrayBA (Block ba1), UArrayBA (Block ba2)) -> f ba1 ba2
+        (UArrayAddr fptr1, UArrayAddr fptr2)         -> withUnsafeFinalPtr fptr1 $ \ptr1 -> withFinalPtr fptr2 $ \ptr2 -> g ptr1 ptr2
+        (UArrayBA (Block ba1), UArrayAddr fptr2)     -> withUnsafeFinalPtr fptr2 $ \ptr2 -> h ba1 ptr2
+        (UArrayAddr fptr1, UArrayBA (Block ba2))     -> withUnsafeFinalPtr fptr1 $ \ptr1 -> i ptr1 ba2
+{-# INLINE [2] unsafeDewrap2 #-}
+
+pureST :: a -> ST s a
+pureST = pure
+
+-- | make an array from a list of elements.
+vFromList :: forall ty . PrimType ty => [ty] -> UArray ty
+vFromList l = runST $ do
+    a <- newNative_ len copyList
+    unsafeFreeze a
+  where
+    len = List.length l
+    copyList :: MutableBlock ty s -> ST s ()
+    copyList mb = loop 0 l
+      where
+        loop _  []     = pure ()
+        loop !i (x:xs) = MBLK.unsafeWrite mb i x >> loop (i+1) xs
+
+-- | Make an array from a list of elements with a size hint.
+--
+-- The list should be of the same size as the hint, as otherwise:
+--
+-- * The length of the list is smaller than the hint:
+--    the array allocated is of the size of the hint, but is sliced
+--    to only represent the valid bits
+-- * The length of the list is bigger than the hint:
+--    The allocated array is the size of the hint, and the list is truncated to
+--    fit.
+vFromListN :: forall ty . PrimType ty => CountOf ty -> [ty] -> UArray ty
+vFromListN len l = runST $ do
+    (sz, ma) <- newNative len copyList
+    unsafeFreezeShrink ma sz
+  where
+    copyList :: MutableBlock ty s -> ST s (CountOf ty)
+    copyList mb = loop 0 l
+      where
+        loop !i  []     = pure (offsetAsSize i)
+        loop !i (x:xs)
+            | i .==# len = pure (offsetAsSize i)
+            | otherwise  = MBLK.unsafeWrite mb i x >> loop (i+1) xs
+
+-- | transform an array to a list.
+vToList :: forall ty . PrimType ty => UArray ty -> [ty]
+vToList a
+    | len == 0  = []
+    | otherwise = unsafeDewrap goBa goPtr a
+  where
+    !len = length a
+    goBa (Block ba) start = loop start
+      where
+        !end = start `offsetPlusE` len
+        loop !i | i == end  = []
+                | otherwise = primBaIndex ba i : loop (i+1)
+    goPtr (Ptr addr) start = pureST (loop start)
+      where
+        !end = start `offsetPlusE` len
+        loop !i | i == end  = []
+                | otherwise = primAddrIndex addr i : loop (i+1)
+
+-- | Check if two vectors are identical
+equal :: (PrimType ty, Eq ty) => UArray ty -> UArray ty -> Bool
+equal a b
+    | la /= lb  = False
+    | otherwise = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b
+  where
+    !start1 = offset a
+    !start2 = offset b
+    !end = start1 `offsetPlusE` la
+    !la = length a
+    !lb = length b
+    goBaBa ba1 ba2 = loop start1 start2
+      where
+        loop !i !o | i == end  = True
+                   | otherwise = primBaIndex ba1 i == primBaIndex ba2 o && loop (i+o1) (o+o1)
+    goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2)
+      where
+        loop !i !o | i == end  = True
+                   | otherwise = primAddrIndex addr1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)
+    goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2)
+      where
+        loop !i !o | i == end  = True
+                   | otherwise = primBaIndex ba1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)
+    goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2)
+      where
+        loop !i !o | i == end  = True
+                   | otherwise = primAddrIndex addr1 i == primBaIndex ba2 o && loop (i+o1) (o+o1)
+
+    o1 = Offset (I# 1#)
+{-# RULES "UArray/Eq/Word8" [3] equal = equalBytes #-}
+{-# INLINEABLE [2] equal #-}
+
+equalBytes :: UArray Word8 -> UArray Word8 -> Bool
+equalBytes a b
+    | la /= lb  = False
+    | otherwise = memcmp a b (sizeInBytes la) == 0
+  where
+    !la = length a
+    !lb = length b
+
+equalMemcmp :: PrimType ty => UArray ty -> UArray ty -> Bool
+equalMemcmp a b
+    | la /= lb  = False
+    | otherwise = memcmp a b (sizeInBytes la) == 0
+  where
+    !la = length a
+    !lb = length b
+
+-- | Compare 2 vectors
+vCompare :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering
+vCompare a@(UArray start1 la _) b@(UArray start2 lb _) = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b
+  where
+    !end = start1 `offsetPlusE` min la lb
+    o1 = Offset (I# 1#)
+    goBaBa ba1 ba2 = loop start1 start2
+      where
+        loop !i !o | i == end   = la `compare` lb
+                   | v1 == v2   = loop (i + o1) (o + o1)
+                   | otherwise  = v1 `compare` v2
+          where v1 = primBaIndex ba1 i
+                v2 = primBaIndex ba2 o
+    goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2)
+      where
+        loop !i !o | i == end   = la `compare` lb
+                   | v1 == v2   = loop (i + o1) (o + o1)
+                   | otherwise  = v1 `compare` v2
+          where v1 = primAddrIndex addr1 i
+                v2 = primAddrIndex addr2 o
+    goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2)
+      where
+        loop !i !o | i == end   = la `compare` lb
+                   | v1 == v2   = loop (i + o1) (o + o1)
+                   | otherwise  = v1 `compare` v2
+          where v1 = primBaIndex ba1 i
+                v2 = primAddrIndex addr2 o
+    goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2)
+      where
+        loop !i !o | i == end   = la `compare` lb
+                   | v1 == v2   = loop (i + o1) (o + o1)
+                   | otherwise  = v1 `compare` v2
+          where v1 = primAddrIndex addr1 i
+                v2 = primBaIndex ba2 o
+-- {-# SPECIALIZE [3] vCompare :: UArray Word8 -> UArray Word8 -> Ordering = vCompareBytes #-}
+{-# RULES "UArray/Ord/Word8" [3] vCompare = vCompareBytes #-}
+{-# INLINEABLE [2] vCompare #-}
+
+vCompareBytes :: UArray Word8 -> UArray Word8 -> Ordering
+vCompareBytes = vCompareMemcmp
+
+vCompareMemcmp :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering
+vCompareMemcmp a b = cintToOrdering $ memcmp a b sz
+  where
+    la = length a
+    lb = length b
+    sz = sizeInBytes $ min la lb
+    cintToOrdering :: CInt -> Ordering
+    cintToOrdering 0 = la `compare` lb
+    cintToOrdering r | r < 0     = LT
+                     | otherwise = GT
+{-# SPECIALIZE [3] vCompareMemcmp :: UArray Word8 -> UArray Word8 -> Ordering #-}
+
+memcmp :: PrimType ty => UArray ty -> UArray ty -> CountOf Word8 -> CInt
+memcmp a@(UArray (offsetInBytes -> o1) _ _) b@(UArray (offsetInBytes -> o2) _ _) sz = unsafeDewrap2
+    (\s1 s2 -> unsafeDupablePerformIO $ sysHsMemcmpBaBa s1 o1 s2 o2 sz)
+    (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrPtr s1 o1 s2 o2 sz)
+    (\s1 s2 -> unsafePrimToST $ sysHsMemcmpBaPtr s1 o1 s2 o2 sz)
+    (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrBa s1 o1 s2 o2 sz)
+    a b
+{-# SPECIALIZE [3] memcmp :: UArray Word8 -> UArray Word8 -> CountOf Word8 -> CInt #-}
+
+-- | Copy a number of elements from an array to another array with offsets
+copyAt :: forall prim ty . (PrimMonad prim, PrimType ty)
+       => MUArray ty (PrimState prim) -- ^ destination array
+       -> Offset ty                  -- ^ offset at destination
+       -> MUArray ty (PrimState prim) -- ^ source array
+       -> Offset ty                  -- ^ offset at source
+       -> CountOf ty                    -- ^ number of elements to copy
+       -> prim ()
+copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayMBA (MutableBlock srcBa))) es n =
+    primitive $ \st -> (# copyMutableByteArray# srcBa os dstMba od nBytes st, () #)
+  where
+    !sz                 = primSizeInBytes (Proxy :: Proxy ty)
+    !(Offset (I# os))   = offsetOfE sz (srcStart + es)
+    !(Offset (I# od))   = offsetOfE sz (dstStart + ed)
+    !(CountOf (I# nBytes)) = sizeOfE sz n
+copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayAddr srcFptr)) es n =
+    withFinalPtr srcFptr $ \srcPtr ->
+        let !(Ptr srcAddr) = srcPtr `plusPtr` os
+         in primitive $ \s -> (# copyAddrToByteArray# srcAddr dstMba od nBytes s, () #)
+  where
+    !sz                 = primSizeInBytes (Proxy :: Proxy ty)
+    !(Offset os)        = offsetOfE sz (srcStart + es)
+    !(Offset (I# od))   = offsetOfE sz (dstStart + ed)
+    !(CountOf (I# nBytes)) = sizeOfE sz n
+copyAt dst od src os n = loop od os
+  where
+    !endIndex = os `offsetPlusE` n
+    loop !d !i
+        | i == endIndex = return ()
+        | otherwise     = unsafeRead src i >>= unsafeWrite dst d >> loop (d+1) (i+1)
+
+-- TODO Optimise with copyByteArray#
+-- | Copy @n@ sequential elements from the specified offset in a source array
+--   to the specified position in a destination array.
+--
+--   This function does not check bounds. Accessing invalid memory can return
+--   unpredictable and invalid values.
+unsafeCopyAtRO :: forall prim ty . (PrimMonad prim, PrimType ty)
+               => MUArray ty (PrimState prim) -- ^ destination array
+               -> Offset ty                   -- ^ offset at destination
+               -> UArray ty                   -- ^ source array
+               -> Offset ty                   -- ^ offset at source
+               -> CountOf ty                     -- ^ number of elements to copy
+               -> prim ()
+unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayBA (Block srcBa))) es n =
+    primitive $ \st -> (# copyByteArray# srcBa os dstMba od nBytes st, () #)
+  where
+    sz = primSizeInBytes (Proxy :: Proxy ty)
+    !(Offset (I# os))   = offsetOfE sz (srcStart+es)
+    !(Offset (I# od))   = offsetOfE sz (dstStart+ed)
+    !(CountOf (I# nBytes)) = sizeOfE sz n
+unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayAddr srcFptr)) es n =
+    withFinalPtr srcFptr $ \srcPtr ->
+        let !(Ptr srcAddr) = srcPtr `plusPtr` os
+         in primitive $ \s -> (# copyAddrToByteArray# srcAddr dstMba od nBytes s, () #)
+  where
+    sz  = primSizeInBytes (Proxy :: Proxy ty)
+    !(Offset os)        = offsetOfE sz (srcStart+es)
+    !(Offset (I# od))   = offsetOfE sz (dstStart+ed)
+    !(CountOf (I# nBytes)) = sizeOfE sz n
+unsafeCopyAtRO dst od src os n = loop od os
+  where
+    !endIndex = os `offsetPlusE` n
+    loop d i
+        | i == endIndex = return ()
+        | otherwise     = unsafeWrite dst d (unsafeIndex src i) >> loop (d+1) (i+1)
+
+empty_ :: Block ()
+empty_ = runST $ primitive $ \s1 ->
+    case newByteArray# 0# s1           of { (# s2, mba #) ->
+    case unsafeFreezeByteArray# mba s2 of { (# s3, ba  #) ->
+        (# s3, Block ba #) }}
+
+empty :: UArray ty
+empty = UArray 0 0 (UArrayBA $ Block ba) where !(Block ba) = empty_
+
+-- | Append 2 arrays together by creating a new bigger array
+append :: PrimType ty => UArray ty -> UArray ty -> UArray ty
+append a b
+    | la == azero = b
+    | lb == azero = a
+    | otherwise = runST $ do
+        r  <- new (la+lb)
+        ma <- unsafeThaw a
+        mb <- unsafeThaw b
+        copyAt r (Offset 0) ma (Offset 0) la
+        copyAt r (sizeAsOffset la) mb (Offset 0) lb
+        unsafeFreeze r
+  where
+    !la = length a
+    !lb = length b
+
+concat :: forall ty . PrimType ty => [UArray ty] -> UArray ty
+concat original = runST $ do
+    r <- new total
+    goCopy r 0 original
+    unsafeFreeze r
+  where
+    !total = size 0 original
+    -- size
+    size !sz []     = sz
+    size !sz (x:xs) = size (length x + sz) xs
+
+    zero = Offset 0
+
+    goCopy r = loop
+      where
+        loop _  []      = pure ()
+        loop !i (x:xs) = do
+            unsafeCopyAtRO r i x zero lx
+            loop (i `offsetPlusE` lx) xs
+          where !lx = length x
+
+-- | Create a Block from a UArray.
+--
+-- Note that because of the slice, the destination block
+-- is re-allocated and copied, unless the slice point
+-- at the whole array
+toBlock :: PrimType ty => UArray ty -> Block ty
+toBlock arr@(UArray start len (UArrayBA blk))
+    | start == 0 && BLK.length blk == len = blk
+    | otherwise                           = toBlock $ copy arr
+toBlock arr = toBlock $ copy arr

bundled/Basement/UArray/Mutable.hs

@@ -0,0 +1,187 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.UArray.Mutable -- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A simple array abstraction that allow to use typed
+-- array of bytes where the array is pinned in memory
+-- to allow easy use with Foreign interfaces, ByteString
+-- and always aligned to 64 bytes.
+--
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Basement.UArray.Mutable
+    ( MUArray(..)
+    -- * Property queries
+    , sizeInMutableBytesOfContent
+    , mutableLength
+    , mutableOffset
+    , mutableSame
+    , onMutableBackend
+    -- * Allocation & Copy
+    , new
+    , newPinned
+    , newNative
+    , newNative_
+    , mutableForeignMem
+    , copyAt
+    , copyFromPtr
+    , copyToPtr
+    , sub
+    -- , copyAddr
+    -- * Reading and Writing cells
+    , unsafeWrite
+    , unsafeRead
+    , write
+    , read
+    , withMutablePtr
+    , withMutablePtrHint
+    ) where
+
+import           GHC.Prim
+import           GHC.Exts
+import           GHC.Types
+import           GHC.Ptr
+import           Basement.Compat.Base
+import           Basement.Compat.Primitive
+import           Data.Proxy
+import           Basement.Types.OffsetSize
+import           Basement.Monad
+import           Basement.PrimType
+import           Basement.FinalPtr
+import           Basement.Exception
+import qualified Basement.Block         as BLK
+import qualified Basement.Block.Mutable as MBLK
+import           Basement.Block         (MutableBlock(..))
+import           Basement.UArray.Base hiding (empty)
+import           Basement.Numerical.Subtractive
+import           Foreign.Marshal.Utils (copyBytes)
+
+sizeInMutableBytesOfContent :: forall ty s . PrimType ty => MUArray ty s -> CountOf Word8
+sizeInMutableBytesOfContent _ = primSizeInBytes (Proxy :: Proxy ty)
+{-# INLINE sizeInMutableBytesOfContent #-}
+
+-- | read a cell in a mutable array.
+--
+-- If the index is out of bounds, an error is raised.
+read :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty
+read array n
+    | isOutOfBound n len = primOutOfBound OOB_Read n len
+    | otherwise          = unsafeRead array n
+  where len = mutableLength array
+{-# INLINE read #-}
+
+-- | Write to a cell in a mutable array.
+--
+-- If the index is out of bounds, an error is raised.
+write :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim ()
+write array n val
+    | isOutOfBound n len = primOutOfBound OOB_Write n len
+    | otherwise          = unsafeWrite array n val
+  where
+    len = mutableLength array
+{-# INLINE write #-}
+
+empty :: (PrimType ty, PrimMonad prim) => prim (MUArray ty (PrimState prim))
+empty = MUArray 0 0 . MUArrayMBA <$> MBLK.mutableEmpty
+
+mutableSame :: MUArray ty st -> MUArray ty st -> Bool
+mutableSame (MUArray sa ea (MUArrayMBA (MutableBlock ma))) (MUArray sb eb (MUArrayMBA (MutableBlock mb))) = (sa == sb) && (ea == eb) && bool# (sameMutableByteArray# ma mb)
+mutableSame (MUArray s1 e1 (MUArrayAddr f1)) (MUArray s2 e2 (MUArrayAddr f2)) = (s1 == s2) && (e1 == e2) && finalPtrSameMemory f1 f2
+mutableSame _ _ = False
+
+mutableForeignMem :: (PrimMonad prim, PrimType ty)
+                  => FinalPtr ty -- ^ the start pointer with a finalizer
+                  -> Int         -- ^ the number of elements (in elements, not bytes)
+                  -> prim (MUArray ty (PrimState prim))
+mutableForeignMem fptr nb = pure $ MUArray (Offset 0) (CountOf nb) (MUArrayAddr fptr)
+
+sub :: (PrimMonad prim, PrimType ty)
+    => MUArray ty (PrimState prim)
+    -> Int -- The number of elements to drop ahead
+    -> Int -- Then the number of element to retain
+    -> prim (MUArray ty (PrimState prim))
+sub (MUArray start sz back) dropElems' takeElems
+    | takeElems <= 0 = empty
+    | Just keepElems <- sz - dropElems, keepElems > 0
+                     = pure $ MUArray (start `offsetPlusE` dropElems) (min (CountOf takeElems) keepElems) back
+    | otherwise      = empty
+  where
+    dropElems = max 0 (CountOf dropElems')
+
+
+-- | return the numbers of elements in a mutable array
+mutableLength :: PrimType ty => MUArray ty st -> CountOf ty
+mutableLength (MUArray _ end _)   = end
+
+withMutablePtrHint :: forall ty prim a . (PrimMonad prim, PrimType ty)
+                   => Bool
+                   -> Bool
+                   -> MUArray ty (PrimState prim)
+                   -> (Ptr ty -> prim a)
+                   -> prim a
+withMutablePtrHint skipCopy skipCopyBack (MUArray start _ back) f =
+    case back of
+        MUArrayAddr fptr -> withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os))
+        MUArrayMBA mb    -> MBLK.withMutablePtrHint skipCopy skipCopyBack mb $ \ptr -> f (ptr `plusPtr` os)
+  where
+    sz           = primSizeInBytes (Proxy :: Proxy ty)
+    !(Offset os) = offsetOfE sz start
+
+-- | Create a pointer on the beginning of the mutable array
+-- and call a function 'f'.
+--
+-- The mutable buffer can be mutated by the 'f' function
+-- and the change will be reflected in the mutable array
+--
+-- If the mutable array is unpinned, a trampoline buffer
+-- is created and the data is only copied when 'f' return.
+withMutablePtr :: (PrimMonad prim, PrimType ty)
+               => MUArray ty (PrimState prim)
+               -> (Ptr ty -> prim a)
+               -> prim a
+withMutablePtr = withMutablePtrHint False False
+
+-- | Copy from a pointer, @count@ elements, into the mutable array
+copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty)
+            => Ptr ty -> CountOf ty -> MUArray ty (PrimState prim) -> prim ()
+copyFromPtr src@(Ptr src#) count marr
+    | count > arrSz = primOutOfBound OOB_MemCopy (sizeAsOffset count) arrSz
+    | otherwise     = onMutableBackend copyNative copyPtr marr
+  where
+    arrSz = mutableLength marr
+    ofs = mutableOffset marr
+
+    sz = primSizeInBytes (Proxy :: Proxy ty)
+    !count'@(CountOf bytes@(I# bytes#)) = sizeOfE sz count
+    !off'@(Offset od@(I# od#)) = offsetOfE sz ofs
+
+    copyNative mba = MBLK.unsafeCopyBytesPtr mba off' src count'
+    copyPtr fptr = withFinalPtr fptr $ \dst ->
+        unsafePrimFromIO $ copyBytes (dst `plusPtr` od) src bytes
+
+-- | Copy all the block content to the memory starting at the destination address
+copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim)
+          => MUArray ty (PrimState prim) -- ^ the source mutable array to copy
+          -> Ptr ty                      -- ^ The destination address where the copy is going to start
+          -> prim ()
+copyToPtr marr dst@(Ptr dst#) = onMutableBackend copyNative copyPtr marr
+  where
+    copyNative (MutableBlock mba) = primitive $ \s1 ->
+        case unsafeFreezeByteArray# mba s1 of
+            (# s2, ba #) -> (# copyByteArrayToAddr# ba os# dst# szBytes# s2, () #)
+    copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr ->
+        copyBytes dst (ptr `plusPtr` os) szBytes
+
+    !(Offset os@(I# os#)) = offsetInBytes $ mutableOffset marr
+    !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ mutableLength marr
+
+mutableOffset :: MUArray ty st -> Offset ty
+mutableOffset (MUArray ofs _ _) = ofs

bundled/Basement/UTF8/Base.hs

@@ -0,0 +1,240 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.String
+-- License     : BSD-style
+-- Maintainer  : Foundation
+--
+-- A String type backed by a UTF8 encoded byte array and all the necessary
+-- functions to manipulate the string.
+--
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE CPP                        #-}
+module Basement.UTF8.Base
+    where
+
+import           GHC.ST (ST, runST)
+import           GHC.Types
+import           GHC.Word
+import           GHC.Prim
+import           GHC.Exts (build)
+import           Basement.Compat.Base
+import           Basement.Numerical.Additive
+import           Basement.Compat.Bifunctor
+import           Basement.NormalForm
+import           Basement.Types.OffsetSize
+import           Basement.PrimType
+import           Basement.Monad
+import           Basement.FinalPtr
+import           Basement.UTF8.Helper
+import           Basement.UTF8.Types
+import qualified Basement.Alg.UTF8         as UTF8
+import           Basement.UArray           (UArray)
+import           Basement.Block            (MutableBlock)
+import qualified Basement.Block.Mutable    as BLK
+import qualified Basement.UArray           as Vec
+import qualified Basement.UArray           as C
+import qualified Basement.UArray.Mutable   as MVec
+import           Basement.UArray.Base   as Vec (offset, pureST, onBackend, ValidRange(..), offsetsValidRange)
+import           GHC.CString                        (unpackCString#, unpackCStringUtf8#)
+
+import           Data.Data
+import           Basement.Compat.ExtList as List
+import           Basement.Compat.Semigroup (Semigroup)
+
+-- | Opaque packed array of characters in the UTF8 encoding
+newtype String = String (UArray Word8)
+    deriving (Typeable, Semigroup, Monoid, Eq, Ord)
+
+-- | Mutable String Buffer.
+--
+-- Use as an *append* buffer, as UTF8 variable encoding
+-- doesn't really allow to change previously written
+-- character without potentially shifting bytes.
+newtype MutableString st = MutableString (MVec.MUArray Word8 st)
+    deriving (Typeable)
+
+instance Show String where
+    show = show . sToList
+instance IsString String where
+    fromString = sFromList
+instance IsList String where
+    type Item String = Char
+    fromList = sFromList
+    toList = sToList
+
+instance Data String where
+    toConstr s   = mkConstr stringType (show s) [] Prefix
+    dataTypeOf _ = stringType
+    gunfold _ _  = error "gunfold"
+
+instance NormalForm String where
+    toNormalForm (String ba) = toNormalForm ba
+
+stringType :: DataType
+stringType = mkNoRepType "Foundation.String"
+
+-- | size in bytes.
+--
+-- this size is available in o(1)
+size :: String -> CountOf Word8
+size (String ba) = Vec.length ba
+
+-- | Convert a String to a list of characters
+--
+-- The list is lazily created as evaluation needed
+sToList :: String -> [Char]
+sToList (String arr) = Vec.onBackend onBA onAddr arr
+  where
+    (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr
+    onBA ba@(BLK.Block _) = loop start
+      where
+        loop !idx
+            | idx == end = []
+            | otherwise  = let !(Step c idx') = UTF8.next ba idx in c : loop idx'
+    onAddr fptr ptr@(Ptr _) = pureST (loop start)
+      where
+        loop !idx
+            | idx == end = []
+            | otherwise  = let !(Step c idx') = UTF8.next ptr idx in c : loop idx'
+{-# NOINLINE sToList #-}
+
+sToListStream (String arr) k z = Vec.onBackend onBA onAddr arr
+  where
+    (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr
+    onBA ba@(BLK.Block _) = loop start
+      where
+        loop !idx
+            | idx == end = z
+            | otherwise  = let !(Step c idx') = UTF8.next ba idx in c `k` loop idx'
+    onAddr fptr ptr@(Ptr _) = pureST (loop start)
+      where
+        loop !idx
+            | idx == end = z
+            | otherwise  = let !(Step c idx') = UTF8.next ptr idx in c `k` loop idx'
+
+{-# RULES "String sToList" [~1] forall s . sToList s = build (\ k z -> sToListStream s k z) #-}
+{-# RULES "String toList" [~1] forall s . toList s = build (\ k z -> sToListStream s k z) #-}
+
+{-# RULES "String sFromList" forall s .  sFromList (unpackCString# s) = fromModified s #-}
+{-# RULES "String sFromList" forall s .  sFromList (unpackCStringUtf8# s) = fromModified s #-}
+
+-- | assuming the given Addr# is a valid modified UTF-8 sequence of bytes
+--
+-- We only modify the given Unicode Null-character (0xC080) into a null bytes
+--
+-- FIXME: need to evaluate the kind of modified UTF8 GHC is actually expecting
+-- it is plausible they only handle the Null Bytes, which this function actually
+-- does.
+fromModified :: Addr# -> String
+fromModified addr = countAndCopy 0 0
+  where
+    countAndCopy :: CountOf Word8 -> Offset Word8 -> String
+    countAndCopy count ofs =
+        case primAddrIndex addr ofs of
+            0x00 -> runST $ do
+                        mb <- MVec.newNative_ count (copy count)
+                        String <$> Vec.unsafeFreeze mb
+            0xC0 -> case primAddrIndex addr (ofs+1) of
+                        0x80 -> countAndCopy (count+1) (ofs+2)
+                        _    -> countAndCopy (count+2) (ofs+2)
+            _    -> countAndCopy (count+1) (ofs+1)
+
+    copy :: CountOf Word8 -> MutableBlock Word8 st -> ST st ()
+    copy count mba = loop 0 0
+      where loop o i
+                | o .==# count = pure ()
+                | otherwise    =
+                    case primAddrIndex addr i of
+                        0xC0 -> case primAddrIndex addr (i+1) of
+                                    0x80 -> BLK.unsafeWrite mba o 0x00 >> loop (o+1) (i+2)
+                                    b2   -> BLK.unsafeWrite mba o 0xC0 >> BLK.unsafeWrite mba (o+1) b2 >> loop (o+2) (i+2)
+                        b1   -> BLK.unsafeWrite mba o b1 >> loop (o+1) (i+1)
+
+
+-- | Create a new String from a list of characters
+--
+-- The list is strictly and fully evaluated before
+-- creating the new String, as the size need to be
+-- computed before filling.
+sFromList :: [Char] -> String
+sFromList l = runST (new bytes >>= startCopy)
+  where
+    -- count how many bytes
+    !bytes = List.sum $ fmap (charToBytes . fromEnum) l
+
+    startCopy :: MutableString (PrimState (ST st)) -> ST st String
+    startCopy ms = loop 0 l
+      where
+        loop _   []     = freeze ms
+        loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs
+{-# INLINE [0] sFromList #-}
+
+next :: String -> Offset8 -> Step
+next (String array) !n = Vec.onBackend nextBA nextAddr array
+  where
+    !start = Vec.offset array
+    reoffset (Step a ofs) = Step a (ofs `offsetSub` start)
+    nextBA ba@(BLK.Block _) = reoffset (UTF8.next ba (start + n))
+    nextAddr _ ptr@(Ptr _)  = pureST $ reoffset (UTF8.next ptr (start + n))
+
+prev :: String -> Offset8 -> StepBack
+prev (String array) !n = Vec.onBackend prevBA prevAddr array
+  where
+    !start = Vec.offset array
+    reoffset (StepBack a ofs) = StepBack a (ofs `offsetSub` start)
+    prevBA ba@(BLK.Block _) = reoffset (UTF8.prev ba (start + n))
+    prevAddr _ ptr@(Ptr _)  = pureST $ reoffset (UTF8.prev ptr (start + n))
+
+-- A variant of 'next' when you want the next character
+-- to be ASCII only.
+nextAscii :: String -> Offset8 -> StepASCII
+nextAscii (String ba) n = StepASCII w
+  where
+    !w = Vec.unsafeIndex ba n
+
+expectAscii :: String -> Offset8 -> Word8 -> Bool
+expectAscii (String ba) n v = Vec.unsafeIndex ba n == v
+{-# INLINE expectAscii #-}
+
+write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8
+write (MutableString marray) ofs c =
+    MVec.onMutableBackend (\mba@(BLK.MutableBlock _) -> UTF8.writeUTF8 mba (start + ofs) c)
+                          (\fptr -> withFinalPtr fptr $ \ptr@(Ptr _) -> UTF8.writeUTF8 ptr (start + ofs) c)
+                          marray
+  where start = MVec.mutableOffset marray
+
+-- | Allocate a MutableString of a specific size in bytes.
+new :: PrimMonad prim
+    => CountOf Word8 -- ^ in number of bytes, not of elements.
+    -> prim (MutableString (PrimState prim))
+new n = MutableString `fmap` MVec.new n
+
+newNative :: PrimMonad prim
+          => CountOf Word8 -- ^ in number of bytes, not of elements.
+          -> (MutableBlock Word8 (PrimState prim) -> prim a)
+          -> prim (a, MutableString (PrimState prim))
+newNative n f = second MutableString `fmap` MVec.newNative n f
+
+newNative_ :: PrimMonad prim
+           => CountOf Word8 -- ^ in number of bytes, not of elements.
+           -> (MutableBlock Word8 (PrimState prim) -> prim ())
+           -> prim (MutableString (PrimState prim))
+newNative_ n f = MutableString `fmap` MVec.newNative_ n f
+
+freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String
+freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba
+{-# INLINE freeze #-}
+
+freezeShrink :: PrimMonad prim
+             => CountOf Word8
+             -> MutableString (PrimState prim)
+             -> prim String
+freezeShrink n (MutableString mba) = String `fmap` C.unsafeFreezeShrink mba n

bundled/Basement/UTF8/Helper.hs

@@ -0,0 +1,251 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.UTF8.Helper
+-- License     : BSD-style
+-- Maintainer  : Foundation
+--
+-- Some low level helpers to use UTF8
+--
+-- Most helpers are lowlevel and unsafe, don't use
+-- directly.
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE CPP                        #-}
+module Basement.UTF8.Helper
+    where
+
+import           Basement.Compat.Base
+import           Basement.Compat.Primitive
+import           Basement.Types.OffsetSize
+import           Basement.UTF8.Types
+import           Basement.Bits
+import           GHC.Prim
+import           GHC.Types
+import           GHC.Word
+
+-- mask an UTF8 continuation byte (stripping the leading 10 and returning 6 valid bits)
+maskContinuation# :: Word# -> Word#
+maskContinuation# v = and# v 0x3f##
+{-# INLINE maskContinuation# #-}
+
+-- mask a UTF8 header for 2 bytes encoding (110xxxxx and 5 valid bits)
+maskHeader2# :: Word# -> Word#
+maskHeader2# h = and# h 0x1f##
+{-# INLINE maskHeader2# #-}
+
+-- mask a UTF8 header for 3 bytes encoding (1110xxxx and 4 valid bits)
+maskHeader3# :: Word# -> Word#
+maskHeader3# h = and# h 0xf##
+{-# INLINE maskHeader3# #-}
+
+-- mask a UTF8 header for 4 bytes encoding (11110xxx and 3 valid bits)
+maskHeader4# :: Word# -> Word#
+maskHeader4# h = and# h 0x7##
+{-# INLINE maskHeader4# #-}
+
+or3# :: Word# -> Word# -> Word# -> Word#
+or3# a b c = or# a (or# b c)
+{-# INLINE or3# #-}
+
+or4# :: Word# -> Word# -> Word# -> Word# -> Word#
+or4# a b c d = or# (or# a b) (or# c d)
+{-# INLINE or4# #-}
+
+toChar# :: Word# -> Char
+toChar# w = C# (chr# (word2Int# w))
+{-# INLINE toChar# #-}
+
+toChar1 :: StepASCII -> Char
+toChar1 (StepASCII (W8# w)) = C# (word8ToChar# w)
+
+toChar2 :: StepASCII -> Word8 -> Char
+toChar2 (StepASCII (W8# b1)) (W8# b2) =
+    toChar# (or# (uncheckedShiftL# (maskHeader2# w1) 6#) (maskContinuation# w2))
+  where
+    w1 = word8ToWord# b1
+    w2 = word8ToWord# b2
+
+toChar3 :: StepASCII -> Word8 -> Word8 -> Char
+toChar3 (StepASCII (W8# b1)) (W8# b2) (W8# b3) =
+    toChar# (or3# (uncheckedShiftL# (maskHeader3# w1) 12#)
+                  (uncheckedShiftL# (maskContinuation# w2) 6#)
+                  (maskContinuation# w3)
+            )
+  where
+    w1 = word8ToWord# b1
+    w2 = word8ToWord# b2
+    w3 = word8ToWord# b3
+
+toChar4 :: StepASCII -> Word8 -> Word8 -> Word8 -> Char
+toChar4 (StepASCII (W8# b1)) (W8# b2) (W8# b3) (W8# b4) =
+    toChar# (or4# (uncheckedShiftL# (maskHeader4# w1) 18#)
+                  (uncheckedShiftL# (maskContinuation# w2) 12#)
+                  (uncheckedShiftL# (maskContinuation# w3) 6#)
+                  (maskContinuation# w4)
+            )
+  where
+    w1 = word8ToWord# b1
+    w2 = word8ToWord# b2
+    w3 = word8ToWord# b3
+    w4 = word8ToWord# b4
+
+-- | Different way to encode a Character in UTF8 represented as an ADT
+data UTF8Char =
+      UTF8_1 {-# UNPACK #-} !Word8
+    | UTF8_2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
+    | UTF8_3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
+    | UTF8_4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
+
+-- | Transform a Unicode code point 'Char' into
+--
+-- note that we expect here a valid unicode code point in the *allowed* range.
+-- bits will be lost if going above 0x10ffff
+asUTF8Char :: Char -> UTF8Char
+asUTF8Char !(C# c)
+  | bool# (ltWord# x 0x80##   ) = encode1
+  | bool# (ltWord# x 0x800##  ) = encode2
+  | bool# (ltWord# x 0x10000##) = encode3
+  | otherwise                   = encode4
+    where
+      !x = int2Word# (ord# c)
+
+      encode1 = UTF8_1 (W8# (wordToWord8# x))
+      encode2 =
+          let !x1 = W8# (wordToWord8# (or# (uncheckedShiftRL# x 6#) 0xc0##))
+              !x2 = toContinuation x
+           in UTF8_2 x1 x2
+      encode3 =
+          let !x1 = W8# (wordToWord8# (or# (uncheckedShiftRL# x 12#) 0xe0##))
+              !x2 = toContinuation (uncheckedShiftRL# x 6#)
+              !x3 = toContinuation x
+           in UTF8_3 x1 x2 x3
+      encode4 =
+          let !x1 = W8# (wordToWord8# (or# (uncheckedShiftRL# x 18#) 0xf0##))
+              !x2 = toContinuation (uncheckedShiftRL# x 12#)
+              !x3 = toContinuation (uncheckedShiftRL# x 6#)
+              !x4 = toContinuation x
+           in UTF8_4 x1 x2 x3 x4
+
+      toContinuation :: Word# -> Word8
+      toContinuation w = W8# (wordToWord8# (or# (and# w 0x3f##) 0x80##))
+      {-# INLINE toContinuation #-}
+
+-- given the encoding of UTF8 Char, get the number of bytes of this sequence
+numBytes :: UTF8Char -> CountOf Word8
+numBytes UTF8_1{} = CountOf 1
+numBytes UTF8_2{} = CountOf 2
+numBytes UTF8_3{} = CountOf 3
+numBytes UTF8_4{} = CountOf 4
+
+-- given the leading byte of a utf8 sequence, get the number of bytes of this sequence
+skipNextHeaderValue :: Word8 -> CountOf Word8
+skipNextHeaderValue !x
+    | x < 0xC0  = CountOf 1 -- 0b11000000
+    | x < 0xE0  = CountOf 2 -- 0b11100000
+    | x < 0xF0  = CountOf 3 -- 0b11110000
+    | otherwise = CountOf 4
+{-# INLINE skipNextHeaderValue #-}
+
+headerIsAscii :: StepASCII -> Bool
+headerIsAscii (StepASCII x) = x < 0x80
+
+charToBytes :: Int -> CountOf Word8
+charToBytes c
+    | c < 0x80     = CountOf 1
+    | c < 0x800    = CountOf 2
+    | c < 0x10000  = CountOf 3
+    | c < 0x110000 = CountOf 4
+    | otherwise    = error ("invalid code point: " `mappend` show c)
+
+-- | Encode a Char into a CharUTF8
+encodeCharUTF8 :: Char -> CharUTF8
+encodeCharUTF8 !(C# c)
+    | bool# (ltWord# x 0x80##   ) = CharUTF8 (W32# (wordToWord32# x))
+    | bool# (ltWord# x 0x800##  ) = CharUTF8 (W32# (wordToWord32# encode2))
+    | bool# (ltWord# x 0x10000##) = CharUTF8 (W32# (wordToWord32# encode3))
+    | otherwise                   = CharUTF8 (W32# (wordToWord32# encode4))
+  where
+    !x = int2Word# (ord# c)
+
+    -- clearing mask, clearing all the bits that need to be clear as per the UTF8 encoding
+    mask2 = 0x0000bfdf## -- 1 continuation , 5 bits header
+    mask3 = 0x00bfbfef## -- 2 continuations, 4 bits header
+    mask4 = 0xbfbfbff7## -- 3 continuations, 3 bits header
+
+    -- setting mask, settings all the bits that need to be set per the UTF8 encoding
+    set2  = 0x000080c0## -- 10xxxxxx     110xxxxx
+    set3  = 0x008080e0## -- 10xxxxxx * 2 1110xxxx
+    set4  = 0x808080f0## -- 10xxxxxx * 3 11111xxx
+
+    encode2 = and# mask2 (or3# set2
+                               (uncheckedShiftRL# x 6#) -- 5 bits to 1st byte
+                               (uncheckedShiftL# x 8# ) -- move lowest bits to the 2nd byte
+                         )
+    encode3 = and# mask3 (or4# set3
+                               (uncheckedShiftRL# x 12#) -- 4 bits to 1st byte
+                               (and# 0x3f00## (uncheckedShiftL# x 2#)) -- 6 bits to the 2nd byte
+                               (uncheckedShiftL# x 16# ) -- move lowest bits to the 3rd byte
+                         )
+    encode4 = and# mask4 (or4# set4
+                               (uncheckedShiftRL# x 18#) -- 3 bits to 1st byte
+                               (or# (and# 0x3f00## (uncheckedShiftRL# x 4#))   -- 6 bits to the 2nd byte
+                                    (and# 0x3f0000## (uncheckedShiftL# x 10#)) -- 6 bits to the 3nd byte
+                               )
+                               (uncheckedShiftL# x 24# ) -- move lowest bits to the 4rd byte
+                         )
+
+-- | decode a CharUTF8 into a Char
+--
+-- If the value inside a CharUTF8 is not properly encoded, this will result in violation
+-- of the Char invariants
+decodeCharUTF8 :: CharUTF8 -> Char
+decodeCharUTF8 c@(CharUTF8 !(W32# w_))
+    | isCharUTF8Case1 c = toChar# w
+    | isCharUTF8Case2 c = encode2
+    | isCharUTF8Case3 c = encode3
+    | otherwise         = encode4
+  where
+    w = word32ToWord# w_
+    encode2 =
+        toChar# (or# (uncheckedShiftL# (maskHeader2# w) 6#)
+                     (maskContinuation# (uncheckedShiftRL# w 8#))
+                )
+    encode3 =
+        toChar# (or3# (uncheckedShiftL# (maskHeader3# w) 12#)
+                      (uncheckedShiftRL# (and# 0x3f00## w) 8#)
+                      (maskContinuation# (uncheckedShiftRL# w 16#))
+                )
+    encode4 =
+        toChar# (or4# (uncheckedShiftL#  (maskHeader4# w) 18#)
+                      (uncheckedShiftRL# (and# 0x3f00## w) 10#)
+                      (uncheckedShiftL#  (and# 0x3f0000## w) 4#)
+                      (maskContinuation# (uncheckedShiftRL# w 24#))
+                )
+
+    -- clearing mask, removing all UTF8 metadata and keeping only signal (content)
+    --maskContent2 = 0x00003f1f## -- 1 continuation , 5 bits header
+    --maskContent3 = 0x003f3f0f## -- 2 continuations, 4 bits header
+    --maskContent4 = 0x3f3f3f07## -- 3 continuations, 3 bits header
+
+isCharUTF8Case1 :: CharUTF8 -> Bool
+isCharUTF8Case1 (CharUTF8 !w) = (w .&. 0x80) == 0
+{-# INLINE isCharUTF8Case1 #-}
+
+isCharUTF8Case2 :: CharUTF8 -> Bool
+isCharUTF8Case2 (CharUTF8 !w) = (w .&. 0x20) == 0
+{-# INLINE isCharUTF8Case2 #-}
+
+isCharUTF8Case3 :: CharUTF8 -> Bool
+isCharUTF8Case3 (CharUTF8 !w) = (w .&. 0x10) == 0
+{-# INLINE isCharUTF8Case3 #-}
+
+isCharUTF8Case4 :: CharUTF8 -> Bool
+isCharUTF8Case4 (CharUTF8 !w) = (w .&. 0x08) == 0
+{-# INLINE isCharUTF8Case4 #-}

bundled/Basement/UTF8/Table.hs

@@ -0,0 +1,121 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.UTF8.Table
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- UTF8 lookup tables for fast continuation & nb bytes per header queries
+{-# LANGUAGE MagicHash #-}
+module Basement.UTF8.Table
+    ( isContinuation
+    , isContinuation2
+    , isContinuation3
+    , getNbBytes
+    , isContinuation#
+    , isContinuationW#
+    , getNbBytes#
+    ) where
+
+import           GHC.Prim (Word#, Int#, Addr#, indexWord8OffAddr#, word2Int#)
+import           GHC.Types
+import           GHC.Word
+import           Basement.Compat.Base
+import           Basement.Compat.Primitive
+import           Basement.Bits
+import           Basement.UTF8.Types (StepASCII(..))
+
+-- | Check if the byte is a continuation byte
+isContinuation :: Word8 -> Bool
+isContinuation (W8# w) = isContinuation# w
+{-# INLINE isContinuation #-}
+
+isContinuation2 :: Word8 -> Word8 -> Bool
+isContinuation2 !w1 !w2 = mask w1 && mask w2
+  where
+    mask v = (v .&. 0xC0) == 0x80
+{-# INLINE isContinuation2 #-}
+
+isContinuation3 :: Word8 -> Word8 -> Word8 -> Bool
+isContinuation3 !w1 !w2 !w3 =
+    mask w1 && mask w2 && mask w3
+  where
+    mask v = (v .&. 0xC0) == 0x80
+{-# INLINE isContinuation3 #-}
+
+-- | Number of bytes associated with a specific header byte
+--
+-- If the header byte is invalid then NbBytesInvalid is returned,
+data NbBytesCont = NbBytesInvalid | NbBytesCont0 | NbBytesCont1 | NbBytesCont2 | NbBytesCont3
+
+-- | Identical to 'NbBytesCont' but doesn't allow to represent any failure.
+--
+-- Only use in validated place
+data NbBytesCont_ = NbBytesCont0_ | NbBytesCont1_ | NbBytesCont2_ | NbBytesCont3_
+
+-- | Get the number of following bytes given the first byte of a UTF8 sequence.
+getNbBytes :: StepASCII -> Int
+getNbBytes (StepASCII (W8# w)) = I# (getNbBytes# w)
+{-# INLINE getNbBytes #-}
+
+-- | Check if the byte is a continuation byte
+isContinuation# :: Word8# -> Bool
+isContinuation# w = W8# (indexWord8OffAddr# (unTable contTable) (word2Int# (word8ToWord# w))) == 0
+{-# INLINE isContinuation# #-}
+
+-- | Check if the byte is a continuation byte
+isContinuationW# :: Word# -> Bool
+isContinuationW# w = W8# (indexWord8OffAddr# (unTable contTable) (word2Int# w)) == 0
+{-# INLINE isContinuationW# #-}
+
+-- | Get the number of following bytes given the first byte of a UTF8 sequence.
+getNbBytes# :: Word8# -> Int#
+getNbBytes# w = word8ToInt# (indexWord8OffAddr# (unTable headTable) (word2Int# (word8ToWord# w)))
+{-# INLINE getNbBytes# #-}
+
+data Table = Table { unTable :: !Addr# }
+
+contTable :: Table
+contTable = Table
+        "\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01"#
+{-# NOINLINE contTable #-}
+
+headTable :: Table
+headTable = Table
+        "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\
+        \\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\
+        \\x03\x03\x03\x03\x03\x03\x03\x03\xff\xff\xff\xff\xff\xff\xff\xff"#
+{-# NOINLINE headTable #-}

bundled/Basement/UTF8/Types.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Basement.UTF8.Types
+    (
+    -- * Stepper
+      Step(..)
+    , StepBack(..)
+    , StepASCII(..)
+    , StepDigit(..)
+    , isValidStepASCII
+    , isValidStepDigit
+    -- * Unicode Errors
+    , ValidationFailure(..)
+    -- * UTF8 Encoded 'Char'
+    , CharUTF8(..)
+    -- * Case Conversion
+    , CM (..)
+    ) where
+
+import           Basement.Compat.Base
+import           Basement.Types.OffsetSize
+
+-- | Step when walking a String
+--
+-- this is a return value composed of :
+-- * the unicode code point read (Char) which need to be
+--   between 0 and 0x10ffff (inclusive)
+-- * The next offset to start reading the next unicode code point (or end)
+data Step = Step {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8)
+
+-- | Similar to Step but used when processing the string from the end.
+--
+-- The stepper is thus the previous character, and the offset of
+-- the beginning of the previous character
+data StepBack = StepBack {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8)
+
+-- | Step when processing digits. the value is between 0 and 9 to be valid
+newtype StepDigit = StepDigit Word8
+
+-- | Step when processing ASCII character
+newtype StepASCII = StepASCII { stepAsciiRawValue :: Word8 }
+
+-- | Specialized tuple used for case mapping.
+data CM = CM {-# UNPACK #-} !Char {-# UNPACK #-} !Char {-# UNPACK #-} !Char deriving (Eq)
+
+-- | Represent an already encoded UTF8 Char where the the lowest 8 bits is the start of the
+-- sequence. If this contains a multi bytes sequence then each higher 8 bits are filled with
+-- the remaining sequence 8 bits per 8 bits.
+--
+-- For example:
+-- 'A' => U+0041  => 41          => 0x00000041
+-- '€  => U+20AC  => E2 82 AC    => 0x00AC82E2
+-- '𐍈' => U+10348 => F0 90 8D 88 => 0x888D90F0
+--
+newtype CharUTF8 = CharUTF8 Word32
+
+isValidStepASCII :: StepASCII -> Bool
+isValidStepASCII (StepASCII w) = w < 0x80
+
+isValidStepDigit :: StepDigit -> Bool
+isValidStepDigit (StepDigit w) = w < 0xa
+
+-- | Possible failure related to validating bytes of UTF8 sequences.
+data ValidationFailure = InvalidHeader
+                       | InvalidContinuation
+                       | MissingByte
+                       | BuildingFailure
+                       deriving (Show,Eq,Typeable)
+
+instance Exception ValidationFailure

bundled/Crypto/Cipher/AES.hs

@@ -0,0 +1,70 @@
+-- |
+-- Module      : Crypto.Cipher.AES
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.Cipher.AES
+    ( AES128
+    , AES192
+    , AES256
+    ) where
+
+import Crypto.Error
+import Crypto.Cipher.Types
+import Crypto.Cipher.Utils
+import Crypto.Cipher.Types.Block
+import Crypto.Cipher.AES.Primitive
+import Crypto.Internal.Imports
+
+-- | AES with 128 bit key
+newtype AES128 = AES128 AES
+    deriving (NFData)
+
+-- | AES with 192 bit key
+newtype AES192 = AES192 AES
+    deriving (NFData)
+
+-- | AES with 256 bit key
+newtype AES256 = AES256 AES
+    deriving (NFData)
+
+instance Cipher AES128 where
+    cipherName    _ = "AES128"
+    cipherKeySize _ = KeySizeFixed 16
+    cipherInit k    = AES128 <$> (initAES =<< validateKeySize (undefined :: AES128) k)
+
+instance Cipher AES192 where
+    cipherName    _ = "AES192"
+    cipherKeySize _ = KeySizeFixed 24
+    cipherInit k    = AES192 <$> (initAES =<< validateKeySize (undefined :: AES192) k)
+
+instance Cipher AES256 where
+    cipherName    _ = "AES256"
+    cipherKeySize _ = KeySizeFixed 32
+    cipherInit k    = AES256 <$> (initAES =<< validateKeySize (undefined :: AES256) k)
+
+
+#define INSTANCE_BLOCKCIPHER(CSTR) \
+instance BlockCipher CSTR where \
+    { blockSize _ = 16 \
+    ; ecbEncrypt (CSTR aes) = encryptECB aes \
+    ; ecbDecrypt (CSTR aes) = decryptECB aes \
+    ; cbcEncrypt (CSTR aes) (IV iv) = encryptCBC aes (IV iv) \
+    ; cbcDecrypt (CSTR aes) (IV iv) = decryptCBC aes (IV iv) \
+    ; ctrCombine (CSTR aes) (IV iv) = encryptCTR aes (IV iv) \
+    ; aeadInit AEAD_GCM (CSTR aes) iv = CryptoPassed $ AEAD (gcmMode aes) (gcmInit aes iv) \
+    ; aeadInit AEAD_OCB (CSTR aes) iv = CryptoPassed $ AEAD (ocbMode aes) (ocbInit aes iv) \
+    ; aeadInit (AEAD_CCM n m l) (CSTR aes) iv = AEAD (ccmMode aes) <$> ccmInit aes iv n m l \
+    ; aeadInit _        _          _  = CryptoFailed CryptoError_AEADModeNotSupported \
+    }; \
+instance BlockCipher128 CSTR where \
+    { xtsEncrypt (CSTR aes1, CSTR aes2) (IV iv) = encryptXTS (aes1,aes2) (IV iv) \
+    ; xtsDecrypt (CSTR aes1, CSTR aes2) (IV iv) = decryptXTS (aes1,aes2) (IV iv) \
+    };
+
+INSTANCE_BLOCKCIPHER(AES128)
+INSTANCE_BLOCKCIPHER(AES192)
+INSTANCE_BLOCKCIPHER(AES256)

bundled/Crypto/Cipher/AES/Primitive.hs

@@ -0,0 +1,645 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-- |
+-- Module      : Crypto.Cipher.AES.Primitive
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+--
+module Crypto.Cipher.AES.Primitive
+    (
+    -- * Block cipher data types
+      AES
+
+    -- * Authenticated encryption block cipher types
+    , AESGCM
+    , AESOCB
+
+    -- * Creation
+    , initAES
+
+    -- * Miscellanea
+    , genCTR
+    , genCounter
+
+    -- * Encryption
+    , encryptECB
+    , encryptCBC
+    , encryptCTR
+    , encryptXTS
+
+    -- * Decryption
+    , decryptECB
+    , decryptCBC
+    , decryptCTR
+    , decryptXTS
+
+    -- * CTR with 32-bit wrapping
+    , combineC32
+
+    -- * Incremental GCM
+    , gcmMode
+    , gcmInit
+
+    -- * Incremental OCB
+    , ocbMode
+    , ocbInit
+
+    -- * CCM
+    , ccmMode
+    , ccmInit
+    ) where
+
+import           Data.Word
+import           Foreign.Ptr
+import           Foreign.C.Types
+import           Foreign.C.String
+
+import           Crypto.Error
+import           Crypto.Cipher.Types
+import           Crypto.Cipher.Types.Block (IV(..))
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes, withByteArray)
+import qualified Crypto.Internal.ByteArray as B
+
+instance Cipher AES where
+    cipherName    _ = "AES"
+    cipherKeySize _ = KeySizeEnum [16,24,32]
+    cipherInit k    = initAES k
+
+instance BlockCipher AES where
+    blockSize _ = 16
+    ecbEncrypt = encryptECB
+    ecbDecrypt = decryptECB
+    cbcEncrypt = encryptCBC
+    cbcDecrypt = decryptCBC
+    ctrCombine = encryptCTR
+    aeadInit AEAD_GCM aes iv = CryptoPassed $ AEAD (gcmMode aes) (gcmInit aes iv)
+    aeadInit AEAD_OCB aes iv = CryptoPassed $ AEAD (ocbMode aes) (ocbInit aes iv)
+    aeadInit (AEAD_CCM n m l) aes iv = AEAD (ccmMode aes) <$> ccmInit aes iv n m l
+    aeadInit _        _   _  = CryptoFailed CryptoError_AEADModeNotSupported
+instance BlockCipher128 AES where
+    xtsEncrypt = encryptXTS
+    xtsDecrypt = decryptXTS
+
+-- | Create an AES AEAD implementation for GCM
+gcmMode :: AES -> AEADModeImpl AESGCM
+gcmMode aes = AEADModeImpl
+    { aeadImplAppendHeader = gcmAppendAAD
+    , aeadImplEncrypt      = gcmAppendEncrypt aes
+    , aeadImplDecrypt      = gcmAppendDecrypt aes
+    , aeadImplFinalize     = gcmFinish aes
+    }
+
+-- | Create an AES AEAD implementation for OCB
+ocbMode :: AES -> AEADModeImpl AESOCB
+ocbMode aes = AEADModeImpl
+    { aeadImplAppendHeader = ocbAppendAAD aes
+    , aeadImplEncrypt      = ocbAppendEncrypt aes
+    , aeadImplDecrypt      = ocbAppendDecrypt aes
+    , aeadImplFinalize     = ocbFinish aes
+    }
+
+-- | Create an AES AEAD implementation for CCM
+ccmMode :: AES -> AEADModeImpl AESCCM
+ccmMode aes = AEADModeImpl
+    { aeadImplAppendHeader = ccmAppendAAD aes
+    , aeadImplEncrypt      = ccmEncrypt aes
+    , aeadImplDecrypt      = ccmDecrypt aes
+    , aeadImplFinalize     = ccmFinish aes
+    }
+
+
+-- | AES Context (pre-processed key)
+newtype AES = AES ScrubbedBytes
+    deriving (NFData)
+
+-- | AESGCM State
+newtype AESGCM = AESGCM ScrubbedBytes
+    deriving (NFData)
+
+-- | AESOCB State
+newtype AESOCB = AESOCB ScrubbedBytes
+    deriving (NFData)
+
+-- | AESCCM State
+newtype AESCCM = AESCCM ScrubbedBytes
+    deriving (NFData)
+
+sizeGCM :: Int
+sizeGCM = 320
+
+sizeOCB :: Int
+sizeOCB = 160
+
+sizeCCM :: Int
+sizeCCM = 80
+
+keyToPtr :: AES -> (Ptr AES -> IO a) -> IO a
+keyToPtr (AES b) f = withByteArray b (f . castPtr)
+
+ivToPtr :: ByteArrayAccess iv => iv -> (Ptr Word8 -> IO a) -> IO a
+ivToPtr iv f = withByteArray iv (f . castPtr)
+
+
+ivCopyPtr :: IV AES -> (Ptr Word8 -> IO a) -> IO (a, IV AES)
+ivCopyPtr (IV iv) f = (\(x,y) -> (x, IV y)) `fmap` copyAndModify iv f
+  where
+    copyAndModify :: ByteArray ba => ba -> (Ptr Word8 -> IO a) -> IO (a, ba)
+    copyAndModify ba f' = B.copyRet ba f'
+
+withKeyAndIV :: ByteArrayAccess iv => AES -> iv -> (Ptr AES -> Ptr Word8 -> IO a) -> IO a
+withKeyAndIV ctx iv f = keyToPtr ctx $ \kptr -> ivToPtr iv $ \ivp -> f kptr ivp
+
+withKey2AndIV :: ByteArrayAccess iv => AES -> AES -> iv -> (Ptr AES -> Ptr AES -> Ptr Word8 -> IO a) -> IO a
+withKey2AndIV key1 key2 iv f =
+    keyToPtr key1 $ \kptr1 -> keyToPtr key2 $ \kptr2 -> ivToPtr iv $ \ivp -> f kptr1 kptr2 ivp
+
+withGCMKeyAndCopySt :: AES -> AESGCM -> (Ptr AESGCM -> Ptr AES -> IO a) -> IO (a, AESGCM)
+withGCMKeyAndCopySt aes (AESGCM gcmSt) f =
+    keyToPtr aes $ \aesPtr -> do
+        newSt <- B.copy gcmSt (\_ -> return ())
+        a     <- withByteArray newSt $ \gcmStPtr -> f (castPtr gcmStPtr) aesPtr
+        return (a, AESGCM newSt)
+
+withNewGCMSt :: AESGCM -> (Ptr AESGCM -> IO ()) -> IO AESGCM
+withNewGCMSt (AESGCM gcmSt) f = B.copy gcmSt (f . castPtr) >>= \sm2 -> return (AESGCM sm2)
+
+withOCBKeyAndCopySt :: AES -> AESOCB -> (Ptr AESOCB -> Ptr AES -> IO a) -> IO (a, AESOCB)
+withOCBKeyAndCopySt aes (AESOCB gcmSt) f =
+    keyToPtr aes $ \aesPtr -> do
+        newSt <- B.copy gcmSt (\_ -> return ())
+        a     <- withByteArray newSt $ \gcmStPtr -> f (castPtr gcmStPtr) aesPtr
+        return (a, AESOCB newSt)
+
+withCCMKeyAndCopySt :: AES -> AESCCM -> (Ptr AESCCM -> Ptr AES -> IO a) -> IO (a, AESCCM)
+withCCMKeyAndCopySt aes (AESCCM ccmSt) f =
+    keyToPtr aes $ \aesPtr -> do
+        newSt <- B.copy ccmSt (\_ -> return ())
+        a     <- withByteArray newSt $ \ccmStPtr -> f (castPtr ccmStPtr) aesPtr
+        return (a, AESCCM newSt)
+
+-- | Initialize a new context with a key
+--
+-- Key needs to be of length 16, 24 or 32 bytes. Any other values will return failure
+initAES :: ByteArrayAccess key => key -> CryptoFailable AES
+initAES k
+    | len == 16 = CryptoPassed $ initWithRounds 10
+    | len == 24 = CryptoPassed $ initWithRounds 12
+    | len == 32 = CryptoPassed $ initWithRounds 14
+    | otherwise = CryptoFailed CryptoError_KeySizeInvalid
+  where len = B.length k
+        initWithRounds nbR = AES $ B.allocAndFreeze (16+2*2*16*nbR) aesInit
+        aesInit ptr = withByteArray k $ \ikey ->
+            c_aes_init (castPtr ptr) (castPtr ikey) (fromIntegral len)
+
+-- | encrypt using Electronic Code Book (ECB)
+{-# NOINLINE encryptECB #-}
+encryptECB :: ByteArray ba => AES -> ba -> ba
+encryptECB = doECB c_aes_encrypt_ecb
+
+-- | encrypt using Cipher Block Chaining (CBC)
+{-# NOINLINE encryptCBC #-}
+encryptCBC :: ByteArray ba
+           => AES        -- ^ AES Context
+           -> IV AES     -- ^ Initial vector of AES block size
+           -> ba         -- ^ plaintext
+           -> ba         -- ^ ciphertext
+encryptCBC = doCBC c_aes_encrypt_cbc
+
+-- | generate a counter mode pad. this is generally xor-ed to an input
+-- to make the standard counter mode block operations.
+--
+-- if the length requested is not a multiple of the block cipher size,
+-- more data will be returned, so that the returned bytearray is
+-- a multiple of the block cipher size.
+{-# NOINLINE genCTR #-}
+genCTR :: ByteArray ba
+       => AES    -- ^ Cipher Key.
+       -> IV AES -- ^ usually a 128 bit integer.
+       -> Int    -- ^ length of bytes required.
+       -> ba
+genCTR ctx (IV iv) len
+    | len <= 0  = B.empty
+    | otherwise = B.allocAndFreeze (nbBlocks * 16) generate
+  where generate o = withKeyAndIV ctx iv $ \k i -> c_aes_gen_ctr (castPtr o) k i (fromIntegral nbBlocks)
+        (nbBlocks',r) = len `quotRem` 16
+        nbBlocks = if r == 0 then nbBlocks' else nbBlocks' + 1
+
+-- | generate a counter mode pad. this is generally xor-ed to an input
+-- to make the standard counter mode block operations.
+--
+-- if the length requested is not a multiple of the block cipher size,
+-- more data will be returned, so that the returned bytearray is
+-- a multiple of the block cipher size.
+--
+-- Similiar to 'genCTR' but also return the next IV for continuation
+{-# NOINLINE genCounter #-}
+genCounter :: ByteArray ba
+           => AES
+           -> IV AES
+           -> Int
+           -> (ba, IV AES)
+genCounter ctx iv len
+    | len <= 0  = (B.empty, iv)
+    | otherwise = unsafeDoIO $
+        keyToPtr ctx $ \k ->
+        ivCopyPtr iv $ \i ->
+        B.alloc outputLength $ \o -> do
+            c_aes_gen_ctr_cont (castPtr o) k i (fromIntegral nbBlocks)
+  where
+        (nbBlocks',r) = len `quotRem` 16
+        nbBlocks = if r == 0 then nbBlocks' else nbBlocks' + 1
+        outputLength = nbBlocks * 16
+
+{- TODO: when genCTR has same AESIV requirements for IV, add the following rules:
+ - RULES "snd . genCounter" forall ctx iv len .  snd (genCounter ctx iv len) = genCTR ctx iv len
+ -}
+
+-- | encrypt using Counter mode (CTR)
+--
+-- in CTR mode encryption and decryption is the same operation.
+{-# NOINLINE encryptCTR #-}
+encryptCTR :: ByteArray ba
+           => AES        -- ^ AES Context
+           -> IV AES     -- ^ initial vector of AES block size (usually representing a 128 bit integer)
+           -> ba         -- ^ plaintext input
+           -> ba         -- ^ ciphertext output
+encryptCTR ctx iv input
+    | len <= 0          = B.empty
+    | B.length iv /= 16 = error $ "AES error: IV length must be block size (16). Its length is: " ++ (show $ B.length iv)
+    | otherwise = B.allocAndFreeze len doEncrypt
+  where doEncrypt o = withKeyAndIV ctx iv $ \k v -> withByteArray input $ \i ->
+                      c_aes_encrypt_ctr (castPtr o) k v i (fromIntegral len)
+        len = B.length input
+
+-- | encrypt using XTS
+--
+-- the first key is the normal block encryption key
+-- the second key is used for the initial block tweak
+{-# NOINLINE encryptXTS #-}
+encryptXTS :: ByteArray ba
+           => (AES,AES)  -- ^ AES cipher and tweak context
+           -> IV AES     -- ^ a 128 bits IV, typically a sector or a block offset in XTS
+           -> Word32     -- ^ number of rounds to skip, also seen a 16 byte offset in the sector or block.
+           -> ba         -- ^ input to encrypt
+           -> ba         -- ^ output encrypted
+encryptXTS = doXTS c_aes_encrypt_xts
+
+-- | decrypt using Electronic Code Book (ECB)
+{-# NOINLINE decryptECB #-}
+decryptECB :: ByteArray ba => AES -> ba -> ba
+decryptECB = doECB c_aes_decrypt_ecb
+
+-- | decrypt using Cipher block chaining (CBC)
+{-# NOINLINE decryptCBC #-}
+decryptCBC :: ByteArray ba => AES -> IV AES -> ba -> ba
+decryptCBC = doCBC c_aes_decrypt_cbc
+
+-- | decrypt using Counter mode (CTR).
+--
+-- in CTR mode encryption and decryption is the same operation.
+decryptCTR :: ByteArray ba
+           => AES        -- ^ AES Context
+           -> IV AES     -- ^ initial vector, usually representing a 128 bit integer
+           -> ba         -- ^ ciphertext input
+           -> ba         -- ^ plaintext output
+decryptCTR = encryptCTR
+
+-- | decrypt using XTS
+{-# NOINLINE decryptXTS #-}
+decryptXTS :: ByteArray ba
+           => (AES,AES)  -- ^ AES cipher and tweak context
+           -> IV AES     -- ^ a 128 bits IV, typically a sector or a block offset in XTS
+           -> Word32     -- ^ number of rounds to skip, also seen a 16 byte offset in the sector or block.
+           -> ba         -- ^ input to decrypt
+           -> ba         -- ^ output decrypted
+decryptXTS = doXTS c_aes_decrypt_xts
+
+-- | encrypt/decrypt using Counter mode (32-bit wrapping used in AES-GCM-SIV)
+{-# NOINLINE combineC32 #-}
+combineC32 :: ByteArray ba
+           => AES        -- ^ AES Context
+           -> IV AES     -- ^ initial vector of AES block size (usually representing a 128 bit integer)
+           -> ba         -- ^ plaintext input
+           -> ba         -- ^ ciphertext output
+combineC32 ctx iv input
+    | len <= 0          = B.empty
+    | B.length iv /= 16 = error $ "AES error: IV length must be block size (16). Its length is: " ++ show (B.length iv)
+    | otherwise = B.allocAndFreeze len doEncrypt
+  where doEncrypt o = withKeyAndIV ctx iv $ \k v -> withByteArray input $ \i ->
+                      c_aes_encrypt_c32 (castPtr o) k v i (fromIntegral len)
+        len = B.length input
+
+{-# INLINE doECB #-}
+doECB :: ByteArray ba
+      => (Ptr b -> Ptr AES -> CString -> CUInt -> IO ())
+      -> AES -> ba -> ba
+doECB f ctx input
+    | len == 0     = B.empty
+    | r /= 0       = error $ "Encryption error: input length must be a multiple of block size (16). Its length is: " ++ (show len)
+    | otherwise    =
+        B.allocAndFreeze len $ \o ->
+        keyToPtr ctx         $ \k ->
+        withByteArray input  $ \i ->
+            f (castPtr o) k i (fromIntegral nbBlocks)
+  where (nbBlocks, r) = len `quotRem` 16
+        len           = B.length input
+
+{-# INLINE doCBC #-}
+doCBC :: ByteArray ba
+      => (Ptr b -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO ())
+      -> AES -> IV AES -> ba -> ba
+doCBC f ctx (IV iv) input
+    | len == 0  = B.empty
+    | r /= 0    = error $ "Encryption error: input length must be a multiple of block size (16). Its length is: " ++ (show len)
+    | otherwise = B.allocAndFreeze len $ \o ->
+                  withKeyAndIV ctx iv $ \k v ->
+                  withByteArray input $ \i ->
+                  f (castPtr o) k v i (fromIntegral nbBlocks)
+  where (nbBlocks, r) = len `quotRem` 16
+        len           = B.length input
+
+{-# INLINE doXTS #-}
+doXTS :: ByteArray ba
+      => (Ptr b -> Ptr AES -> Ptr AES -> Ptr Word8 -> CUInt -> CString -> CUInt -> IO ())
+      -> (AES, AES)
+      -> IV AES
+      -> Word32
+      -> ba
+      -> ba
+doXTS f (key1,key2) iv spoint input
+    | len == 0  = B.empty
+    | r /= 0    = error $ "Encryption error: input length must be a multiple of block size (16) for now. Its length is: " ++ (show len)
+    | otherwise = B.allocAndFreeze len $ \o -> withKey2AndIV key1 key2 iv $ \k1 k2 v -> withByteArray input $ \i ->
+            f (castPtr o) k1 k2 v (fromIntegral spoint) i (fromIntegral nbBlocks)
+  where (nbBlocks, r) = len `quotRem` 16
+        len           = B.length input
+
+------------------------------------------------------------------------
+-- GCM
+------------------------------------------------------------------------
+
+-- | initialize a gcm context
+{-# NOINLINE gcmInit #-}
+gcmInit :: ByteArrayAccess iv => AES -> iv -> AESGCM
+gcmInit ctx iv = unsafeDoIO $ do
+    sm <- B.alloc sizeGCM $ \gcmStPtr ->
+            withKeyAndIV ctx iv $ \k v ->
+            c_aes_gcm_init (castPtr gcmStPtr) k v (fromIntegral $ B.length iv)
+    return $ AESGCM sm
+
+-- | append data which is only going to be authenticated to the GCM context.
+--
+-- needs to happen after initialization and before appending encryption/decryption data.
+{-# NOINLINE gcmAppendAAD #-}
+gcmAppendAAD :: ByteArrayAccess aad => AESGCM -> aad -> AESGCM
+gcmAppendAAD gcmSt input = unsafeDoIO doAppend
+  where doAppend =
+            withNewGCMSt gcmSt $ \gcmStPtr ->
+            withByteArray input $ \i ->
+            c_aes_gcm_aad gcmStPtr i (fromIntegral $ B.length input)
+
+-- | append data to encrypt and append to the GCM context
+--
+-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function.
+-- needs to happen after AAD appending, or after initialization if no AAD data.
+{-# NOINLINE gcmAppendEncrypt #-}
+gcmAppendEncrypt :: ByteArray ba => AES -> AESGCM -> ba -> (ba, AESGCM)
+gcmAppendEncrypt ctx gcm input = unsafeDoIO $ withGCMKeyAndCopySt ctx gcm doEnc
+  where len = B.length input
+        doEnc gcmStPtr aesPtr =
+            B.alloc len $ \o ->
+            withByteArray input $ \i ->
+            c_aes_gcm_encrypt (castPtr o) gcmStPtr aesPtr i (fromIntegral len)
+
+-- | append data to decrypt and append to the GCM context
+--
+-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function.
+-- needs to happen after AAD appending, or after initialization if no AAD data.
+{-# NOINLINE gcmAppendDecrypt #-}
+gcmAppendDecrypt :: ByteArray ba => AES -> AESGCM -> ba -> (ba, AESGCM)
+gcmAppendDecrypt ctx gcm input = unsafeDoIO $ withGCMKeyAndCopySt ctx gcm doDec
+  where len = B.length input
+        doDec gcmStPtr aesPtr =
+            B.alloc len $ \o ->
+            withByteArray input $ \i ->
+            c_aes_gcm_decrypt (castPtr o) gcmStPtr aesPtr i (fromIntegral len)
+
+-- | Generate the Tag from GCM context
+{-# NOINLINE gcmFinish #-}
+gcmFinish :: AES -> AESGCM -> Int -> AuthTag
+gcmFinish ctx gcm taglen = AuthTag $ B.take taglen computeTag
+  where computeTag = B.allocAndFreeze 16 $ \t ->
+                        withGCMKeyAndCopySt ctx gcm (c_aes_gcm_finish (castPtr t)) >> return ()
+
+------------------------------------------------------------------------
+-- OCB v3
+------------------------------------------------------------------------
+
+-- | initialize an ocb context
+{-# NOINLINE ocbInit #-}
+ocbInit :: ByteArrayAccess iv => AES -> iv -> AESOCB
+ocbInit ctx iv = unsafeDoIO $ do
+    sm <- B.alloc sizeOCB $ \ocbStPtr ->
+            withKeyAndIV ctx iv $ \k v ->
+            c_aes_ocb_init (castPtr ocbStPtr) k v (fromIntegral $ B.length iv)
+    return $ AESOCB sm
+
+-- | append data which is going to just be authenticated to the OCB context.
+--
+-- need to happen after initialization and before appending encryption/decryption data.
+{-# NOINLINE ocbAppendAAD #-}
+ocbAppendAAD :: ByteArrayAccess aad => AES -> AESOCB -> aad -> AESOCB
+ocbAppendAAD ctx ocb input = unsafeDoIO (snd `fmap` withOCBKeyAndCopySt ctx ocb doAppend)
+  where doAppend ocbStPtr aesPtr =
+            withByteArray input $ \i ->
+            c_aes_ocb_aad ocbStPtr aesPtr i (fromIntegral $ B.length input)
+
+-- | append data to encrypt and append to the OCB context
+--
+-- the bytearray needs to be a multiple of the AES block size, unless it's the last call to this function.
+-- need to happen after AAD appending, or after initialization if no AAD data.
+{-# NOINLINE ocbAppendEncrypt #-}
+ocbAppendEncrypt :: ByteArray ba => AES -> AESOCB -> ba -> (ba, AESOCB)
+ocbAppendEncrypt ctx ocb input = unsafeDoIO $ withOCBKeyAndCopySt ctx ocb doEnc
+  where len = B.length input
+        doEnc ocbStPtr aesPtr =
+            B.alloc len $ \o ->
+            withByteArray input $ \i ->
+            c_aes_ocb_encrypt (castPtr o) ocbStPtr aesPtr i (fromIntegral len)
+
+-- | append data to decrypt and append to the OCB context
+--
+-- the bytearray needs to be a multiple of the AES block size, unless it's the last call to this function.
+-- need to happen after AAD appending, or after initialization if no AAD data.
+{-# NOINLINE ocbAppendDecrypt #-}
+ocbAppendDecrypt :: ByteArray ba => AES -> AESOCB -> ba -> (ba, AESOCB)
+ocbAppendDecrypt ctx ocb input = unsafeDoIO $ withOCBKeyAndCopySt ctx ocb doDec
+  where len = B.length input
+        doDec ocbStPtr aesPtr =
+            B.alloc len $ \o ->
+            withByteArray input $ \i ->
+            c_aes_ocb_decrypt (castPtr o) ocbStPtr aesPtr i (fromIntegral len)
+
+-- | Generate the Tag from OCB context
+{-# NOINLINE ocbFinish #-}
+ocbFinish :: AES -> AESOCB -> Int -> AuthTag
+ocbFinish ctx ocb taglen = AuthTag $ B.take taglen computeTag
+  where computeTag = B.allocAndFreeze 16 $ \t ->
+                        withOCBKeyAndCopySt ctx ocb (c_aes_ocb_finish (castPtr t)) >> return ()
+
+ccmGetM :: CCM_M -> Int
+ccmGetL :: CCM_L -> Int
+ccmGetM m = case m of
+  CCM_M4 -> 4
+  CCM_M6 -> 6
+  CCM_M8 -> 8
+  CCM_M10 -> 10
+  CCM_M12 -> 12
+  CCM_M14 -> 14
+  CCM_M16 -> 16
+
+ccmGetL l = case l of
+  CCM_L2 -> 2
+  CCM_L3 -> 3
+  CCM_L4 -> 4
+
+-- | initialize a ccm context
+{-# NOINLINE ccmInit #-}
+ccmInit :: ByteArrayAccess iv => AES -> iv -> Int -> CCM_M -> CCM_L -> CryptoFailable AESCCM
+ccmInit ctx iv n m l
+    | 15 - li /= B.length iv = CryptoFailed CryptoError_IvSizeInvalid
+    | otherwise = unsafeDoIO $ do
+          sm <- B.alloc sizeCCM $ \ccmStPtr ->
+            withKeyAndIV ctx iv $ \k v ->
+            c_aes_ccm_init (castPtr ccmStPtr) k v (fromIntegral $ B.length iv) (fromIntegral n) (fromIntegral mi) (fromIntegral li)
+          return $ CryptoPassed (AESCCM sm)
+  where
+    mi = ccmGetM m
+    li = ccmGetL l
+
+-- | append data which is only going to be authenticated to the CCM context.
+--
+-- needs to happen after initialization and before appending encryption/decryption data.
+{-# NOINLINE ccmAppendAAD #-}
+ccmAppendAAD :: ByteArrayAccess aad => AES -> AESCCM -> aad -> AESCCM
+ccmAppendAAD ctx ccm input = unsafeDoIO $ snd <$> withCCMKeyAndCopySt ctx ccm doAppend
+  where doAppend ccmStPtr aesPtr =
+            withByteArray input $ \i -> c_aes_ccm_aad ccmStPtr aesPtr i (fromIntegral $ B.length input)
+
+-- | append data to encrypt and append to the CCM context
+--
+-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function.
+-- needs to happen after AAD appending, or after initialization if no AAD data.
+{-# NOINLINE ccmEncrypt #-}
+ccmEncrypt :: ByteArray ba => AES -> AESCCM -> ba -> (ba, AESCCM)
+ccmEncrypt ctx ccm input = unsafeDoIO $ withCCMKeyAndCopySt ctx ccm cbcmacAndIv
+  where len = B.length input
+        cbcmacAndIv ccmStPtr aesPtr =
+            B.alloc len $ \o ->
+            withByteArray input $ \i ->
+            c_aes_ccm_encrypt (castPtr o) ccmStPtr aesPtr i (fromIntegral len)
+
+-- | append data to decrypt and append to the CCM context
+--
+-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function.
+-- needs to happen after AAD appending, or after initialization if no AAD data.
+{-# NOINLINE ccmDecrypt #-}
+ccmDecrypt :: ByteArray ba => AES -> AESCCM -> ba -> (ba, AESCCM)
+ccmDecrypt ctx ccm input = unsafeDoIO $ withCCMKeyAndCopySt ctx ccm cbcmacAndIv
+  where len = B.length input
+        cbcmacAndIv ccmStPtr aesPtr =
+            B.alloc len $ \o ->
+            withByteArray input $ \i ->
+            c_aes_ccm_decrypt (castPtr o) ccmStPtr aesPtr i (fromIntegral len)
+
+-- | Generate the Tag from CCM context
+{-# NOINLINE ccmFinish #-}
+ccmFinish :: AES -> AESCCM -> Int -> AuthTag
+ccmFinish ctx ccm taglen = AuthTag $ B.take taglen computeTag
+  where computeTag = B.allocAndFreeze 16 $ \t ->
+                        withCCMKeyAndCopySt ctx ccm (c_aes_ccm_finish (castPtr t)) >> return ()
+
+------------------------------------------------------------------------
+foreign import ccall "cryptonite_aes.h cryptonite_aes_initkey"
+    c_aes_init :: Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_ecb"
+    c_aes_encrypt_ecb :: CString -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_decrypt_ecb"
+    c_aes_decrypt_ecb :: CString -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_cbc"
+    c_aes_encrypt_cbc :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_decrypt_cbc"
+    c_aes_decrypt_cbc :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_xts"
+    c_aes_encrypt_xts :: CString -> Ptr AES -> Ptr AES -> Ptr Word8 -> CUInt -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_decrypt_xts"
+    c_aes_decrypt_xts :: CString -> Ptr AES -> Ptr AES -> Ptr Word8 -> CUInt -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_gen_ctr"
+    c_aes_gen_ctr :: CString -> Ptr AES -> Ptr Word8 -> CUInt -> IO ()
+
+foreign import ccall unsafe "cryptonite_aes.h cryptonite_aes_gen_ctr_cont"
+    c_aes_gen_ctr_cont :: CString -> Ptr AES -> Ptr Word8 -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_ctr"
+    c_aes_encrypt_ctr :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_c32"
+    c_aes_encrypt_c32 :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_init"
+    c_aes_gcm_init :: Ptr AESGCM -> Ptr AES -> Ptr Word8 -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_aad"
+    c_aes_gcm_aad :: Ptr AESGCM -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_encrypt"
+    c_aes_gcm_encrypt :: CString -> Ptr AESGCM -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_decrypt"
+    c_aes_gcm_decrypt :: CString -> Ptr AESGCM -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_finish"
+    c_aes_gcm_finish :: CString -> Ptr AESGCM -> Ptr AES -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_init"
+    c_aes_ocb_init :: Ptr AESOCB -> Ptr AES -> Ptr Word8 -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_aad"
+    c_aes_ocb_aad :: Ptr AESOCB -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_encrypt"
+    c_aes_ocb_encrypt :: CString -> Ptr AESOCB -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_decrypt"
+    c_aes_ocb_decrypt :: CString -> Ptr AESOCB -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_finish"
+    c_aes_ocb_finish :: CString -> Ptr AESOCB -> Ptr AES -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_init"
+    c_aes_ccm_init :: Ptr AESCCM -> Ptr AES -> Ptr Word8 -> CUInt -> CUInt -> CInt -> CInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_aad"
+    c_aes_ccm_aad :: Ptr AESCCM -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_encrypt"
+    c_aes_ccm_encrypt :: CString -> Ptr AESCCM -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_decrypt"
+    c_aes_ccm_decrypt :: CString -> Ptr AESCCM -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_finish"
+    c_aes_ccm_finish :: CString -> Ptr AESCCM -> Ptr AES -> IO ()

bundled/Crypto/Cipher/AESGCMSIV.hs

@@ -0,0 +1,193 @@
+-- |
+-- Module      : Crypto.Cipher.AESGCMSIV
+-- License     : BSD-style
+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Implementation of AES-GCM-SIV, an AEAD scheme with nonce misuse resistance
+-- defined in <https://tools.ietf.org/html/rfc8452 RFC 8452>.
+--
+-- To achieve the nonce misuse-resistance property, encryption requires two
+-- passes on the plaintext, hence no streaming API is provided.  This AEAD
+-- operates on complete inputs held in memory.  For simplicity, the
+-- implementation of decryption uses a similar pattern, with performance
+-- penalty compared to an implementation which is able to merge both passes.
+--
+-- The specification allows inputs up to 2^36 bytes but this implementation
+-- requires AAD and plaintext/ciphertext to be both smaller than 2^32 bytes.
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.Cipher.AESGCMSIV
+    ( Nonce
+    , nonce
+    , generateNonce
+    , encrypt
+    , decrypt
+    ) where
+
+import Data.Bits
+import Data.Word
+
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Ptr (Ptr, plusPtr)
+import Foreign.Storable (peekElemOff, poke, pokeElemOff)
+
+import           Data.ByteArray
+import qualified Data.ByteArray as B
+import           Data.Memory.Endian (toLE)
+import           Data.Memory.PtrMethods (memXor)
+
+import Crypto.Cipher.AES.Primitive
+import Crypto.Cipher.Types
+import Crypto.Error
+import Crypto.Internal.Compat (unsafeDoIO)
+import Crypto.Random
+
+
+-- 12-byte nonces
+
+-- | Nonce value for AES-GCM-SIV, always 12 bytes.
+newtype Nonce = Nonce Bytes deriving (Show, Eq, ByteArrayAccess)
+
+-- | Nonce smart constructor.  Accepts only 12-byte inputs.
+nonce :: ByteArrayAccess iv => iv -> CryptoFailable Nonce
+nonce iv
+    | B.length iv == 12 = CryptoPassed (Nonce $ B.convert iv)
+    | otherwise         = CryptoFailed CryptoError_IvSizeInvalid
+
+-- | Generate a random nonce for use with AES-GCM-SIV.
+generateNonce :: MonadRandom m => m Nonce
+generateNonce = Nonce <$> getRandomBytes 12
+
+
+-- POLYVAL (mutable context)
+
+newtype Polyval = Polyval Bytes
+
+polyvalInit :: ScrubbedBytes -> IO Polyval
+polyvalInit h = Polyval <$> doInit
+  where doInit = B.alloc 272 $ \pctx -> B.withByteArray h $ \ph ->
+            c_aes_polyval_init pctx ph
+
+polyvalUpdate :: ByteArrayAccess ba => Polyval -> ba -> IO ()
+polyvalUpdate (Polyval ctx) bs = B.withByteArray ctx $ \pctx ->
+    B.withByteArray bs $ \pbs -> c_aes_polyval_update pctx pbs sz
+  where sz = fromIntegral (B.length bs)
+
+polyvalFinalize :: Polyval -> IO ScrubbedBytes
+polyvalFinalize (Polyval ctx) = B.alloc 16 $ \dst ->
+    B.withByteArray ctx $ \pctx -> c_aes_polyval_finalize pctx dst
+
+foreign import ccall unsafe "cryptonite_aes.h cryptonite_aes_polyval_init"
+    c_aes_polyval_init :: Ptr Polyval -> CString -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_polyval_update"
+    c_aes_polyval_update :: Ptr Polyval -> CString -> CUInt -> IO ()
+
+foreign import ccall unsafe "cryptonite_aes.h cryptonite_aes_polyval_finalize"
+    c_aes_polyval_finalize :: Ptr Polyval -> CString -> IO ()
+
+
+-- Key Generation
+
+le32iv :: Word32 -> Nonce -> Bytes
+le32iv n (Nonce iv) = B.allocAndFreeze 16 $ \ptr -> do
+    poke ptr (toLE n)
+    copyByteArrayToPtr iv (ptr `plusPtr` 4)
+
+deriveKeys :: BlockCipher128 aes => aes -> Nonce -> (ScrubbedBytes, AES)
+deriveKeys aes iv =
+    case cipherKeySize aes of
+        KeySizeFixed sz | sz `mod` 8 == 0 ->
+            let mak = buildKey [0 .. 1]
+                key = buildKey [2 .. fromIntegral (sz `div` 8) + 1]
+                mek = throwCryptoError (cipherInit key)
+             in (mak, mek)
+        _ -> error "AESGCMSIV: invalid cipher"
+  where
+    idx n = ecbEncrypt aes (le32iv n iv) `takeView` 8
+    buildKey = B.concat . map idx
+
+
+-- Encryption and decryption
+
+lengthInvalid :: ByteArrayAccess ba => ba -> Bool
+lengthInvalid bs
+    | finiteBitSize len > 32 = len >= 1 `unsafeShiftL` 32
+    | otherwise              = False
+  where len = B.length bs
+
+-- | AEAD encryption with the specified key and nonce.  The key must be given
+-- as an initialized 'Crypto.Cipher.AES.AES128' or 'Crypto.Cipher.AES.AES256'
+-- cipher.
+--
+-- Lengths of additional data and plaintext must be less than 2^32 bytes,
+-- otherwise an exception is thrown.
+encrypt :: (BlockCipher128 aes, ByteArrayAccess aad, ByteArray ba)
+        => aes -> Nonce -> aad -> ba -> (AuthTag, ba)
+encrypt aes iv aad plaintext
+    | lengthInvalid aad = error "AESGCMSIV: aad is too large"
+    | lengthInvalid plaintext = error "AESGCMSIV: plaintext is too large"
+    | otherwise = (AuthTag tag, ciphertext)
+  where
+    (mak, mek) = deriveKeys aes iv
+    ss = getSs mak aad plaintext
+    tag = buildTag mek ss iv
+    ciphertext = combineC32 mek (transformTag tag) plaintext
+
+-- | AEAD decryption with the specified key and nonce.  The key must be given
+-- as an initialized 'Crypto.Cipher.AES.AES128' or 'Crypto.Cipher.AES.AES256'
+-- cipher.
+--
+-- Lengths of additional data and ciphertext must be less than 2^32 bytes,
+-- otherwise an exception is thrown.
+decrypt :: (BlockCipher128 aes, ByteArrayAccess aad, ByteArray ba)
+        => aes -> Nonce -> aad -> ba -> AuthTag -> Maybe ba
+decrypt aes iv aad ciphertext (AuthTag tag)
+    | lengthInvalid aad = error "AESGCMSIV: aad is too large"
+    | lengthInvalid ciphertext = error "AESGCMSIV: ciphertext is too large"
+    | tag `constEq` buildTag mek ss iv = Just plaintext
+    | otherwise = Nothing
+  where
+    (mak, mek) = deriveKeys aes iv
+    ss = getSs mak aad plaintext
+    plaintext = combineC32 mek (transformTag tag) ciphertext
+
+-- Calculate S_s = POLYVAL(mak, X_1, X_2, ...).
+getSs :: (ByteArrayAccess aad, ByteArrayAccess ba)
+      => ScrubbedBytes -> aad -> ba -> ScrubbedBytes
+getSs mak aad plaintext = unsafeDoIO $ do
+    ctx <- polyvalInit mak
+    polyvalUpdate ctx aad
+    polyvalUpdate ctx plaintext
+    polyvalUpdate ctx (lb :: Bytes)  -- the "length block"
+    polyvalFinalize ctx
+  where
+    lb = B.allocAndFreeze 16 $ \ptr -> do
+            pokeElemOff ptr 0 (toLE64 $ B.length aad)
+            pokeElemOff ptr 1 (toLE64 $ B.length plaintext)
+    toLE64 x = toLE (fromIntegral x * 8 :: Word64)
+
+-- XOR the first 12 bytes of S_s with the nonce and clear the most significant
+-- bit of the last byte.
+tagInput :: ScrubbedBytes -> Nonce -> Bytes
+tagInput ss (Nonce iv) =
+    B.copyAndFreeze ss $ \ptr ->
+    B.withByteArray iv $ \ivPtr -> do
+        memXor ptr ptr ivPtr 12
+        b <- peekElemOff ptr 15
+        pokeElemOff ptr 15 (b .&. (0x7f :: Word8))
+
+-- Encrypt the result with AES using the message-encryption key to produce the
+-- tag.
+buildTag :: BlockCipher128 aes => aes -> ScrubbedBytes -> Nonce -> Bytes
+buildTag mek ss iv = ecbEncrypt mek (tagInput ss iv)
+
+-- The initial counter block is the tag with the most significant bit of the
+-- last byte set to one.
+transformTag :: Bytes -> IV AES
+transformTag tag = toIV $ B.copyAndFreeze tag $ \ptr ->
+    peekElemOff ptr 15 >>= pokeElemOff ptr 15 . (.|. (0x80 :: Word8))
+  where toIV bs = let Just iv = makeIV (bs :: Bytes) in iv

bundled/Crypto/Cipher/Blowfish.hs

@@ -0,0 +1,67 @@
+-- |
+-- Module      : Crypto.Cipher.Blowfish
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.Cipher.Blowfish
+    ( Blowfish
+    , Blowfish64
+    , Blowfish128
+    , Blowfish256
+    , Blowfish448
+    ) where
+
+import Crypto.Internal.Imports
+import Crypto.Cipher.Types
+import Crypto.Cipher.Blowfish.Primitive
+
+-- | variable keyed blowfish state
+newtype Blowfish = Blowfish Context
+    deriving (NFData)
+
+-- | 64 bit keyed blowfish state
+newtype Blowfish64 = Blowfish64 Context
+    deriving (NFData)
+
+-- | 128 bit keyed blowfish state
+newtype Blowfish128 = Blowfish128 Context
+    deriving (NFData)
+
+-- | 256 bit keyed blowfish state
+newtype Blowfish256 = Blowfish256 Context
+    deriving (NFData)
+
+-- | 448 bit keyed blowfish state
+newtype Blowfish448 = Blowfish448 Context
+    deriving (NFData)
+
+instance Cipher Blowfish where
+    cipherName _    = "blowfish"
+    cipherKeySize _ = KeySizeRange 6 56
+    cipherInit k    = Blowfish `fmap` initBlowfish k
+
+instance BlockCipher Blowfish where
+    blockSize _ = 8
+    ecbEncrypt (Blowfish bf) = encrypt bf
+    ecbDecrypt (Blowfish bf) = decrypt bf
+
+#define INSTANCE_CIPHER(CSTR, NAME, KEYSIZE) \
+instance Cipher CSTR where \
+    { cipherName _ = NAME \
+    ; cipherKeySize _ = KeySizeFixed KEYSIZE \
+    ; cipherInit k = CSTR `fmap` initBlowfish k \
+    }; \
+instance BlockCipher CSTR where \
+    { blockSize _ = 8 \
+    ; ecbEncrypt (CSTR bf) = encrypt bf \
+    ; ecbDecrypt (CSTR bf) = decrypt bf \
+    };
+
+INSTANCE_CIPHER(Blowfish64, "blowfish64", 8)
+INSTANCE_CIPHER(Blowfish128, "blowfish128", 16)
+INSTANCE_CIPHER(Blowfish256, "blowfish256", 32)
+INSTANCE_CIPHER(Blowfish448, "blowfish448", 56)

bundled/Crypto/Cipher/Blowfish/Box.hs

@@ -0,0 +1,296 @@
+-- |
+-- Module      : Crypto.Cipher.Blowfish.Box
+-- License     : BSD-style
+-- Stability   : experimental
+-- Portability : Good
+{-# LANGUAGE MagicHash #-}
+module Crypto.Cipher.Blowfish.Box
+    (   KeySchedule(..)
+    ,   createKeySchedule
+    ,   copyKeySchedule
+    ) where
+
+import           Crypto.Internal.WordArray (MutableArray32,
+                                            mutableArray32FromAddrBE,
+                                            mutableArrayRead32,
+                                            mutableArrayWrite32)
+
+newtype KeySchedule = KeySchedule MutableArray32
+
+-- | Copy the state of one key schedule into the other.
+--   The first parameter is the destination and the second the source.
+copyKeySchedule :: KeySchedule -> KeySchedule -> IO ()
+copyKeySchedule (KeySchedule dst) (KeySchedule src) = loop 0
+  where
+    loop 1042 = return ()
+    loop i    = do
+        w32 <-mutableArrayRead32 src i
+        mutableArrayWrite32 dst i w32
+        loop (i + 1)
+
+-- | Create a key schedule mutable array of the pbox followed by
+-- all the sboxes.
+createKeySchedule :: IO KeySchedule
+createKeySchedule = KeySchedule `fmap` mutableArray32FromAddrBE 1042 "\
+    \\x24\x3f\x6a\x88\x85\xa3\x08\xd3\x13\x19\x8a\x2e\x03\x70\x73\x44\
+    \\xa4\x09\x38\x22\x29\x9f\x31\xd0\x08\x2e\xfa\x98\xec\x4e\x6c\x89\
+    \\x45\x28\x21\xe6\x38\xd0\x13\x77\xbe\x54\x66\xcf\x34\xe9\x0c\x6c\
+    \\xc0\xac\x29\xb7\xc9\x7c\x50\xdd\x3f\x84\xd5\xb5\xb5\x47\x09\x17\
+    \\x92\x16\xd5\xd9\x89\x79\xfb\x1b\
+    \\xd1\x31\x0b\xa6\x98\xdf\xb5\xac\x2f\xfd\x72\xdb\xd0\x1a\xdf\xb7\
+    \\xb8\xe1\xaf\xed\x6a\x26\x7e\x96\xba\x7c\x90\x45\xf1\x2c\x7f\x99\
+    \\x24\xa1\x99\x47\xb3\x91\x6c\xf7\x08\x01\xf2\xe2\x85\x8e\xfc\x16\
+    \\x63\x69\x20\xd8\x71\x57\x4e\x69\xa4\x58\xfe\xa3\xf4\x93\x3d\x7e\
+    \\x0d\x95\x74\x8f\x72\x8e\xb6\x58\x71\x8b\xcd\x58\x82\x15\x4a\xee\
+    \\x7b\x54\xa4\x1d\xc2\x5a\x59\xb5\x9c\x30\xd5\x39\x2a\xf2\x60\x13\
+    \\xc5\xd1\xb0\x23\x28\x60\x85\xf0\xca\x41\x79\x18\xb8\xdb\x38\xef\
+    \\x8e\x79\xdc\xb0\x60\x3a\x18\x0e\x6c\x9e\x0e\x8b\xb0\x1e\x8a\x3e\
+    \\xd7\x15\x77\xc1\xbd\x31\x4b\x27\x78\xaf\x2f\xda\x55\x60\x5c\x60\
+    \\xe6\x55\x25\xf3\xaa\x55\xab\x94\x57\x48\x98\x62\x63\xe8\x14\x40\
+    \\x55\xca\x39\x6a\x2a\xab\x10\xb6\xb4\xcc\x5c\x34\x11\x41\xe8\xce\
+    \\xa1\x54\x86\xaf\x7c\x72\xe9\x93\xb3\xee\x14\x11\x63\x6f\xbc\x2a\
+    \\x2b\xa9\xc5\x5d\x74\x18\x31\xf6\xce\x5c\x3e\x16\x9b\x87\x93\x1e\
+    \\xaf\xd6\xba\x33\x6c\x24\xcf\x5c\x7a\x32\x53\x81\x28\x95\x86\x77\
+    \\x3b\x8f\x48\x98\x6b\x4b\xb9\xaf\xc4\xbf\xe8\x1b\x66\x28\x21\x93\
+    \\x61\xd8\x09\xcc\xfb\x21\xa9\x91\x48\x7c\xac\x60\x5d\xec\x80\x32\
+    \\xef\x84\x5d\x5d\xe9\x85\x75\xb1\xdc\x26\x23\x02\xeb\x65\x1b\x88\
+    \\x23\x89\x3e\x81\xd3\x96\xac\xc5\x0f\x6d\x6f\xf3\x83\xf4\x42\x39\
+    \\x2e\x0b\x44\x82\xa4\x84\x20\x04\x69\xc8\xf0\x4a\x9e\x1f\x9b\x5e\
+    \\x21\xc6\x68\x42\xf6\xe9\x6c\x9a\x67\x0c\x9c\x61\xab\xd3\x88\xf0\
+    \\x6a\x51\xa0\xd2\xd8\x54\x2f\x68\x96\x0f\xa7\x28\xab\x51\x33\xa3\
+    \\x6e\xef\x0b\x6c\x13\x7a\x3b\xe4\xba\x3b\xf0\x50\x7e\xfb\x2a\x98\
+    \\xa1\xf1\x65\x1d\x39\xaf\x01\x76\x66\xca\x59\x3e\x82\x43\x0e\x88\
+    \\x8c\xee\x86\x19\x45\x6f\x9f\xb4\x7d\x84\xa5\xc3\x3b\x8b\x5e\xbe\
+    \\xe0\x6f\x75\xd8\x85\xc1\x20\x73\x40\x1a\x44\x9f\x56\xc1\x6a\xa6\
+    \\x4e\xd3\xaa\x62\x36\x3f\x77\x06\x1b\xfe\xdf\x72\x42\x9b\x02\x3d\
+    \\x37\xd0\xd7\x24\xd0\x0a\x12\x48\xdb\x0f\xea\xd3\x49\xf1\xc0\x9b\
+    \\x07\x53\x72\xc9\x80\x99\x1b\x7b\x25\xd4\x79\xd8\xf6\xe8\xde\xf7\
+    \\xe3\xfe\x50\x1a\xb6\x79\x4c\x3b\x97\x6c\xe0\xbd\x04\xc0\x06\xba\
+    \\xc1\xa9\x4f\xb6\x40\x9f\x60\xc4\x5e\x5c\x9e\xc2\x19\x6a\x24\x63\
+    \\x68\xfb\x6f\xaf\x3e\x6c\x53\xb5\x13\x39\xb2\xeb\x3b\x52\xec\x6f\
+    \\x6d\xfc\x51\x1f\x9b\x30\x95\x2c\xcc\x81\x45\x44\xaf\x5e\xbd\x09\
+    \\xbe\xe3\xd0\x04\xde\x33\x4a\xfd\x66\x0f\x28\x07\x19\x2e\x4b\xb3\
+    \\xc0\xcb\xa8\x57\x45\xc8\x74\x0f\xd2\x0b\x5f\x39\xb9\xd3\xfb\xdb\
+    \\x55\x79\xc0\xbd\x1a\x60\x32\x0a\xd6\xa1\x00\xc6\x40\x2c\x72\x79\
+    \\x67\x9f\x25\xfe\xfb\x1f\xa3\xcc\x8e\xa5\xe9\xf8\xdb\x32\x22\xf8\
+    \\x3c\x75\x16\xdf\xfd\x61\x6b\x15\x2f\x50\x1e\xc8\xad\x05\x52\xab\
+    \\x32\x3d\xb5\xfa\xfd\x23\x87\x60\x53\x31\x7b\x48\x3e\x00\xdf\x82\
+    \\x9e\x5c\x57\xbb\xca\x6f\x8c\xa0\x1a\x87\x56\x2e\xdf\x17\x69\xdb\
+    \\xd5\x42\xa8\xf6\x28\x7e\xff\xc3\xac\x67\x32\xc6\x8c\x4f\x55\x73\
+    \\x69\x5b\x27\xb0\xbb\xca\x58\xc8\xe1\xff\xa3\x5d\xb8\xf0\x11\xa0\
+    \\x10\xfa\x3d\x98\xfd\x21\x83\xb8\x4a\xfc\xb5\x6c\x2d\xd1\xd3\x5b\
+    \\x9a\x53\xe4\x79\xb6\xf8\x45\x65\xd2\x8e\x49\xbc\x4b\xfb\x97\x90\
+    \\xe1\xdd\xf2\xda\xa4\xcb\x7e\x33\x62\xfb\x13\x41\xce\xe4\xc6\xe8\
+    \\xef\x20\xca\xda\x36\x77\x4c\x01\xd0\x7e\x9e\xfe\x2b\xf1\x1f\xb4\
+    \\x95\xdb\xda\x4d\xae\x90\x91\x98\xea\xad\x8e\x71\x6b\x93\xd5\xa0\
+    \\xd0\x8e\xd1\xd0\xaf\xc7\x25\xe0\x8e\x3c\x5b\x2f\x8e\x75\x94\xb7\
+    \\x8f\xf6\xe2\xfb\xf2\x12\x2b\x64\x88\x88\xb8\x12\x90\x0d\xf0\x1c\
+    \\x4f\xad\x5e\xa0\x68\x8f\xc3\x1c\xd1\xcf\xf1\x91\xb3\xa8\xc1\xad\
+    \\x2f\x2f\x22\x18\xbe\x0e\x17\x77\xea\x75\x2d\xfe\x8b\x02\x1f\xa1\
+    \\xe5\xa0\xcc\x0f\xb5\x6f\x74\xe8\x18\xac\xf3\xd6\xce\x89\xe2\x99\
+    \\xb4\xa8\x4f\xe0\xfd\x13\xe0\xb7\x7c\xc4\x3b\x81\xd2\xad\xa8\xd9\
+    \\x16\x5f\xa2\x66\x80\x95\x77\x05\x93\xcc\x73\x14\x21\x1a\x14\x77\
+    \\xe6\xad\x20\x65\x77\xb5\xfa\x86\xc7\x54\x42\xf5\xfb\x9d\x35\xcf\
+    \\xeb\xcd\xaf\x0c\x7b\x3e\x89\xa0\xd6\x41\x1b\xd3\xae\x1e\x7e\x49\
+    \\x00\x25\x0e\x2d\x20\x71\xb3\x5e\x22\x68\x00\xbb\x57\xb8\xe0\xaf\
+    \\x24\x64\x36\x9b\xf0\x09\xb9\x1e\x55\x63\x91\x1d\x59\xdf\xa6\xaa\
+    \\x78\xc1\x43\x89\xd9\x5a\x53\x7f\x20\x7d\x5b\xa2\x02\xe5\xb9\xc5\
+    \\x83\x26\x03\x76\x62\x95\xcf\xa9\x11\xc8\x19\x68\x4e\x73\x4a\x41\
+    \\xb3\x47\x2d\xca\x7b\x14\xa9\x4a\x1b\x51\x00\x52\x9a\x53\x29\x15\
+    \\xd6\x0f\x57\x3f\xbc\x9b\xc6\xe4\x2b\x60\xa4\x76\x81\xe6\x74\x00\
+    \\x08\xba\x6f\xb5\x57\x1b\xe9\x1f\xf2\x96\xec\x6b\x2a\x0d\xd9\x15\
+    \\xb6\x63\x65\x21\xe7\xb9\xf9\xb6\xff\x34\x05\x2e\xc5\x85\x56\x64\
+    \\x53\xb0\x2d\x5d\xa9\x9f\x8f\xa1\x08\xba\x47\x99\x6e\x85\x07\x6a\
+    \\x4b\x7a\x70\xe9\xb5\xb3\x29\x44\xdb\x75\x09\x2e\xc4\x19\x26\x23\
+    \\xad\x6e\xa6\xb0\x49\xa7\xdf\x7d\x9c\xee\x60\xb8\x8f\xed\xb2\x66\
+    \\xec\xaa\x8c\x71\x69\x9a\x17\xff\x56\x64\x52\x6c\xc2\xb1\x9e\xe1\
+    \\x19\x36\x02\xa5\x75\x09\x4c\x29\xa0\x59\x13\x40\xe4\x18\x3a\x3e\
+    \\x3f\x54\x98\x9a\x5b\x42\x9d\x65\x6b\x8f\xe4\xd6\x99\xf7\x3f\xd6\
+    \\xa1\xd2\x9c\x07\xef\xe8\x30\xf5\x4d\x2d\x38\xe6\xf0\x25\x5d\xc1\
+    \\x4c\xdd\x20\x86\x84\x70\xeb\x26\x63\x82\xe9\xc6\x02\x1e\xcc\x5e\
+    \\x09\x68\x6b\x3f\x3e\xba\xef\xc9\x3c\x97\x18\x14\x6b\x6a\x70\xa1\
+    \\x68\x7f\x35\x84\x52\xa0\xe2\x86\xb7\x9c\x53\x05\xaa\x50\x07\x37\
+    \\x3e\x07\x84\x1c\x7f\xde\xae\x5c\x8e\x7d\x44\xec\x57\x16\xf2\xb8\
+    \\xb0\x3a\xda\x37\xf0\x50\x0c\x0d\xf0\x1c\x1f\x04\x02\x00\xb3\xff\
+    \\xae\x0c\xf5\x1a\x3c\xb5\x74\xb2\x25\x83\x7a\x58\xdc\x09\x21\xbd\
+    \\xd1\x91\x13\xf9\x7c\xa9\x2f\xf6\x94\x32\x47\x73\x22\xf5\x47\x01\
+    \\x3a\xe5\xe5\x81\x37\xc2\xda\xdc\xc8\xb5\x76\x34\x9a\xf3\xdd\xa7\
+    \\xa9\x44\x61\x46\x0f\xd0\x03\x0e\xec\xc8\xc7\x3e\xa4\x75\x1e\x41\
+    \\xe2\x38\xcd\x99\x3b\xea\x0e\x2f\x32\x80\xbb\xa1\x18\x3e\xb3\x31\
+    \\x4e\x54\x8b\x38\x4f\x6d\xb9\x08\x6f\x42\x0d\x03\xf6\x0a\x04\xbf\
+    \\x2c\xb8\x12\x90\x24\x97\x7c\x79\x56\x79\xb0\x72\xbc\xaf\x89\xaf\
+    \\xde\x9a\x77\x1f\xd9\x93\x08\x10\xb3\x8b\xae\x12\xdc\xcf\x3f\x2e\
+    \\x55\x12\x72\x1f\x2e\x6b\x71\x24\x50\x1a\xdd\xe6\x9f\x84\xcd\x87\
+    \\x7a\x58\x47\x18\x74\x08\xda\x17\xbc\x9f\x9a\xbc\xe9\x4b\x7d\x8c\
+    \\xec\x7a\xec\x3a\xdb\x85\x1d\xfa\x63\x09\x43\x66\xc4\x64\xc3\xd2\
+    \\xef\x1c\x18\x47\x32\x15\xd9\x08\xdd\x43\x3b\x37\x24\xc2\xba\x16\
+    \\x12\xa1\x4d\x43\x2a\x65\xc4\x51\x50\x94\x00\x02\x13\x3a\xe4\xdd\
+    \\x71\xdf\xf8\x9e\x10\x31\x4e\x55\x81\xac\x77\xd6\x5f\x11\x19\x9b\
+    \\x04\x35\x56\xf1\xd7\xa3\xc7\x6b\x3c\x11\x18\x3b\x59\x24\xa5\x09\
+    \\xf2\x8f\xe6\xed\x97\xf1\xfb\xfa\x9e\xba\xbf\x2c\x1e\x15\x3c\x6e\
+    \\x86\xe3\x45\x70\xea\xe9\x6f\xb1\x86\x0e\x5e\x0a\x5a\x3e\x2a\xb3\
+    \\x77\x1f\xe7\x1c\x4e\x3d\x06\xfa\x29\x65\xdc\xb9\x99\xe7\x1d\x0f\
+    \\x80\x3e\x89\xd6\x52\x66\xc8\x25\x2e\x4c\xc9\x78\x9c\x10\xb3\x6a\
+    \\xc6\x15\x0e\xba\x94\xe2\xea\x78\xa5\xfc\x3c\x53\x1e\x0a\x2d\xf4\
+    \\xf2\xf7\x4e\xa7\x36\x1d\x2b\x3d\x19\x39\x26\x0f\x19\xc2\x79\x60\
+    \\x52\x23\xa7\x08\xf7\x13\x12\xb6\xeb\xad\xfe\x6e\xea\xc3\x1f\x66\
+    \\xe3\xbc\x45\x95\xa6\x7b\xc8\x83\xb1\x7f\x37\xd1\x01\x8c\xff\x28\
+    \\xc3\x32\xdd\xef\xbe\x6c\x5a\xa5\x65\x58\x21\x85\x68\xab\x98\x02\
+    \\xee\xce\xa5\x0f\xdb\x2f\x95\x3b\x2a\xef\x7d\xad\x5b\x6e\x2f\x84\
+    \\x15\x21\xb6\x28\x29\x07\x61\x70\xec\xdd\x47\x75\x61\x9f\x15\x10\
+    \\x13\xcc\xa8\x30\xeb\x61\xbd\x96\x03\x34\xfe\x1e\xaa\x03\x63\xcf\
+    \\xb5\x73\x5c\x90\x4c\x70\xa2\x39\xd5\x9e\x9e\x0b\xcb\xaa\xde\x14\
+    \\xee\xcc\x86\xbc\x60\x62\x2c\xa7\x9c\xab\x5c\xab\xb2\xf3\x84\x6e\
+    \\x64\x8b\x1e\xaf\x19\xbd\xf0\xca\xa0\x23\x69\xb9\x65\x5a\xbb\x50\
+    \\x40\x68\x5a\x32\x3c\x2a\xb4\xb3\x31\x9e\xe9\xd5\xc0\x21\xb8\xf7\
+    \\x9b\x54\x0b\x19\x87\x5f\xa0\x99\x95\xf7\x99\x7e\x62\x3d\x7d\xa8\
+    \\xf8\x37\x88\x9a\x97\xe3\x2d\x77\x11\xed\x93\x5f\x16\x68\x12\x81\
+    \\x0e\x35\x88\x29\xc7\xe6\x1f\xd6\x96\xde\xdf\xa1\x78\x58\xba\x99\
+    \\x57\xf5\x84\xa5\x1b\x22\x72\x63\x9b\x83\xc3\xff\x1a\xc2\x46\x96\
+    \\xcd\xb3\x0a\xeb\x53\x2e\x30\x54\x8f\xd9\x48\xe4\x6d\xbc\x31\x28\
+    \\x58\xeb\xf2\xef\x34\xc6\xff\xea\xfe\x28\xed\x61\xee\x7c\x3c\x73\
+    \\x5d\x4a\x14\xd9\xe8\x64\xb7\xe3\x42\x10\x5d\x14\x20\x3e\x13\xe0\
+    \\x45\xee\xe2\xb6\xa3\xaa\xab\xea\xdb\x6c\x4f\x15\xfa\xcb\x4f\xd0\
+    \\xc7\x42\xf4\x42\xef\x6a\xbb\xb5\x65\x4f\x3b\x1d\x41\xcd\x21\x05\
+    \\xd8\x1e\x79\x9e\x86\x85\x4d\xc7\xe4\x4b\x47\x6a\x3d\x81\x62\x50\
+    \\xcf\x62\xa1\xf2\x5b\x8d\x26\x46\xfc\x88\x83\xa0\xc1\xc7\xb6\xa3\
+    \\x7f\x15\x24\xc3\x69\xcb\x74\x92\x47\x84\x8a\x0b\x56\x92\xb2\x85\
+    \\x09\x5b\xbf\x00\xad\x19\x48\x9d\x14\x62\xb1\x74\x23\x82\x0e\x00\
+    \\x58\x42\x8d\x2a\x0c\x55\xf5\xea\x1d\xad\xf4\x3e\x23\x3f\x70\x61\
+    \\x33\x72\xf0\x92\x8d\x93\x7e\x41\xd6\x5f\xec\xf1\x6c\x22\x3b\xdb\
+    \\x7c\xde\x37\x59\xcb\xee\x74\x60\x40\x85\xf2\xa7\xce\x77\x32\x6e\
+    \\xa6\x07\x80\x84\x19\xf8\x50\x9e\xe8\xef\xd8\x55\x61\xd9\x97\x35\
+    \\xa9\x69\xa7\xaa\xc5\x0c\x06\xc2\x5a\x04\xab\xfc\x80\x0b\xca\xdc\
+    \\x9e\x44\x7a\x2e\xc3\x45\x34\x84\xfd\xd5\x67\x05\x0e\x1e\x9e\xc9\
+    \\xdb\x73\xdb\xd3\x10\x55\x88\xcd\x67\x5f\xda\x79\xe3\x67\x43\x40\
+    \\xc5\xc4\x34\x65\x71\x3e\x38\xd8\x3d\x28\xf8\x9e\xf1\x6d\xff\x20\
+    \\x15\x3e\x21\xe7\x8f\xb0\x3d\x4a\xe6\xe3\x9f\x2b\xdb\x83\xad\xf7\
+    \\xe9\x3d\x5a\x68\x94\x81\x40\xf7\xf6\x4c\x26\x1c\x94\x69\x29\x34\
+    \\x41\x15\x20\xf7\x76\x02\xd4\xf7\xbc\xf4\x6b\x2e\xd4\xa2\x00\x68\
+    \\xd4\x08\x24\x71\x33\x20\xf4\x6a\x43\xb7\xd4\xb7\x50\x00\x61\xaf\
+    \\x1e\x39\xf6\x2e\x97\x24\x45\x46\x14\x21\x4f\x74\xbf\x8b\x88\x40\
+    \\x4d\x95\xfc\x1d\x96\xb5\x91\xaf\x70\xf4\xdd\xd3\x66\xa0\x2f\x45\
+    \\xbf\xbc\x09\xec\x03\xbd\x97\x85\x7f\xac\x6d\xd0\x31\xcb\x85\x04\
+    \\x96\xeb\x27\xb3\x55\xfd\x39\x41\xda\x25\x47\xe6\xab\xca\x0a\x9a\
+    \\x28\x50\x78\x25\x53\x04\x29\xf4\x0a\x2c\x86\xda\xe9\xb6\x6d\xfb\
+    \\x68\xdc\x14\x62\xd7\x48\x69\x00\x68\x0e\xc0\xa4\x27\xa1\x8d\xee\
+    \\x4f\x3f\xfe\xa2\xe8\x87\xad\x8c\xb5\x8c\xe0\x06\x7a\xf4\xd6\xb6\
+    \\xaa\xce\x1e\x7c\xd3\x37\x5f\xec\xce\x78\xa3\x99\x40\x6b\x2a\x42\
+    \\x20\xfe\x9e\x35\xd9\xf3\x85\xb9\xee\x39\xd7\xab\x3b\x12\x4e\x8b\
+    \\x1d\xc9\xfa\xf7\x4b\x6d\x18\x56\x26\xa3\x66\x31\xea\xe3\x97\xb2\
+    \\x3a\x6e\xfa\x74\xdd\x5b\x43\x32\x68\x41\xe7\xf7\xca\x78\x20\xfb\
+    \\xfb\x0a\xf5\x4e\xd8\xfe\xb3\x97\x45\x40\x56\xac\xba\x48\x95\x27\
+    \\x55\x53\x3a\x3a\x20\x83\x8d\x87\xfe\x6b\xa9\xb7\xd0\x96\x95\x4b\
+    \\x55\xa8\x67\xbc\xa1\x15\x9a\x58\xcc\xa9\x29\x63\x99\xe1\xdb\x33\
+    \\xa6\x2a\x4a\x56\x3f\x31\x25\xf9\x5e\xf4\x7e\x1c\x90\x29\x31\x7c\
+    \\xfd\xf8\xe8\x02\x04\x27\x2f\x70\x80\xbb\x15\x5c\x05\x28\x2c\xe3\
+    \\x95\xc1\x15\x48\xe4\xc6\x6d\x22\x48\xc1\x13\x3f\xc7\x0f\x86\xdc\
+    \\x07\xf9\xc9\xee\x41\x04\x1f\x0f\x40\x47\x79\xa4\x5d\x88\x6e\x17\
+    \\x32\x5f\x51\xeb\xd5\x9b\xc0\xd1\xf2\xbc\xc1\x8f\x41\x11\x35\x64\
+    \\x25\x7b\x78\x34\x60\x2a\x9c\x60\xdf\xf8\xe8\xa3\x1f\x63\x6c\x1b\
+    \\x0e\x12\xb4\xc2\x02\xe1\x32\x9e\xaf\x66\x4f\xd1\xca\xd1\x81\x15\
+    \\x6b\x23\x95\xe0\x33\x3e\x92\xe1\x3b\x24\x0b\x62\xee\xbe\xb9\x22\
+    \\x85\xb2\xa2\x0e\xe6\xba\x0d\x99\xde\x72\x0c\x8c\x2d\xa2\xf7\x28\
+    \\xd0\x12\x78\x45\x95\xb7\x94\xfd\x64\x7d\x08\x62\xe7\xcc\xf5\xf0\
+    \\x54\x49\xa3\x6f\x87\x7d\x48\xfa\xc3\x9d\xfd\x27\xf3\x3e\x8d\x1e\
+    \\x0a\x47\x63\x41\x99\x2e\xff\x74\x3a\x6f\x6e\xab\xf4\xf8\xfd\x37\
+    \\xa8\x12\xdc\x60\xa1\xeb\xdd\xf8\x99\x1b\xe1\x4c\xdb\x6e\x6b\x0d\
+    \\xc6\x7b\x55\x10\x6d\x67\x2c\x37\x27\x65\xd4\x3b\xdc\xd0\xe8\x04\
+    \\xf1\x29\x0d\xc7\xcc\x00\xff\xa3\xb5\x39\x0f\x92\x69\x0f\xed\x0b\
+    \\x66\x7b\x9f\xfb\xce\xdb\x7d\x9c\xa0\x91\xcf\x0b\xd9\x15\x5e\xa3\
+    \\xbb\x13\x2f\x88\x51\x5b\xad\x24\x7b\x94\x79\xbf\x76\x3b\xd6\xeb\
+    \\x37\x39\x2e\xb3\xcc\x11\x59\x79\x80\x26\xe2\x97\xf4\x2e\x31\x2d\
+    \\x68\x42\xad\xa7\xc6\x6a\x2b\x3b\x12\x75\x4c\xcc\x78\x2e\xf1\x1c\
+    \\x6a\x12\x42\x37\xb7\x92\x51\xe7\x06\xa1\xbb\xe6\x4b\xfb\x63\x50\
+    \\x1a\x6b\x10\x18\x11\xca\xed\xfa\x3d\x25\xbd\xd8\xe2\xe1\xc3\xc9\
+    \\x44\x42\x16\x59\x0a\x12\x13\x86\xd9\x0c\xec\x6e\xd5\xab\xea\x2a\
+    \\x64\xaf\x67\x4e\xda\x86\xa8\x5f\xbe\xbf\xe9\x88\x64\xe4\xc3\xfe\
+    \\x9d\xbc\x80\x57\xf0\xf7\xc0\x86\x60\x78\x7b\xf8\x60\x03\x60\x4d\
+    \\xd1\xfd\x83\x46\xf6\x38\x1f\xb0\x77\x45\xae\x04\xd7\x36\xfc\xcc\
+    \\x83\x42\x6b\x33\xf0\x1e\xab\x71\xb0\x80\x41\x87\x3c\x00\x5e\x5f\
+    \\x77\xa0\x57\xbe\xbd\xe8\xae\x24\x55\x46\x42\x99\xbf\x58\x2e\x61\
+    \\x4e\x58\xf4\x8f\xf2\xdd\xfd\xa2\xf4\x74\xef\x38\x87\x89\xbd\xc2\
+    \\x53\x66\xf9\xc3\xc8\xb3\x8e\x74\xb4\x75\xf2\x55\x46\xfc\xd9\xb9\
+    \\x7a\xeb\x26\x61\x8b\x1d\xdf\x84\x84\x6a\x0e\x79\x91\x5f\x95\xe2\
+    \\x46\x6e\x59\x8e\x20\xb4\x57\x70\x8c\xd5\x55\x91\xc9\x02\xde\x4c\
+    \\xb9\x0b\xac\xe1\xbb\x82\x05\xd0\x11\xa8\x62\x48\x75\x74\xa9\x9e\
+    \\xb7\x7f\x19\xb6\xe0\xa9\xdc\x09\x66\x2d\x09\xa1\xc4\x32\x46\x33\
+    \\xe8\x5a\x1f\x02\x09\xf0\xbe\x8c\x4a\x99\xa0\x25\x1d\x6e\xfe\x10\
+    \\x1a\xb9\x3d\x1d\x0b\xa5\xa4\xdf\xa1\x86\xf2\x0f\x28\x68\xf1\x69\
+    \\xdc\xb7\xda\x83\x57\x39\x06\xfe\xa1\xe2\xce\x9b\x4f\xcd\x7f\x52\
+    \\x50\x11\x5e\x01\xa7\x06\x83\xfa\xa0\x02\xb5\xc4\x0d\xe6\xd0\x27\
+    \\x9a\xf8\x8c\x27\x77\x3f\x86\x41\xc3\x60\x4c\x06\x61\xa8\x06\xb5\
+    \\xf0\x17\x7a\x28\xc0\xf5\x86\xe0\x00\x60\x58\xaa\x30\xdc\x7d\x62\
+    \\x11\xe6\x9e\xd7\x23\x38\xea\x63\x53\xc2\xdd\x94\xc2\xc2\x16\x34\
+    \\xbb\xcb\xee\x56\x90\xbc\xb6\xde\xeb\xfc\x7d\xa1\xce\x59\x1d\x76\
+    \\x6f\x05\xe4\x09\x4b\x7c\x01\x88\x39\x72\x0a\x3d\x7c\x92\x7c\x24\
+    \\x86\xe3\x72\x5f\x72\x4d\x9d\xb9\x1a\xc1\x5b\xb4\xd3\x9e\xb8\xfc\
+    \\xed\x54\x55\x78\x08\xfc\xa5\xb5\xd8\x3d\x7c\xd3\x4d\xad\x0f\xc4\
+    \\x1e\x50\xef\x5e\xb1\x61\xe6\xf8\xa2\x85\x14\xd9\x6c\x51\x13\x3c\
+    \\x6f\xd5\xc7\xe7\x56\xe1\x4e\xc4\x36\x2a\xbf\xce\xdd\xc6\xc8\x37\
+    \\xd7\x9a\x32\x34\x92\x63\x82\x12\x67\x0e\xfa\x8e\x40\x60\x00\xe0\
+    \\x3a\x39\xce\x37\xd3\xfa\xf5\xcf\xab\xc2\x77\x37\x5a\xc5\x2d\x1b\
+    \\x5c\xb0\x67\x9e\x4f\xa3\x37\x42\xd3\x82\x27\x40\x99\xbc\x9b\xbe\
+    \\xd5\x11\x8e\x9d\xbf\x0f\x73\x15\xd6\x2d\x1c\x7e\xc7\x00\xc4\x7b\
+    \\xb7\x8c\x1b\x6b\x21\xa1\x90\x45\xb2\x6e\xb1\xbe\x6a\x36\x6e\xb4\
+    \\x57\x48\xab\x2f\xbc\x94\x6e\x79\xc6\xa3\x76\xd2\x65\x49\xc2\xc8\
+    \\x53\x0f\xf8\xee\x46\x8d\xde\x7d\xd5\x73\x0a\x1d\x4c\xd0\x4d\xc6\
+    \\x29\x39\xbb\xdb\xa9\xba\x46\x50\xac\x95\x26\xe8\xbe\x5e\xe3\x04\
+    \\xa1\xfa\xd5\xf0\x6a\x2d\x51\x9a\x63\xef\x8c\xe2\x9a\x86\xee\x22\
+    \\xc0\x89\xc2\xb8\x43\x24\x2e\xf6\xa5\x1e\x03\xaa\x9c\xf2\xd0\xa4\
+    \\x83\xc0\x61\xba\x9b\xe9\x6a\x4d\x8f\xe5\x15\x50\xba\x64\x5b\xd6\
+    \\x28\x26\xa2\xf9\xa7\x3a\x3a\xe1\x4b\xa9\x95\x86\xef\x55\x62\xe9\
+    \\xc7\x2f\xef\xd3\xf7\x52\xf7\xda\x3f\x04\x6f\x69\x77\xfa\x0a\x59\
+    \\x80\xe4\xa9\x15\x87\xb0\x86\x01\x9b\x09\xe6\xad\x3b\x3e\xe5\x93\
+    \\xe9\x90\xfd\x5a\x9e\x34\xd7\x97\x2c\xf0\xb7\xd9\x02\x2b\x8b\x51\
+    \\x96\xd5\xac\x3a\x01\x7d\xa6\x7d\xd1\xcf\x3e\xd6\x7c\x7d\x2d\x28\
+    \\x1f\x9f\x25\xcf\xad\xf2\xb8\x9b\x5a\xd6\xb4\x72\x5a\x88\xf5\x4c\
+    \\xe0\x29\xac\x71\xe0\x19\xa5\xe6\x47\xb0\xac\xfd\xed\x93\xfa\x9b\
+    \\xe8\xd3\xc4\x8d\x28\x3b\x57\xcc\xf8\xd5\x66\x29\x79\x13\x2e\x28\
+    \\x78\x5f\x01\x91\xed\x75\x60\x55\xf7\x96\x0e\x44\xe3\xd3\x5e\x8c\
+    \\x15\x05\x6d\xd4\x88\xf4\x6d\xba\x03\xa1\x61\x25\x05\x64\xf0\xbd\
+    \\xc3\xeb\x9e\x15\x3c\x90\x57\xa2\x97\x27\x1a\xec\xa9\x3a\x07\x2a\
+    \\x1b\x3f\x6d\x9b\x1e\x63\x21\xf5\xf5\x9c\x66\xfb\x26\xdc\xf3\x19\
+    \\x75\x33\xd9\x28\xb1\x55\xfd\xf5\x03\x56\x34\x82\x8a\xba\x3c\xbb\
+    \\x28\x51\x77\x11\xc2\x0a\xd9\xf8\xab\xcc\x51\x67\xcc\xad\x92\x5f\
+    \\x4d\xe8\x17\x51\x38\x30\xdc\x8e\x37\x9d\x58\x62\x93\x20\xf9\x91\
+    \\xea\x7a\x90\xc2\xfb\x3e\x7b\xce\x51\x21\xce\x64\x77\x4f\xbe\x32\
+    \\xa8\xb6\xe3\x7e\xc3\x29\x3d\x46\x48\xde\x53\x69\x64\x13\xe6\x80\
+    \\xa2\xae\x08\x10\xdd\x6d\xb2\x24\x69\x85\x2d\xfd\x09\x07\x21\x66\
+    \\xb3\x9a\x46\x0a\x64\x45\xc0\xdd\x58\x6c\xde\xcf\x1c\x20\xc8\xae\
+    \\x5b\xbe\xf7\xdd\x1b\x58\x8d\x40\xcc\xd2\x01\x7f\x6b\xb4\xe3\xbb\
+    \\xdd\xa2\x6a\x7e\x3a\x59\xff\x45\x3e\x35\x0a\x44\xbc\xb4\xcd\xd5\
+    \\x72\xea\xce\xa8\xfa\x64\x84\xbb\x8d\x66\x12\xae\xbf\x3c\x6f\x47\
+    \\xd2\x9b\xe4\x63\x54\x2f\x5d\x9e\xae\xc2\x77\x1b\xf6\x4e\x63\x70\
+    \\x74\x0e\x0d\x8d\xe7\x5b\x13\x57\xf8\x72\x16\x71\xaf\x53\x7d\x5d\
+    \\x40\x40\xcb\x08\x4e\xb4\xe2\xcc\x34\xd2\x46\x6a\x01\x15\xaf\x84\
+    \\xe1\xb0\x04\x28\x95\x98\x3a\x1d\x06\xb8\x9f\xb4\xce\x6e\xa0\x48\
+    \\x6f\x3f\x3b\x82\x35\x20\xab\x82\x01\x1a\x1d\x4b\x27\x72\x27\xf8\
+    \\x61\x15\x60\xb1\xe7\x93\x3f\xdc\xbb\x3a\x79\x2b\x34\x45\x25\xbd\
+    \\xa0\x88\x39\xe1\x51\xce\x79\x4b\x2f\x32\xc9\xb7\xa0\x1f\xba\xc9\
+    \\xe0\x1c\xc8\x7e\xbc\xc7\xd1\xf6\xcf\x01\x11\xc3\xa1\xe8\xaa\xc7\
+    \\x1a\x90\x87\x49\xd4\x4f\xbd\x9a\xd0\xda\xde\xcb\xd5\x0a\xda\x38\
+    \\x03\x39\xc3\x2a\xc6\x91\x36\x67\x8d\xf9\x31\x7c\xe0\xb1\x2b\x4f\
+    \\xf7\x9e\x59\xb7\x43\xf5\xbb\x3a\xf2\xd5\x19\xff\x27\xd9\x45\x9c\
+    \\xbf\x97\x22\x2c\x15\xe6\xfc\x2a\x0f\x91\xfc\x71\x9b\x94\x15\x25\
+    \\xfa\xe5\x93\x61\xce\xb6\x9c\xeb\xc2\xa8\x64\x59\x12\xba\xa8\xd1\
+    \\xb6\xc1\x07\x5e\xe3\x05\x6a\x0c\x10\xd2\x50\x65\xcb\x03\xa4\x42\
+    \\xe0\xec\x6e\x0e\x16\x98\xdb\x3b\x4c\x98\xa0\xbe\x32\x78\xe9\x64\
+    \\x9f\x1f\x95\x32\xe0\xd3\x92\xdf\xd3\xa0\x34\x2b\x89\x71\xf2\x1e\
+    \\x1b\x0a\x74\x41\x4b\xa3\x34\x8c\xc5\xbe\x71\x20\xc3\x76\x32\xd8\
+    \\xdf\x35\x9f\x8d\x9b\x99\x2f\x2e\xe6\x0b\x6f\x47\x0f\xe3\xf1\x1d\
+    \\xe5\x4c\xda\x54\x1e\xda\xd8\x91\xce\x62\x79\xcf\xcd\x3e\x7e\x6f\
+    \\x16\x18\xb1\x66\xfd\x2c\x1d\x05\x84\x8f\xd2\xc5\xf6\xfb\x22\x99\
+    \\xf5\x23\xf3\x57\xa6\x32\x76\x23\x93\xa8\x35\x31\x56\xcc\xcd\x02\
+    \\xac\xf0\x81\x62\x5a\x75\xeb\xb5\x6e\x16\x36\x97\x88\xd2\x73\xcc\
+    \\xde\x96\x62\x92\x81\xb9\x49\xd0\x4c\x50\x90\x1b\x71\xc6\x56\x14\
+    \\xe6\xc6\xc7\xbd\x32\x7a\x14\x0a\x45\xe1\xd0\x06\xc3\xf2\x7b\x9a\
+    \\xc9\xaa\x53\xfd\x62\xa8\x0f\x00\xbb\x25\xbf\xe2\x35\xbd\xd2\xf6\
+    \\x71\x12\x69\x05\xb2\x04\x02\x22\xb6\xcb\xcf\x7c\xcd\x76\x9c\x2b\
+    \\x53\x11\x3e\xc0\x16\x40\xe3\xd3\x38\xab\xbd\x60\x25\x47\xad\xf0\
+    \\xba\x38\x20\x9c\xf7\x46\xce\x76\x77\xaf\xa1\xc5\x20\x75\x60\x60\
+    \\x85\xcb\xfe\x4e\x8a\xe8\x8d\xd8\x7a\xaa\xf9\xb0\x4c\xf9\xaa\x7e\
+    \\x19\x48\xc2\x5c\x02\xfb\x8a\x8c\x01\xc3\x6a\xe4\xd6\xeb\xe1\xf9\
+    \\x90\xd4\xf8\x69\xa6\x5c\xde\xa0\x3f\x09\x25\x2d\xc2\x08\xe6\x9f\
+    \\xb7\x4e\x61\x32\xce\x77\xe2\x5b\x57\x8f\xdf\xe3\x3a\xc3\x72\xe6\
+    \"#

bundled/Crypto/Cipher/Blowfish/Primitive.hs

@@ -0,0 +1,258 @@
+-- |
+-- Module      : Crypto.Cipher.Blowfish.Primitive
+-- License     : BSD-style
+-- Stability   : experimental
+-- Portability : Good
+
+-- Rewritten by Vincent Hanquez (c) 2015
+--              Lars Petersen (c) 2018
+--
+-- Original code:
+--      Crypto.Cipher.Blowfish.Primitive, copyright (c) 2012 Stijn van Drongelen
+--      based on: BlowfishAux.hs (C) 2002 HardCore SoftWare, Doug Hoyte
+--           (as found in Crypto-4.2.4)
+{-# LANGUAGE BangPatterns #-}
+module Crypto.Cipher.Blowfish.Primitive
+    ( Context
+    , initBlowfish
+    , encrypt
+    , decrypt
+    , KeySchedule
+    , createKeySchedule
+    , freezeKeySchedule
+    , expandKey
+    , expandKeyWithSalt
+    , cipherBlockMutable
+    ) where
+
+import           Control.Monad              (when)
+import           Data.Bits
+import           Data.Memory.Endian
+import           Data.Word
+
+import           Crypto.Cipher.Blowfish.Box
+import           Crypto.Error
+import           Crypto.Internal.ByteArray  (ByteArray, ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray  as B
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Crypto.Internal.WordArray
+
+newtype Context = Context Array32
+
+instance NFData Context where
+    rnf a = a `seq` ()
+
+-- | Initialize a new Blowfish context from a key.
+--
+-- key needs to be between 0 and 448 bits.
+initBlowfish :: ByteArrayAccess key => key -> CryptoFailable Context
+initBlowfish key
+    | B.length key > (448 `div` 8) = CryptoFailed CryptoError_KeySizeInvalid
+    | otherwise                    = CryptoPassed $ unsafeDoIO $ do
+        ks <- createKeySchedule
+        expandKey ks key
+        freezeKeySchedule ks
+
+-- | Get an immutable Blowfish context by freezing a mutable key schedule.
+freezeKeySchedule :: KeySchedule -> IO Context
+freezeKeySchedule (KeySchedule ma) = Context `fmap` mutableArray32Freeze ma
+
+expandKey :: (ByteArrayAccess key) => KeySchedule -> key -> IO ()
+expandKey ks@(KeySchedule ma) key = do
+    when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do
+        mutableArrayWriteXor32 ma i l
+        mutableArrayWriteXor32 ma (i + 1) r
+        when (i + 2 < 18) (cont a0 a1)
+    loop 0 0 0
+    where
+        loop i l r = do
+            n <- cipherBlockMutable ks (fromIntegral l `shiftL` 32 .|. fromIntegral r)
+            let nl = fromIntegral (n `shiftR` 32)
+                nr = fromIntegral (n .&. 0xffffffff)
+            mutableArrayWrite32 ma i nl
+            mutableArrayWrite32 ma (i + 1) nr
+            when (i < 18 + 1024) (loop (i + 2) nl nr)
+
+expandKeyWithSalt :: (ByteArrayAccess key, ByteArrayAccess salt)
+    => KeySchedule
+    -> key
+    -> salt
+    -> IO ()
+expandKeyWithSalt ks key salt
+    | B.length salt == 16 = expandKeyWithSalt128 ks key (fromBE $ B.toW64BE salt 0) (fromBE $ B.toW64BE salt 8)
+    | otherwise           = expandKeyWithSaltAny ks key salt
+
+expandKeyWithSaltAny :: (ByteArrayAccess key, ByteArrayAccess salt)
+    => KeySchedule         -- ^ The key schedule
+    -> key                 -- ^ The key
+    -> salt                -- ^ The salt
+    -> IO ()
+expandKeyWithSaltAny ks@(KeySchedule ma) key salt = do
+    when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do
+        mutableArrayWriteXor32 ma i l
+        mutableArrayWriteXor32 ma (i + 1) r
+        when (i + 2 < 18) (cont a0 a1)
+    -- Go through the entire key schedule overwriting the P-Array and S-Boxes
+    when (B.length salt > 0) $ iterKeyStream salt 0 0 $ \i l r a0 a1 cont-> do
+        let l' = xor l a0
+        let r' = xor r a1
+        n <- cipherBlockMutable ks (fromIntegral l' `shiftL` 32 .|. fromIntegral r')
+        let nl = fromIntegral (n `shiftR` 32)
+            nr = fromIntegral (n .&. 0xffffffff)
+        mutableArrayWrite32 ma i nl
+        mutableArrayWrite32 ma (i + 1) nr
+        when (i + 2 < 18 + 1024) (cont nl nr)
+
+expandKeyWithSalt128 :: ByteArrayAccess ba
+    => KeySchedule         -- ^ The key schedule
+    -> ba                  -- ^ The key
+    -> Word64              -- ^ First word of the salt
+    -> Word64              -- ^ Second word of the salt
+    -> IO ()
+expandKeyWithSalt128 ks@(KeySchedule ma) key salt1 salt2 = do
+    when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do
+        mutableArrayWriteXor32 ma i l
+        mutableArrayWriteXor32 ma (i + 1) r
+        when (i + 2 < 18) (cont a0 a1)
+    -- Go through the entire key schedule overwriting the P-Array and S-Boxes
+    loop 0 salt1 salt1 salt2
+    where
+        loop i input slt1 slt2
+            | i == 1042   = return ()
+            | otherwise = do
+                n <- cipherBlockMutable ks input
+                let nl = fromIntegral (n `shiftR` 32)
+                    nr = fromIntegral (n .&. 0xffffffff)
+                mutableArrayWrite32 ma i     nl
+                mutableArrayWrite32 ma (i+1) nr
+                loop (i+2) (n `xor` slt2) slt2 slt1
+
+-- | Encrypt blocks
+--
+-- Input need to be a multiple of 8 bytes
+encrypt :: ByteArray ba => Context -> ba -> ba
+encrypt ctx ba
+    | B.length ba == 0         = B.empty
+    | B.length ba `mod` 8 /= 0 = error "invalid data length"
+    | otherwise                = B.mapAsWord64 (cipherBlock ctx False) ba
+
+-- | Decrypt blocks
+--
+-- Input need to be a multiple of 8 bytes
+decrypt :: ByteArray ba => Context -> ba -> ba
+decrypt ctx ba
+    | B.length ba == 0         = B.empty
+    | B.length ba `mod` 8 /= 0 = error "invalid data length"
+    | otherwise                = B.mapAsWord64 (cipherBlock ctx True) ba
+
+-- | Encrypt or decrypt a single block of 64 bits.
+--
+-- The inverse argument decides whether to encrypt or decrypt.
+cipherBlock :: Context -> Bool -> Word64 -> Word64
+cipherBlock (Context ar) inverse input = doRound input 0
+    where
+    -- | Transform the input over 16 rounds
+    doRound :: Word64 -> Int -> Word64
+    doRound !i roundIndex
+        | roundIndex == 16 =
+            let final = (fromIntegral (p 16) `shiftL` 32) .|. fromIntegral (p 17)
+             in rotateL (i `xor` final) 32
+        | otherwise     =
+            let newr = fromIntegral (i `shiftR` 32) `xor` p roundIndex
+                newi = ((i `shiftL` 32) `xor` f newr) .|. fromIntegral newr
+             in doRound newi (roundIndex+1)
+
+    -- | The Blowfish Feistel function F
+    f   :: Word32 -> Word64
+    f t = let a = s0 (0xff .&. (t `shiftR` 24))
+              b = s1 (0xff .&. (t `shiftR` 16))
+              c = s2 (0xff .&. (t `shiftR` 8))
+              d = s3 (0xff .&.  t)
+           in fromIntegral (((a + b) `xor` c) + d) `shiftL` 32
+
+    -- | S-Box arrays, each containing 256 32-bit words
+    --   The first 18 words contain the P-Array of subkeys
+    s0, s1, s2, s3 :: Word32 -> Word32
+    s0 i            = arrayRead32 ar (fromIntegral i + 18)
+    s1 i            = arrayRead32 ar (fromIntegral i + 274)
+    s2 i            = arrayRead32 ar (fromIntegral i + 530)
+    s3 i            = arrayRead32 ar (fromIntegral i + 786)
+    p              :: Int -> Word32
+    p i | inverse   = arrayRead32 ar (17 - i)
+        | otherwise = arrayRead32 ar i
+
+-- | Blowfish encrypt a Word using the current state of the key schedule
+cipherBlockMutable :: KeySchedule -> Word64 -> IO Word64
+cipherBlockMutable (KeySchedule ma) input = doRound input 0
+    where
+    -- | Transform the input over 16 rounds
+    doRound !i roundIndex
+        | roundIndex == 16 = do
+            pVal1 <- mutableArrayRead32 ma 16
+            pVal2 <- mutableArrayRead32 ma 17
+            let final = (fromIntegral pVal1 `shiftL` 32) .|. fromIntegral pVal2
+            return $ rotateL (i `xor` final) 32
+        | otherwise     = do
+            pVal <- mutableArrayRead32 ma roundIndex
+            let newr = fromIntegral (i `shiftR` 32) `xor` pVal
+            newr' <- f newr
+            let newi = ((i `shiftL` 32) `xor` newr') .|. fromIntegral newr
+            doRound newi (roundIndex+1)
+
+    -- | The Blowfish Feistel function F
+    f   :: Word32 -> IO Word64
+    f t = do
+        a <- s0 (0xff .&. (t `shiftR` 24))
+        b <- s1 (0xff .&. (t `shiftR` 16))
+        c <- s2 (0xff .&. (t `shiftR` 8))
+        d <- s3 (0xff .&.  t)
+        return (fromIntegral (((a + b) `xor` c) + d) `shiftL` 32)
+
+    -- | S-Box arrays, each containing 256 32-bit words
+    --   The first 18 words contain the P-Array of subkeys
+    s0, s1, s2, s3 :: Word32 -> IO Word32
+    s0 i = mutableArrayRead32 ma (fromIntegral i + 18)
+    s1 i = mutableArrayRead32 ma (fromIntegral i + 274)
+    s2 i = mutableArrayRead32 ma (fromIntegral i + 530)
+    s3 i = mutableArrayRead32 ma (fromIntegral i + 786)
+
+iterKeyStream :: (ByteArrayAccess x)
+    => x
+    -> Word32
+    -> Word32
+    -> (Int -> Word32 -> Word32 -> Word32 -> Word32 -> (Word32 -> Word32 -> IO ()) -> IO ())
+    -> IO ()
+iterKeyStream x a0 a1 g = f 0 0 a0 a1
+    where
+        len          = B.length x
+        -- Avoiding the modulo operation when interating over the ring
+        -- buffer is assumed to be more efficient here. All other
+        -- implementations do this, too. The branch prediction shall prefer
+        -- the branch with the increment.
+        n j          = if j + 1 >= len then 0 else j + 1
+        f i j0 b0 b1 = g i l r b0 b1 (f (i + 2) j8)
+            where
+                j1 = n j0
+                j2 = n j1
+                j3 = n j2
+                j4 = n j3
+                j5 = n j4
+                j6 = n j5
+                j7 = n j6
+                j8 = n j7
+                x0 = fromIntegral (B.index x j0)
+                x1 = fromIntegral (B.index x j1)
+                x2 = fromIntegral (B.index x j2)
+                x3 = fromIntegral (B.index x j3)
+                x4 = fromIntegral (B.index x j4)
+                x5 = fromIntegral (B.index x j5)
+                x6 = fromIntegral (B.index x j6)
+                x7 = fromIntegral (B.index x j7)
+                l  = shiftL x0 24 .|. shiftL x1 16 .|. shiftL x2 8 .|. x3
+                r  = shiftL x4 24 .|. shiftL x5 16 .|. shiftL x6 8 .|. x7
+{-# INLINE iterKeyStream #-}
+-- Benchmarking shows that GHC considers this function too big to inline
+-- although forcing inlining causes an actual improvement.
+-- It is assumed that all function calls (especially the continuation)
+-- collapse into a tight loop after inlining.

bundled/Crypto/Cipher/CAST5.hs

@@ -0,0 +1,43 @@
+-- |
+-- Module      : Crypto.Cipher.CAST5
+-- License     : BSD-style
+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
+-- Stability   : stable
+-- Portability : good
+--
+module Crypto.Cipher.CAST5
+    ( CAST5
+    ) where
+
+import           Crypto.Error
+import           Crypto.Cipher.Types
+import           Crypto.Cipher.CAST5.Primitive
+import           Crypto.Internal.ByteArray (ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray as B
+
+-- | CAST5 block cipher (also known as CAST-128).  Key is between
+-- 40 and 128 bits.
+newtype CAST5 = CAST5 Key
+
+instance Cipher CAST5 where
+    cipherName    _ = "CAST5"
+    cipherKeySize _ = KeySizeRange 5 16
+    cipherInit      = initCAST5
+
+instance BlockCipher CAST5 where
+    blockSize _ = 8
+    ecbEncrypt (CAST5 k) = B.mapAsWord64 (encrypt k)
+    ecbDecrypt (CAST5 k) = B.mapAsWord64 (decrypt k)
+
+initCAST5 :: ByteArrayAccess key => key -> CryptoFailable CAST5
+initCAST5 bs
+    | len <   5 = CryptoFailed CryptoError_KeySizeInvalid
+    | len <  16 = CryptoPassed (CAST5 $ buildKey short padded)
+    | len == 16 = CryptoPassed (CAST5 $ buildKey False bs)
+    | otherwise = CryptoFailed CryptoError_KeySizeInvalid
+  where
+    len   = B.length bs
+    short = len <= 10
+
+    padded :: B.Bytes
+    padded = B.convert bs `B.append` B.replicate (16 - len) 0

bundled/Crypto/Cipher/CAST5/Primitive.hs

@@ -0,0 +1,573 @@
+{-# LANGUAGE MagicHash #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Crypto.Cipher.CAST5.Primitive
+-- License     :  BSD-style
+--
+-- Haskell implementation of the CAST-128 Encryption Algorithm
+--
+-----------------------------------------------------------------------------
+
+
+module Crypto.Cipher.CAST5.Primitive
+    ( encrypt
+    , decrypt
+    , Key()
+    , buildKey
+    ) where
+
+import Control.Monad (void, (>=>))
+
+import Data.Bits
+import Data.Memory.Endian
+import Data.Word
+
+import           Crypto.Internal.ByteArray (ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.WordArray
+
+
+-- Data Types
+
+data P = P {-# UNPACK #-} !Word32 -- left word
+           {-# UNPACK #-} !Word32 -- right word
+
+data Q = Q {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
+           {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
+
+-- | All subkeys for 12 or 16 rounds
+data Key = K12 {-# UNPACK #-} !Array32 -- [ km1, kr1, km2, kr2, ..., km12, kr12 ]
+         | K16 {-# UNPACK #-} !Array32 -- [ km1, kr1, km2, kr2, ..., km16, kr16 ]
+
+
+-- Big-endian Transformations
+
+decomp64 :: Word64 -> P
+decomp64 x = P (fromIntegral (x `shiftR` 32)) (fromIntegral x)
+
+comp64 :: P -> Word64
+comp64 (P l r) = (fromIntegral l `shiftL` 32) .|. fromIntegral r
+
+decomp32 :: Word32 -> (Word8, Word8, Word8, Word8)
+decomp32 x =
+    let a = fromIntegral (x `shiftR` 24)
+        b = fromIntegral (x `shiftR` 16)
+        c = fromIntegral (x `shiftR`  8)
+        d = fromIntegral x
+    in (a, b, c, d)
+
+
+-- Encryption
+
+-- | Encrypts a block using the specified key
+encrypt :: Key -> Word64 -> Word64
+encrypt k = comp64 . cast_enc k . decomp64
+
+cast_enc :: Key -> P -> P
+cast_enc (K12 a) (P l0 r0) = P r12 r11
+  where
+    r1  = type1 a 0  l0  r0
+    r2  = type2 a 2  r0  r1
+    r3  = type3 a 4  r1  r2
+    r4  = type1 a 6  r2  r3
+    r5  = type2 a 8  r3  r4
+    r6  = type3 a 10 r4  r5
+    r7  = type1 a 12 r5  r6
+    r8  = type2 a 14 r6  r7
+    r9  = type3 a 16 r7  r8
+    r10 = type1 a 18 r8  r9
+    r11 = type2 a 20 r9  r10
+    r12 = type3 a 22 r10 r11
+
+cast_enc (K16 a) p = P r16 r15
+  where
+    P r12 r11 = cast_enc (K12 a) p
+
+    r13 = type1 a 24 r11 r12
+    r14 = type2 a 26 r12 r13
+    r15 = type3 a 28 r13 r14
+    r16 = type1 a 30 r14 r15
+
+-- Decryption
+
+-- | Decrypts a block using the specified key
+decrypt :: Key -> Word64 -> Word64
+decrypt k = comp64 . cast_dec k . decomp64
+
+cast_dec :: Key -> P -> P
+cast_dec (K12 a) (P r12 r11) = P l0 r0
+  where
+    r10 = type3 a 22 r12 r11
+    r9  = type2 a 20 r11 r10
+    r8  = type1 a 18 r10 r9
+    r7  = type3 a 16 r9  r8
+    r6  = type2 a 14 r8  r7
+    r5  = type1 a 12 r7  r6
+    r4  = type3 a 10 r6  r5
+    r3  = type2 a 8  r5  r4
+    r2  = type1 a 6  r4  r3
+    r1  = type3 a 4  r3  r2
+    r0  = type2 a 2  r2  r1
+    l0  = type1 a 0  r1  r0
+
+cast_dec (K16 a) (P r16 r15) = cast_dec (K12 a) (P r12 r11)
+  where
+    r14 = type1 a 30 r16 r15
+    r13 = type3 a 28 r15 r14
+    r12 = type2 a 26 r14 r13
+    r11 = type1 a 24 r13 r12
+
+
+-- Non-Identical Rounds
+
+type1 :: Array32 -> Int -> Word32 -> Word32 -> Word32
+type1 arr idx l r =
+    let km = arrayRead32 arr idx
+        kr = arrayRead32 arr (idx + 1)
+        j = (km + r) `rotateL` fromIntegral kr
+        (ja, jb, jc, jd) = decomp32 j
+     in l `xor` (((sbox_s1 ja `xor` sbox_s2 jb) - sbox_s3 jc) + sbox_s4 jd)
+
+type2 :: Array32 -> Int -> Word32 -> Word32 -> Word32
+type2 arr idx l r =
+    let km = arrayRead32 arr idx
+        kr = arrayRead32 arr (idx + 1)
+        j = (km `xor` r) `rotateL` fromIntegral kr
+        (ja, jb, jc, jd) = decomp32 j
+     in l `xor` (((sbox_s1 ja - sbox_s2 jb) + sbox_s3 jc) `xor` sbox_s4 jd)
+
+type3 :: Array32 -> Int -> Word32 -> Word32 -> Word32
+type3 arr idx l r =
+    let km = arrayRead32 arr idx
+        kr = arrayRead32 arr (idx + 1)
+        j = (km - r) `rotateL` fromIntegral kr
+        (ja, jb, jc, jd) = decomp32 j
+     in l `xor` (((sbox_s1 ja + sbox_s2 jb) `xor` sbox_s3 jc) - sbox_s4 jd)
+
+
+-- Key Schedule
+
+-- | Precompute "masking" and "rotation" subkeys
+buildKey :: ByteArrayAccess key
+         => Bool -- ^ @True@ for short keys that only need 12 rounds
+         -> key  -- ^ Input key padded to 16 bytes
+         -> Key  -- ^ Output data structure
+buildKey isShort key =
+    let P x0123 x4567 = decomp64 (fromBE $ B.toW64BE key 0)
+        P x89AB xCDEF = decomp64 (fromBE $ B.toW64BE key 8)
+     in keySchedule isShort (Q x0123 x4567 x89AB xCDEF)
+
+keySchedule :: Bool -> Q -> Key
+keySchedule isShort x
+    | isShort   = K12 $ allocArray32AndFreeze 24 $ \ma ->
+        void (steps123 ma 0 x >>= skip4 >>= steps123 ma 1)
+
+    | otherwise = K16 $ allocArray32AndFreeze 32 $ \ma ->
+        void (steps123 ma 0 x >>= step4 ma 24 >>= steps123 ma 1 >>= step4 ma 25)
+
+  where
+    sbox_s56785 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s5 e
+    sbox_s56786 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s6 e
+    sbox_s56787 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s7 e
+    sbox_s56788 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s8 e
+
+    steps123 ma off = step1 ma off >=> step2 ma (off + 8) >=> step3 ma (off + 16)
+
+    step1 :: MutableArray32 -> Int -> Q -> IO Q
+    step1 ma off (Q x0123 x4567 x89AB xCDEF) = do
+        let (x8, x9, xA, xB) = decomp32 x89AB
+            (xC, xD, xE, xF) = decomp32 xCDEF
+
+            z0123 = x0123 `xor` sbox_s56787 xD xF xC xE x8
+            z4567 = x89AB `xor` sbox_s56788 z0 z2 z1 z3 xA
+            z89AB = xCDEF `xor` sbox_s56785 z7 z6 z5 z4 x9
+            zCDEF = x4567 `xor` sbox_s56786 zA z9 zB z8 xB
+
+            (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+            (z8, z9, zA, zB) = decomp32 z89AB
+            (zC, zD, zE, zF) = decomp32 zCDEF
+
+        mutableArrayWrite32 ma (off + 0) $ sbox_s56785 z8 z9 z7 z6 z2
+        mutableArrayWrite32 ma (off + 2) $ sbox_s56786 zA zB z5 z4 z6
+        mutableArrayWrite32 ma (off + 4) $ sbox_s56787 zC zD z3 z2 z9
+        mutableArrayWrite32 ma (off + 6) $ sbox_s56788 zE zF z1 z0 zC
+        return (Q z0123 z4567 z89AB zCDEF)
+
+    step2 :: MutableArray32 -> Int -> Q -> IO Q
+    step2 ma off (Q z0123 z4567 z89AB zCDEF) = do
+        let (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+
+            x0123 = z89AB `xor` sbox_s56787 z5 z7 z4 z6 z0
+            x4567 = z0123 `xor` sbox_s56788 x0 x2 x1 x3 z2
+            x89AB = z4567 `xor` sbox_s56785 x7 x6 x5 x4 z1
+            xCDEF = zCDEF `xor` sbox_s56786 xA x9 xB x8 z3
+
+            (x0, x1, x2, x3) = decomp32 x0123
+            (x4, x5, x6, x7) = decomp32 x4567
+            (x8, x9, xA, xB) = decomp32 x89AB
+            (xC, xD, xE, xF) = decomp32 xCDEF
+
+        mutableArrayWrite32 ma (off + 0) $ sbox_s56785 x3 x2 xC xD x8
+        mutableArrayWrite32 ma (off + 2) $ sbox_s56786 x1 x0 xE xF xD
+        mutableArrayWrite32 ma (off + 4) $ sbox_s56787 x7 x6 x8 x9 x3
+        mutableArrayWrite32 ma (off + 6) $ sbox_s56788 x5 x4 xA xB x7
+        return (Q x0123 x4567 x89AB xCDEF)
+
+    step3 :: MutableArray32 -> Int -> Q -> IO Q
+    step3 ma off (Q x0123 x4567 x89AB xCDEF) = do
+        let (x8, x9, xA, xB) = decomp32 x89AB
+            (xC, xD, xE, xF) = decomp32 xCDEF
+
+            z0123 = x0123 `xor` sbox_s56787 xD xF xC xE x8
+            z4567 = x89AB `xor` sbox_s56788 z0 z2 z1 z3 xA
+            z89AB = xCDEF `xor` sbox_s56785 z7 z6 z5 z4 x9
+            zCDEF = x4567 `xor` sbox_s56786 zA z9 zB z8 xB
+
+            (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+            (z8, z9, zA, zB) = decomp32 z89AB
+            (zC, zD, zE, zF) = decomp32 zCDEF
+
+        mutableArrayWrite32 ma (off + 0) $ sbox_s56785 z3 z2 zC zD z9
+        mutableArrayWrite32 ma (off + 2) $ sbox_s56786 z1 z0 zE zF zC
+        mutableArrayWrite32 ma (off + 4) $ sbox_s56787 z7 z6 z8 z9 z2
+        mutableArrayWrite32 ma (off + 6) $ sbox_s56788 z5 z4 zA zB z6
+        return (Q z0123 z4567 z89AB zCDEF)
+
+    step4 :: MutableArray32 -> Int -> Q -> IO Q
+    step4 ma off (Q z0123 z4567 z89AB zCDEF) = do
+        let (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+
+            x0123 = z89AB `xor` sbox_s56787 z5 z7 z4 z6 z0
+            x4567 = z0123 `xor` sbox_s56788 x0 x2 x1 x3 z2
+            x89AB = z4567 `xor` sbox_s56785 x7 x6 x5 x4 z1
+            xCDEF = zCDEF `xor` sbox_s56786 xA x9 xB x8 z3
+
+            (x0, x1, x2, x3) = decomp32 x0123
+            (x4, x5, x6, x7) = decomp32 x4567
+            (x8, x9, xA, xB) = decomp32 x89AB
+            (xC, xD, xE, xF) = decomp32 xCDEF
+
+        mutableArrayWrite32 ma (off + 0) $ sbox_s56785 x8 x9 x7 x6 x3
+        mutableArrayWrite32 ma (off + 2) $ sbox_s56786 xA xB x5 x4 x7
+        mutableArrayWrite32 ma (off + 4) $ sbox_s56787 xC xD x3 x2 x8
+        mutableArrayWrite32 ma (off + 6) $ sbox_s56788 xE xF x1 x0 xD
+        return (Q x0123 x4567 x89AB xCDEF)
+
+    skip4 :: Q -> IO Q
+    skip4 (Q z0123 z4567 z89AB zCDEF) = do
+        let (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+
+            x0123 = z89AB `xor` sbox_s56787 z5 z7 z4 z6 z0
+            x4567 = z0123 `xor` sbox_s56788 x0 x2 x1 x3 z2
+            x89AB = z4567 `xor` sbox_s56785 x7 x6 x5 x4 z1
+            xCDEF = zCDEF `xor` sbox_s56786 xA x9 xB x8 z3
+
+            (x0, x1, x2, x3) = decomp32 x0123
+            (x4, x5, x6, x7) = decomp32 x4567
+            (x8, x9, xA, xB) = decomp32 x89AB
+
+        return (Q x0123 x4567 x89AB xCDEF)
+
+-- S-Boxes
+
+sbox_s1 :: Word8 -> Word32
+sbox_s1 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x30\xfb\x40\xd4\x9f\xa0\xff\x0b\x6b\xec\xcd\x2f\x3f\x25\x8c\x7a\x1e\x21\x3f\x2f\x9c\x00\x4d\xd3\x60\x03\xe5\x40\xcf\x9f\xc9\x49\
+            \\xbf\xd4\xaf\x27\x88\xbb\xbd\xb5\xe2\x03\x40\x90\x98\xd0\x96\x75\x6e\x63\xa0\xe0\x15\xc3\x61\xd2\xc2\xe7\x66\x1d\x22\xd4\xff\x8e\
+            \\x28\x68\x3b\x6f\xc0\x7f\xd0\x59\xff\x23\x79\xc8\x77\x5f\x50\xe2\x43\xc3\x40\xd3\xdf\x2f\x86\x56\x88\x7c\xa4\x1a\xa2\xd2\xbd\x2d\
+            \\xa1\xc9\xe0\xd6\x34\x6c\x48\x19\x61\xb7\x6d\x87\x22\x54\x0f\x2f\x2a\xbe\x32\xe1\xaa\x54\x16\x6b\x22\x56\x8e\x3a\xa2\xd3\x41\xd0\
+            \\x66\xdb\x40\xc8\xa7\x84\x39\x2f\x00\x4d\xff\x2f\x2d\xb9\xd2\xde\x97\x94\x3f\xac\x4a\x97\xc1\xd8\x52\x76\x44\xb7\xb5\xf4\x37\xa7\
+            \\xb8\x2c\xba\xef\xd7\x51\xd1\x59\x6f\xf7\xf0\xed\x5a\x09\x7a\x1f\x82\x7b\x68\xd0\x90\xec\xf5\x2e\x22\xb0\xc0\x54\xbc\x8e\x59\x35\
+            \\x4b\x6d\x2f\x7f\x50\xbb\x64\xa2\xd2\x66\x49\x10\xbe\xe5\x81\x2d\xb7\x33\x22\x90\xe9\x3b\x15\x9f\xb4\x8e\xe4\x11\x4b\xff\x34\x5d\
+            \\xfd\x45\xc2\x40\xad\x31\x97\x3f\xc4\xf6\xd0\x2e\x55\xfc\x81\x65\xd5\xb1\xca\xad\xa1\xac\x2d\xae\xa2\xd4\xb7\x6d\xc1\x9b\x0c\x50\
+            \\x88\x22\x40\xf2\x0c\x6e\x4f\x38\xa4\xe4\xbf\xd7\x4f\x5b\xa2\x72\x56\x4c\x1d\x2f\xc5\x9c\x53\x19\xb9\x49\xe3\x54\xb0\x46\x69\xfe\
+            \\xb1\xb6\xab\x8a\xc7\x13\x58\xdd\x63\x85\xc5\x45\x11\x0f\x93\x5d\x57\x53\x8a\xd5\x6a\x39\x04\x93\xe6\x3d\x37\xe0\x2a\x54\xf6\xb3\
+            \\x3a\x78\x7d\x5f\x62\x76\xa0\xb5\x19\xa6\xfc\xdf\x7a\x42\x20\x6a\x29\xf9\xd4\xd5\xf6\x1b\x18\x91\xbb\x72\x27\x5e\xaa\x50\x81\x67\
+            \\x38\x90\x10\x91\xc6\xb5\x05\xeb\x84\xc7\xcb\x8c\x2a\xd7\x5a\x0f\x87\x4a\x14\x27\xa2\xd1\x93\x6b\x2a\xd2\x86\xaf\xaa\x56\xd2\x91\
+            \\xd7\x89\x43\x60\x42\x5c\x75\x0d\x93\xb3\x9e\x26\x18\x71\x84\xc9\x6c\x00\xb3\x2d\x73\xe2\xbb\x14\xa0\xbe\xbc\x3c\x54\x62\x37\x79\
+            \\x64\x45\x9e\xab\x3f\x32\x8b\x82\x77\x18\xcf\x82\x59\xa2\xce\xa6\x04\xee\x00\x2e\x89\xfe\x78\xe6\x3f\xab\x09\x50\x32\x5f\xf6\xc2\
+            \\x81\x38\x3f\x05\x69\x63\xc5\xc8\x76\xcb\x5a\xd6\xd4\x99\x74\xc9\xca\x18\x0d\xcf\x38\x07\x82\xd5\xc7\xfa\x5c\xf6\x8a\xc3\x15\x11\
+            \\x35\xe7\x9e\x13\x47\xda\x91\xd0\xf4\x0f\x90\x86\xa7\xe2\x41\x9e\x31\x36\x62\x41\x05\x1e\xf4\x95\xaa\x57\x3b\x04\x4a\x80\x5d\x8d\
+            \\x54\x83\x00\xd0\x00\x32\x2a\x3c\xbf\x64\xcd\xdf\xba\x57\xa6\x8e\x75\xc6\x37\x2b\x50\xaf\xd3\x41\xa7\xc1\x32\x75\x91\x5a\x0b\xf5\
+            \\x6b\x54\xbf\xab\x2b\x0b\x14\x26\xab\x4c\xc9\xd7\x44\x9c\xcd\x82\xf7\xfb\xf2\x65\xab\x85\xc5\xf3\x1b\x55\xdb\x94\xaa\xd4\xe3\x24\
+            \\xcf\xa4\xbd\x3f\x2d\xea\xa3\xe2\x9e\x20\x4d\x02\xc8\xbd\x25\xac\xea\xdf\x55\xb3\xd5\xbd\x9e\x98\xe3\x12\x31\xb2\x2a\xd5\xad\x6c\
+            \\x95\x43\x29\xde\xad\xbe\x45\x28\xd8\x71\x0f\x69\xaa\x51\xc9\x0f\xaa\x78\x6b\xf6\x22\x51\x3f\x1e\xaa\x51\xa7\x9b\x2a\xd3\x44\xcc\
+            \\x7b\x5a\x41\xf0\xd3\x7c\xfb\xad\x1b\x06\x95\x05\x41\xec\xe4\x91\xb4\xc3\x32\xe6\x03\x22\x68\xd4\xc9\x60\x0a\xcc\xce\x38\x7e\x6d\
+            \\xbf\x6b\xb1\x6c\x6a\x70\xfb\x78\x0d\x03\xd9\xc9\xd4\xdf\x39\xde\xe0\x10\x63\xda\x47\x36\xf4\x64\x5a\xd3\x28\xd8\xb3\x47\xcc\x96\
+            \\x75\xbb\x0f\xc3\x98\x51\x1b\xfb\x4f\xfb\xcc\x35\xb5\x8b\xcf\x6a\xe1\x1f\x0a\xbc\xbf\xc5\xfe\x4a\xa7\x0a\xec\x10\xac\x39\x57\x0a\
+            \\x3f\x04\x44\x2f\x61\x88\xb1\x53\xe0\x39\x7a\x2e\x57\x27\xcb\x79\x9c\xeb\x41\x8f\x1c\xac\xd6\x8d\x2a\xd3\x7c\x96\x01\x75\xcb\x9d\
+            \\xc6\x9d\xff\x09\xc7\x5b\x65\xf0\xd9\xdb\x40\xd8\xec\x0e\x77\x79\x47\x44\xea\xd4\xb1\x1c\x32\x74\xdd\x24\xcb\x9e\x7e\x1c\x54\xbd\
+            \\xf0\x11\x44\xf9\xd2\x24\x0e\xb1\x96\x75\xb3\xfd\xa3\xac\x37\x55\xd4\x7c\x27\xaf\x51\xc8\x5f\x4d\x56\x90\x75\x96\xa5\xbb\x15\xe6\
+            \\x58\x03\x04\xf0\xca\x04\x2c\xf1\x01\x1a\x37\xea\x8d\xbf\xaa\xdb\x35\xba\x3e\x4a\x35\x26\xff\xa0\xc3\x7b\x4d\x09\xbc\x30\x6e\xd9\
+            \\x98\xa5\x26\x66\x56\x48\xf7\x25\xff\x5e\x56\x9d\x0c\xed\x63\xd0\x7c\x63\xb2\xcf\x70\x0b\x45\xe1\xd5\xea\x50\xf1\x85\xa9\x28\x72\
+            \\xaf\x1f\xbd\xa7\xd4\x23\x48\x70\xa7\x87\x0b\xf3\x2d\x3b\x4d\x79\x42\xe0\x41\x98\x0c\xd0\xed\xe7\x26\x47\x0d\xb8\xf8\x81\x81\x4c\
+            \\x47\x4d\x6a\xd7\x7c\x0c\x5e\x5c\xd1\x23\x19\x59\x38\x1b\x72\x98\xf5\xd2\xf4\xdb\xab\x83\x86\x53\x6e\x2f\x1e\x23\x83\x71\x9c\x9e\
+            \\xbd\x91\xe0\x46\x9a\x56\x45\x6e\xdc\x39\x20\x0c\x20\xc8\xc5\x71\x96\x2b\xda\x1c\xe1\xe6\x96\xff\xb1\x41\xab\x08\x7c\xca\x89\xb9\
+            \\x1a\x69\xe7\x83\x02\xcc\x48\x43\xa2\xf7\xc5\x79\x42\x9e\xf4\x7d\x42\x7b\x16\x9c\x5a\xc9\xf0\x49\xdd\x8f\x0f\x00\x5c\x81\x65\xbf"#
+
+sbox_s2 :: Word8 -> Word32
+sbox_s2 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x1f\x20\x10\x94\xef\x0b\xa7\x5b\x69\xe3\xcf\x7e\x39\x3f\x43\x80\xfe\x61\xcf\x7a\xee\xc5\x20\x7a\x55\x88\x9c\x94\x72\xfc\x06\x51\
+            \\xad\xa7\xef\x79\x4e\x1d\x72\x35\xd5\x5a\x63\xce\xde\x04\x36\xba\x99\xc4\x30\xef\x5f\x0c\x07\x94\x18\xdc\xdb\x7d\xa1\xd6\xef\xf3\
+            \\xa0\xb5\x2f\x7b\x59\xe8\x36\x05\xee\x15\xb0\x94\xe9\xff\xd9\x09\xdc\x44\x00\x86\xef\x94\x44\x59\xba\x83\xcc\xb3\xe0\xc3\xcd\xfb\
+            \\xd1\xda\x41\x81\x3b\x09\x2a\xb1\xf9\x97\xf1\xc1\xa5\xe6\xcf\x7b\x01\x42\x0d\xdb\xe4\xe7\xef\x5b\x25\xa1\xff\x41\xe1\x80\xf8\x06\
+            \\x1f\xc4\x10\x80\x17\x9b\xee\x7a\xd3\x7a\xc6\xa9\xfe\x58\x30\xa4\x98\xde\x8b\x7f\x77\xe8\x3f\x4e\x79\x92\x92\x69\x24\xfa\x9f\x7b\
+            \\xe1\x13\xc8\x5b\xac\xc4\x00\x83\xd7\x50\x35\x25\xf7\xea\x61\x5f\x62\x14\x31\x54\x0d\x55\x4b\x63\x5d\x68\x11\x21\xc8\x66\xc3\x59\
+            \\x3d\x63\xcf\x73\xce\xe2\x34\xc0\xd4\xd8\x7e\x87\x5c\x67\x2b\x21\x07\x1f\x61\x81\x39\xf7\x62\x7f\x36\x1e\x30\x84\xe4\xeb\x57\x3b\
+            \\x60\x2f\x64\xa4\xd6\x3a\xcd\x9c\x1b\xbc\x46\x35\x9e\x81\x03\x2d\x27\x01\xf5\x0c\x99\x84\x7a\xb4\xa0\xe3\xdf\x79\xba\x6c\xf3\x8c\
+            \\x10\x84\x30\x94\x25\x37\xa9\x5e\xf4\x6f\x6f\xfe\xa1\xff\x3b\x1f\x20\x8c\xfb\x6a\x8f\x45\x8c\x74\xd9\xe0\xa2\x27\x4e\xc7\x3a\x34\
+            \\xfc\x88\x4f\x69\x3e\x4d\xe8\xdf\xef\x0e\x00\x88\x35\x59\x64\x8d\x8a\x45\x38\x8c\x1d\x80\x43\x66\x72\x1d\x9b\xfd\xa5\x86\x84\xbb\
+            \\xe8\x25\x63\x33\x84\x4e\x82\x12\x12\x8d\x80\x98\xfe\xd3\x3f\xb4\xce\x28\x0a\xe1\x27\xe1\x9b\xa5\xd5\xa6\xc2\x52\xe4\x97\x54\xbd\
+            \\xc5\xd6\x55\xdd\xeb\x66\x70\x64\x77\x84\x0b\x4d\xa1\xb6\xa8\x01\x84\xdb\x26\xa9\xe0\xb5\x67\x14\x21\xf0\x43\xb7\xe5\xd0\x58\x60\
+            \\x54\xf0\x30\x84\x06\x6f\xf4\x72\xa3\x1a\xa1\x53\xda\xdc\x47\x55\xb5\x62\x5d\xbf\x68\x56\x1b\xe6\x83\xca\x6b\x94\x2d\x6e\xd2\x3b\
+            \\xec\xcf\x01\xdb\xa6\xd3\xd0\xba\xb6\x80\x3d\x5c\xaf\x77\xa7\x09\x33\xb4\xa3\x4c\x39\x7b\xc8\xd6\x5e\xe2\x2b\x95\x5f\x0e\x53\x04\
+            \\x81\xed\x6f\x61\x20\xe7\x43\x64\xb4\x5e\x13\x78\xde\x18\x63\x9b\x88\x1c\xa1\x22\xb9\x67\x26\xd1\x80\x49\xa7\xe8\x22\xb7\xda\x7b\
+            \\x5e\x55\x2d\x25\x52\x72\xd2\x37\x79\xd2\x95\x1c\xc6\x0d\x89\x4c\x48\x8c\xb4\x02\x1b\xa4\xfe\x5b\xa4\xb0\x9f\x6b\x1c\xa8\x15\xcf\
+            \\xa2\x0c\x30\x05\x88\x71\xdf\x63\xb9\xde\x2f\xcb\x0c\xc6\xc9\xe9\x0b\xee\xff\x53\xe3\x21\x45\x17\xb4\x54\x28\x35\x9f\x63\x29\x3c\
+            \\xee\x41\xe7\x29\x6e\x1d\x2d\x7c\x50\x04\x52\x86\x1e\x66\x85\xf3\xf3\x34\x01\xc6\x30\xa2\x2c\x95\x31\xa7\x08\x50\x60\x93\x0f\x13\
+            \\x73\xf9\x84\x17\xa1\x26\x98\x59\xec\x64\x5c\x44\x52\xc8\x77\xa9\xcd\xff\x33\xa6\xa0\x2b\x17\x41\x7c\xba\xd9\xa2\x21\x80\x03\x6f\
+            \\x50\xd9\x9c\x08\xcb\x3f\x48\x61\xc2\x6b\xd7\x65\x64\xa3\xf6\xab\x80\x34\x26\x76\x25\xa7\x5e\x7b\xe4\xe6\xd1\xfc\x20\xc7\x10\xe6\
+            \\xcd\xf0\xb6\x80\x17\x84\x4d\x3b\x31\xee\xf8\x4d\x7e\x08\x24\xe4\x2c\xcb\x49\xeb\x84\x6a\x3b\xae\x8f\xf7\x78\x88\xee\x5d\x60\xf6\
+            \\x7a\xf7\x56\x73\x2f\xdd\x5c\xdb\xa1\x16\x31\xc1\x30\xf6\x6f\x43\xb3\xfa\xec\x54\x15\x7f\xd7\xfa\xef\x85\x79\xcc\xd1\x52\xde\x58\
+            \\xdb\x2f\xfd\x5e\x8f\x32\xce\x19\x30\x6a\xf9\x7a\x02\xf0\x3e\xf8\x99\x31\x9a\xd5\xc2\x42\xfa\x0f\xa7\xe3\xeb\xb0\xc6\x8e\x49\x06\
+            \\xb8\xda\x23\x0c\x80\x82\x30\x28\xdc\xde\xf3\xc8\xd3\x5f\xb1\x71\x08\x8a\x1b\xc8\xbe\xc0\xc5\x60\x61\xa3\xc9\xe8\xbc\xa8\xf5\x4d\
+            \\xc7\x2f\xef\xfa\x22\x82\x2e\x99\x82\xc5\x70\xb4\xd8\xd9\x4e\x89\x8b\x1c\x34\xbc\x30\x1e\x16\xe6\x27\x3b\xe9\x79\xb0\xff\xea\xa6\
+            \\x61\xd9\xb8\xc6\x00\xb2\x48\x69\xb7\xff\xce\x3f\x08\xdc\x28\x3b\x43\xda\xf6\x5a\xf7\xe1\x97\x98\x76\x19\xb7\x2f\x8f\x1c\x9b\xa4\
+            \\xdc\x86\x37\xa0\x16\xa7\xd3\xb1\x9f\xc3\x93\xb7\xa7\x13\x6e\xeb\xc6\xbc\xc6\x3e\x1a\x51\x37\x42\xef\x68\x28\xbc\x52\x03\x65\xd6\
+            \\x2d\x6a\x77\xab\x35\x27\xed\x4b\x82\x1f\xd2\x16\x09\x5c\x6e\x2e\xdb\x92\xf2\xfb\x5e\xea\x29\xcb\x14\x58\x92\xf5\x91\x58\x4f\x7f\
+            \\x54\x83\x69\x7b\x26\x67\xa8\xcc\x85\x19\x60\x48\x8c\x4b\xac\xea\x83\x38\x60\xd4\x0d\x23\xe0\xf9\x6c\x38\x7e\x8a\x0a\xe6\xd2\x49\
+            \\xb2\x84\x60\x0c\xd8\x35\x73\x1d\xdc\xb1\xc6\x47\xac\x4c\x56\xea\x3e\xbd\x81\xb3\x23\x0e\xab\xb0\x64\x38\xbc\x87\xf0\xb5\xb1\xfa\
+            \\x8f\x5e\xa2\xb3\xfc\x18\x46\x42\x0a\x03\x6b\x7a\x4f\xb0\x89\xbd\x64\x9d\xa5\x89\xa3\x45\x41\x5e\x5c\x03\x83\x23\x3e\x5d\x3b\xb9\
+            \\x43\xd7\x95\x72\x7e\x6d\xd0\x7c\x06\xdf\xdf\x1e\x6c\x6c\xc4\xef\x71\x60\xa5\x39\x73\xbf\xbe\x70\x83\x87\x76\x05\x45\x23\xec\xf1"#
+
+sbox_s3 :: Word8 -> Word32
+sbox_s3 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x8d\xef\xc2\x40\x25\xfa\x5d\x9f\xeb\x90\x3d\xbf\xe8\x10\xc9\x07\x47\x60\x7f\xff\x36\x9f\xe4\x4b\x8c\x1f\xc6\x44\xae\xce\xca\x90\
+            \\xbe\xb1\xf9\xbf\xee\xfb\xca\xea\xe8\xcf\x19\x50\x51\xdf\x07\xae\x92\x0e\x88\x06\xf0\xad\x05\x48\xe1\x3c\x8d\x83\x92\x70\x10\xd5\
+            \\x11\x10\x7d\x9f\x07\x64\x7d\xb9\xb2\xe3\xe4\xd4\x3d\x4f\x28\x5e\xb9\xaf\xa8\x20\xfa\xde\x82\xe0\xa0\x67\x26\x8b\x82\x72\x79\x2e\
+            \\x55\x3f\xb2\xc0\x48\x9a\xe2\x2b\xd4\xef\x97\x94\x12\x5e\x3f\xbc\x21\xff\xfc\xee\x82\x5b\x1b\xfd\x92\x55\xc5\xed\x12\x57\xa2\x40\
+            \\x4e\x1a\x83\x02\xba\xe0\x7f\xff\x52\x82\x46\xe7\x8e\x57\x14\x0e\x33\x73\xf7\xbf\x8c\x9f\x81\x88\xa6\xfc\x4e\xe8\xc9\x82\xb5\xa5\
+            \\xa8\xc0\x1d\xb7\x57\x9f\xc2\x64\x67\x09\x4f\x31\xf2\xbd\x3f\x5f\x40\xff\xf7\xc1\x1f\xb7\x8d\xfc\x8e\x6b\xd2\xc1\x43\x7b\xe5\x9b\
+            \\x99\xb0\x3d\xbf\xb5\xdb\xc6\x4b\x63\x8d\xc0\xe6\x55\x81\x9d\x99\xa1\x97\xc8\x1c\x4a\x01\x2d\x6e\xc5\x88\x4a\x28\xcc\xc3\x6f\x71\
+            \\xb8\x43\xc2\x13\x6c\x07\x43\xf1\x83\x09\x89\x3c\x0f\xed\xdd\x5f\x2f\x7f\xe8\x50\xd7\xc0\x7f\x7e\x02\x50\x7f\xbf\x5a\xfb\x9a\x04\
+            \\xa7\x47\xd2\xd0\x16\x51\x19\x2e\xaf\x70\xbf\x3e\x58\xc3\x13\x80\x5f\x98\x30\x2e\x72\x7c\xc3\xc4\x0a\x0f\xb4\x02\x0f\x7f\xef\x82\
+            \\x8c\x96\xfd\xad\x5d\x2c\x2a\xae\x8e\xe9\x9a\x49\x50\xda\x88\xb8\x84\x27\xf4\xa0\x1e\xac\x57\x90\x79\x6f\xb4\x49\x82\x52\xdc\x15\
+            \\xef\xbd\x7d\x9b\xa6\x72\x59\x7d\xad\xa8\x40\xd8\x45\xf5\x45\x04\xfa\x5d\x74\x03\xe8\x3e\xc3\x05\x4f\x91\x75\x1a\x92\x56\x69\xc2\
+            \\x23\xef\xe9\x41\xa9\x03\xf1\x2e\x60\x27\x0d\xf2\x02\x76\xe4\xb6\x94\xfd\x65\x74\x92\x79\x85\xb2\x82\x76\xdb\xcb\x02\x77\x81\x76\
+            \\xf8\xaf\x91\x8d\x4e\x48\xf7\x9e\x8f\x61\x6d\xdf\xe2\x9d\x84\x0e\x84\x2f\x7d\x83\x34\x0c\xe5\xc8\x96\xbb\xb6\x82\x93\xb4\xb1\x48\
+            \\xef\x30\x3c\xab\x98\x4f\xaf\x28\x77\x9f\xaf\x9b\x92\xdc\x56\x0d\x22\x4d\x1e\x20\x84\x37\xaa\x88\x7d\x29\xdc\x96\x27\x56\xd3\xdc\
+            \\x8b\x90\x7c\xee\xb5\x1f\xd2\x40\xe7\xc0\x7c\xe3\xe5\x66\xb4\xa1\xc3\xe9\x61\x5e\x3c\xf8\x20\x9d\x60\x94\xd1\xe3\xcd\x9c\xa3\x41\
+            \\x5c\x76\x46\x0e\x00\xea\x98\x3b\xd4\xd6\x78\x81\xfd\x47\x57\x2c\xf7\x6c\xed\xd9\xbd\xa8\x22\x9c\x12\x7d\xad\xaa\x43\x8a\x07\x4e\
+            \\x1f\x97\xc0\x90\x08\x1b\xdb\x8a\x93\xa0\x7e\xbe\xb9\x38\xca\x15\x97\xb0\x3c\xff\x3d\xc2\xc0\xf8\x8d\x1a\xb2\xec\x64\x38\x0e\x51\
+            \\x68\xcc\x7b\xfb\xd9\x0f\x27\x88\x12\x49\x01\x81\x5d\xe5\xff\xd4\xdd\x7e\xf8\x6a\x76\xa2\xe2\x14\xb9\xa4\x03\x68\x92\x5d\x95\x8f\
+            \\x4b\x39\xff\xfa\xba\x39\xae\xe9\xa4\xff\xd3\x0b\xfa\xf7\x93\x3b\x6d\x49\x86\x23\x19\x3c\xbc\xfa\x27\x62\x75\x45\x82\x5c\xf4\x7a\
+            \\x61\xbd\x8b\xa0\xd1\x1e\x42\xd1\xce\xad\x04\xf4\x12\x7e\xa3\x92\x10\x42\x8d\xb7\x82\x72\xa9\x72\x92\x70\xc4\xa8\x12\x7d\xe5\x0b\
+            \\x28\x5b\xa1\xc8\x3c\x62\xf4\x4f\x35\xc0\xea\xa5\xe8\x05\xd2\x31\x42\x89\x29\xfb\xb4\xfc\xdf\x82\x4f\xb6\x6a\x53\x0e\x7d\xc1\x5b\
+            \\x1f\x08\x1f\xab\x10\x86\x18\xae\xfc\xfd\x08\x6d\xf9\xff\x28\x89\x69\x4b\xcc\x11\x23\x6a\x5c\xae\x12\xde\xca\x4d\x2c\x3f\x8c\xc5\
+            \\xd2\xd0\x2d\xfe\xf8\xef\x58\x96\xe4\xcf\x52\xda\x95\x15\x5b\x67\x49\x4a\x48\x8c\xb9\xb6\xa8\x0c\x5c\x8f\x82\xbc\x89\xd3\x6b\x45\
+            \\x3a\x60\x94\x37\xec\x00\xc9\xa9\x44\x71\x52\x53\x0a\x87\x4b\x49\xd7\x73\xbc\x40\x7c\x34\x67\x1c\x02\x71\x7e\xf6\x4f\xeb\x55\x36\
+            \\xa2\xd0\x2f\xff\xd2\xbf\x60\xc4\xd4\x3f\x03\xc0\x50\xb4\xef\x6d\x07\x47\x8c\xd1\x00\x6e\x18\x88\xa2\xe5\x3f\x55\xb9\xe6\xd4\xbc\
+            \\xa2\x04\x80\x16\x97\x57\x38\x33\xd7\x20\x7d\x67\xde\x0f\x8f\x3d\x72\xf8\x7b\x33\xab\xcc\x4f\x33\x76\x88\xc5\x5d\x7b\x00\xa6\xb0\
+            \\x94\x7b\x00\x01\x57\x00\x75\xd2\xf9\xbb\x88\xf8\x89\x42\x01\x9e\x42\x64\xa5\xff\x85\x63\x02\xe0\x72\xdb\xd9\x2b\xee\x97\x1b\x69\
+            \\x6e\xa2\x2f\xde\x5f\x08\xae\x2b\xaf\x7a\x61\x6d\xe5\xc9\x87\x67\xcf\x1f\xeb\xd2\x61\xef\xc8\xc2\xf1\xac\x25\x71\xcc\x82\x39\xc2\
+            \\x67\x21\x4c\xb8\xb1\xe5\x83\xd1\xb7\xdc\x3e\x62\x7f\x10\xbd\xce\xf9\x0a\x5c\x38\x0f\xf0\x44\x3d\x60\x6e\x6d\xc6\x60\x54\x3a\x49\
+            \\x57\x27\xc1\x48\x2b\xe9\x8a\x1d\x8a\xb4\x17\x38\x20\xe1\xbe\x24\xaf\x96\xda\x0f\x68\x45\x84\x25\x99\x83\x3b\xe5\x60\x0d\x45\x7d\
+            \\x28\x2f\x93\x50\x83\x34\xb3\x62\xd9\x1d\x11\x20\x2b\x6d\x8d\xa0\x64\x2b\x1e\x31\x9c\x30\x5a\x00\x52\xbc\xe6\x88\x1b\x03\x58\x8a\
+            \\xf7\xba\xef\xd5\x41\x42\xed\x9c\xa4\x31\x5c\x11\x83\x32\x3e\xc5\xdf\xef\x46\x36\xa1\x33\xc5\x01\xe9\xd3\x53\x1c\xee\x35\x37\x83"#
+
+sbox_s4 :: Word8 -> Word32
+sbox_s4 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x9d\xb3\x04\x20\x1f\xb6\xe9\xde\xa7\xbe\x7b\xef\xd2\x73\xa2\x98\x4a\x4f\x7b\xdb\x64\xad\x8c\x57\x85\x51\x04\x43\xfa\x02\x0e\xd1\
+            \\x7e\x28\x7a\xff\xe6\x0f\xb6\x63\x09\x5f\x35\xa1\x79\xeb\xf1\x20\xfd\x05\x9d\x43\x64\x97\xb7\xb1\xf3\x64\x1f\x63\x24\x1e\x4a\xdf\
+            \\x28\x14\x7f\x5f\x4f\xa2\xb8\xcd\xc9\x43\x00\x40\x0c\xc3\x22\x20\xfd\xd3\x0b\x30\xc0\xa5\x37\x4f\x1d\x2d\x00\xd9\x24\x14\x7b\x15\
+            \\xee\x4d\x11\x1a\x0f\xca\x51\x67\x71\xff\x90\x4c\x2d\x19\x5f\xfe\x1a\x05\x64\x5f\x0c\x13\xfe\xfe\x08\x1b\x08\xca\x05\x17\x01\x21\
+            \\x80\x53\x01\x00\xe8\x3e\x5e\xfe\xac\x9a\xf4\xf8\x7f\xe7\x27\x01\xd2\xb8\xee\x5f\x06\xdf\x42\x61\xbb\x9e\x9b\x8a\x72\x93\xea\x25\
+            \\xce\x84\xff\xdf\xf5\x71\x88\x01\x3d\xd6\x4b\x04\xa2\x6f\x26\x3b\x7e\xd4\x84\x00\x54\x7e\xeb\xe6\x44\x6d\x4c\xa0\x6c\xf3\xd6\xf5\
+            \\x26\x49\xab\xdf\xae\xa0\xc7\xf5\x36\x33\x8c\xc1\x50\x3f\x7e\x93\xd3\x77\x20\x61\x11\xb6\x38\xe1\x72\x50\x0e\x03\xf8\x0e\xb2\xbb\
+            \\xab\xe0\x50\x2e\xec\x8d\x77\xde\x57\x97\x1e\x81\xe1\x4f\x67\x46\xc9\x33\x54\x00\x69\x20\x31\x8f\x08\x1d\xbb\x99\xff\xc3\x04\xa5\
+            \\x4d\x35\x18\x05\x7f\x3d\x5c\xe3\xa6\xc8\x66\xc6\x5d\x5b\xcc\xa9\xda\xec\x6f\xea\x9f\x92\x6f\x91\x9f\x46\x22\x2f\x39\x91\x46\x7d\
+            \\xa5\xbf\x6d\x8e\x11\x43\xc4\x4f\x43\x95\x83\x02\xd0\x21\x4e\xeb\x02\x20\x83\xb8\x3f\xb6\x18\x0c\x18\xf8\x93\x1e\x28\x16\x58\xe6\
+            \\x26\x48\x6e\x3e\x8b\xd7\x8a\x70\x74\x77\xe4\xc1\xb5\x06\xe0\x7c\xf3\x2d\x0a\x25\x79\x09\x8b\x02\xe4\xea\xbb\x81\x28\x12\x3b\x23\
+            \\x69\xde\xad\x38\x15\x74\xca\x16\xdf\x87\x1b\x62\x21\x1c\x40\xb7\xa5\x1a\x9e\xf9\x00\x14\x37\x7b\x04\x1e\x8a\xc8\x09\x11\x40\x03\
+            \\xbd\x59\xe4\xd2\xe3\xd1\x56\xd5\x4f\xe8\x76\xd5\x2f\x91\xa3\x40\x55\x7b\xe8\xde\x00\xea\xe4\xa7\x0c\xe5\xc2\xec\x4d\xb4\xbb\xa6\
+            \\xe7\x56\xbd\xff\xdd\x33\x69\xac\xec\x17\xb0\x35\x06\x57\x23\x27\x99\xaf\xc8\xb0\x56\xc8\xc3\x91\x6b\x65\x81\x1c\x5e\x14\x61\x19\
+            \\x6e\x85\xcb\x75\xbe\x07\xc0\x02\xc2\x32\x55\x77\x89\x3f\xf4\xec\x5b\xbf\xc9\x2d\xd0\xec\x3b\x25\xb7\x80\x1a\xb7\x8d\x6d\x3b\x24\
+            \\x20\xc7\x63\xef\xc3\x66\xa5\xfc\x9c\x38\x28\x80\x0a\xce\x32\x05\xaa\xc9\x54\x8a\xec\xa1\xd7\xc7\x04\x1a\xfa\x32\x1d\x16\x62\x5a\
+            \\x67\x01\x90\x2c\x9b\x75\x7a\x54\x31\xd4\x77\xf7\x91\x26\xb0\x31\x36\xcc\x6f\xdb\xc7\x0b\x8b\x46\xd9\xe6\x6a\x48\x56\xe5\x5a\x79\
+            \\x02\x6a\x4c\xeb\x52\x43\x7e\xff\x2f\x8f\x76\xb4\x0d\xf9\x80\xa5\x86\x74\xcd\xe3\xed\xda\x04\xeb\x17\xa9\xbe\x04\x2c\x18\xf4\xdf\
+            \\xb7\x74\x7f\x9d\xab\x2a\xf7\xb4\xef\xc3\x4d\x20\x2e\x09\x6b\x7c\x17\x41\xa2\x54\xe5\xb6\xa0\x35\x21\x3d\x42\xf6\x2c\x1c\x7c\x26\
+            \\x61\xc2\xf5\x0f\x65\x52\xda\xf9\xd2\xc2\x31\xf8\x25\x13\x0f\x69\xd8\x16\x7f\xa2\x04\x18\xf2\xc8\x00\x1a\x96\xa6\x0d\x15\x26\xab\
+            \\x63\x31\x5c\x21\x5e\x0a\x72\xec\x49\xba\xfe\xfd\x18\x79\x08\xd9\x8d\x0d\xbd\x86\x31\x11\x70\xa7\x3e\x9b\x64\x0c\xcc\x3e\x10\xd7\
+            \\xd5\xca\xd3\xb6\x0c\xae\xc3\x88\xf7\x30\x01\xe1\x6c\x72\x8a\xff\x71\xea\xe2\xa1\x1f\x9a\xf3\x6e\xcf\xcb\xd1\x2f\xc1\xde\x84\x17\
+            \\xac\x07\xbe\x6b\xcb\x44\xa1\xd8\x8b\x9b\x0f\x56\x01\x39\x88\xc3\xb1\xc5\x2f\xca\xb4\xbe\x31\xcd\xd8\x78\x28\x06\x12\xa3\xa4\xe2\
+            \\x6f\x7d\xe5\x32\x58\xfd\x7e\xb6\xd0\x1e\xe9\x00\x24\xad\xff\xc2\xf4\x99\x0f\xc5\x97\x11\xaa\xc5\x00\x1d\x7b\x95\x82\xe5\xe7\xd2\
+            \\x10\x98\x73\xf6\x00\x61\x30\x96\xc3\x2d\x95\x21\xad\xa1\x21\xff\x29\x90\x84\x15\x7f\xbb\x97\x7f\xaf\x9e\xb3\xdb\x29\xc9\xed\x2a\
+            \\x5c\xe2\xa4\x65\xa7\x30\xf3\x2c\xd0\xaa\x3f\xe8\x8a\x5c\xc0\x91\xd4\x9e\x2c\xe7\x0c\xe4\x54\xa9\xd6\x0a\xcd\x86\x01\x5f\x19\x19\
+            \\x77\x07\x91\x03\xde\xa0\x3a\xf6\x78\xa8\x56\x5e\xde\xe3\x56\xdf\x21\xf0\x5c\xbe\x8b\x75\xe3\x87\xb3\xc5\x06\x51\xb8\xa5\xc3\xef\
+            \\xd8\xee\xb6\xd2\xe5\x23\xbe\x77\xc2\x15\x45\x29\x2f\x69\xef\xdf\xaf\xe6\x7a\xfb\xf4\x70\xc4\xb2\xf3\xe0\xeb\x5b\xd6\xcc\x98\x76\
+            \\x39\xe4\x46\x0c\x1f\xda\x85\x38\x19\x87\x83\x2f\xca\x00\x73\x67\xa9\x91\x44\xf8\x29\x6b\x29\x9e\x49\x2f\xc2\x95\x92\x66\xbe\xab\
+            \\xb5\x67\x6e\x69\x9b\xd3\xdd\xda\xdf\x7e\x05\x2f\xdb\x25\x70\x1c\x1b\x5e\x51\xee\xf6\x53\x24\xe6\x6a\xfc\xe3\x6c\x03\x16\xcc\x04\
+            \\x86\x44\x21\x3e\xb7\xdc\x59\xd0\x79\x65\x29\x1f\xcc\xd6\xfd\x43\x41\x82\x39\x79\x93\x2b\xcd\xf6\xb6\x57\xc3\x4d\x4e\xdf\xd2\x82\
+            \\x7a\xe5\x29\x0c\x3c\xb9\x53\x6b\x85\x1e\x20\xfe\x98\x33\x55\x7e\x13\xec\xf0\xb0\xd3\xff\xb3\x72\x3f\x85\xc5\xc1\x0a\xef\x7e\xd2"#
+
+sbox_s5 :: Word8 -> Word32
+sbox_s5 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x7e\xc9\x0c\x04\x2c\x6e\x74\xb9\x9b\x0e\x66\xdf\xa6\x33\x79\x11\xb8\x6a\x7f\xff\x1d\xd3\x58\xf5\x44\xdd\x9d\x44\x17\x31\x16\x7f\
+            \\x08\xfb\xf1\xfa\xe7\xf5\x11\xcc\xd2\x05\x1b\x00\x73\x5a\xba\x00\x2a\xb7\x22\xd8\x38\x63\x81\xcb\xac\xf6\x24\x3a\x69\xbe\xfd\x7a\
+            \\xe6\xa2\xe7\x7f\xf0\xc7\x20\xcd\xc4\x49\x48\x16\xcc\xf5\xc1\x80\x38\x85\x16\x40\x15\xb0\xa8\x48\xe6\x8b\x18\xcb\x4c\xaa\xde\xff\
+            \\x5f\x48\x0a\x01\x04\x12\xb2\xaa\x25\x98\x14\xfc\x41\xd0\xef\xe2\x4e\x40\xb4\x8d\x24\x8e\xb6\xfb\x8d\xba\x1c\xfe\x41\xa9\x9b\x02\
+            \\x1a\x55\x0a\x04\xba\x8f\x65\xcb\x72\x51\xf4\xe7\x95\xa5\x17\x25\xc1\x06\xec\xd7\x97\xa5\x98\x0a\xc5\x39\xb9\xaa\x4d\x79\xfe\x6a\
+            \\xf2\xf3\xf7\x63\x68\xaf\x80\x40\xed\x0c\x9e\x56\x11\xb4\x95\x8b\xe1\xeb\x5a\x88\x87\x09\xe6\xb0\xd7\xe0\x71\x56\x4e\x29\xfe\xa7\
+            \\x63\x66\xe5\x2d\x02\xd1\xc0\x00\xc4\xac\x8e\x05\x93\x77\xf5\x71\x0c\x05\x37\x2a\x57\x85\x35\xf2\x22\x61\xbe\x02\xd6\x42\xa0\xc9\
+            \\xdf\x13\xa2\x80\x74\xb5\x5b\xd2\x68\x21\x99\xc0\xd4\x21\xe5\xec\x53\xfb\x3c\xe8\xc8\xad\xed\xb3\x28\xa8\x7f\xc9\x3d\x95\x99\x81\
+            \\x5c\x1f\xf9\x00\xfe\x38\xd3\x99\x0c\x4e\xff\x0b\x06\x24\x07\xea\xaa\x2f\x4f\xb1\x4f\xb9\x69\x76\x90\xc7\x95\x05\xb0\xa8\xa7\x74\
+            \\xef\x55\xa1\xff\xe5\x9c\xa2\xc2\xa6\xb6\x2d\x27\xe6\x6a\x42\x63\xdf\x65\x00\x1f\x0e\xc5\x09\x66\xdf\xdd\x55\xbc\x29\xde\x06\x55\
+            \\x91\x1e\x73\x9a\x17\xaf\x89\x75\x32\xc7\x91\x1c\x89\xf8\x94\x68\x0d\x01\xe9\x80\x52\x47\x55\xf4\x03\xb6\x3c\xc9\x0c\xc8\x44\xb2\
+            \\xbc\xf3\xf0\xaa\x87\xac\x36\xe9\xe5\x3a\x74\x26\x01\xb3\xd8\x2b\x1a\x9e\x74\x49\x64\xee\x2d\x7e\xcd\xdb\xb1\xda\x01\xc9\x49\x10\
+            \\xb8\x68\xbf\x80\x0d\x26\xf3\xfd\x93\x42\xed\xe7\x04\xa5\xc2\x84\x63\x67\x37\xb6\x50\xf5\xb6\x16\xf2\x47\x66\xe3\x8e\xca\x36\xc1\
+            \\x13\x6e\x05\xdb\xfe\xf1\x83\x91\xfb\x88\x7a\x37\xd6\xe7\xf7\xd4\xc7\xfb\x7d\xc9\x30\x63\xfc\xdf\xb6\xf5\x89\xde\xec\x29\x41\xda\
+            \\x26\xe4\x66\x95\xb7\x56\x64\x19\xf6\x54\xef\xc5\xd0\x8d\x58\xb7\x48\x92\x54\x01\xc1\xba\xcb\x7f\xe5\xff\x55\x0f\xb6\x08\x30\x49\
+            \\x5b\xb5\xd0\xe8\x87\xd7\x2e\x5a\xab\x6a\x6e\xe1\x22\x3a\x66\xce\xc6\x2b\xf3\xcd\x9e\x08\x85\xf9\x68\xcb\x3e\x47\x08\x6c\x01\x0f\
+            \\xa2\x1d\xe8\x20\xd1\x8b\x69\xde\xf3\xf6\x57\x77\xfa\x02\xc3\xf6\x40\x7e\xda\xc3\xcb\xb3\xd5\x50\x17\x93\x08\x4d\xb0\xd7\x0e\xba\
+            \\x0a\xb3\x78\xd5\xd9\x51\xfb\x0c\xde\xd7\xda\x56\x41\x24\xbb\xe4\x94\xca\x0b\x56\x0f\x57\x55\xd1\xe0\xe1\xe5\x6e\x61\x84\xb5\xbe\
+            \\x58\x0a\x24\x9f\x94\xf7\x4b\xc0\xe3\x27\x88\x8e\x9f\x7b\x55\x61\xc3\xdc\x02\x80\x05\x68\x77\x15\x64\x6c\x6b\xd7\x44\x90\x4d\xb3\
+            \\x66\xb4\xf0\xa3\xc0\xf1\x64\x8a\x69\x7e\xd5\xaf\x49\xe9\x2f\xf6\x30\x9e\x37\x4f\x2c\xb6\x35\x6a\x85\x80\x85\x73\x49\x91\xf8\x40\
+            \\x76\xf0\xae\x02\x08\x3b\xe8\x4d\x28\x42\x1c\x9a\x44\x48\x94\x06\x73\x6e\x4c\xb8\xc1\x09\x29\x10\x8b\xc9\x5f\xc6\x7d\x86\x9c\xf4\
+            \\x13\x4f\x61\x6f\x2e\x77\x11\x8d\xb3\x1b\x2b\xe1\xaa\x90\xb4\x72\x3c\xa5\xd7\x17\x7d\x16\x1b\xba\x9c\xad\x90\x10\xaf\x46\x2b\xa2\
+            \\x9f\xe4\x59\xd2\x45\xd3\x45\x59\xd9\xf2\xda\x13\xdb\xc6\x54\x87\xf3\xe4\xf9\x4e\x17\x6d\x48\x6f\x09\x7c\x13\xea\x63\x1d\xa5\xc7\
+            \\x44\x5f\x73\x82\x17\x56\x83\xf4\xcd\xc6\x6a\x97\x70\xbe\x02\x88\xb3\xcd\xcf\x72\x6e\x5d\xd2\xf3\x20\x93\x60\x79\x45\x9b\x80\xa5\
+            \\xbe\x60\xe2\xdb\xa9\xc2\x31\x01\xeb\xa5\x31\x5c\x22\x4e\x42\xf2\x1c\x5c\x15\x72\xf6\x72\x1b\x2c\x1a\xd2\xff\xf3\x8c\x25\x40\x4e\
+            \\x32\x4e\xd7\x2f\x40\x67\xb7\xfd\x05\x23\x13\x8e\x5c\xa3\xbc\x78\xdc\x0f\xd6\x6e\x75\x92\x22\x83\x78\x4d\x6b\x17\x58\xeb\xb1\x6e\
+            \\x44\x09\x4f\x85\x3f\x48\x1d\x87\xfc\xfe\xae\x7b\x77\xb5\xff\x76\x8c\x23\x02\xbf\xaa\xf4\x75\x56\x5f\x46\xb0\x2a\x2b\x09\x28\x01\
+            \\x3d\x38\xf5\xf7\x0c\xa8\x1f\x36\x52\xaf\x4a\x8a\x66\xd5\xe7\xc0\xdf\x3b\x08\x74\x95\x05\x51\x10\x1b\x5a\xd7\xa8\xf6\x1e\xd5\xad\
+            \\x6c\xf6\xe4\x79\x20\x75\x81\x84\xd0\xce\xfa\x65\x88\xf7\xbe\x58\x4a\x04\x68\x26\x0f\xf6\xf8\xf3\xa0\x9c\x7f\x70\x53\x46\xab\xa0\
+            \\x5c\xe9\x6c\x28\xe1\x76\xed\xa3\x6b\xac\x30\x7f\x37\x68\x29\xd2\x85\x36\x0f\xa9\x17\xe3\xfe\x2a\x24\xb7\x97\x67\xf5\xa9\x6b\x20\
+            \\xd6\xcd\x25\x95\x68\xff\x1e\xbf\x75\x55\x44\x2c\xf1\x9f\x06\xbe\xf9\xe0\x65\x9a\xee\xb9\x49\x1d\x34\x01\x07\x18\xbb\x30\xca\xb8\
+            \\xe8\x22\xfe\x15\x88\x57\x09\x83\x75\x0e\x62\x49\xda\x62\x7e\x55\x5e\x76\xff\xa8\xb1\x53\x45\x46\x6d\x47\xde\x08\xef\xe9\xe7\xd4"#
+
+sbox_s6 :: Word8 -> Word32
+sbox_s6 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\xf6\xfa\x8f\x9d\x2c\xac\x6c\xe1\x4c\xa3\x48\x67\xe2\x33\x7f\x7c\x95\xdb\x08\xe7\x01\x68\x43\xb4\xec\xed\x5c\xbc\x32\x55\x53\xac\
+            \\xbf\x9f\x09\x60\xdf\xa1\xe2\xed\x83\xf0\x57\x9d\x63\xed\x86\xb9\x1a\xb6\xa6\xb8\xde\x5e\xbe\x39\xf3\x8f\xf7\x32\x89\x89\xb1\x38\
+            \\x33\xf1\x49\x61\xc0\x19\x37\xbd\xf5\x06\xc6\xda\xe4\x62\x5e\x7e\xa3\x08\xea\x99\x4e\x23\xe3\x3c\x79\xcb\xd7\xcc\x48\xa1\x43\x67\
+            \\xa3\x14\x96\x19\xfe\xc9\x4b\xd5\xa1\x14\x17\x4a\xea\xa0\x18\x66\xa0\x84\xdb\x2d\x09\xa8\x48\x6f\xa8\x88\x61\x4a\x29\x00\xaf\x98\
+            \\x01\x66\x59\x91\xe1\x99\x28\x63\xc8\xf3\x0c\x60\x2e\x78\xef\x3c\xd0\xd5\x19\x32\xcf\x0f\xec\x14\xf7\xca\x07\xd2\xd0\xa8\x20\x72\
+            \\xfd\x41\x19\x7e\x93\x05\xa6\xb0\xe8\x6b\xe3\xda\x74\xbe\xd3\xcd\x37\x2d\xa5\x3c\x4c\x7f\x44\x48\xda\xb5\xd4\x40\x6d\xba\x0e\xc3\
+            \\x08\x39\x19\xa7\x9f\xba\xee\xd9\x49\xdb\xcf\xb0\x4e\x67\x0c\x53\x5c\x3d\x9c\x01\x64\xbd\xb9\x41\x2c\x0e\x63\x6a\xba\x7d\xd9\xcd\
+            \\xea\x6f\x73\x88\xe7\x0b\xc7\x62\x35\xf2\x9a\xdb\x5c\x4c\xdd\x8d\xf0\xd4\x8d\x8c\xb8\x81\x53\xe2\x08\xa1\x98\x66\x1a\xe2\xea\xc8\
+            \\x28\x4c\xaf\x89\xaa\x92\x82\x23\x93\x34\xbe\x53\x3b\x3a\x21\xbf\x16\x43\x4b\xe3\x9a\xea\x39\x06\xef\xe8\xc3\x6e\xf8\x90\xcd\xd9\
+            \\x80\x22\x6d\xae\xc3\x40\xa4\xa3\xdf\x7e\x9c\x09\xa6\x94\xa8\x07\x5b\x7c\x5e\xcc\x22\x1d\xb3\xa6\x9a\x69\xa0\x2f\x68\x81\x8a\x54\
+            \\xce\xb2\x29\x6f\x53\xc0\x84\x3a\xfe\x89\x36\x55\x25\xbf\xe6\x8a\xb4\x62\x8a\xbc\xcf\x22\x2e\xbf\x25\xac\x6f\x48\xa9\xa9\x93\x87\
+            \\x53\xbd\xdb\x65\xe7\x6f\xfb\xe7\xe9\x67\xfd\x78\x0b\xa9\x35\x63\x8e\x34\x2b\xc1\xe8\xa1\x1b\xe9\x49\x80\x74\x0d\xc8\x08\x7d\xfc\
+            \\x8d\xe4\xbf\x99\xa1\x11\x01\xa0\x7f\xd3\x79\x75\xda\x5a\x26\xc0\xe8\x1f\x99\x4f\x95\x28\xcd\x89\xfd\x33\x9f\xed\xb8\x78\x34\xbf\
+            \\x5f\x04\x45\x6d\x22\x25\x86\x98\xc9\xc4\xc8\x3b\x2d\xc1\x56\xbe\x4f\x62\x8d\xaa\x57\xf5\x5e\xc5\xe2\x22\x0a\xbe\xd2\x91\x6e\xbf\
+            \\x4e\xc7\x5b\x95\x24\xf2\xc3\xc0\x42\xd1\x5d\x99\xcd\x0d\x7f\xa0\x7b\x6e\x27\xff\xa8\xdc\x8a\xf0\x73\x45\xc1\x06\xf4\x1e\x23\x2f\
+            \\x35\x16\x23\x86\xe6\xea\x89\x26\x33\x33\xb0\x94\x15\x7e\xc6\xf2\x37\x2b\x74\xaf\x69\x25\x73\xe4\xe9\xa9\xd8\x48\xf3\x16\x02\x89\
+            \\x3a\x62\xef\x1d\xa7\x87\xe2\x38\xf3\xa5\xf6\x76\x74\x36\x48\x53\x20\x95\x10\x63\x45\x76\x69\x8d\xb6\xfa\xd4\x07\x59\x2a\xf9\x50\
+            \\x36\xf7\x35\x23\x4c\xfb\x6e\x87\x7d\xa4\xce\xc0\x6c\x15\x2d\xaa\xcb\x03\x96\xa8\xc5\x0d\xfe\x5d\xfc\xd7\x07\xab\x09\x21\xc4\x2f\
+            \\x89\xdf\xf0\xbb\x5f\xe2\xbe\x78\x44\x8f\x4f\x33\x75\x46\x13\xc9\x2b\x05\xd0\x8d\x48\xb9\xd5\x85\xdc\x04\x94\x41\xc8\x09\x8f\x9b\
+            \\x7d\xed\xe7\x86\xc3\x9a\x33\x73\x42\x41\x00\x05\x6a\x09\x17\x51\x0e\xf3\xc8\xa6\x89\x00\x72\xd6\x28\x20\x76\x82\xa9\xa9\xf7\xbe\
+            \\xbf\x32\x67\x9d\xd4\x5b\x5b\x75\xb3\x53\xfd\x00\xcb\xb0\xe3\x58\x83\x0f\x22\x0a\x1f\x8f\xb2\x14\xd3\x72\xcf\x08\xcc\x3c\x4a\x13\
+            \\x8c\xf6\x31\x66\x06\x1c\x87\xbe\x88\xc9\x8f\x88\x60\x62\xe3\x97\x47\xcf\x8e\x7a\xb6\xc8\x52\x83\x3c\xc2\xac\xfb\x3f\xc0\x69\x76\
+            \\x4e\x8f\x02\x52\x64\xd8\x31\x4d\xda\x38\x70\xe3\x1e\x66\x54\x59\xc1\x09\x08\xf0\x51\x30\x21\xa5\x6c\x5b\x68\xb7\x82\x2f\x8a\xa0\
+            \\x30\x07\xcd\x3e\x74\x71\x9e\xef\xdc\x87\x26\x81\x07\x33\x40\xd4\x7e\x43\x2f\xd9\x0c\x5e\xc2\x41\x88\x09\x28\x6c\xf5\x92\xd8\x91\
+            \\x08\xa9\x30\xf6\x95\x7e\xf3\x05\xb7\xfb\xff\xbd\xc2\x66\xe9\x6f\x6f\xe4\xac\x98\xb1\x73\xec\xc0\xbc\x60\xb4\x2a\x95\x34\x98\xda\
+            \\xfb\xa1\xae\x12\x2d\x4b\xd7\x36\x0f\x25\xfa\xab\xa4\xf3\xfc\xeb\xe2\x96\x91\x23\x25\x7f\x0c\x3d\x93\x48\xaf\x49\x36\x14\x00\xbc\
+            \\xe8\x81\x6f\x4a\x38\x14\xf2\x00\xa3\xf9\x40\x43\x9c\x7a\x54\xc2\xbc\x70\x4f\x57\xda\x41\xe7\xf9\xc2\x5a\xd3\x3a\x54\xf4\xa0\x84\
+            \\xb1\x7f\x55\x05\x59\x35\x7c\xbe\xed\xbd\x15\xc8\x7f\x97\xc5\xab\xba\x5a\xc7\xb5\xb6\xf6\xde\xaf\x3a\x47\x9c\x3a\x53\x02\xda\x25\
+            \\x65\x3d\x7e\x6a\x54\x26\x8d\x49\x51\xa4\x77\xea\x50\x17\xd5\x5b\xd7\xd2\x5d\x88\x44\x13\x6c\x76\x04\x04\xa8\xc8\xb8\xe5\xa1\x21\
+            \\xb8\x1a\x92\x8a\x60\xed\x58\x69\x97\xc5\x5b\x96\xea\xec\x99\x1b\x29\x93\x59\x13\x01\xfd\xb7\xf1\x08\x8e\x8d\xfa\x9a\xb6\xf6\xf5\
+            \\x3b\x4c\xbf\x9f\x4a\x5d\xe3\xab\xe6\x05\x1d\x35\xa0\xe1\xd8\x55\xd3\x6b\x4c\xf1\xf5\x44\xed\xeb\xb0\xe9\x35\x24\xbe\xbb\x8f\xbd\
+            \\xa2\xd7\x62\xcf\x49\xc9\x2f\x54\x38\xb5\xf3\x31\x71\x28\xa4\x54\x48\x39\x29\x05\xa6\x5b\x1d\xb8\x85\x1c\x97\xbd\xd6\x75\xcf\x2f"#
+
+sbox_s7 :: Word8 -> Word32
+sbox_s7 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x85\xe0\x40\x19\x33\x2b\xf5\x67\x66\x2d\xbf\xff\xcf\xc6\x56\x93\x2a\x8d\x7f\x6f\xab\x9b\xc9\x12\xde\x60\x08\xa1\x20\x28\xda\x1f\
+            \\x02\x27\xbc\xe7\x4d\x64\x29\x16\x18\xfa\xc3\x00\x50\xf1\x8b\x82\x2c\xb2\xcb\x11\xb2\x32\xe7\x5c\x4b\x36\x95\xf2\xb2\x87\x07\xde\
+            \\xa0\x5f\xbc\xf6\xcd\x41\x81\xe9\xe1\x50\x21\x0c\xe2\x4e\xf1\xbd\xb1\x68\xc3\x81\xfd\xe4\xe7\x89\x5c\x79\xb0\xd8\x1e\x8b\xfd\x43\
+            \\x4d\x49\x50\x01\x38\xbe\x43\x41\x91\x3c\xee\x1d\x92\xa7\x9c\x3f\x08\x97\x66\xbe\xba\xee\xad\xf4\x12\x86\xbe\xcf\xb6\xea\xcb\x19\
+            \\x26\x60\xc2\x00\x75\x65\xbd\xe4\x64\x24\x1f\x7a\x82\x48\xdc\xa9\xc3\xb3\xad\x66\x28\x13\x60\x86\x0b\xd8\xdf\xa8\x35\x6d\x1c\xf2\
+            \\x10\x77\x89\xbe\xb3\xb2\xe9\xce\x05\x02\xaa\x8f\x0b\xc0\x35\x1e\x16\x6b\xf5\x2a\xeb\x12\xff\x82\xe3\x48\x69\x11\xd3\x4d\x75\x16\
+            \\x4e\x7b\x3a\xff\x5f\x43\x67\x1b\x9c\xf6\xe0\x37\x49\x81\xac\x83\x33\x42\x66\xce\x8c\x93\x41\xb7\xd0\xd8\x54\xc0\xcb\x3a\x6c\x88\
+            \\x47\xbc\x28\x29\x47\x25\xba\x37\xa6\x6a\xd2\x2b\x7a\xd6\x1f\x1e\x0c\x5c\xba\xfa\x44\x37\xf1\x07\xb6\xe7\x99\x62\x42\xd2\xd8\x16\
+            \\x0a\x96\x12\x88\xe1\xa5\xc0\x6e\x13\x74\x9e\x67\x72\xfc\x08\x1a\xb1\xd1\x39\xf7\xf9\x58\x37\x45\xcf\x19\xdf\x58\xbe\xc3\xf7\x56\
+            \\xc0\x6e\xba\x30\x07\x21\x1b\x24\x45\xc2\x88\x29\xc9\x5e\x31\x7f\xbc\x8e\xc5\x11\x38\xbc\x46\xe9\xc6\xe6\xfa\x14\xba\xe8\x58\x4a\
+            \\xad\x4e\xbc\x46\x46\x8f\x50\x8b\x78\x29\x43\x5f\xf1\x24\x18\x3b\x82\x1d\xba\x9f\xaf\xf6\x0f\xf4\xea\x2c\x4e\x6d\x16\xe3\x92\x64\
+            \\x92\x54\x4a\x8b\x00\x9b\x4f\xc3\xab\xa6\x8c\xed\x9a\xc9\x6f\x78\x06\xa5\xb7\x9a\xb2\x85\x6e\x6e\x1a\xec\x3c\xa9\xbe\x83\x86\x88\
+            \\x0e\x08\x04\xe9\x55\xf1\xbe\x56\xe7\xe5\x36\x3b\xb3\xa1\xf2\x5d\xf7\xde\xbb\x85\x61\xfe\x03\x3c\x16\x74\x62\x33\x3c\x03\x4c\x28\
+            \\xda\x6d\x0c\x74\x79\xaa\xc5\x6c\x3c\xe4\xe1\xad\x51\xf0\xc8\x02\x98\xf8\xf3\x5a\x16\x26\xa4\x9f\xee\xd8\x2b\x29\x1d\x38\x2f\xe3\
+            \\x0c\x4f\xb9\x9a\xbb\x32\x57\x78\x3e\xc6\xd9\x7b\x6e\x77\xa6\xa9\xcb\x65\x8b\x5c\xd4\x52\x30\xc7\x2b\xd1\x40\x8b\x60\xc0\x3e\xb7\
+            \\xb9\x06\x8d\x78\xa3\x37\x54\xf4\xf4\x30\xc8\x7d\xc8\xa7\x13\x02\xb9\x6d\x8c\x32\xeb\xd4\xe7\xbe\xbe\x8b\x9d\x2d\x79\x79\xfb\x06\
+            \\xe7\x22\x53\x08\x8b\x75\xcf\x77\x11\xef\x8d\xa4\xe0\x83\xc8\x58\x8d\x6b\x78\x6f\x5a\x63\x17\xa6\xfa\x5c\xf7\xa0\x5d\xda\x00\x33\
+            \\xf2\x8e\xbf\xb0\xf5\xb9\xc3\x10\xa0\xea\xc2\x80\x08\xb9\x76\x7a\xa3\xd9\xd2\xb0\x79\xd3\x42\x17\x02\x1a\x71\x8d\x9a\xc6\x33\x6a\
+            \\x27\x11\xfd\x60\x43\x80\x50\xe3\x06\x99\x08\xa8\x3d\x7f\xed\xc4\x82\x6d\x2b\xef\x4e\xeb\x84\x76\x48\x8d\xcf\x25\x36\xc9\xd5\x66\
+            \\x28\xe7\x4e\x41\xc2\x61\x0a\xca\x3d\x49\xa9\xcf\xba\xe3\xb9\xdf\xb6\x5f\x8d\xe6\x92\xae\xaf\x64\x3a\xc7\xd5\xe6\x9e\xa8\x05\x09\
+            \\xf2\x2b\x01\x7d\xa4\x17\x3f\x70\xdd\x1e\x16\xc3\x15\xe0\xd7\xf9\x50\xb1\xb8\x87\x2b\x9f\x4f\xd5\x62\x5a\xba\x82\x6a\x01\x79\x62\
+            \\x2e\xc0\x1b\x9c\x15\x48\x8a\xa9\xd7\x16\xe7\x40\x40\x05\x5a\x2c\x93\xd2\x9a\x22\xe3\x2d\xbf\x9a\x05\x87\x45\xb9\x34\x53\xdc\x1e\
+            \\xd6\x99\x29\x6e\x49\x6c\xff\x6f\x1c\x9f\x49\x86\xdf\xe2\xed\x07\xb8\x72\x42\xd1\x19\xde\x7e\xae\x05\x3e\x56\x1a\x15\xad\x6f\x8c\
+            \\x66\x62\x6c\x1c\x71\x54\xc2\x4c\xea\x08\x2b\x2a\x93\xeb\x29\x39\x17\xdc\xb0\xf0\x58\xd4\xf2\xae\x9e\xa2\x94\xfb\x52\xcf\x56\x4c\
+            \\x98\x83\xfe\x66\x2e\xc4\x05\x81\x76\x39\x53\xc3\x01\xd6\x69\x2e\xd3\xa0\xc1\x08\xa1\xe7\x16\x0e\xe4\xf2\xdf\xa6\x69\x3e\xd2\x85\
+            \\x74\x90\x46\x98\x4c\x2b\x0e\xdd\x4f\x75\x76\x56\x5d\x39\x33\x78\xa1\x32\x23\x4f\x3d\x32\x1c\x5d\xc3\xf5\xe1\x94\x4b\x26\x93\x01\
+            \\xc7\x9f\x02\x2f\x3c\x99\x7e\x7e\x5e\x4f\x95\x04\x3f\xfa\xfb\xbd\x76\xf7\xad\x0e\x29\x66\x93\xf4\x3d\x1f\xce\x6f\xc6\x1e\x45\xbe\
+            \\xd3\xb5\xab\x34\xf7\x2b\xf9\xb7\x1b\x04\x34\xc0\x4e\x72\xb5\x67\x55\x92\xa3\x3d\xb5\x22\x93\x01\xcf\xd2\xa8\x7f\x60\xae\xb7\x67\
+            \\x18\x14\x38\x6b\x30\xbc\xc3\x3d\x38\xa0\xc0\x7d\xfd\x16\x06\xf2\xc3\x63\x51\x9b\x58\x9d\xd3\x90\x54\x79\xf8\xe6\x1c\xb8\xd6\x47\
+            \\x97\xfd\x61\xa9\xea\x77\x59\xf4\x2d\x57\x53\x9d\x56\x9a\x58\xcf\xe8\x4e\x63\xad\x46\x2e\x1b\x78\x65\x80\xf8\x7e\xf3\x81\x79\x14\
+            \\x91\xda\x55\xf4\x40\xa2\x30\xf3\xd1\x98\x8f\x35\xb6\xe3\x18\xd2\x3f\xfa\x50\xbc\x3d\x40\xf0\x21\xc3\xc0\xbd\xae\x49\x58\xc2\x4c\
+            \\x51\x8f\x36\xb2\x84\xb1\xd3\x70\x0f\xed\xce\x83\x87\x8d\xda\xda\xf2\xa2\x79\xc7\x94\xe0\x1b\xe8\x90\x71\x6f\x4b\x95\x4b\x8a\xa3"#
+
+sbox_s8 :: Word8 -> Word32
+sbox_s8 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\xe2\x16\x30\x0d\xbb\xdd\xff\xfc\xa7\xeb\xda\xbd\x35\x64\x80\x95\x77\x89\xf8\xb7\xe6\xc1\x12\x1b\x0e\x24\x16\x00\x05\x2c\xe8\xb5\
+            \\x11\xa9\xcf\xb0\xe5\x95\x2f\x11\xec\xe7\x99\x0a\x93\x86\xd1\x74\x2a\x42\x93\x1c\x76\xe3\x81\x11\xb1\x2d\xef\x3a\x37\xdd\xdd\xfc\
+            \\xde\x9a\xde\xb1\x0a\x0c\xc3\x2c\xbe\x19\x70\x29\x84\xa0\x09\x40\xbb\x24\x3a\x0f\xb4\xd1\x37\xcf\xb4\x4e\x79\xf0\x04\x9e\xed\xfd\
+            \\x0b\x15\xa1\x5d\x48\x0d\x31\x68\x8b\xbb\xde\x5a\x66\x9d\xed\x42\xc7\xec\xe8\x31\x3f\x8f\x95\xe7\x72\xdf\x19\x1b\x75\x80\x33\x0d\
+            \\x94\x07\x42\x51\x5c\x7d\xcd\xfa\xab\xbe\x6d\x63\xaa\x40\x21\x64\xb3\x01\xd4\x0a\x02\xe7\xd1\xca\x53\x57\x1d\xae\x7a\x31\x82\xa2\
+            \\x12\xa8\xdd\xec\xfd\xaa\x33\x5d\x17\x6f\x43\xe8\x71\xfb\x46\xd4\x38\x12\x90\x22\xce\x94\x9a\xd4\xb8\x47\x69\xad\x96\x5b\xd8\x62\
+            \\x82\xf3\xd0\x55\x66\xfb\x97\x67\x15\xb8\x0b\x4e\x1d\x5b\x47\xa0\x4c\xfd\xe0\x6f\xc2\x8e\xc4\xb8\x57\xe8\x72\x6e\x64\x7a\x78\xfc\
+            \\x99\x86\x5d\x44\x60\x8b\xd5\x93\x6c\x20\x0e\x03\x39\xdc\x5f\xf6\x5d\x0b\x00\xa3\xae\x63\xaf\xf2\x7e\x8b\xd6\x32\x70\x10\x8c\x0c\
+            \\xbb\xd3\x50\x49\x29\x98\xdf\x04\x98\x0c\xf4\x2a\x9b\x6d\xf4\x91\x9e\x7e\xdd\x53\x06\x91\x85\x48\x58\xcb\x7e\x07\x3b\x74\xef\x2e\
+            \\x52\x2f\xff\xb1\xd2\x47\x08\xcc\x1c\x7e\x27\xcd\xa4\xeb\x21\x5b\x3c\xf1\xd2\xe2\x19\xb4\x7a\x38\x42\x4f\x76\x18\x35\x85\x60\x39\
+            \\x9d\x17\xde\xe7\x27\xeb\x35\xe6\xc9\xaf\xf6\x7b\x36\xba\xf5\xb8\x09\xc4\x67\xcd\xc1\x89\x10\xb1\xe1\x1d\xbf\x7b\x06\xcd\x1a\xf8\
+            \\x71\x70\xc6\x08\x2d\x5e\x33\x54\xd4\xde\x49\x5a\x64\xc6\xd0\x06\xbc\xc0\xc6\x2c\x3d\xd0\x0d\xb3\x70\x8f\x8f\x34\x77\xd5\x1b\x42\
+            \\x26\x4f\x62\x0f\x24\xb8\xd2\xbf\x15\xc1\xb7\x9e\x46\xa5\x25\x64\xf8\xd7\xe5\x4e\x3e\x37\x81\x60\x78\x95\xcd\xa5\x85\x9c\x15\xa5\
+            \\xe6\x45\x97\x88\xc3\x7b\xc7\x5f\xdb\x07\xba\x0c\x06\x76\xa3\xab\x7f\x22\x9b\x1e\x31\x84\x2e\x7b\x24\x25\x9f\xd7\xf8\xbe\xf4\x72\
+            \\x83\x5f\xfc\xb8\x6d\xf4\xc1\xf2\x96\xf5\xb1\x95\xfd\x0a\xf0\xfc\xb0\xfe\x13\x4c\xe2\x50\x6d\x3d\x4f\x9b\x12\xea\xf2\x15\xf2\x25\
+            \\xa2\x23\x73\x6f\x9f\xb4\xc4\x28\x25\xd0\x49\x79\x34\xc7\x13\xf8\xc4\x61\x81\x87\xea\x7a\x6e\x98\x7c\xd1\x6e\xfc\x14\x36\x87\x6c\
+            \\xf1\x54\x41\x07\xbe\xde\xee\x14\x56\xe9\xaf\x27\xa0\x4a\xa4\x41\x3c\xf7\xc8\x99\x92\xec\xba\xe6\xdd\x67\x01\x6d\x15\x16\x82\xeb\
+            \\xa8\x42\xee\xdf\xfd\xba\x60\xb4\xf1\x90\x7b\x75\x20\xe3\x03\x0f\x24\xd8\xc2\x9e\xe1\x39\x67\x3b\xef\xa6\x3f\xb8\x71\x87\x30\x54\
+            \\xb6\xf2\xcf\x3b\x9f\x32\x64\x42\xcb\x15\xa4\xcc\xb0\x1a\x45\x04\xf1\xe4\x7d\x8d\x84\x4a\x1b\xe5\xba\xe7\xdf\xdc\x42\xcb\xda\x70\
+            \\xcd\x7d\xae\x0a\x57\xe8\x5b\x7a\xd5\x3f\x5a\xf6\x20\xcf\x4d\x8c\xce\xa4\xd4\x28\x79\xd1\x30\xa4\x34\x86\xeb\xfb\x33\xd3\xcd\xdc\
+            \\x77\x85\x3b\x53\x37\xef\xfc\xb5\xc5\x06\x87\x78\xe5\x80\xb3\xe6\x4e\x68\xb8\xf4\xc5\xc8\xb3\x7e\x0d\x80\x9e\xa2\x39\x8f\xeb\x7c\
+            \\x13\x2a\x4f\x94\x43\xb7\x95\x0e\x2f\xee\x7d\x1c\x22\x36\x13\xbd\xdd\x06\xca\xa2\x37\xdf\x93\x2b\xc4\x24\x82\x89\xac\xf3\xeb\xc3\
+            \\x57\x15\xf6\xb7\xef\x34\x78\xdd\xf2\x67\x61\x6f\xc1\x48\xcb\xe4\x90\x52\x81\x5e\x5e\x41\x0f\xab\xb4\x8a\x24\x65\x2e\xda\x7f\xa4\
+            \\xe8\x7b\x40\xe4\xe9\x8e\xa0\x84\x58\x89\xe9\xe1\xef\xd3\x90\xfc\xdd\x07\xd3\x5b\xdb\x48\x56\x94\x38\xd7\xe5\xb2\x57\x72\x01\x01\
+            \\x73\x0e\xde\xbc\x5b\x64\x31\x13\x94\x91\x7e\x4f\x50\x3c\x2f\xba\x64\x6f\x12\x82\x75\x23\xd2\x4a\xe0\x77\x96\x95\xf9\xc1\x7a\x8f\
+            \\x7a\x5b\x21\x21\xd1\x87\xb8\x96\x29\x26\x3a\x4d\xba\x51\x0c\xdf\x81\xf4\x7c\x9f\xad\x11\x63\xed\xea\x7b\x59\x65\x1a\x00\x72\x6e\
+            \\x11\x40\x30\x92\x00\xda\x6d\x77\x4a\x0c\xdd\x61\xad\x1f\x46\x03\x60\x5b\xdf\xb0\x9e\xed\xc3\x64\x22\xeb\xe6\xa8\xce\xe7\xd2\x8a\
+            \\xa0\xe7\x36\xa0\x55\x64\xa6\xb9\x10\x85\x32\x09\xc7\xeb\x8f\x37\x2d\xe7\x05\xca\x89\x51\x57\x0f\xdf\x09\x82\x2b\xbd\x69\x1a\x6c\
+            \\xaa\x12\xe4\xf2\x87\x45\x1c\x0f\xe0\xf6\xa2\x7a\x3a\xda\x48\x19\x4c\xf1\x76\x4f\x0d\x77\x1c\x2b\x67\xcd\xb1\x56\x35\x0d\x83\x84\
+            \\x59\x38\xfa\x0f\x42\x39\x9e\xf3\x36\x99\x7b\x07\x0e\x84\x09\x3d\x4a\xa9\x3e\x61\x83\x60\xd8\x7b\x1f\xa9\x8b\x0c\x11\x49\x38\x2c\
+            \\xe9\x76\x25\xa5\x06\x14\xd1\xb7\x0e\x25\x24\x4b\x0c\x76\x83\x47\x58\x9e\x8d\x82\x0d\x20\x59\xd1\xa4\x66\xbb\x1e\xf8\xda\x0a\x82\
+            \\x04\xf1\x91\x30\xba\x6e\x4e\xc0\x99\x26\x51\x64\x1e\xe7\x23\x0d\x50\xb2\xad\x80\xea\xee\x68\x01\x8d\xb2\xa2\x83\xea\x8b\xf5\x9e"#

bundled/Crypto/Cipher/Camellia.hs

@@ -0,0 +1,28 @@
+-- |
+-- Module      : Crypto.Cipher.Camellia
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+-- Camellia support. only 128 bit variant available for now.
+
+module Crypto.Cipher.Camellia
+    ( Camellia128
+    ) where
+
+import Crypto.Cipher.Camellia.Primitive
+import Crypto.Cipher.Types
+
+-- | Camellia block cipher with 128 bit key
+newtype Camellia128 = Camellia128 Camellia
+
+instance Cipher Camellia128 where
+    cipherName    _ = "Camellia128"
+    cipherKeySize _ = KeySizeFixed 16
+    cipherInit k    = Camellia128 `fmap` initCamellia k
+
+instance BlockCipher Camellia128 where
+    blockSize _ = 16
+    ecbEncrypt (Camellia128 key) = encrypt key
+    ecbDecrypt (Camellia128 key) = decrypt key

bundled/Crypto/Cipher/Camellia/Primitive.hs

@@ -0,0 +1,283 @@
+
+-- |
+-- Module      : Crypto.Cipher.Camellia.Primitive
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+-- This only cover Camellia 128 bits for now. The API will change once
+-- 192 and 256 mode are implemented too.
+{-# LANGUAGE MagicHash #-}
+module Crypto.Cipher.Camellia.Primitive
+    ( Camellia
+    , initCamellia
+    , encrypt
+    , decrypt
+    ) where
+
+import           Data.Word
+import           Data.Bits
+
+import           Crypto.Error
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.Words
+import           Crypto.Internal.WordArray
+import           Data.Memory.Endian
+
+data Mode = Decrypt | Encrypt
+
+w64tow128 :: (Word64, Word64) -> Word128
+w64tow128 (x1, x2) = Word128 x1 x2
+
+w64tow8 :: Word64 -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8)
+w64tow8 x = (t1, t2, t3, t4, t5, t6, t7, t8)
+    where
+        t1 = fromIntegral (x `shiftR` 56)
+        t2 = fromIntegral (x `shiftR` 48)
+        t3 = fromIntegral (x `shiftR` 40)
+        t4 = fromIntegral (x `shiftR` 32)
+        t5 = fromIntegral (x `shiftR` 24)
+        t6 = fromIntegral (x `shiftR` 16)
+        t7 = fromIntegral (x `shiftR` 8)
+        t8 = fromIntegral (x)
+
+w8tow64 :: (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) -> Word64
+w8tow64 (t1,t2,t3,t4,t5,t6,t7,t8) =
+    (fromIntegral t1 `shiftL` 56) .|.
+    (fromIntegral t2 `shiftL` 48) .|.
+    (fromIntegral t3 `shiftL` 40) .|.
+    (fromIntegral t4 `shiftL` 32) .|.
+    (fromIntegral t5 `shiftL` 24) .|.
+    (fromIntegral t6 `shiftL` 16) .|.
+    (fromIntegral t7 `shiftL` 8)  .|.
+    (fromIntegral t8)
+
+sbox :: Int -> Word8
+sbox = arrayRead8 t
+  where t = array8
+            "\x70\x82\x2c\xec\xb3\x27\xc0\xe5\xe4\x85\x57\x35\xea\x0c\xae\x41\
+            \\x23\xef\x6b\x93\x45\x19\xa5\x21\xed\x0e\x4f\x4e\x1d\x65\x92\xbd\
+            \\x86\xb8\xaf\x8f\x7c\xeb\x1f\xce\x3e\x30\xdc\x5f\x5e\xc5\x0b\x1a\
+            \\xa6\xe1\x39\xca\xd5\x47\x5d\x3d\xd9\x01\x5a\xd6\x51\x56\x6c\x4d\
+            \\x8b\x0d\x9a\x66\xfb\xcc\xb0\x2d\x74\x12\x2b\x20\xf0\xb1\x84\x99\
+            \\xdf\x4c\xcb\xc2\x34\x7e\x76\x05\x6d\xb7\xa9\x31\xd1\x17\x04\xd7\
+            \\x14\x58\x3a\x61\xde\x1b\x11\x1c\x32\x0f\x9c\x16\x53\x18\xf2\x22\
+            \\xfe\x44\xcf\xb2\xc3\xb5\x7a\x91\x24\x08\xe8\xa8\x60\xfc\x69\x50\
+            \\xaa\xd0\xa0\x7d\xa1\x89\x62\x97\x54\x5b\x1e\x95\xe0\xff\x64\xd2\
+            \\x10\xc4\x00\x48\xa3\xf7\x75\xdb\x8a\x03\xe6\xda\x09\x3f\xdd\x94\
+            \\x87\x5c\x83\x02\xcd\x4a\x90\x33\x73\x67\xf6\xf3\x9d\x7f\xbf\xe2\
+            \\x52\x9b\xd8\x26\xc8\x37\xc6\x3b\x81\x96\x6f\x4b\x13\xbe\x63\x2e\
+            \\xe9\x79\xa7\x8c\x9f\x6e\xbc\x8e\x29\xf5\xf9\xb6\x2f\xfd\xb4\x59\
+            \\x78\x98\x06\x6a\xe7\x46\x71\xba\xd4\x25\xab\x42\x88\xa2\x8d\xfa\
+            \\x72\x07\xb9\x55\xf8\xee\xac\x0a\x36\x49\x2a\x68\x3c\x38\xf1\xa4\
+            \\x40\x28\xd3\x7b\xbb\xc9\x43\xc1\x15\xe3\xad\xf4\x77\xc7\x80\x9e"#
+
+sbox1 :: Word8 -> Word8
+sbox1 x = sbox (fromIntegral x)
+
+sbox2 :: Word8 -> Word8
+sbox2 x = sbox1 x `rotateL` 1
+
+sbox3 :: Word8 -> Word8
+sbox3 x = sbox1 x `rotateL` 7
+
+sbox4 :: Word8 -> Word8
+sbox4 x = sbox1 (x `rotateL` 1)
+
+sigma1, sigma2, sigma3, sigma4, sigma5, sigma6 :: Word64
+sigma1 = 0xA09E667F3BCC908B
+sigma2 = 0xB67AE8584CAA73B2
+sigma3 = 0xC6EF372FE94F82BE
+sigma4 = 0x54FF53A5F1D36F1C
+sigma5 = 0x10E527FADE682D1D
+sigma6 = 0xB05688C2B3E6C1FD
+
+rotl128 :: Word128 -> Int -> Word128
+rotl128 v               0  = v
+rotl128 (Word128 x1 x2) 64 = Word128 x2 x1
+
+rotl128 v@(Word128 x1 x2) w
+    | w > 64    = (v `rotl128` 64) `rotl128` (w - 64)
+    | otherwise = Word128 (x1high .|. x2low) (x2high .|. x1low)
+        where
+            splitBits i = (i .&. complement x, i .&. x)
+                where x = 2 ^ w - 1
+            (x1high, x1low) = splitBits (x1 `rotateL` w)
+            (x2high, x2low) = splitBits (x2 `rotateL` w)
+
+-- | Camellia context
+data Camellia = Camellia
+    { k  :: Array64
+    , kw :: Array64
+    , ke :: Array64
+    }
+
+setKeyInterim :: ByteArrayAccess key => key -> (Word128, Word128, Word128, Word128)
+setKeyInterim keyseed = (w64tow128 kL, w64tow128 kR, w64tow128 kA, w64tow128 kB)
+  where kL = (fromBE $ B.toW64BE keyseed 0, fromBE $ B.toW64BE keyseed 8)
+        kR = (0, 0)
+
+        kA = let d1 = (fst kL `xor` fst kR)
+                 d2 = (snd kL `xor` snd kR)
+                 d3 = d2 `xor` feistel d1 sigma1
+                 d4 = d1 `xor` feistel d3 sigma2
+                 d5 = d4 `xor` (fst kL)
+                 d6 = d3 `xor` (snd kL)
+                 d7 = d6 `xor` feistel d5 sigma3
+                 d8 = d5 `xor` feistel d7 sigma4
+              in (d8, d7)
+
+        kB = let d1 = (fst kA `xor` fst kR)
+                 d2 = (snd kA `xor` snd kR)
+                 d3 = d2 `xor` feistel d1 sigma5
+                 d4 = d1 `xor` feistel d3 sigma6
+              in (d4, d3)
+
+-- | Initialize a 128-bit key
+--
+-- Return the initialized key or a error message if the given 
+-- keyseed was not 16-bytes in length.
+initCamellia :: ByteArray key
+             => key -- ^ The key to create the camellia context
+             -> CryptoFailable Camellia
+initCamellia key
+    | B.length key /= 16 = CryptoFailed $ CryptoError_KeySizeInvalid
+    | otherwise          =
+        let (kL, _, kA, _) = setKeyInterim key in
+
+        let (Word128 kw1 kw2) = (kL `rotl128` 0) in
+        let (Word128 k1 k2)   = (kA `rotl128` 0) in
+        let (Word128 k3 k4)   = (kL `rotl128` 15) in
+        let (Word128 k5 k6)   = (kA `rotl128` 15) in
+        let (Word128 ke1 ke2) = (kA `rotl128` 30) in --ke1 = (KA <<<  30) >> 64; ke2 = (KA <<<  30) & MASK64;
+        let (Word128 k7 k8)   = (kL `rotl128` 45) in --k7  = (KL <<<  45) >> 64; k8  = (KL <<<  45) & MASK64;
+        let (Word128 k9 _)    = (kA `rotl128` 45) in --k9  = (KA <<<  45) >> 64;
+        let (Word128 _ k10)   = (kL `rotl128` 60) in
+        let (Word128 k11 k12) = (kA `rotl128` 60) in
+        let (Word128 ke3 ke4) = (kL `rotl128` 77) in
+        let (Word128 k13 k14) = (kL `rotl128` 94) in
+        let (Word128 k15 k16) = (kA `rotl128` 94) in
+        let (Word128 k17 k18) = (kL `rotl128` 111) in
+        let (Word128 kw3 kw4) = (kA `rotl128` 111) in
+
+        CryptoPassed $ Camellia
+            { kw = array64 4 [ kw1, kw2, kw3, kw4 ]
+            , ke = array64 4 [ ke1, ke2, ke3, ke4 ]
+            , k  = array64 18 [ k1, k2, k3, k4, k5, k6, k7, k8, k9, k10, k11, k12, k13, k14, k15, k16, k17, k18 ]
+            }
+
+feistel :: Word64 -> Word64 -> Word64
+feistel fin sk = 
+    let x = fin `xor` sk in
+    let (t1, t2, t3, t4, t5, t6, t7, t8) = w64tow8 x in
+    let t1' = sbox1 t1 in
+    let t2' = sbox2 t2 in
+    let t3' = sbox3 t3 in
+    let t4' = sbox4 t4 in
+    let t5' = sbox2 t5 in
+    let t6' = sbox3 t6 in
+    let t7' = sbox4 t7 in
+    let t8' = sbox1 t8 in
+    let y1 = t1' `xor` t3' `xor` t4' `xor` t6' `xor` t7' `xor` t8' in
+    let y2 = t1' `xor` t2' `xor` t4' `xor` t5' `xor` t7' `xor` t8' in
+    let y3 = t1' `xor` t2' `xor` t3' `xor` t5' `xor` t6' `xor` t8' in
+    let y4 = t2' `xor` t3' `xor` t4' `xor` t5' `xor` t6' `xor` t7' in
+    let y5 = t1' `xor` t2' `xor` t6' `xor` t7' `xor` t8' in
+    let y6 = t2' `xor` t3' `xor` t5' `xor` t7' `xor` t8' in
+    let y7 = t3' `xor` t4' `xor` t5' `xor` t6' `xor` t8' in
+    let y8 = t1' `xor` t4' `xor` t5' `xor` t6' `xor` t7' in
+    w8tow64 (y1, y2, y3, y4, y5, y6, y7, y8)
+
+fl :: Word64 -> Word64 -> Word64
+fl fin sk =
+    let (x1, x2) = w64to32 fin in
+    let (k1, k2) = w64to32 sk in
+    let y2 = x2 `xor` ((x1 .&. k1) `rotateL` 1) in
+    let y1 = x1 `xor` (y2 .|. k2) in
+    w32to64 (y1, y2)
+
+flinv :: Word64 -> Word64 -> Word64
+flinv fin sk =
+    let (y1, y2) = w64to32 fin in
+    let (k1, k2) = w64to32 sk in
+    let x1 = y1 `xor` (y2 .|. k2) in
+    let x2 = y2 `xor` ((x1 .&. k1) `rotateL` 1) in
+    w32to64 (x1, x2)
+
+{- in decrypt mode 0->17 1->16 ... -}
+getKeyK :: Mode -> Camellia -> Int -> Word64
+getKeyK Encrypt key i = k key `arrayRead64` i
+getKeyK Decrypt key i = k key `arrayRead64` (17 - i)
+
+{- in decrypt mode 0->3 1->2 2->1 3->0 -}
+getKeyKe :: Mode -> Camellia -> Int -> Word64
+getKeyKe Encrypt key i = ke key `arrayRead64` i
+getKeyKe Decrypt key i = ke key `arrayRead64` (3 - i)
+
+{- in decrypt mode 0->2 1->3 2->0 3->1 -}
+getKeyKw :: Mode -> Camellia -> Int -> Word64
+getKeyKw Encrypt key i = (kw key) `arrayRead64` i
+getKeyKw Decrypt key i = (kw key) `arrayRead64` ((i + 2) `mod` 4)
+
+{- perform the following
+    D2 = D2 ^ F(D1, k1);     // Round 1
+    D1 = D1 ^ F(D2, k2);     // Round 2
+    D2 = D2 ^ F(D1, k3);     // Round 3
+    D1 = D1 ^ F(D2, k4);     // Round 4
+    D2 = D2 ^ F(D1, k5);     // Round 5
+    D1 = D1 ^ F(D2, k6);     // Round 6
+ -}
+doBlockRound :: Mode -> Camellia -> Word64 -> Word64 -> Int -> (Word64, Word64)
+doBlockRound mode key d1 d2 i =
+    let r1 = d2 `xor` feistel d1 (getKeyK mode key (0+i)) in     {- Round 1+i -}
+    let r2 = d1 `xor` feistel r1 (getKeyK mode key (1+i)) in     {- Round 2+i -}
+    let r3 = r1 `xor` feistel r2 (getKeyK mode key (2+i)) in     {- Round 3+i -}
+    let r4 = r2 `xor` feistel r3 (getKeyK mode key (3+i)) in     {- Round 4+i -}
+    let r5 = r3 `xor` feistel r4 (getKeyK mode key (4+i)) in     {- Round 5+i -}
+    let r6 = r4 `xor` feistel r5 (getKeyK mode key (5+i)) in     {- Round 6+i -}
+    (r6, r5)
+
+doBlock :: Mode -> Camellia -> Word128 -> Word128
+doBlock mode key (Word128 d1 d2) =
+    let d1a = d1 `xor` (getKeyKw mode key 0) in {- Prewhitening -}
+    let d2a = d2 `xor` (getKeyKw mode key 1) in
+
+    let (d1b, d2b) = doBlockRound mode key d1a d2a 0 in
+
+    let d1c = fl    d1b (getKeyKe mode key 0) in {- FL -}
+    let d2c = flinv d2b (getKeyKe mode key 1) in {- FLINV -}
+
+    let (d1d, d2d) = doBlockRound mode key d1c d2c 6 in
+
+    let d1e = fl    d1d (getKeyKe mode key 2) in {- FL -}
+    let d2e = flinv d2d (getKeyKe mode key 3) in {- FLINV -}
+
+    let (d1f, d2f) = doBlockRound mode key d1e d2e 12 in
+
+    let d2g = d2f `xor` (getKeyKw mode key 2) in {- Postwhitening -}
+    let d1g = d1f `xor` (getKeyKw mode key 3) in
+    w64tow128 (d2g, d1g)
+
+{- encryption for 128 bits blocks -}
+encryptBlock :: Camellia -> Word128 -> Word128
+encryptBlock = doBlock Encrypt
+
+{- decryption for 128 bits blocks -}
+decryptBlock :: Camellia -> Word128 -> Word128
+decryptBlock = doBlock Decrypt
+
+-- | Encrypts the given ByteString using the given Key
+encrypt :: ByteArray ba
+        => Camellia     -- ^ The key to use
+        -> ba           -- ^ The data to encrypt
+        -> ba
+encrypt key = B.mapAsWord128 (encryptBlock key)
+
+-- | Decrypts the given ByteString using the given Key
+decrypt :: ByteArray ba
+        => Camellia     -- ^ The key to use
+        -> ba           -- ^ The data to decrypt
+        -> ba
+decrypt key = B.mapAsWord128 (decryptBlock key)

bundled/Crypto/Cipher/ChaCha.hs

@@ -0,0 +1,126 @@
+-- |
+-- Module      : Crypto.Cipher.ChaCha
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.Cipher.ChaCha
+    ( initialize
+    , combine
+    , generate
+    , State
+    -- * Simple interface for DRG purpose
+    , initializeSimple
+    , generateSimple
+    , StateSimple
+    ) where
+
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Foreign.Ptr
+import           Foreign.C.Types
+
+-- | ChaCha context
+newtype State = State ScrubbedBytes
+    deriving (NFData)
+
+-- | ChaCha context for DRG purpose (see Crypto.Random.ChaChaDRG)
+newtype StateSimple = StateSimple ScrubbedBytes -- just ChaCha's state
+    deriving (NFData)
+
+-- | Initialize a new ChaCha context with the number of rounds,
+-- the key and the nonce associated.
+initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)
+           => Int   -- ^ number of rounds (8,12,20)
+           -> key   -- ^ the key (128 or 256 bits)
+           -> nonce -- ^ the nonce (64 or 96 bits)
+           -> State -- ^ the initial ChaCha state
+initialize nbRounds key nonce
+    | kLen `notElem` [16,32]          = error "ChaCha: key length should be 128 or 256 bits"
+    | nonceLen `notElem` [8,12]       = error "ChaCha: nonce length should be 64 or 96 bits"
+    | nbRounds `notElem` [8,12,20]    = error "ChaCha: rounds should be 8, 12 or 20"
+    | otherwise                       = unsafeDoIO $ do
+        stPtr <- B.alloc 132 $ \stPtr ->
+            B.withByteArray nonce $ \noncePtr  ->
+            B.withByteArray key   $ \keyPtr ->
+                ccryptonite_chacha_init stPtr  nbRounds kLen keyPtr nonceLen noncePtr
+        return $ State stPtr
+  where kLen     = B.length key
+        nonceLen = B.length nonce
+
+-- | Initialize simple ChaCha State
+--
+-- The seed need to be at least 40 bytes long
+initializeSimple :: ByteArrayAccess seed
+                 => seed -- ^ a 40 bytes long seed
+                 -> StateSimple
+initializeSimple seed
+    | sLen < 40 = error "ChaCha Random: seed length should be 40 bytes"
+    | otherwise = unsafeDoIO $ do
+        stPtr <- B.alloc 64 $ \stPtr ->
+                    B.withByteArray seed $ \seedPtr ->
+                        ccryptonite_chacha_init_core stPtr 32 seedPtr 8 (seedPtr `plusPtr` 32)
+        return $ StateSimple stPtr
+  where
+    sLen = B.length seed
+
+-- | Combine the chacha output and an arbitrary message with a xor,
+-- and return the combined output and the new state.
+combine :: ByteArray ba
+        => State       -- ^ the current ChaCha state
+        -> ba          -- ^ the source to xor with the generator
+        -> (ba, State)
+combine prevSt@(State prevStMem) src
+    | B.null src = (B.empty, prevSt)
+    | otherwise  = unsafeDoIO $ do
+        (out, st) <- B.copyRet prevStMem $ \ctx ->
+            B.alloc (B.length src) $ \dstPtr ->
+            B.withByteArray src    $ \srcPtr ->
+                ccryptonite_chacha_combine dstPtr ctx srcPtr (fromIntegral $ B.length src)
+        return (out, State st)
+
+-- | Generate a number of bytes from the ChaCha output directly
+generate :: ByteArray ba
+         => State -- ^ the current ChaCha state
+         -> Int   -- ^ the length of data to generate
+         -> (ba, State)
+generate prevSt@(State prevStMem) len
+    | len <= 0  = (B.empty, prevSt)
+    | otherwise = unsafeDoIO $ do
+        (out, st) <- B.copyRet prevStMem $ \ctx ->
+            B.alloc len $ \dstPtr ->
+                ccryptonite_chacha_generate dstPtr ctx (fromIntegral len)
+        return (out, State st)
+
+-- | similar to 'generate' but assume certains values
+generateSimple :: ByteArray ba
+               => StateSimple
+               -> Int
+               -> (ba, StateSimple)
+generateSimple (StateSimple prevSt) nbBytes = unsafeDoIO $ do
+    newSt  <- B.copy prevSt (\_ -> return ())
+    output <- B.alloc nbBytes $ \dstPtr ->
+        B.withByteArray newSt $ \stPtr ->
+            ccryptonite_chacha_random 8 dstPtr stPtr (fromIntegral nbBytes)
+    return (output, StateSimple newSt)
+
+foreign import ccall "cryptonite_chacha_init_core"
+    ccryptonite_chacha_init_core :: Ptr StateSimple -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO ()
+
+foreign import ccall "cryptonite_chacha_init"
+    ccryptonite_chacha_init :: Ptr State -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO ()
+
+foreign import ccall "cryptonite_chacha_combine"
+    ccryptonite_chacha_combine :: Ptr Word8 -> Ptr State -> Ptr Word8 -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_chacha_generate"
+    ccryptonite_chacha_generate :: Ptr Word8 -> Ptr State -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_chacha_random"
+    ccryptonite_chacha_random :: Int -> Ptr Word8 -> Ptr StateSimple -> CUInt -> IO ()
+

bundled/Crypto/Cipher/ChaChaPoly1305.hs

@@ -0,0 +1,201 @@
+-- |
+-- Module      : Crypto.Cipher.ChaChaPoly1305
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+--
+-- A simple AEAD scheme using ChaCha20 and Poly1305. See
+-- <https://tools.ietf.org/html/rfc7539 RFC 7539>.
+--
+-- The State is not modified in place, so each function changing the State,
+-- returns a new State.
+--
+-- Authenticated Data need to be added before any call to 'encrypt' or 'decrypt',
+-- and once all the data has been added, then 'finalizeAAD' need to be called.
+--
+-- Once 'finalizeAAD' has been called, no further 'appendAAD' call should be make.
+--
+-- >import Data.ByteString.Char8 as B
+-- >import Data.ByteArray
+-- >import Crypto.Error
+-- >import Crypto.Cipher.ChaChaPoly1305 as C
+-- >
+-- >encrypt
+-- >    :: ByteString -- nonce (12 random bytes)
+-- >    -> ByteString -- symmetric key
+-- >    -> ByteString -- optional associated data (won't be encrypted)
+-- >    -> ByteString -- input plaintext to be encrypted
+-- >    -> CryptoFailable ByteString -- ciphertext with a 128-bit tag attached
+-- >encrypt nonce key header plaintext = do
+-- >    st1 <- C.nonce12 nonce >>= C.initialize key
+-- >    let
+-- >        st2 = C.finalizeAAD $ C.appendAAD header st1
+-- >        (out, st3) = C.encrypt plaintext st2
+-- >        auth = C.finalize st3
+-- >    return $ out `B.append` Data.ByteArray.convert auth
+--
+module Crypto.Cipher.ChaChaPoly1305
+    ( State
+    , Nonce
+    , nonce12
+    , nonce8
+    , incrementNonce
+    , initialize
+    , appendAAD
+    , finalizeAAD
+    , encrypt
+    , decrypt
+    , finalize
+    ) where
+
+import           Control.Monad             (when)
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, Bytes, ScrubbedBytes)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.Imports
+import           Crypto.Error
+import qualified Crypto.Cipher.ChaCha as ChaCha
+import qualified Crypto.MAC.Poly1305  as Poly1305
+import           Data.Memory.Endian
+import qualified Data.ByteArray.Pack as P
+import           Foreign.Ptr
+import           Foreign.Storable
+
+-- | A ChaChaPoly1305 State.
+--
+-- The state is immutable, and only new state can be created
+data State = State !ChaCha.State
+                   !Poly1305.State
+                   !Word64 -- AAD length
+                   !Word64 -- ciphertext length
+
+-- | Valid Nonce for ChaChaPoly1305.
+--
+-- It can be created with 'nonce8' or 'nonce12'
+data Nonce = Nonce8 Bytes | Nonce12 Bytes
+
+instance ByteArrayAccess Nonce where
+  length (Nonce8  n) = B.length n
+  length (Nonce12 n) = B.length n
+
+  withByteArray (Nonce8  n) = B.withByteArray n
+  withByteArray (Nonce12 n) = B.withByteArray n
+
+-- Based on the following pseudo code:
+--
+-- chacha20_aead_encrypt(aad, key, iv, constant, plaintext):
+--     nonce = constant | iv
+--     otk = poly1305_key_gen(key, nonce)
+--     ciphertext = chacha20_encrypt(key, 1, nonce, plaintext)
+--     mac_data = aad | pad16(aad)
+--     mac_data |= ciphertext | pad16(ciphertext)
+--     mac_data |= num_to_4_le_bytes(aad.length)
+--     mac_data |= num_to_4_le_bytes(ciphertext.length)
+--     tag = poly1305_mac(mac_data, otk)
+--     return (ciphertext, tag)
+
+pad16 :: Word64 -> Bytes
+pad16 n
+    | modLen == 0 = B.empty
+    | otherwise   = B.replicate (16 - modLen) 0
+  where
+    modLen = fromIntegral (n `mod` 16)
+
+-- | Nonce smart constructor 12 bytes IV, nonce constructor
+nonce12 :: ByteArrayAccess iv => iv -> CryptoFailable Nonce
+nonce12 iv
+    | B.length iv /= 12 = CryptoFailed CryptoError_IvSizeInvalid
+    | otherwise         = CryptoPassed . Nonce12 . B.convert $ iv
+
+-- | 8 bytes IV, nonce constructor
+nonce8 :: ByteArrayAccess ba
+       => ba -- ^ 4 bytes constant
+       -> ba -- ^ 8 bytes IV
+       -> CryptoFailable Nonce
+nonce8 constant iv
+    | B.length constant /= 4 = CryptoFailed CryptoError_IvSizeInvalid
+    | B.length iv       /= 8 = CryptoFailed CryptoError_IvSizeInvalid
+    | otherwise              = CryptoPassed . Nonce8 . B.concat $ [constant, iv]
+
+-- | Increment a nonce
+incrementNonce :: Nonce -> Nonce
+incrementNonce (Nonce8  n) = Nonce8  $ incrementNonce' n 4
+incrementNonce (Nonce12 n) = Nonce12 $ incrementNonce' n 0
+
+incrementNonce' :: Bytes -> Int -> Bytes
+incrementNonce' b offset = B.copyAndFreeze b $ \s ->
+    loop s (s `plusPtr` offset)
+    where
+      loop :: Ptr Word8 -> Ptr Word8 -> IO ()
+      loop s p
+          | s == (p `plusPtr` (B.length b - offset - 1)) = peek s >>= poke s . (+) 1
+          | otherwise = do
+              r <- (+) 1 <$> peek p
+              poke p r
+              when (r == 0) $ loop s (p `plusPtr` 1)
+
+-- | Initialize a new ChaChaPoly1305 State
+--
+-- The key length need to be 256 bits, and the nonce
+-- procured using either `nonce8` or `nonce12`
+initialize :: ByteArrayAccess key
+           => key -> Nonce -> CryptoFailable State
+initialize key (Nonce8  nonce) = initialize' key nonce
+initialize key (Nonce12 nonce) = initialize' key nonce
+
+initialize' :: ByteArrayAccess key
+            => key -> Bytes -> CryptoFailable State
+initialize' key nonce
+    | B.length key /= 32 = CryptoFailed CryptoError_KeySizeInvalid
+    | otherwise          = CryptoPassed $ State encState polyState 0 0
+  where
+    rootState           = ChaCha.initialize 20 key nonce
+    (polyKey, encState) = ChaCha.generate rootState 64
+    polyState           = throwCryptoError $ Poly1305.initialize (B.take 32 polyKey :: ScrubbedBytes)
+
+-- | Append Authenticated Data to the State and return
+-- the new modified State.
+--
+-- Once no further call to this function need to be make,
+-- the user should call 'finalizeAAD'
+appendAAD :: ByteArrayAccess ba => ba -> State -> State
+appendAAD ba (State encState macState aadLength plainLength) =
+    State encState newMacState newLength plainLength
+  where
+    newMacState = Poly1305.update macState ba
+    newLength   = aadLength + fromIntegral (B.length ba)
+
+-- | Finalize the Authenticated Data and return the finalized State
+finalizeAAD :: State -> State
+finalizeAAD (State encState macState aadLength plainLength) =
+    State encState newMacState aadLength plainLength
+  where
+    newMacState = Poly1305.update macState $ pad16 aadLength
+
+-- | Encrypt a piece of data and returns the encrypted Data and the
+-- updated State.
+encrypt :: ByteArray ba => ba -> State -> (ba, State)
+encrypt input (State encState macState aadLength plainLength) =
+    (output, State newEncState newMacState aadLength newPlainLength)
+  where
+    (output, newEncState) = ChaCha.combine encState input
+    newMacState           = Poly1305.update macState output
+    newPlainLength        = plainLength + fromIntegral (B.length input)
+
+-- | Decrypt a piece of data and returns the decrypted Data and the
+-- updated State.
+decrypt :: ByteArray ba => ba -> State -> (ba, State)
+decrypt input (State encState macState aadLength plainLength) =
+    (output, State newEncState newMacState aadLength newPlainLength)
+  where
+    (output, newEncState) = ChaCha.combine encState input
+    newMacState           = Poly1305.update macState input
+    newPlainLength        = plainLength + fromIntegral (B.length input)
+
+-- | Generate an authentication tag from the State.
+finalize :: State -> Poly1305.Auth
+finalize (State _ macState aadLength plainLength) =
+    Poly1305.finalize $ Poly1305.updates macState
+        [ pad16 plainLength
+        , either (error "finalize: internal error") id $ P.fill 16 (P.putStorable (toLE aadLength) >> P.putStorable (toLE plainLength))
+        ]

bundled/Crypto/Cipher/DES.hs

@@ -0,0 +1,39 @@
+-- |
+-- Module      : Crypto.Cipher.DES
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+--
+module Crypto.Cipher.DES
+    ( DES
+    ) where
+
+import           Data.Word
+import           Crypto.Error
+import           Crypto.Cipher.Types
+import           Crypto.Cipher.DES.Primitive
+import           Crypto.Internal.ByteArray (ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray as B
+import           Data.Memory.Endian
+
+-- | DES Context
+data DES = DES Word64
+    deriving (Eq)
+
+instance Cipher DES where
+    cipherName    _ = "DES"
+    cipherKeySize _ = KeySizeFixed 8
+    cipherInit k    = initDES k
+
+instance BlockCipher DES where
+    blockSize _ = 8
+    ecbEncrypt (DES key) = B.mapAsWord64 (unBlock . encrypt key . Block)
+    ecbDecrypt (DES key) = B.mapAsWord64 (unBlock . decrypt key . Block)
+
+initDES :: ByteArrayAccess key => key -> CryptoFailable DES
+initDES k
+    | len == 8  = CryptoPassed $ DES key
+    | otherwise = CryptoFailed $ CryptoError_KeySizeInvalid
+  where len = B.length k
+        key = fromBE $ B.toW64BE k 0