la_ancapo/stellar-veritas
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source
This commit is contained in:
La Ancapo 2026-01-25 02:27:22 +01:00
commit c101616e62
309 changed files with 53937 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

20
bundled/Basement/Alg/Class.hs Normal file
View file

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

75
bundled/Basement/Alg/Mutable.hs Normal file
View file

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

123
bundled/Basement/Alg/PrimArray.hs Normal file
View file

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

140
bundled/Basement/Alg/String.hs Normal file
View file

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

298
bundled/Basement/Alg/UTF8.hs Normal file
View file

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

69
bundled/Basement/Alg/XorShift.hs Normal file
View file

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

90
bundled/Basement/Base16.hs Normal file
View file

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

35
bundled/Basement/Bindings/Memory.hs Normal file
View file

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

478
bundled/Basement/Bits.hs Normal file
View file

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

447
bundled/Basement/Block.hs Normal file
View file

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

493
bundled/Basement/Block/Base.hs Normal file
View file

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

155
bundled/Basement/Block/Builder.hs Normal file
View file

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

159
bundled/Basement/Block/Mutable.hs Normal file
View file

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

15
bundled/Basement/BlockN.hs Normal file
View file

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

132
bundled/Basement/Bounded.hs Normal file
View file

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

781
bundled/Basement/BoxedArray.hs Normal file
View file

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

154
bundled/Basement/Cast.hs Normal file
View file

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

16
bundled/Basement/Compat/AMP.hs Normal file
View file

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

99
bundled/Basement/Compat/Base.hs Normal file
View file

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

122
bundled/Basement/Compat/Bifunctor.hs Normal file
View file

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

28
bundled/Basement/Compat/C/Types.hs Normal file
View file

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

29
bundled/Basement/Compat/CallStack.hs Normal file
View file

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

52
bundled/Basement/Compat/ExtList.hs Normal file
View file

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

42
bundled/Basement/Compat/Identity.hs Normal file
View file

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

41
bundled/Basement/Compat/IsList.hs Normal file
View file

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

55
bundled/Basement/Compat/MonadTrans.hs Normal file
View file

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

66
bundled/Basement/Compat/Natural.hs Normal file
View file

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

200
bundled/Basement/Compat/NumLiteral.hs Normal file
View file

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

41
bundled/Basement/Compat/PrimTypes.hs Normal file
View file

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

318
bundled/Basement/Compat/Primitive.hs Normal file
View file

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

170
bundled/Basement/Compat/Semigroup.hs Normal file
View file

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

42
bundled/Basement/Compat/Typeable.hs Normal file
View file

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

147
bundled/Basement/Endianness.hs Normal file
View file

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

21
bundled/Basement/Environment.hs Normal file
View file

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

46
bundled/Basement/Error.hs Normal file
View file

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

76
bundled/Basement/Exception.hs Normal file
View file

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

117
bundled/Basement/FinalPtr.hs Normal file
View file

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

78
bundled/Basement/Floating.hs Normal file
View file

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

336
bundled/Basement/From.hs Normal file
View file

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

130
bundled/Basement/Imports.hs Normal file
View file

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

235
bundled/Basement/IntegralConv.hs Normal file
View file

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

144
bundled/Basement/Monad.hs Normal file
View file

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

36
bundled/Basement/MutableBuilder.hs Normal file
View file

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

132
bundled/Basement/Nat.hs Normal file
View file

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

30
bundled/Basement/NonEmpty.hs Normal file
View file

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

136
bundled/Basement/NormalForm.hs Normal file
View file

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

271
bundled/Basement/Numerical/Additive.hs Normal file
View file

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

135
bundled/Basement/Numerical/Conversion.hs Normal file
View file

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

331
bundled/Basement/Numerical/Multiplicative.hs Normal file
View file

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

128
bundled/Basement/Numerical/Number.hs Normal file
View file

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

186
bundled/Basement/Numerical/Subtractive.hs Normal file
View file

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

768
bundled/Basement/PrimType.hs Normal file
View file

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

36
bundled/Basement/Runtime.hs Normal file
View file

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

19
bundled/Basement/Show.hs Normal file
View file

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

283
bundled/Basement/Sized/Block.hs Normal file
View file

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

389
bundled/Basement/Sized/List.hs Normal file
View file

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

164
bundled/Basement/Sized/UVect.hs Normal file
View file

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

166
bundled/Basement/Sized/Vect.hs Normal file
View file

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

1479
bundled/Basement/String.hs Normal file
View file

File diff suppressed because it is too large Load diff

63
bundled/Basement/String/Builder.hs Normal file
View file

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

3245
bundled/Basement/String/CaseMapping.hs Normal file
View file

File diff suppressed because it is too large Load diff

91
bundled/Basement/String/Encoding/ASCII7.hs Normal file
View file

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

107
bundled/Basement/String/Encoding/Encoding.hs Normal file
View file

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

70
bundled/Basement/String/Encoding/ISO_8859_1.hs Normal file
View file

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

106
bundled/Basement/String/Encoding/UTF16.hs Normal file
View file

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

61
bundled/Basement/String/Encoding/UTF32.hs Normal file
View file

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

31
bundled/Basement/Terminal.hs Normal file
View file

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

175
bundled/Basement/Terminal/ANSI.hs Normal file
View file

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

190
bundled/Basement/Terminal/Size.hsc Normal file
View file

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

32
bundled/Basement/These.hs Normal file
View file

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

67
bundled/Basement/Types/AsciiString.hs Normal file
View file

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

121
bundled/Basement/Types/Char7.hs Normal file
View file

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

13
bundled/Basement/Types/CharUTF8.hs Normal file
View file

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

288
bundled/Basement/Types/OffsetSize.hs Normal file
View file

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

45
bundled/Basement/Types/Ptr.hs Normal file
View file

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

262
bundled/Basement/Types/Word128.hs Normal file
View file

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

351
bundled/Basement/Types/Word256.hs Normal file
View file

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

947
bundled/Basement/UArray.hs Normal file
View file

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

655
bundled/Basement/UArray/Base.hs Normal file
View file

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

187
bundled/Basement/UArray/Mutable.hs Normal file
View file

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

240
bundled/Basement/UTF8/Base.hs Normal file
View file

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

251
bundled/Basement/UTF8/Helper.hs Normal file
View file

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

121
bundled/Basement/UTF8/Table.hs Normal file
View file

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

73
bundled/Basement/UTF8/Types.hs Normal file
View file

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