basement 0.0.3 → 0.0.4

raw patch · 34 files changed

+1084/−467 lines, 34 filesdep +Win32dep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Win32

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Basement/Alg/Class.hs +15/−0
• Basement/Alg/Foreign/PrimArray.hs +0/−124
• Basement/Alg/Foreign/String.hs +31/−24
• Basement/Alg/Foreign/UTF8.hs +37/−0
• Basement/Alg/Mutable.hs +2/−6
• Basement/Alg/Native/PrimArray.hs +0/−124
• Basement/Alg/Native/String.hs +31/−24
• Basement/Alg/Native/UTF8.hs +37/−0
• Basement/Alg/PrimArray.hs +122/−0
• Basement/Block.hs +9/−4
• Basement/Block/Base.hs +11/−10
• Basement/Bounded.hs +44/−0
• Basement/BoxedArray.hs +7/−3
• Basement/Compat/Bifunctor.hs +34/−0
• Basement/Compat/NumLiteral.hs +15/−0
• Basement/Compat/Semigroup.hs +6/−1
• Basement/Imports.hs +8/−0
• Basement/Nat.hs +18/−33
• Basement/NormalForm.hs +3/−0
• Basement/Numerical/Additive.hs +12/−0
• Basement/Numerical/Subtractive.hs +9/−0
• Basement/Sized/Block.hs +1/−0
• Basement/String.hs +8/−28
• Basement/Terminal.hs +26/−0
• Basement/Terminal/ANSI.hs +170/−0
• Basement/Terminal/Size.hsc +187/−0
• Basement/Types/AsciiString.hs +2/−1
• Basement/Types/OffsetSize.hs +25/−0
• Basement/UArray.hs +31/−60
• Basement/UArray/Base.hs +36/−1
• Basement/UTF8/Base.hs +34/−8
• Basement/UTF8/Table.hs +40/−13
• basement.cabal +13/−3
• cbits/foundation_system.h +60/−0

@@ -0,0 +1,15 @@+{-# 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 ()

@@ -1,124 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.Alg.Foreign.PrimArray-    ( findIndexElem-    , revFindIndexElem-    , findIndexPredicate-    , revFindIndexPredicate-    , foldl-    , foldr-    , foldl1-    , all-    , any-    , filter-    , primIndex-    ) 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.Foreign.Prim--findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty-findIndexElem ty ba startIndex endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && t /= ty = loop (i+1)-        | otherwise               = i-      where t = primIndex ba i-{-# INLINE findIndexElem #-}--revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty-revFindIndexElem ty ba startIndex endIndex-    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)-    | otherwise             = endIndex-  where-    loop !i-        | t == ty        = i-        | i > startIndex = loop (i `offsetMinusE` 1)-        | otherwise      = endIndex-      where t = primIndex ba i-{-# INLINE revFindIndexElem #-}--findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty-findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && not found = loop (i+1)-        | otherwise                 = i-      where found = predicate (primIndex ba i)-{-# INLINE findIndexPredicate #-}--revFindIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty-revFindIndexPredicate predicate ba startIndex endIndex-    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)-    | otherwise             = endIndex-  where-    loop !i-        | found          = i-        | i > startIndex = loop (i `offsetMinusE` 1)-        | otherwise      = endIndex-      where found = predicate (primIndex ba i)-{-# INLINE revFindIndexPredicate #-}--foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> 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 (primIndex ba i))-{-# INLINE foldl #-}--foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a-foldr f !initialAcc ba startIndex endIndex = loop startIndex-  where-    loop !i-        | i == endIndex = initialAcc-        | otherwise     = primIndex ba i `f` loop (i+1)-{-# INLINE foldr #-}--foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty-foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)-  where-    loop !i !acc-        | i == endIndex = acc-        | otherwise     = loop (i+1) (f acc (primIndex ba i))-{-# INLINE foldl1 #-}--filter :: (PrimMonad prim, PrimType ty)-       => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> 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 = primIndex src s--all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool-all predicate ba start end = loop start-  where-    loop !i-        | i == end                   = True-        | predicate (primIndex ba i) = loop (i+1)-        | otherwise                  = False-{-# INLINE all #-}--any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool-any predicate ba start end = loop start-  where-    loop !i-        | i == end                   = False-        | predicate (primIndex ba i) = True-        | otherwise                  = loop (i+1)-{-# INLINE any #-}

@@ -50,44 +50,51 @@          -> PrimBackend.Immutable          -> Offset Word8          -> (Offset Word8, Maybe ValidationFailure)-validate end ba ofsStart = loop ofsStart+validate end ba ofsStart = loop4 ofsStart   where+    loop4 !ofs+        | ofs4 < end =+            let h1 = PrimBackend.primIndex ba ofs+                h2 = PrimBackend.primIndex ba (ofs+1)+                h3 = PrimBackend.primIndex ba (ofs+2)+                h4 = PrimBackend.primIndex 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  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)-        | ofs == end = (end, Nothing)-        | otherwise  =-            let !h = PrimBackend.primIndex ba ofs in-            case headerIsAscii h of-                True  -> loop (ofs + Offset 1)-                False ->-                    case one (CountOf $ getNbBytes h) ofs of-                        (nextOfs, Nothing)  -> loop nextOfs-                        (pos, Just failure) -> (pos, Just failure)+        | ofs == end      = (end, Nothing)+        | headerIsAscii h = loop (ofs + Offset 1)+        | otherwise       = multi (CountOf $ getNbBytes h) ofs+      where+        h = PrimBackend.primIndex ba ofs -    one (CountOf 0xff) pos = (pos, Just InvalidHeader)-    one nbConts pos-        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)+    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 = PrimBackend.primIndex ba (pos + Offset 1)+                    let c1 = PrimBackend.primIndex ba posNext                     in if isContinuation c1-                        then (pos + Offset 2, Nothing)+                        then loop (pos + Offset 2)                         else (pos, Just InvalidContinuation)                 CountOf 2 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                    let c1 = PrimBackend.primIndex ba posNext                         c2 = PrimBackend.primIndex ba (pos + Offset 2)-                     in if isContinuation c1 && isContinuation c2-                            then (pos + Offset 3, Nothing)+                     in if isContinuation2 c1 c2+                            then loop (pos + Offset 3)                             else (pos, Just InvalidContinuation)-                CountOf 3 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                CountOf _ ->+                    let c1 = PrimBackend.primIndex ba posNext                         c2 = PrimBackend.primIndex ba (pos + Offset 2)                         c3 = PrimBackend.primIndex ba (pos + Offset 3)-                     in if isContinuation c1 && isContinuation c2 && isContinuation c3-                            then (pos + Offset 4, Nothing)+                     in if isContinuation3 c1 c2 c3+                            then loop (pos + Offset 4)                             else (pos, Just InvalidContinuation)-                CountOf _ -> error "internal error"+      where posNext = pos + Offset 1  findIndexPredicate :: (Char -> Bool)                    -> PrimBackend.Immutable

