diff --git a/Basement/Alg/Class.hs b/Basement/Alg/Class.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Class.hs @@ -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 () diff --git a/Basement/Alg/Foreign/PrimArray.hs b/Basement/Alg/Foreign/PrimArray.hs deleted file mode 100644 --- a/Basement/Alg/Foreign/PrimArray.hs +++ /dev/null @@ -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 #-} diff --git a/Basement/Alg/Foreign/String.hs b/Basement/Alg/Foreign/String.hs --- a/Basement/Alg/Foreign/String.hs +++ b/Basement/Alg/Foreign/String.hs @@ -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 diff --git a/Basement/Alg/Foreign/UTF8.hs b/Basement/Alg/Foreign/UTF8.hs --- a/Basement/Alg/Foreign/UTF8.hs +++ b/Basement/Alg/Foreign/UTF8.hs @@ -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 #-} diff --git a/Basement/Alg/Mutable.hs b/Basement/Alg/Mutable.hs --- a/Basement/Alg/Mutable.hs +++ b/Basement/Alg/Mutable.hs @@ -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) diff --git a/Basement/Alg/Native/PrimArray.hs b/Basement/Alg/Native/PrimArray.hs deleted file mode 100644 --- a/Basement/Alg/Native/PrimArray.hs +++ /dev/null @@ -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 #-} diff --git a/Basement/Alg/Native/String.hs b/Basement/Alg/Native/String.hs --- a/Basement/Alg/Native/String.hs +++ b/Basement/Alg/Native/String.hs @@ -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 diff --git a/Basement/Alg/Native/UTF8.hs b/Basement/Alg/Native/UTF8.hs --- a/Basement/Alg/Native/UTF8.hs +++ b/Basement/Alg/Native/UTF8.hs @@ -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 #-} diff --git a/Basement/Alg/PrimArray.hs b/Basement/Alg/PrimArray.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/PrimArray.hs @@ -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 #-} diff --git a/Basement/Block.hs b/Basement/Block.hs --- a/Basement/Block.hs +++ b/Basement/Block.hs @@ -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) #-} diff --git a/Basement/Block/Base.hs b/Basement/Block/Base.hs --- a/Basement/Block/Base.hs +++ b/Basement/Block/Base.hs @@ -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 diff --git a/Basement/Bounded.hs b/Basement/Bounded.hs --- a/Basement/Bounded.hs +++ b/Basement/Bounded.hs @@ -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)) + diff --git a/Basement/BoxedArray.hs b/Basement/BoxedArray.hs --- a/Basement/BoxedArray.hs +++ b/Basement/BoxedArray.hs @@ -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)) diff --git a/Basement/Compat/Bifunctor.hs b/Basement/Compat/Bifunctor.hs --- a/Basement/Compat/Bifunctor.hs +++ b/Basement/Compat/Bifunctor.hs @@ -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 diff --git a/Basement/Compat/NumLiteral.hs b/Basement/Compat/NumLiteral.hs --- a/Basement/Compat/NumLiteral.hs +++ b/Basement/Compat/NumLiteral.hs @@ -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 diff --git a/Basement/Compat/Semigroup.hs b/Basement/Compat/Semigroup.hs --- a/Basement/Compat/Semigroup.hs +++ b/Basement/Compat/Semigroup.hs @@ -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 diff --git a/Basement/Imports.hs b/Basement/Imports.hs --- a/Basement/Imports.hs +++ b/Basement/Imports.hs @@ -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 diff --git a/Basement/Nat.hs b/Basement/Nat.hs --- a/Basement/Nat.hs +++ b/Basement/Nat.hs @@ -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 diff --git a/Basement/NormalForm.hs b/Basement/NormalForm.hs --- a/Basement/NormalForm.hs +++ b/Basement/NormalForm.hs @@ -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 diff --git a/Basement/Numerical/Additive.hs b/Basement/Numerical/Additive.hs --- a/Basement/Numerical/Additive.hs +++ b/Basement/Numerical/Additive.hs @@ -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 diff --git a/Basement/Numerical/Subtractive.hs b/Basement/Numerical/Subtractive.hs --- a/Basement/Numerical/Subtractive.hs +++ b/Basement/Numerical/Subtractive.hs @@ -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 diff --git a/Basement/Sized/Block.hs b/Basement/Sized/Block.hs --- a/Basement/Sized/Block.hs +++ b/Basement/Sized/Block.hs @@ -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) diff --git a/Basement/String.hs b/Basement/String.hs --- a/Basement/String.hs +++ b/Basement/String.hs @@ -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`. diff --git a/Basement/Terminal.hs b/Basement/Terminal.hs new file mode 100644 --- /dev/null +++ b/Basement/Terminal.hs @@ -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 diff --git a/Basement/Terminal/ANSI.hs b/Basement/Terminal/ANSI.hs new file mode 100644 --- /dev/null +++ b/Basement/Terminal/ANSI.hs @@ -0,0 +1,170 @@ +-- | +-- Module : Basement.Terminal.ANSI +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- +-- 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 diff --git a/Basement/Terminal/Size.hsc b/Basement/Terminal/Size.hsc new file mode 100644 --- /dev/null +++ b/Basement/Terminal/Size.hsc @@ -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 +#elif defined FOUNDATION_SYSTEM_UNIX +#include +#endif + +#include + +#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) diff --git a/Basement/Types/AsciiString.hs b/Basement/Types/AsciiString.hs --- a/Basement/Types/AsciiString.hs +++ b/Basement/Types/AsciiString.hs @@ -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) diff --git a/Basement/Types/OffsetSize.hs b/Basement/Types/OffsetSize.hs --- a/Basement/Types/OffsetSize.hs +++ b/Basement/Types/OffsetSize.hs @@ -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 diff --git a/Basement/UArray.hs b/Basement/UArray.hs --- a/Basement/UArray.hs +++ b/Basement/UArray.hs @@ -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 () diff --git a/Basement/UArray/Base.hs b/Basement/UArray/Base.hs --- a/Basement/UArray/Base.hs +++ b/Basement/UArray/Base.hs @@ -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) diff --git a/Basement/UTF8/Base.hs b/Basement/UTF8/Base.hs --- a/Basement/UTF8/Base.hs +++ b/Basement/UTF8/Base.hs @@ -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 #-} diff --git a/Basement/UTF8/Table.hs b/Basement/UTF8/Table.hs --- a/Basement/UTF8/Table.hs +++ b/Basement/UTF8/Table.hs @@ -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 diff --git a/basement.cabal b/basement.cabal --- a/basement.cabal +++ b/basement.cabal @@ -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 diff --git a/cbits/foundation_system.h b/cbits/foundation_system.h new file mode 100644 --- /dev/null +++ b/cbits/foundation_system.h @@ -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