@@ -20,6 +20,7 @@     , any     , foldr     , length+    , reverse     -- temporary     , primIndex64     , primRead8@@ -34,6 +35,7 @@ import           Basement.Compat.Base hiding (toList) import           Basement.Compat.Primitive import           Basement.Alg.Foreign.Prim+import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST import           Data.Proxy import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive@@ -245,3 +247,38 @@                 c'   = if cont then c else c+1              in processStart c' (i+1) {-# INLINE length #-}++reverse :: PrimMonad prim+        => MutableByteArray# (PrimState prim) -- ^ Destination buffer+        -> Offset Word8                       -- ^ Destination start+        -> Immutable                          -- ^ 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 = PrimNative.primWrite dst d h >> loop (d `offsetSub` 1) (s + 1)+        | otherwise       = do+            case getNbBytes h of+                1 -> do+                    PrimNative.primWrite dst (d `offsetSub` 1) h+                    PrimNative.primWrite dst d                 (primIndex8 src (s + 1))+                    loop (d `offsetSub` 2) (s + 2)+                2 -> do+                    PrimNative.primWrite dst (d `offsetSub` 2) h+                    PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 1))+                    PrimNative.primWrite dst d                 (primIndex8 src (s + 2))+                    loop (d `offsetSub` 3) (s + 3)+                3 -> do+                    PrimNative.primWrite dst (d `offsetSub` 3) h+                    PrimNative.primWrite dst (d `offsetSub` 2) (primIndex8 src (s + 1))+                    PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 2))+                    PrimNative.primWrite dst d                 (primIndex8 src (s + 3))+                    loop (d `offsetSub` 4) (s + 4)+                _ -> error "impossible"+      where h = primIndex8 src s+{-# INLINE reverse #-}

@@ -1,7 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Basement.Alg.Mutable-    ( RandomAccess, read, write-    , inplaceSortBy+    ( inplaceSortBy     ) where  import           GHC.Types@@ -12,10 +11,7 @@ import           Basement.Types.OffsetSize import           Basement.PrimType import           Basement.Monad--class RandomAccess container prim ty where-    read  :: container -> (Offset ty)       -> prim ty-    write :: container -> (Offset ty) -> ty -> prim ()+import           Basement.Alg.Class  inplaceSortBy :: (PrimMonad prim, RandomAccess container prim ty)                => (ty -> ty -> Ordering)

@@ -1,124 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE CPP                        #-}-module Basement.Alg.Native.PrimArray-    ( findIndexElem-    , revFindIndexElem-    , findIndexPredicate-    , revFindIndexPredicate-    , foldl-    , foldr-    , foldl1-    , all-    , any-    , filter-    , primIndex-    ) 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.Native.Prim--findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty-findIndexElem ty ba startIndex endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && t /= ty = loop (i+1)-        | otherwise               = i-      where t = primIndex ba i-{-# INLINE findIndexElem #-}--revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty-revFindIndexElem ty ba startIndex endIndex-    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)-    | otherwise             = endIndex-  where-    loop !i-        | t == ty        = i-        | i > startIndex = loop (i `offsetMinusE` 1)-        | otherwise      = endIndex-      where t = primIndex ba i-{-# INLINE revFindIndexElem #-}--findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty-findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex-  where-    loop !i-        | i < endIndex && not found = loop (i+1)-        | otherwise                 = i-      where found = predicate (primIndex ba i)-{-# INLINE findIndexPredicate #-}--revFindIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty-revFindIndexPredicate predicate ba startIndex endIndex-    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)-    | otherwise             = endIndex-  where-    loop !i-        | found          = i-        | i > startIndex = loop (i `offsetMinusE` 1)-        | otherwise      = endIndex-      where found = predicate (primIndex ba i)-{-# INLINE revFindIndexPredicate #-}--foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> 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 (primIndex ba i))-{-# INLINE foldl #-}--foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a-foldr f !initialAcc ba startIndex endIndex = loop startIndex-  where-    loop !i-        | i == endIndex = initialAcc-        | otherwise     = primIndex ba i `f` loop (i+1)-{-# INLINE foldr #-}--foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty-foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)-  where-    loop !i !acc-        | i == endIndex = acc-        | otherwise     = loop (i+1) (f acc (primIndex ba i))-{-# INLINE foldl1 #-}--filter :: (PrimMonad prim, PrimType ty)-       => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> 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 = primIndex src s--all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool-all predicate ba start end = loop start-  where-    loop !i-        | i == end                   = True-        | predicate (primIndex ba i) = loop (i+1)-        | otherwise                  = False-{-# INLINE all #-}--any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool-any predicate ba start end = loop start-  where-    loop !i-        | i == end                   = False-        | predicate (primIndex ba i) = True-        | otherwise                  = loop (i+1)-{-# INLINE any #-}

@@ -50,44 +50,51 @@          -> PrimBackend.Immutable          -> Offset Word8          -> (Offset Word8, Maybe ValidationFailure)-validate end ba ofsStart = loop ofsStart+validate end ba ofsStart = loop4 ofsStart   where+    loop4 !ofs+        | ofs4 < end =+            let h1 = PrimBackend.primIndex ba ofs+                h2 = PrimBackend.primIndex ba (ofs+1)+                h3 = PrimBackend.primIndex ba (ofs+2)+                h4 = PrimBackend.primIndex 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  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)-        | ofs == end = (end, Nothing)-        | otherwise  =-            let !h = PrimBackend.primIndex ba ofs in-            case headerIsAscii h of-                True  -> loop (ofs + Offset 1)-                False ->-                    case one (CountOf $ getNbBytes h) ofs of-                        (nextOfs, Nothing)  -> loop nextOfs-                        (pos, Just failure) -> (pos, Just failure)+        | ofs == end      = (end, Nothing)+        | headerIsAscii h = loop (ofs + Offset 1)+        | otherwise       = multi (CountOf $ getNbBytes h) ofs+      where+        h = PrimBackend.primIndex ba ofs -    one (CountOf 0xff) pos = (pos, Just InvalidHeader)-    one nbConts pos-        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)+    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 = PrimBackend.primIndex ba (pos + Offset 1)+                    let c1 = PrimBackend.primIndex ba posNext                     in if isContinuation c1-                        then (pos + Offset 2, Nothing)+                        then loop (pos + Offset 2)                         else (pos, Just InvalidContinuation)                 CountOf 2 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                    let c1 = PrimBackend.primIndex ba posNext                         c2 = PrimBackend.primIndex ba (pos + Offset 2)-                     in if isContinuation c1 && isContinuation c2-                            then (pos + Offset 3, Nothing)+                     in if isContinuation2 c1 c2+                            then loop (pos + Offset 3)                             else (pos, Just InvalidContinuation)-                CountOf 3 ->-                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                CountOf _ ->+                    let c1 = PrimBackend.primIndex ba posNext                         c2 = PrimBackend.primIndex ba (pos + Offset 2)                         c3 = PrimBackend.primIndex ba (pos + Offset 3)-                     in if isContinuation c1 && isContinuation c2 && isContinuation c3-                            then (pos + Offset 4, Nothing)+                     in if isContinuation3 c1 c2 c3+                            then loop (pos + Offset 4)                             else (pos, Just InvalidContinuation)-                CountOf _ -> error "internal error"+      where posNext = pos + Offset 1  findIndexPredicate :: (Char -> Bool)                    -> PrimBackend.Immutable

@@ -20,6 +20,7 @@     , any     , foldr     , length+    , reverse     -- temporary     , primIndex64     , primRead8@@ -34,6 +35,7 @@ import           Basement.Compat.Base hiding (toList) import           Basement.Compat.Primitive import           Basement.Alg.Native.Prim+import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST import           Data.Proxy import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive@@ -245,3 +247,38 @@                 c'   = if cont then c else c+1              in processStart c' (i+1) {-# INLINE length #-}++reverse :: PrimMonad prim+        => MutableByteArray# (PrimState prim) -- ^ Destination buffer+        -> Offset Word8                       -- ^ Destination start+        -> Immutable                          -- ^ 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 = PrimNative.primWrite dst d h >> loop (d `offsetSub` 1) (s + 1)+        | otherwise       = do+            case getNbBytes h of+                1 -> do+                    PrimNative.primWrite dst (d `offsetSub` 1) h+                    PrimNative.primWrite dst d                 (primIndex8 src (s + 1))+                    loop (d `offsetSub` 2) (s + 2)+                2 -> do+                    PrimNative.primWrite dst (d `offsetSub` 2) h+                    PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 1))+                    PrimNative.primWrite dst d                 (primIndex8 src (s + 2))+                    loop (d `offsetSub` 3) (s + 3)+                3 -> do+                    PrimNative.primWrite dst (d `offsetSub` 3) h+                    PrimNative.primWrite dst (d `offsetSub` 2) (primIndex8 src (s + 1))+                    PrimNative.primWrite dst (d `offsetSub` 1) (primIndex8 src (s + 2))+                    PrimNative.primWrite dst d                 (primIndex8 src (s + 3))+                    loop (d `offsetSub` 4) (s + 4)+                _ -> error "impossible"+      where h = primIndex8 src s+{-# INLINE reverse #-}

@@ -0,0 +1,122 @@+{-# 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 && t /= ty = loop (i+1)+        | otherwise               = i+      where t = index ba i+{-# INLINE findIndexElem #-}++revFindIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty+revFindIndexElem ty ba startIndex endIndex+    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)+    | otherwise             = endIndex+  where+    loop !i+        | t == ty        = i+        | i > startIndex = loop (i `offsetMinusE` 1)+        | otherwise      = endIndex+      where t = index ba i+{-# 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 && not found = loop (i+1)+        | otherwise                 = i+      where found = predicate (index ba i)+{-# INLINE findIndexPredicate #-}++revFindIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty+revFindIndexPredicate predicate ba startIndex endIndex+    | endIndex > startIndex = loop (endIndex `offsetMinusE` 1)+    | otherwise             = endIndex+  where+    loop !i+        | found          = i+        | i > startIndex = loop (i `offsetMinusE` 1)+        | otherwise      = endIndex+      where found = predicate (index ba i)+{-# 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 #-}

@@ -80,15 +80,20 @@ import           Basement.Block.Base import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive-import qualified Basement.Alg.Native.PrimArray as Alg import qualified Basement.Alg.Native.Prim as Prim 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) -         => MutAlg.RandomAccess (MutableBlock ty st) prim ty where+         => 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 #-}+ -- | 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@@ -270,11 +275,11 @@ {-# 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@(Block ba)+breakEnd predicate blk     | k == end  = (blk, mempty)     | otherwise = splitAt (offsetAsSize (k+1)) blk   where-    k = Alg.revFindIndexPredicate predicate ba 0 end+    k = Alg.revFindIndexPredicate predicate blk 0 end     end = 0 `offsetPlusE` len     !len = length blk {-# SPECIALIZE [2] breakEnd :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-}

@@ -34,6 +34,7 @@ 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@@ -63,6 +64,8 @@ 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     mappend = append@@ -341,11 +344,13 @@         => Block ty         -> (Ptr ty -> prim a)         -> prim a-withPtr (Block ba) f = do+withPtr x@(Block ba) f = do     let addr = Ptr (byteArrayContents# ba)-    res <- f addr+    f addr <* touch x++touch :: PrimMonad prim => Block ty -> prim ()+touch (Block ba) =     unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) }-    return res  -- | Use the 'Ptr' to a mutable block in a safer construct --@@ -354,10 +359,6 @@                 => MutableBlock ty (PrimState prim)                 -> (Ptr ty -> prim a)                 -> prim a-mutableWithPtr (MutableBlock mba) f = do-    addr <- primitive $ \s1 ->-        case unsafeFreezeByteArray# mba s1 of-            (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #)-    res <- f addr-    unsafePrimFromIO $ primitive $ \s -> case touch# mba s of { s2 -> (# s2, () #) }-    return res+mutableWithPtr mb f = do+    b <- unsafeFreeze mb+    withPtr b f

@@ -10,6 +10,7 @@ -- {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} module Basement.Bounded     ( Zn64     , unZn64@@ -33,6 +34,15 @@ 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)+ -- | Create an element of ℤ/nℤ from a Word64 -- -- If the value is greater than n, then the value is normalized by using the@@ -46,10 +56,31 @@         -> 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+ -- | Create an element of ℤ/nℤ from a Natural. -- -- If the value is greater than n, then the value is normalized by using the@@ -60,3 +91,16 @@ -- | 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))+

@@ -82,8 +82,10 @@ import           Basement.Numerical.Subtractive import           Basement.NonEmpty import           Basement.Compat.Base-import qualified Basement.Alg.Mutable as MutAlg+import qualified Basement.Alg.Class as Alg+import qualified Basement.Alg.Mutable as Alg import           Basement.Compat.MonadTrans+import           Basement.Compat.Semigroup import           Basement.Types.OffsetSize import           Basement.PrimType import           Basement.NormalForm@@ -125,6 +127,8 @@ instance Functor Array where     fmap = map +instance Semigroup (Array a) where+    (<>) = append instance Monoid (Array a) where     mempty  = empty     mappend = append@@ -628,7 +632,7 @@              in if predicate e then Just e else loop (i+1)  instance (PrimMonad prim, st ~ PrimState prim) -         => MutAlg.RandomAccess (MArray ty st) prim ty where+         => Alg.RandomAccess (MArray ty st) prim ty where     read (MArray _ _ mba) = primMutableArrayRead mba     write (MArray _ _ mba) = primMutableArrayWrite mba @@ -639,7 +643,7 @@   where     len = length vec     doSort :: PrimMonad prim => (ty -> ty -> Ordering) -> MArray ty (PrimState prim) -> prim (Array ty)-    doSort ford ma = MutAlg.inplaceSortBy ford 0 len ma >> unsafeFreeze ma+    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))

@@ -5,6 +5,14 @@ -- 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@. --@@ -35,18 +43,44 @@     -- | 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 

@@ -18,6 +18,7 @@ import qualified Prelude import           Basement.Compat.Natural import           Foreign.C.Types+import           Foreign.Ptr (IntPtr) import           System.Posix.Types  -- | Integral Literal support@@ -64,13 +65,27 @@     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 CSize 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 COff where     fromInteger a = Prelude.fromInteger a instance Integral CUIntPtr where+    fromInteger a = Prelude.fromInteger a+instance Integral CIntPtr where     fromInteger a = Prelude.fromInteger a  instance Integral Float where

@@ -2,6 +2,7 @@ #if !(MIN_VERSION_base(4,9,0)) {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-} #endif module Basement.Compat.Semigroup     ( Semigroup(..)@@ -18,6 +19,7 @@ import Data.Data (Data) import Data.Monoid (Monoid(..)) import GHC.Generics (Generic)+import Data.Typeable  -- errorWithoutStackTrace @@ -25,7 +27,7 @@ infixr 5 :|  data ListNonEmpty a = a :| [a]-  deriving ( Eq, Ord, Show, Read, Data, Generic )+  deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic )  -- | The class of semigroups (types with an associative binary operation). --@@ -90,6 +92,9 @@     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

@@ -6,6 +6,7 @@ -- Portability : portable -- -- re-export of all the base prelude and basic primitive stuffs+{-# LANGUAGE CPP #-} module Basement.Imports     ( (Prelude.$)     , (Prelude.$!)@@ -68,7 +69,13 @@     , 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@@ -88,6 +95,7 @@ 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

@@ -16,8 +16,6 @@     , CmpNat     -- * Nat convertion     , natValNatural-    , natValCountOf-    , natValOffset     , natValInt     , natValInt8     , natValInt16@@ -33,8 +31,6 @@     -- * Constraint     , NatInBoundOf     , NatWithinBound-    , Countable-    , Offsetable     ) where  #include "MachDeps.h"@@ -42,7 +38,6 @@ import           GHC.TypeLits import           Basement.Compat.Base import           Basement.Compat.Natural-import           Basement.Types.OffsetSize import           Basement.Types.Char7 (Char7) import           Basement.Types.Word128 (Word128) import           Basement.Types.Word256 (Word256)@@ -57,12 +52,6 @@ natValNatural :: forall n proxy . KnownNat n => proxy n -> Natural natValNatural n = Prelude.fromIntegral (natVal n) -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)- natValInt :: forall n proxy . (KnownNat n, NatWithinBound Int n) => proxy n -> Int natValInt n = Prelude.fromIntegral (natVal n) @@ -94,28 +83,27 @@ natValWord8 n = Prelude.fromIntegral (natVal n)  -- | Get Maximum bounds of different Integral / Natural types related to Nat-type family NatNumMaxBound ty where-    NatNumMaxBound Char   = 0x10ffff-    NatNumMaxBound Char7  = 0x7f-    NatNumMaxBound Int64  = 0x7fffffffffffffff-    NatNumMaxBound Int32  = 0x7fffffff-    NatNumMaxBound Int16  = 0x7fff-    NatNumMaxBound Int8   = 0x7f-    NatNumMaxBound Word256 = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff-    NatNumMaxBound Word128 = 0xffffffffffffffffffffffffffffffff-    NatNumMaxBound Word64 = 0xffffffffffffffff-    NatNumMaxBound Word32 = 0xffffffff-    NatNumMaxBound Word16 = 0xffff-    NatNumMaxBound Word8  = 0xff+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-    NatNumMaxBound Int    = NatNumMaxBound Int64-    NatNumMaxBound Word   = NatNumMaxBound Word64+type instance NatNumMaxBound Int    = NatNumMaxBound Int64+type instance NatNumMaxBound Word   = NatNumMaxBound Word64 #else-    NatNumMaxBound Int    = NatNumMaxBound Int32-    NatNumMaxBound Word   = NatNumMaxBound Word32+type instance NatNumMaxBound Int    = NatNumMaxBound Int32+type instance NatNumMaxBound Word   = NatNumMaxBound Word32 #endif-    NatNumMaxBound (CountOf x) = NatNumMaxBound Int-    NatNumMaxBound (Offset x) = NatNumMaxBound Int  -- | Check if a Nat is in bounds of another integral / natural types type family NatInBoundOf ty n where@@ -134,6 +122,3 @@ #else type NatWithinBound ty n = NatInBoundOf ty n ~ 'True #endif--type Countable ty n = NatWithinBound (CountOf ty) n-type Offsetable ty n = NatWithinBound (Offset ty) n

@@ -10,6 +10,7 @@ import Basement.Types.Char7 import Basement.Types.Word128 (Word128) import Basement.Types.Word256 (Word256)+import Basement.Bounded import Basement.Endianness import Foreign.C.Types @@ -76,6 +77,8 @@ 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

@@ -1,5 +1,7 @@ {-# LANGUAGE CPP               #-} {-# LANGUAGE MagicHash         #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-prof-auto #-} module Basement.Numerical.Additive     ( Additive(..)     ) where@@ -15,6 +17,8 @@ import           GHC.Int import           GHC.Word import           Foreign.C.Types+import           Basement.Bounded+import           Basement.Nat import           Basement.Types.Word128 (Word128) import           Basement.Types.Word256 (Word256) import qualified Basement.Types.Word128 as Word128@@ -118,6 +122,14 @@     scale = scaleNum instance Additive CSize where     azero = 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 

@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances #-} module Basement.Numerical.Subtractive     ( Subtractive(..)     ) where@@ -5,6 +6,8 @@ import           Basement.Compat.Base 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@@ -82,3 +85,9 @@ 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

@@ -47,6 +47,7 @@ import qualified Basement.Block as B import           Basement.Monad (PrimMonad, PrimState) import           Basement.Nat+import           Basement.Types.OffsetSize import           Basement.NormalForm import           Basement.PrimType (PrimType) import           Basement.Types.OffsetSize (CountOf(..), Offset(..), offsetSub)

@@ -795,35 +795,15 @@  -- | Reverse a string reverse :: String -> String-reverse s@(String ba) = runST $ do-    ms <- new len-    loop ms (Offset 0) (Offset 0 `offsetPlusE` len)+reverse (String arr) = runST $ do+    ((), dst) <- newNative (C.length arr) $ \(MutableBlock mba) ->+            C.onBackendPrim+                (\(Block ba) -> PrimBA.reverse mba 0 ba start end)+                (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> PrimAddr.reverse mba 0 addr start end)+                arr+    freeze dst   where-    !len = size s-    -- write those bytes-    loop :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Offset8 -> prim String-    loop ms@(MutableString mba) si didx-        | didx == Offset 0 = freeze ms-        | otherwise = do-            let !h = Vec.unsafeIndex ba si-                !nb = CountOf (getNbBytes h + 1)-                d  = didx `offsetMinusE` nb-            case nb of-                CountOf 1 -> Vec.unsafeWrite mba d h-                CountOf 2 -> do-                    Vec.unsafeWrite mba d       h-                    Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))-                CountOf 3 -> do-                    Vec.unsafeWrite mba d       h-                    Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))-                    Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))-                CountOf 4 -> do-                    Vec.unsafeWrite mba d       h-                    Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex  ba (si + 1))-                    Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))-                    Vec.unsafeWrite mba (d + 3) (Vec.unsafeIndex ba (si + 3))-                _  -> return () -- impossible-            loop ms (si `offsetPlusE` nb) d+    !(C.ValidRange start end) = C.offsetsValidRange arr  -- Finds where are the insertion points when we search for a `needle` -- within an `haystack`.

@@ -0,0 +1,26 @@+{-# 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

@@ -0,0 +1,170 @@+-- |+-- 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

@@ -0,0 +1,187 @@+{-# 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>+#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)

@@ -22,6 +22,7 @@     ) where  import           Basement.Compat.Base+import           Basement.Compat.Semigroup import           Basement.Types.Char7 import           Basement.UArray.Base import qualified Basement.Types.Char7 as Char7@@ -29,7 +30,7 @@  -- | Opaque packed array of characters in the ASCII encoding newtype AsciiString = AsciiString { toBytes :: UArray Char7 }-    deriving (Typeable, Monoid, Eq, Ord)+    deriving (Typeable, Semigroup, Monoid, Eq, Ord)  newtype MutableAsciiString st = MutableAsciiString (MUArray Char7 st)     deriving (Typeable)

@@ -9,6 +9,10 @@ {-# LANGUAGE MagicHash                  #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE CPP                        #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# OPTIONS_GHC -fno-prof-auto          #-} module Basement.Types.OffsetSize     ( FileSize(..)     , Offset(..)@@ -35,6 +39,10 @@     , csizeOfSize     , sizeOfCSSize     , sizeOfCSize+    , Countable+    , Offsetable+    , natValCountOf+    , natValOffset     ) where  #include "MachDeps.h"@@ -47,11 +55,13 @@ import System.Posix.Types (CSsize (..)) import Data.Bits import Basement.Compat.Base+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.Nat import Basement.IntegralConv import Data.List (foldl') import qualified Prelude@@ -193,6 +203,9 @@     (CountOf a) - (CountOf b) | a >= b    = Just . CountOf $ a - b                               | otherwise = Nothing +instance Semigroup (CountOf ty) where+    (<>) = (+)+ instance Monoid (CountOf ty) where     mempty = azero     mappend = (+)@@ -242,3 +255,15 @@ #else sizeOfCSize (CSize (W64# sz)) = CountOf (I# (word2Int# sz)) #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

@@ -137,14 +137,10 @@ import qualified Basement.Compat.ExtList as List import qualified Basement.Base16 as Base16 import qualified Basement.Alg.Native.Prim as PrimBA-import qualified Basement.Alg.Native.PrimArray as PrimBA import qualified Basement.Alg.Foreign.Prim as PrimAddr-import qualified Basement.Alg.Foreign.PrimArray as PrimAddr-import qualified Basement.Alg.Mutable as MutAlg--instance (PrimMonad prim, PrimType ty) => MutAlg.RandomAccess (Ptr ty) prim ty where-    read (Ptr addr) = PrimAddr.primRead addr-    write (Ptr addr) = PrimAddr.primWrite addr+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. --@@ -376,15 +372,14 @@  breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty) breakElem !ty arr@(UArray start len backend)+-- TODO: return Maybe k     | 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 = onBackend goBa (\fptr -> pure . goAddr fptr) arr-    goBa (Block ba) = PrimBA.findIndexElem ty ba start end-    goAddr _ (Ptr addr) = PrimAddr.findIndexElem ty addr start end+    !k = onBackendPure' arr $ Alg.findIndexElem ty {-# NOINLINE [3] breakElem #-} {-# RULES "breakElem Word8" [4] breakElem = breakElemByte #-} {-# SPECIALIZE [3] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-}@@ -397,9 +392,9 @@                    , UArray k     (len `sizeSub` (offsetAsSize k `sizeSub` offsetAsSize start)) backend)   where     !end = start `offsetPlusE` len-    !k = onBackend goBa (\fptr -> pure . goAddr fptr) arr+    !k = onBackendPure goBa goAddr arr     goBa (Block ba) = sysHsMemFindByteBa ba start end ty-    goAddr _ (Ptr addr) = sysHsMemFindByteAddr addr start end ty+    goAddr (Ptr addr) = sysHsMemFindByteAddr addr start end ty  -- | Similar to breakElem specialized to split on linefeed --@@ -418,14 +413,14 @@   where     !end = start `offsetPlusE` len     -- return (offset of CR, offset of LF, whether the last element was a carriage return-    !(k1, k2) = onBackend goBa (\fptr -> pure . goAddr fptr) arr+    !(k1, k2) = onBackendPure goBa goAddr arr     lineFeed = 0xa     carriageReturn = 0xd     goBa (Block ba) =         let k = sysHsMemFindByteBa ba start end lineFeed             cr = k > start && PrimBA.primIndex ba (k `offsetSub` 1) == carriageReturn          in (if cr then k `offsetSub` 1 else k, k)-    goAddr _ (Ptr addr) =+    goAddr (Ptr addr) =         let k = sysHsMemFindByteAddr addr start end lineFeed             cr = k > start && PrimAddr.primIndex addr (k `offsetSub` 1) == carriageReturn          in (if cr then k `offsetSub` 1 else k, k)@@ -479,38 +474,35 @@  findIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty) findIndex ty arr+-- TODO: check for end could be done in algorithm     | k == end  = Nothing     | otherwise = Just (k `offsetSub` start)   where-    !k = onBackend goBa (\_ -> pure . goAddr) arr+    !k = onBackendPure' arr $ Alg.findIndexElem ty     !start = offset arr     !end = start `offsetPlusE` length arr-    goBa (Block ba) = PrimBA.findIndexElem ty ba start end-    goAddr (Ptr addr) = PrimAddr.findIndexElem ty addr start end {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}  revFindIndex :: PrimType ty => ty -> UArray ty -> Maybe (Offset ty) revFindIndex ty arr+-- TODO: check for end could be done in algorithm     | k == end  = Nothing     | otherwise = Just (k `offsetSub` start)   where-    !k = onBackend goBa (\_ -> pure . goAddr) arr+    !k = onBackendPure' arr $ Alg.revFindIndexElem ty     !start = offset arr     !end = start `offsetPlusE` length arr-    goBa (Block ba) = PrimBA.revFindIndexElem ty ba start end-    goAddr (Ptr addr) = PrimAddr.revFindIndexElem ty addr start end {-# 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+-- TODO2: check for end could be done in algorithm? but maybe more ops are involved     | k == end  = (arr, mempty)     | otherwise = splitAt (offsetAsSize (k `offsetSub` start)) arr   where-    !k = onBackend goBa (\_ -> pure . goAddr) arr+    !k = onBackendPure' arr $ Alg.findIndexPredicate predicate     !start = offset arr     !end = start `offsetPlusE` length arr-    goBa (Block ba) = PrimBA.findIndexPredicate predicate ba start end-    goAddr (Ptr addr) = PrimAddr.findIndexPredicate predicate addr start end  {- {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-}@@ -543,23 +535,22 @@ -- ([1,2,3], [0,0,0]) breakEnd :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) breakEnd predicate arr+-- TODO2: check for end could be done in algorithm? but maybe more ops are involved     | k == end  = (arr, mempty)     | otherwise = splitAt (offsetAsSize (k+1) `sizeSub` offsetAsSize start) arr   where-    !k = onBackend goBa (\_ -> pure . goAddr) arr+    !k = onBackendPure' arr $ Alg.revFindIndexPredicate predicate     !start = offset arr     !end   = start `offsetPlusE` length arr-    goBa (Block ba) = PrimBA.revFindIndexPredicate predicate ba start end-    goAddr (Ptr addr) = PrimAddr.revFindIndexPredicate predicate addr start end {-# SPECIALIZE [3] breakEnd :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-}  elem :: PrimType ty => ty -> UArray ty -> Bool-elem !ty arr = onBackend goBa (\_ -> pure . goAddr) arr /= end+--elem !ty arr = onBackendPure goBa goAddr arr /= end+-- check for end could be done in algorithm? isNothing?+elem !ty arr = onBackendPure' arr (Alg.findIndexElem ty) /= end   where     !start = offset arr     !end = start `offsetPlusE` length arr-    goBa (Block ba) = PrimBA.findIndexElem ty ba start end-    goAddr (Ptr addr) = PrimAddr.findIndexElem ty addr start end {-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-}  intersperse :: forall ty . PrimType ty => ty -> UArray ty -> UArray ty@@ -648,17 +639,17 @@     !start = offset vec      goNative :: MutableBlock ty s -> ST s ()-    goNative mb = MutAlg.inplaceSortBy ford start len mb+    goNative mb = Alg.inplaceSortBy ford start len mb     goAddr :: Ptr ty -> ST s ()-    goAddr (Ptr addr) = MutAlg.inplaceSortBy ford start len (Ptr addr :: Ptr ty)+    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 ba) -> PrimBA.filter predicate mba ba start end)-                          (\fptr -> withFinalPtr fptr $ \(Ptr addr) ->-                                        PrimAddr.filter predicate mba addr start end)+            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@@ -693,6 +684,8 @@             | 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`.@@ -773,23 +766,11 @@         | otherwise  = unsafeIndex vec i `f` loop (i+1)  foldl' :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a-foldl' f initialAcc arr = onBackend goBA (\_ -> pure . goAddr) arr-  where-    !len = length arr-    !start = offset arr-    !end = start `offsetPlusE` len-    goBA (Block ba) = PrimBA.foldl f initialAcc ba start end-    goAddr (Ptr ptr) = PrimAddr.foldl f initialAcc ptr start end+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) = onBackend goBA (\_ -> pure . goAddr) arr-  where-    !len = length arr-    !start = offset arr-    !end = start `offsetPlusE` len-    goBA (Block ba) = PrimBA.foldl1 f ba start end-    goAddr (Ptr ptr) = PrimAddr.foldl1 f ptr start end+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@@ -797,21 +778,11 @@                in foldr f (unsafeIndex initialAcc 0) rest  all :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool-all predicate arr = onBackend (\(Block ba) -> PrimBA.all predicate ba start end)-                              (\_ (Ptr ptr) -> pure (PrimAddr.all predicate ptr start end))-                              arr-  where-    start = offset arr-    end = start `offsetPlusE` length arr+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 = onBackend (\(Block ba) -> PrimBA.any predicate ba start end)-                              (\_ (Ptr ptr) -> pure (PrimAddr.any predicate ptr start end))-                              arr-  where-    start = offset arr-    end = start `offsetPlusE` length arr+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 ()

@@ -2,6 +2,8 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} module Basement.UArray.Base     ( MUArray(..)     , UArray(..)@@ -28,6 +30,8 @@     , unsafeIndex     , unsafeIndexer     , onBackend+    , onBackendPure+    , onBackendPure'     , onBackendPrim     , onMutableBackend     , unsafeDewrap@@ -57,9 +61,11 @@ import           Basement.Monad import           Basement.PrimType import           Basement.Compat.Base+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@@ -81,6 +87,13 @@ 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 (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@@ -112,6 +125,8 @@     {-# SPECIALIZE instance Ord (UArray Word8) #-}     compare = vCompare +instance PrimType ty => Semigroup (UArray ty) where+    (<>) = append instance PrimType ty => Monoid (UArray ty) where     mempty  = empty     mappend = append@@ -262,8 +277,28 @@           -> UArray ty           -> a onBackend onBa _      (UArray _ _ (UArrayBA ba))     = onBa ba-onBackend _    onAddr (UArray _ _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr (onAddr fptr)+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' :: PrimType  ty+               => UArray ty+               -> (forall container. Alg.Indexable container ty +                   => container -> Offset ty -> Offset ty -> a)+               -> a+onBackendPure' arr f = onBackendPure (\c -> f c start end) +                                     (\c -> f c start end) arr+  where !len = length arr+        !start = offset arr+        !end = start `offsetPlusE` len+{-# INLINE onBackendPure' #-}  onBackendPrim :: PrimMonad prim               => (Block ty -> prim a)

@@ -19,6 +19,7 @@ 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@@ -37,15 +38,16 @@ 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)+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, Monoid, Eq, Ord)+    deriving (Typeable, Semigroup, Monoid, Eq, Ord)  -- | Mutable String Buffer. --@@ -85,13 +87,37 @@ -- -- The list is lazily created as evaluation needed sToList :: String -> [Char]-sToList s = loop 0+sToList (String arr) = Vec.onBackend onBA onAddr arr   where-    !nbBytes = size s-    loop idx-        | idx .==# nbBytes = []-        | otherwise        =-            let !(Step c idx') = next s idx in c : loop idx'+    (Vec.ValidRange !start !end) = Vec.offsetsValidRange arr+    onBA (BLK.Block ba) = loop start+      where+        loop !idx+            | idx == end = []+            | otherwise  = let !(Step c idx') = PrimBA.next ba idx in c : loop idx'+    onAddr fptr (Ptr ptr) = pureST (loop start)+      where+        loop !idx+            | idx == end = []+            | otherwise  = let !(Step c idx') = PrimAddr.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 (BLK.Block ba) = loop start+      where+        loop !idx+            | idx == end = z+            | otherwise  = let !(Step c idx') = PrimBA.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') = PrimAddr.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 #-}

@@ -9,6 +9,8 @@ {-# LANGUAGE MagicHash #-} module Basement.UTF8.Table     ( isContinuation+    , isContinuation2+    , isContinuation3     , getNbBytes     , isContinuation#     , getNbBytes#@@ -18,12 +20,37 @@ import           GHC.Types import           GHC.Word import           Basement.Compat.Base+import           Basement.Compat.Primitive  -- | Check if the byte is a continuation byte isContinuation :: Word8 -> Bool isContinuation (W8# w) = isContinuation# w {-# INLINE isContinuation #-} +isContinuation2 :: Word8 -> Word8 -> Bool+isContinuation2 (W8# w1) (W8# w2) =+    bool# (mask w1 `andI#` mask w2)+  where+    mask v = (and# 0xC0## v) `eqWord#` 0x80##+{-# INLINE isContinuation2 #-}++isContinuation3 :: Word8 -> Word8 -> Word8 -> Bool+isContinuation3 (W8# w1) (W8# w2) (W8# w3) =+    bool# (mask w1) && bool# (mask w2) && bool# (mask w3)+  where+    mask v = (and# 0xC0## v) `eqWord#` 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 :: Word8 -> Int getNbBytes (W8# w) = I# (getNbBytes# w)@@ -31,7 +58,7 @@  -- | Check if the byte is a continuation byte isContinuation# :: Word# -> Bool-isContinuation# w = W# (indexWord8OffAddr# (unTable contTable) (word2Int# w)) /= W# 0##+isContinuation# w = W# (indexWord8OffAddr# (unTable contTable) (word2Int# w)) == W# 0## {-# INLINE isContinuation# #-}  -- | Get the number of following bytes given the first byte of a UTF8 sequence.@@ -43,22 +70,22 @@  contTable :: Table contTable = 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\+        "\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\-        \\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\-        \\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

@@ -1,5 +1,5 @@ name:                basement-version:             0.0.3+version:             0.0.4 synopsis:            Foundation scrap box of array & string description:         Foundation most basic primitives without any dependencies homepage:            https://github.com/haskell-foundation/foundation#readme@@ -60,6 +60,10 @@                      Basement.NormalForm                      Basement.These +                     -- Terminal+                     Basement.Terminal+                     Basement.Terminal.ANSI+                      -- numeric stuff                      Basement.IntegralConv                      Basement.Floating@@ -97,17 +101,17 @@                      Basement.Show                      Basement.Runtime +                     Basement.Alg.Class                      Basement.Alg.Mutable+                     Basement.Alg.PrimArray                       Basement.Alg.Native.Prim                      Basement.Alg.Native.UTF8                      Basement.Alg.Native.String-                     Basement.Alg.Native.PrimArray                       Basement.Alg.Foreign.Prim                      Basement.Alg.Foreign.UTF8                      Basement.Alg.Foreign.String-                     Basement.Alg.Foreign.PrimArray                       Basement.Numerical.Conversion @@ -126,9 +130,15 @@                      Basement.String.Encoding.ASCII7                      Basement.String.Encoding.ISO_8859_1 +                     Basement.Terminal.Size +   build-depends:       base >= 4.7 && < 5                      , ghc-prim++  if os(windows)+    build-depends:     Win32+   default-language:    Haskell2010   default-extensions: NoImplicitPrelude                       RebindableSyntax

@@ -0,0 +1,60 @@+#ifndef FOUNDATION_SYSTEM_H+# define FOUNDATION_SYSTEM_H++#ifdef _WIN32+   #define FOUNDATION_SYSTEM_WINDOWS+   #define FOUNDATION_SYSTEM_API_NO_CLOCK++   //define something for Windows (32-bit and 64-bit, this part is common)+   #ifdef _WIN64+      #define FOUNDATION_SYSTEM_WINDOWS_64+      //define something for Windows (64-bit only)+   #else+      #define FOUNDATION_SYSTEM_WINDOWS_32+      //define something for Windows (32-bit only)+   #endif+#elif __APPLE__+    #include "TargetConditionals.h"+    #include "Availability.h"++    #if TARGET_OS_MAC+      #define FOUNDATION_SYSTEM_UNIX+      #define FOUNDATION_SYSTEM_MACOS++      #if !defined(__MAC_10_12) || __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_12+      #define FOUNDATION_SYSTEM_API_NO_CLOCK+      #endif+      // Other kinds of Mac OS+    #else+    #   error "foundation: system: Unknown Apple platform"+    #endif+#elif __linux__+    #define FOUNDATION_SYSTEM_UNIX+    #define FOUNDATION_SYSTEM_LINUX+    // linux+#elif defined(__FreeBSD__)+    #define FOUNDATION_SYSTEM_UNIX+    #define FOUNDATION_SYSTEM_BSD+    #define FOUNDATION_SYSTEM_FREEBSD+    // freeBSD+#elif defined(__NetBSD__)+    #define FOUNDATION_SYSTEM_UNIX+    #define FOUNDATION_SYSTEM_BSD+    #define FOUNDATION_SYSTEM_NETBSD+    // NetBSD+#elif defined(__OpenBSD__)+    #define FOUNDATION_SYSTEM_UNIX+    #define FOUNDATION_SYSTEM_BSD+    #define FOUNDATION_SYSTEM_OPENBSD+    // OpenBSD+#elif __unix__ // all unices not caught above+    #define FOUNDATION_SYSTEM_UNIX+    // Unix+#elif defined(_POSIX_VERSION)+    #define FOUNDATION_SYSTEM_UNIX+    // POSIX+#else+#   error "foundation: system: Unknown compiler"+#endif++#endif