diff --git a/Basement/Alg/Class.hs b/Basement/Alg/Class.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Class.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Basement.Alg.Class + ( Indexable, index + , RandomAccess, read, write + ) where + +import Basement.Types.OffsetSize + +class Indexable container ty where + index :: container -> (Offset ty) -> ty + +class RandomAccess container prim ty where + read :: container -> (Offset ty) -> prim ty + write :: container -> (Offset ty) -> ty -> prim () diff --git a/Basement/Alg/Mutable.hs b/Basement/Alg/Mutable.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Mutable.hs @@ -0,0 +1,70 @@ +{-# 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] + -- 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 (i==j OR aj=p AND aj= pivot + -- complete partitioning by swapping pivot to the center + write mvec hi ai + write mvec i pivot + pure i + go lo hi +{-# INLINE inplaceSortBy #-} diff --git a/Basement/Alg/PrimArray.hs b/Basement/Alg/PrimArray.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/PrimArray.hs @@ -0,0 +1,118 @@ +{-# 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 #-} diff --git a/Basement/Alg/String.hs b/Basement/Alg/String.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/String.hs @@ -0,0 +1,135 @@ +{-# 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 #-} diff --git a/Basement/Alg/UTF8.hs b/Basement/Alg/UTF8.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/UTF8.hs @@ -0,0 +1,293 @@ +{-# 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.PrimType +import Basement.UTF8.Helper +import Basement.UTF8.Table +import Basement.UTF8.Types +import Basement.HeadHackageUtils + +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 index ba prevOfs1 of + (W8# v1) | isContinuation# (word8ToWordCompat# v1) -> atLeast2 (maskContinuation# (word8ToWordCompat# v1)) + | otherwise -> StepBack (toChar# (word8ToWordCompat# 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 index ba prevOfs2 of + (W8# v2) | isContinuation# (word8ToWordCompat# v2) -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# (word8ToWordCompat# v2)) 6#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# (word8ToWordCompat# v2)) 6#) v)) prevOfs2 + atLeast3 !v = + case index ba prevOfs3 of + (W8# v3) | isContinuation# (word8ToWordCompat# v3) -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# (word8ToWordCompat# v3)) 12#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# (word8ToWordCompat# v3)) 12#) v)) prevOfs3 + atLeast4 !v = + case index ba prevOfs4 of + (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# (word8ToWordCompat# 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# (wordToWord8Compat# x)) >> pure (i + Offset 1) + encode2 = do + let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## + x2 = toContinuation x + write mba i (W8# (wordToWord8Compat# x1)) + write mba (i+1) (W8# (wordToWord8Compat# 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# (wordToWord8Compat# x1)) + write mba (i+Offset 1) (W8# (wordToWord8Compat# x2)) + write mba (i+Offset 2) (W8# (wordToWord8Compat# 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# (wordToWord8Compat# x1)) + write mba (i+Offset 1) (W8# (wordToWord8Compat# x2)) + write mba (i+Offset 2) (W8# (wordToWord8Compat# x3)) + write mba (i+Offset 3) (W8# (wordToWord8Compat# 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 #-} diff --git a/Basement/Alg/XorShift.hs b/Basement/Alg/XorShift.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/XorShift.hs @@ -0,0 +1,64 @@ +-- | +-- Module : Foundation.Random.XorShift +-- License : BSD-style +-- +-- XorShift variant: Xoroshiro128+ +-- +-- +-- Xoroshiro128+ is a PRNG that uses a shift/rotate-based linear transformation. +-- This is lar +-- +-- C implementation at: +-- +-- +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 diff --git a/Basement/Base16.hs b/Basement/Base16.hs new file mode 100644 --- /dev/null +++ b/Basement/Base16.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +module Basement.Base16 + ( unsafeConvertByte + , hexWord16 + , hexWord32 + , escapeByte + , Base16Escape(..) + ) where + +import GHC.Prim +import GHC.Types +import GHC.Word +import Basement.HeadHackageUtils +import Basement.Types.Char7 + +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. +unsafeConvertByte :: Word# -> (# Word#, Word# #) +unsafeConvertByte b = (# r tableHi b, r tableLo b #) + where + r :: Table -> Word# -> Word# + r (Table !table) index = word8ToWordCompat# (indexWord8OffAddr# table (word2Int# index)) +{-# INLINE unsafeConvertByte #-} + +escapeByte :: Word8 -> Base16Escape +escapeByte !(W8# b) = Base16Escape (r tableHi (word8ToWordCompat# b)) (r tableLo (word8ToWordCompat# b)) + where + r :: Table -> Word# -> Char7 + r (Table !table) index = Char7 (W8# (indexWord8OffAddr# table (word2Int# index))) +{-# INLINE escapeByte #-} + +-- | hex word16 +hexWord16 :: Word16 -> (Char, Char, Char, Char) +hexWord16 (W16# w) = (toChar w1,toChar w2,toChar w3,toChar w4) + where + toChar :: Word# -> Char + toChar c = C# (chr# (word2Int# c)) + !(# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# (word16ToWordCompat# w) 8#) + !(# w3, w4 #) = unsafeConvertByte (and# (word16ToWordCompat# w) 0xff##) + +-- | 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 :: Word# -> Char + toChar c = C# (chr# (word2Int# c)) + !(# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# (word32ToWordCompat# w) 24#) + !(# w3, w4 #) = unsafeConvertByte (and# (uncheckedShiftRL# (word32ToWordCompat# w) 16#) 0xff##) + !(# w5, w6 #) = unsafeConvertByte (and# (uncheckedShiftRL# (word32ToWordCompat# w) 8#) 0xff##) + !(# w7, w8 #) = unsafeConvertByte (and# (word32ToWordCompat# w) 0xff##) + +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"# + diff --git a/Basement/Bindings/Memory.hs b/Basement/Bindings/Memory.hs new file mode 100644 --- /dev/null +++ b/Basement/Bindings/Memory.hs @@ -0,0 +1,30 @@ +{-# 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 diff --git a/Basement/Bits.hs b/Basement/Bits.hs new file mode 100644 --- /dev/null +++ b/Basement/Bits.hs @@ -0,0 +1,614 @@ +-- | +-- 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 Basement.HeadHackageUtils + +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 + +#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 (W8# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W8# x# + | otherwise = W8# (narrow8WordCompat# ((word8ToWordCompat# x# `uncheckedShiftL#` i'#) `or#` + (word8ToWordCompat# x# `uncheckedShiftRL#` (8# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 7##) + rotateR (W8# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W8# x# + | otherwise = W8# (narrow8WordCompat# ((word8ToWordCompat# x# `uncheckedShiftRL#` i'#) `or#` + (word8ToWordCompat# x# `uncheckedShiftL#` (8# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 7##) + bitFlip (W8# x#) = W8# (wordToWord8Compat# (word8ToWordCompat# x# `xor#` word8ToWordCompat# mb#)) + where !(W8# mb#) = maxBound + popCount (W8# x#) = CountOf $ wordToInt (W# (popCnt8# (word8ToWordCompat# x#))) + countLeadingZeros (W8# w#) = CountOf $ wordToInt (W# (clz8# (word8ToWordCompat# w#))) + countTrailingZeros (W8# w#) = CountOf $ wordToInt (W# (ctz8# (word8ToWordCompat# w#))) +instance BitOps Word8 where + (W8# x#) .&. (W8# y#) = W8# (wordToWord8Compat# (word8ToWordCompat# x# `and#` word8ToWordCompat# y#)) + (W8# x#) .|. (W8# y#) = W8# (wordToWord8Compat# (word8ToWordCompat# x# `or#` word8ToWordCompat# y#)) + (W8# x#) .^. (W8# y#) = W8# (wordToWord8Compat# (word8ToWordCompat# x# `xor#` word8ToWordCompat# y#)) + (W8# x#) .<<. (CountOf (I# i#)) = W8# (narrow8WordCompat# (word8ToWordCompat# x# `shiftL#` i#)) + (W8# x#) .>>. (CountOf (I# i#)) = W8# (narrow8WordCompat# (word8ToWordCompat# x# `shiftRL#` i#)) + +-- Word16 --------------------------------------------------------------------- + +instance FiniteBitsOps Word16 where + numberOfBits _ = 16 + rotateL (W16# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W16# x# + | otherwise = W16# (narrow16WordCompat# ((word16ToWordCompat# x# `uncheckedShiftL#` i'#) `or#` + (word16ToWordCompat# x# `uncheckedShiftRL#` (16# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 15##) + rotateR (W16# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W16# x# + | otherwise = W16# (narrow16WordCompat# ((word16ToWordCompat# x# `uncheckedShiftRL#` i'#) `or#` + (word16ToWordCompat# x# `uncheckedShiftL#` (16# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 15##) + bitFlip (W16# x#) = W16# (wordToWord16Compat# (word16ToWordCompat# x# `xor#` word16ToWordCompat# mb#)) + where !(W16# mb#) = maxBound + popCount (W16# x#) = CountOf $ wordToInt (W# (popCnt16# (word16ToWordCompat# x#))) + countLeadingZeros (W16# w#) = CountOf $ wordToInt (W# (clz16# (word16ToWordCompat# w#))) + countTrailingZeros (W16# w#) = CountOf $ wordToInt (W# (ctz16# (word16ToWordCompat# w#))) +instance BitOps Word16 where + (W16# x#) .&. (W16# y#) = W16# (wordToWord16Compat# (word16ToWordCompat# x# `and#` word16ToWordCompat# y#)) + (W16# x#) .|. (W16# y#) = W16# (wordToWord16Compat# (word16ToWordCompat# x# `or#` word16ToWordCompat# y#)) + (W16# x#) .^. (W16# y#) = W16# (wordToWord16Compat# (word16ToWordCompat# x# `xor#` word16ToWordCompat# y#)) + (W16# x#) .<<. (CountOf (I# i#)) = W16# (narrow16WordCompat# (word16ToWordCompat# x# `shiftL#` i#)) + (W16# x#) .>>. (CountOf (I# i#)) = W16# (narrow16WordCompat# (word16ToWordCompat# x# `shiftRL#` i#)) + +-- Word32 --------------------------------------------------------------------- + +instance FiniteBitsOps Word32 where + numberOfBits _ = 32 + rotateL (W32# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W32# x# + | otherwise = W32# (narrow32WordCompat# ((word32ToWordCompat# x# `uncheckedShiftL#` i'#) `or#` + (word32ToWordCompat# x# `uncheckedShiftRL#` (32# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 31##) + rotateR (W32# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W32# x# + | otherwise = W32# (narrow32WordCompat# ((word32ToWordCompat# x# `uncheckedShiftRL#` i'#) `or#` + (word32ToWordCompat# x# `uncheckedShiftL#` (32# -# i'#)))) + where + !i'# = word2Int# (int2Word# i# `and#` 31##) + bitFlip (W32# x#) = W32# (wordToWord32Compat# (word32ToWordCompat# x# `xor#` word32ToWordCompat# mb#)) + where !(W32# mb#) = maxBound + popCount (W32# x#) = CountOf $ wordToInt (W# (popCnt32# (word32ToWordCompat# x#))) + countLeadingZeros (W32# w#) = CountOf $ wordToInt (W# (clz32# (word32ToWordCompat# w#))) + countTrailingZeros (W32# w#) = CountOf $ wordToInt (W# (ctz32# (word32ToWordCompat# w#))) +instance BitOps Word32 where + (W32# x#) .&. (W32# y#) = W32# (wordToWord32Compat# (word32ToWordCompat# x# `and#` word32ToWordCompat# y#)) + (W32# x#) .|. (W32# y#) = W32# (wordToWord32Compat# (word32ToWordCompat# x# `or#` word32ToWordCompat# y#)) + (W32# x#) .^. (W32# y#) = W32# (wordToWord32Compat# (word32ToWordCompat# x# `xor#` word32ToWordCompat# y#)) + (W32# x#) .<<. (CountOf (I# i#)) = W32# (narrow32WordCompat# (word32ToWordCompat# x# `shiftL#` i#)) + (W32# x#) .>>. (CountOf (I# i#)) = W32# (narrow32WordCompat# (word32ToWordCompat# x# `shiftRL#` i#)) + +-- Word --------------------------------------------------------------------- + +#if WORD_SIZE_IN_BITS == 64 +instance FiniteBitsOps Word where + numberOfBits _ = 64 + rotateL (W# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W# x# + | otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + rotateR (W# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W# x# + | otherwise = W# ((x# `uncheckedShiftRL#` i'#) `or#` + (x# `uncheckedShiftL#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + bitFlip (W# x#) = W# (x# `xor#` mb#) + where !(W# mb#) = maxBound + popCount (W# x#) = CountOf $ wordToInt (W# (popCnt64# x#)) + countLeadingZeros (W# w#) = CountOf $ wordToInt (W# (clz64# w#)) + countTrailingZeros (W# w#) = CountOf $ wordToInt (W# (ctz64# w#)) +#else +instance FiniteBitsOps Word where + numberOfBits _ = 32 + rotateL (W# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W# x# + | otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (32# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 31##) + rotateR (W# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W# x# + | otherwise = W# ((x# `uncheckedShiftRL#` i'#) `or#` + (x# `uncheckedShiftL#` (32# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 31##) + bitFlip (W# x#) = W# (x# `xor#` mb#) + where !(W# mb#) = maxBound + 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 + (W# x#) .&. (W# y#) = W# (x# `and#` y#) + (W# x#) .|. (W# y#) = W# (x# `or#` y#) + (W# x#) .^. (W# y#) = W# (x# `xor#` y#) + (W# x#) .<<. (CountOf (I# i#)) = W# ((x# `shiftL#` i#)) + (W# x#) .>>. (CountOf (I# i#)) = W# ((x# `shiftRL#` i#)) + +-- Word64 --------------------------------------------------------------------- + +#if WORD_SIZE_IN_BITS == 64 +instance FiniteBitsOps Word64 where + numberOfBits _ = 64 + rotateL (W64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W64# x# + | otherwise = W64# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + rotateR (W64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W64# x# + | otherwise = W64# ((x# `uncheckedShiftRL#` i'#) `or#` + (x# `uncheckedShiftL#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + bitFlip (W64# x#) = W64# (x# `xor#` mb#) + where !(W64# mb#) = maxBound + 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 + (W64# x#) .&. (W64# y#) = W64# (x# `and#` y#) + (W64# x#) .|. (W64# y#) = W64# (x# `or#` y#) + (W64# x#) .^. (W64# y#) = W64# (x# `xor#` y#) + (W64# x#) .<<. (CountOf (I# i#)) = W64# (x# `shiftL#` i#) + (W64# x#) .>>. (CountOf (I# i#)) = W64# (x# `shiftRL#` i#) +#else +instance FiniteBitsOps Word64 where + numberOfBits _ = 64 + rotateL (W64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W64# x# + | otherwise = W64# ((x# `uncheckedShiftL64#` i'#) `or64#` + (x# `uncheckedShiftRL64#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + rotateR (W64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = W64# x# + | otherwise = W64# ((x# `uncheckedShiftRL64#` i'#) `or64#` + (x# `uncheckedShiftL64#` (64# -# i'#))) + where + !i'# = word2Int# (int2Word# i# `and#` 63##) + bitFlip (W64# x#) = W64# (not64# x#) + 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 + (W64# x#) .&. (W64# y#) = W64# (x# `and64#` y#) + (W64# x#) .|. (W64# y#) = W64# (x# `or64#` y#) + (W64# x#) .^. (W64# y#) = W64# (x# `xor64#` y#) + (W64# x#) .<<. (CountOf (I# i#)) = W64# (x# `shiftL64#` i#) + (W64# x#) .>>. (CountOf (I# i#)) = W64# (x# `shiftRL64#` i#) + +shiftL64#, shiftRL64# :: Word64# -> Int# -> Word64# +a `shiftL64#` b | isTrue# (b >=# 64#) = wordToWord64# 0## + | otherwise = a `uncheckedShiftL64#` b +a `shiftRL64#` b | isTrue# (b >=# 64#) = wordToWord64# 0## + | otherwise = a `uncheckedShiftRL64#` b +#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 (I8# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I8# x# + | otherwise = I8# (narrow8IntCompat# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (8# -# i'#))))) + where + !x'# = narrow8Word# (int2Word# (int8ToIntCompat# x#)) + !i'# = word2Int# (int2Word# i# `and#` 7##) + rotateR (I8# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I8# x# + | otherwise = I8# (narrow8IntCompat# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#` + (x'# `uncheckedShiftL#` (8# -# i'#))))) + where + !x'# = narrow8Word# (int2Word# (int8ToIntCompat# x#)) + !i'# = word2Int# (int2Word# i# `and#` 7##) + bitFlip (I8# x#) = I8# (intToInt8Compat# (word2Int# (not# (int2Word# (int8ToIntCompat# x#))))) + popCount (I8# x#) = CountOf $ wordToInt (W# (popCnt8# (int2Word# (int8ToIntCompat# x#)))) + countLeadingZeros (I8# w#) = CountOf $ wordToInt (W# (clz8# (int2Word# (int8ToIntCompat# w#)))) + countTrailingZeros (I8# w#) = CountOf $ wordToInt (W# (ctz8# (int2Word# (int8ToIntCompat# w#)))) +instance BitOps Int8 where + (I8# x#) .&. (I8# y#) = I8# (intToInt8Compat# (int8ToIntCompat# x# `andI#` int8ToIntCompat# y#)) + (I8# x#) .|. (I8# y#) = I8# (intToInt8Compat# (int8ToIntCompat# x# `orI#` int8ToIntCompat# y#)) + (I8# x#) .^. (I8# y#) = I8# (intToInt8Compat# (int8ToIntCompat# x# `xorI#` int8ToIntCompat# y#)) + (I8# x#) .<<. (CountOf (I# i#)) = I8# (narrow8IntCompat# (int8ToIntCompat# x# `iShiftL#` i#)) + (I8# x#) .>>. (CountOf (I# i#)) = I8# (narrow8IntCompat# (int8ToIntCompat# x# `iShiftRL#` i#)) + +-- Int16 ---------------------------------------------------------------------- + +instance FiniteBitsOps Int16 where + numberOfBits _ = 16 + rotateL (I16# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I16# x# + | otherwise = I16# (narrow16IntCompat# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (16# -# i'#))))) + where + !x'# = narrow16Word# (int2Word# (int16ToIntCompat# x#)) + !i'# = word2Int# (int2Word# i# `and#` 15##) + rotateR (I16# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I16# x# + | otherwise = I16# (narrow16IntCompat# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#` + (x'# `uncheckedShiftL#` (16# -# i'#))))) + where + !x'# = narrow16Word# (int2Word# (int16ToIntCompat# x#)) + !i'# = word2Int# (int2Word# i# `and#` 15##) + bitFlip (I16# x#) = I16# (intToInt16Compat# (word2Int# (not# (int2Word# (int16ToIntCompat# x#))))) + popCount (I16# x#) = CountOf $ wordToInt (W# (popCnt16# (int2Word# (int16ToIntCompat# x#)))) + countLeadingZeros (I16# w#) = CountOf $ wordToInt (W# (clz16# (int2Word# (int16ToIntCompat# w#)))) + countTrailingZeros (I16# w#) = CountOf $ wordToInt (W# (ctz16# (int2Word# (int16ToIntCompat# w#)))) +instance BitOps Int16 where + (I16# x#) .&. (I16# y#) = I16# (intToInt16Compat# (int16ToIntCompat# x# `andI#` int16ToIntCompat# y#)) + (I16# x#) .|. (I16# y#) = I16# (intToInt16Compat# (int16ToIntCompat# x# `orI#` int16ToIntCompat# y#)) + (I16# x#) .^. (I16# y#) = I16# (intToInt16Compat# (int16ToIntCompat# x# `xorI#` int16ToIntCompat# y#)) + (I16# x#) .<<. (CountOf (I# i#)) = I16# (narrow16IntCompat# (int16ToIntCompat# x# `iShiftL#` i#)) + (I16# x#) .>>. (CountOf (I# i#)) = I16# (narrow16IntCompat# (int16ToIntCompat# x# `iShiftRL#` i#)) + +-- Int32 ---------------------------------------------------------------------- + +instance FiniteBitsOps Int32 where + numberOfBits _ = 32 + rotateL (I32# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I32# x# + | otherwise = I32# (narrow32IntCompat# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (32# -# i'#))))) + where + !x'# = narrow32Word# (int2Word# (int32ToIntCompat# x#)) + !i'# = word2Int# (int2Word# i# `and#` 31##) + rotateR (I32# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I32# x# + | otherwise = I32# (narrow32IntCompat# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#` + (x'# `uncheckedShiftL#` (32# -# i'#))))) + where + !x'# = narrow32Word# (int2Word# (int32ToIntCompat# x#)) + !i'# = word2Int# (int2Word# i# `and#` 31##) + bitFlip (I32# x#) = I32# (intToInt32Compat# (word2Int# (not# (int2Word# (int32ToIntCompat# x#))))) + popCount (I32# x#) = CountOf $ wordToInt (W# (popCnt32# (int2Word# (int32ToIntCompat# x#)))) + countLeadingZeros (I32# w#) = CountOf $ wordToInt (W# (clz32# (int2Word# (int32ToIntCompat# w#)))) + countTrailingZeros (I32# w#) = CountOf $ wordToInt (W# (ctz32# (int2Word# (int32ToIntCompat# w#)))) +instance BitOps Int32 where + (I32# x#) .&. (I32# y#) = I32# (intToInt32Compat# (int32ToIntCompat# x# `andI#` int32ToIntCompat# y#)) + (I32# x#) .|. (I32# y#) = I32# (intToInt32Compat# (int32ToIntCompat# x# `orI#` int32ToIntCompat# y#)) + (I32# x#) .^. (I32# y#) = I32# (intToInt32Compat# (int32ToIntCompat# x# `xorI#` int32ToIntCompat# y#)) + (I32# x#) .<<. (CountOf (I# i#)) = I32# (narrow32IntCompat# (int32ToIntCompat# x# `iShiftL#` i#)) + (I32# x#) .>>. (CountOf (I# i#)) = I32# (narrow32IntCompat# (int32ToIntCompat# x# `iShiftRL#` i#)) + +-- Int64 ---------------------------------------------------------------------- + +#if WORD_SIZE_IN_BITS == 64 +instance FiniteBitsOps Int64 where + numberOfBits _ = 64 + rotateL (I64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I64# x# + | otherwise = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (64# -# i'#)))) + where + !x'# = int2Word# x# + !i'# = word2Int# (int2Word# i# `and#` 63##) + rotateR (I64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I64# x# + | otherwise = I64# (word2Int# ((x'# `uncheckedShiftRL#` i'#) `or#` + (x'# `uncheckedShiftL#` (64# -# i'#)))) + where + !x'# = int2Word# x# + !i'# = word2Int# (int2Word# i# `and#` 63##) + bitFlip (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) + 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#))) +instance BitOps Int64 where + (I64# x#) .&. (I64# y#) = I64# (x# `andI#` y#) + (I64# x#) .|. (I64# y#) = I64# (x# `orI#` y#) + (I64# x#) .^. (I64# y#) = I64# (x# `xorI#` y#) + (I64# x#) .<<. (CountOf (I# w#)) = I64# (x# `iShiftL#` w#) + (I64# x#) .>>. (CountOf (I# w#)) = I64# (x# `iShiftRL#` w#) +#else +instance FiniteBitsOps Int64 where + numberOfBits _ = 64 + rotateL (I64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I64# x# + | otherwise = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#` + (x'# `uncheckedShiftRL64#` (64# -# i'#)))) + where + !x'# = int64ToWord64# x# + !i'# = word2Int# (int2Word# i# `and#` 63##) + rotateR (I64# x#) (CountOf (I# i#)) + | isTrue# (i'# ==# 0#) = I64# x# + | otherwise = I64# (word64ToInt64# ((x'# `uncheckedShiftRL64#` i'#) `or64#` + (x'# `uncheckedShiftL64#` (64# -# i'#)))) + where + !x'# = int64ToWord64# x# + !i'# = word2Int# (int2Word# i# `and#` 63##) + bitFlip (I64# x#) = I64# (word64ToInt64# (not64# (int64ToWord64# x#))) + 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 + (I64# x#) .&. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `and64#` int64ToWord64# y#)) + (I64# x#) .|. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `or64#` int64ToWord64# y#)) + (I64# x#) .^. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# y#)) + (I64# x#) .<<. (CountOf (I# w#)) = I64# (x# `iShiftL64#` w#) + (I64# x#) .>>. (CountOf (I# w#)) = I64# (x# `iShiftRA64#` w#) + + +iShiftL64#, iShiftRA64# :: Int64# -> Int# -> Int64# +a `iShiftL64#` b | isTrue# (b >=# 64#) = intToInt64# 0# + | otherwise = a `uncheckedIShiftL64#` b +a `iShiftRA64#` b | isTrue# (b >=# 64#) && isTrue# (a `ltInt64#` (intToInt64# 0#)) + = intToInt64# (-1#) + | isTrue# (b >=# 64#) = intToInt64# 0# + | otherwise = a `uncheckedIShiftRA64#` b + +#endif diff --git a/Basement/Block.hs b/Basement/Block.hs new file mode 100644 --- /dev/null +++ b/Basement/Block.hs @@ -0,0 +1,441 @@ +-- | +-- 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 #-} +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 diff --git a/Basement/Block/Base.hs b/Basement/Block/Base.hs new file mode 100644 --- /dev/null +++ b/Basement/Block/Base.hs @@ -0,0 +1,489 @@ +{-# 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 + mappend = append + 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 diff --git a/Basement/Block/Builder.hs b/Basement/Block/Builder.hs new file mode 100644 --- /dev/null +++ b/Basement/Block/Builder.hs @@ -0,0 +1,151 @@ +-- | +-- Module : Basement.Block.Builder +-- License : BSD-style +-- Maintainer : Foundation +-- +-- Block builder + +{-# LANGUAGE Rank2Types #-} + +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 + {-# INLINE mempty #-} + mappend = append + {-# INLINABLE mappend #-} + 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 diff --git a/Basement/Block/Mutable.hs b/Basement/Block/Mutable.hs new file mode 100644 --- /dev/null +++ b/Basement/Block/Mutable.hs @@ -0,0 +1,154 @@ +-- | +-- 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< (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 diff --git a/Basement/BlockN.hs b/Basement/BlockN.hs new file mode 100644 --- /dev/null +++ b/Basement/BlockN.hs @@ -0,0 +1,10 @@ +-- | +-- 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 diff --git a/Basement/Bounded.hs b/Basement/Bounded.hs new file mode 100644 --- /dev/null +++ b/Basement/Bounded.hs @@ -0,0 +1,125 @@ +-- | +-- 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 #-} +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)) + diff --git a/Basement/BoxedArray.hs b/Basement/BoxedArray.hs new file mode 100644 --- /dev/null +++ b/Basement/BoxedArray.hs @@ -0,0 +1,776 @@ +-- | +-- Module : Basement.BoxedArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Simple boxed array abstraction +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +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 + mappend = append + 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 diff --git a/Basement/Cast.hs b/Basement/Cast.hs new file mode 100644 --- /dev/null +++ b/Basement/Cast.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | +-- 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.HeadHackageUtils +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# (narrow8WordCompat# (int2Word# (int8ToIntCompat# i))) +instance Cast Int16 Word16 where + cast (I16# i) = W16# (narrow16WordCompat# (int2Word# (int16ToIntCompat# i))) +instance Cast Int32 Word32 where + cast (I32# i) = W32# (narrow32WordCompat# (int2Word# (int32ToIntCompat# 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# (narrow8IntCompat# (word2Int# (word8ToWordCompat# i))) +instance Cast Word16 Int16 where + cast (W16# i) = I16# (narrow16IntCompat# (word2Int# (word16ToWordCompat# i))) +instance Cast Word32 Int32 where + cast (W32# i) = I32# (narrow32IntCompat# (word2Int# (word32ToWordCompat# 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 +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) +#else +instance Cast Word Word32 where + cast (W# w) = W32# w +instance Cast Word32 Word where + cast (W32# w) = W# w + +instance Cast Word Int32 where + cast (W# w) = I32# (word2Int# w) +instance Cast Int32 Word where + cast (I32# i) = W# (int2Word# i) + +instance Cast Int Int32 where + cast (I# i) = I32# i +instance Cast Int32 Int where + cast (I32# i) = I# i + +instance Cast Int Word32 where + cast (I# i) = W32# (int2Word# i) +instance Cast Word32 Int where + cast (W32# w) = I# (word2Int# w) +#endif + +instance Cast (Block.Block a) (Block.Block Word8) where + cast (Block.Block ba) = Block.Block ba diff --git a/Basement/Compat/AMP.hs b/Basement/Compat/AMP.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/AMP.hs @@ -0,0 +1,11 @@ +{-# 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 diff --git a/Basement/Compat/Base.hs b/Basement/Compat/Base.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Base.hs @@ -0,0 +1,94 @@ +-- | +-- Module : Basement.Compat.Base +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/Bifunctor.hs b/Basement/Compat/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Bifunctor.hs @@ -0,0 +1,117 @@ +-- | +-- Module : Basement.Compat.Bifunctor +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/C/Types.hs b/Basement/Compat/C/Types.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/C/Types.hs @@ -0,0 +1,23 @@ +{-# 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 diff --git a/Basement/Compat/CallStack.hs b/Basement/Compat/CallStack.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/CallStack.hs @@ -0,0 +1,24 @@ +{-# 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 diff --git a/Basement/Compat/ExtList.hs b/Basement/Compat/ExtList.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/ExtList.hs @@ -0,0 +1,47 @@ +{-# 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 diff --git a/Basement/Compat/Identity.hs b/Basement/Compat/Identity.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Identity.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Basement.Compat.Identity +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/IsList.hs b/Basement/Compat/IsList.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/IsList.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Basement.Compat.IsList +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Compat/MonadTrans.hs b/Basement/Compat/MonadTrans.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/MonadTrans.hs @@ -0,0 +1,50 @@ +-- | +-- 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 a = State $ \st -> return (a,st) + 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 a = Reader $ \_ -> return a + ma >>= mb = Reader $ \r -> do + a <- runReader ma r + runReader (mb a) r diff --git a/Basement/Compat/Natural.hs b/Basement/Compat/Natural.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Natural.hs @@ -0,0 +1,61 @@ +{-# 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 diff --git a/Basement/Compat/NumLiteral.hs b/Basement/Compat/NumLiteral.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/NumLiteral.hs @@ -0,0 +1,195 @@ +{-# 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 diff --git a/Basement/Compat/PrimTypes.hs b/Basement/Compat/PrimTypes.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/PrimTypes.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Basement.Compat.PrimTypes +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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# diff --git a/Basement/Compat/Primitive.hs b/Basement/Compat/Primitive.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Primitive.hs @@ -0,0 +1,79 @@ +-- | +-- Module : Basement.Compat.Primitive +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE UnliftedFFITypes #-} +module Basement.Compat.Primitive + ( bool# + , PinnedStatus(..), toPinnedStatus# + , compatMkWeak# + , compatIsByteArrayPinned# + , compatIsMutableByteArrayPinned# + , unsafeCoerce# + , Word(..) + ) where + +import qualified Prelude +import GHC.Exts +import GHC.Prim +import GHC.Word +import GHC.IO + +import Basement.Compat.PrimTypes + +-- 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 diff --git a/Basement/Compat/Semigroup.hs b/Basement/Compat/Semigroup.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Semigroup.hs @@ -0,0 +1,165 @@ +{-# 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 diff --git a/Basement/Compat/Typeable.hs b/Basement/Compat/Typeable.hs new file mode 100644 --- /dev/null +++ b/Basement/Compat/Typeable.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Basement.Compat.Typeable +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- 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 diff --git a/Basement/Endianness.hs b/Basement/Endianness.hs new file mode 100644 --- /dev/null +++ b/Basement/Endianness.hs @@ -0,0 +1,141 @@ +-- | +-- 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 #-} + +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 diff --git a/Basement/Environment.hs b/Basement/Environment.hs new file mode 100644 --- /dev/null +++ b/Basement/Environment.hs @@ -0,0 +1,16 @@ +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) diff --git a/Basement/Error.hs b/Basement/Error.hs new file mode 100644 --- /dev/null +++ b/Basement/Error.hs @@ -0,0 +1,41 @@ +{-# 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 diff --git a/Basement/Exception.hs b/Basement/Exception.hs new file mode 100644 --- /dev/null +++ b/Basement/Exception.hs @@ -0,0 +1,71 @@ +-- | +-- Module : Basement.Exception +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/FinalPtr.hs b/Basement/FinalPtr.hs new file mode 100644 --- /dev/null +++ b/Basement/FinalPtr.hs @@ -0,0 +1,112 @@ +-- | +-- Module : Basement.FinalPtr +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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_ #-} diff --git a/Basement/Floating.hs b/Basement/Floating.hs new file mode 100644 --- /dev/null +++ b/Basement/Floating.hs @@ -0,0 +1,73 @@ +{-# 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 #-} diff --git a/Basement/From.hs b/Basement/From.hs new file mode 100644 --- /dev/null +++ b/Basement/From.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE CPP #-} +{-# 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 +#if __GLASGOW_HASKELL__ >= 903 + hiding (word64ToWord#) +#endif +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.HeadHackageUtils +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# (intToInt16Compat# (int8ToIntCompat# i)) +instance From Int8 Int32 where + from (I8# i) = I32# (intToInt32Compat# (int8ToIntCompat# i)) +instance From Int8 Int64 where + from (I8# i) = intToInt64 (I# (int8ToIntCompat# i)) +instance From Int8 Int where + from (I8# i) = I# (int8ToIntCompat# i) + +instance From Int16 Int32 where + from (I16# i) = I32# (intToInt32Compat# (int16ToIntCompat# i)) +instance From Int16 Int64 where + from (I16# i) = intToInt64 (I# (int16ToIntCompat# i)) +instance From Int16 Int where + from (I16# i) = I# (int16ToIntCompat# i) + +instance From Int32 Int64 where + from (I32# i) = intToInt64 (I# (int32ToIntCompat# i)) +instance From Int32 Int where + from (I32# i) = I# (int32ToIntCompat# i) + +instance From Int Int64 where + from = intToInt64 + +instance From Word8 Word16 where + from (W8# i) = W16# (wordToWord16Compat# (word8ToWordCompat# i)) +instance From Word8 Word32 where + from (W8# i) = W32# (wordToWord32Compat# (word8ToWordCompat# i)) +instance From Word8 Word64 where + from (W8# i) = wordToWord64 (W# (word8ToWordCompat# i)) +instance From Word8 Word128 where + from (W8# i) = Word128 0 (wordToWord64 $ W# (word8ToWordCompat# i)) +instance From Word8 Word256 where + from (W8# i) = Word256 0 0 0 (wordToWord64 $ W# (word8ToWordCompat# i)) +instance From Word8 Word where + from (W8# i) = W# (word8ToWordCompat# i) +instance From Word8 Int16 where + from (W8# w) = I16# (intToInt16Compat# (word2Int# (word8ToWordCompat# w))) +instance From Word8 Int32 where + from (W8# w) = I32# (intToInt32Compat# (word2Int# (word8ToWordCompat# w))) +instance From Word8 Int64 where + from (W8# w) = intToInt64 (I# (word2Int# (word8ToWordCompat# w))) +instance From Word8 Int where + from (W8# w) = I# (word2Int# (word8ToWordCompat# w)) + +instance From Word16 Word32 where + from (W16# i) = W32# (wordToWord32Compat# (word16ToWordCompat# i)) +instance From Word16 Word64 where + from (W16# i) = wordToWord64 (W# (word16ToWordCompat# i)) +instance From Word16 Word128 where + from (W16# i) = Word128 0 (wordToWord64 $ W# (word16ToWordCompat# i)) +instance From Word16 Word256 where + from (W16# i) = Word256 0 0 0 (wordToWord64 $ W# (word16ToWordCompat# i)) +instance From Word16 Word where + from (W16# i) = W# (word16ToWordCompat# i) +instance From Word16 Int32 where + from (W16# w) = I32# (intToInt32Compat# (word2Int# (word16ToWordCompat# w))) +instance From Word16 Int64 where + from (W16# w) = intToInt64 (I# (word2Int# (word16ToWordCompat# w))) +instance From Word16 Int where + from (W16# w) = I# (word2Int# (word16ToWordCompat# w)) + +instance From Word32 Word64 where + from (W32# i) = wordToWord64 (W# (word32ToWordCompat# i)) +instance From Word32 Word128 where + from (W32# i) = Word128 0 (wordToWord64 $ W# (word32ToWordCompat# i)) +instance From Word32 Word256 where + from (W32# i) = Word256 0 0 0 (wordToWord64 $ W# (word32ToWordCompat# i)) +instance From Word32 Word where + from (W32# i) = W# (word32ToWordCompat# i) +instance From Word32 Int64 where + from (W32# w) = intToInt64 (I# (word2Int# (word32ToWordCompat# w))) +instance From Word32 Int where + from (W32# w) = I# (word2Int# (word32ToWordCompat# 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 + from = narrow . unZn64 where narrow (W64# w) = W8# (narrow8WordCompat# (word64ToWord# w)) +instance (KnownNat n, NatWithinBound Word16 n) => From (Zn64 n) Word16 where + from = narrow . unZn64 where narrow (W64# w) = W16# (narrow16WordCompat# (word64ToWord# w)) +instance (KnownNat n, NatWithinBound Word32 n) => From (Zn64 n) Word32 where + from = narrow . unZn64 where narrow (W64# w) = W32# (narrow32WordCompat# (word64ToWord# w)) +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 + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W8# (narrow8WordCompat# (word64ToWord# w)) +instance (KnownNat n, NatWithinBound Word16 n) => From (Zn n) Word16 where + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W16# (narrow16WordCompat# (word64ToWord# w)) +instance (KnownNat n, NatWithinBound Word32 n) => From (Zn n) Word32 where + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W32# (narrow32WordCompat# (word64ToWord# w)) +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 diff --git a/Basement/HeadHackageUtils.hs b/Basement/HeadHackageUtils.hs new file mode 100644 --- /dev/null +++ b/Basement/HeadHackageUtils.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +module Basement.HeadHackageUtils where + +import GHC.Exts + +#if MIN_VERSION_base(4,16,0) +int8ToIntCompat# :: Int8# -> Int# +int8ToIntCompat# = int8ToInt# + +int16ToIntCompat# :: Int16# -> Int# +int16ToIntCompat# = int16ToInt# + +int32ToIntCompat# :: Int32# -> Int# +int32ToIntCompat# = int32ToInt# + +word8ToWordCompat# :: Word8# -> Word# +word8ToWordCompat# = word8ToWord# + +word16ToWordCompat# :: Word16# -> Word# +word16ToWordCompat# = word16ToWord# + +word32ToWordCompat# :: Word32# -> Word# +word32ToWordCompat# = word32ToWord# + +intToInt8Compat# :: Int# -> Int8# +intToInt8Compat# = intToInt8# + +intToInt16Compat# :: Int# -> Int16# +intToInt16Compat# = intToInt16# + +intToInt32Compat# :: Int# -> Int32# +intToInt32Compat# = intToInt32# + +wordToWord8Compat# :: Word# -> Word8# +wordToWord8Compat# = wordToWord8# + +wordToWord16Compat# :: Word# -> Word16# +wordToWord16Compat# = wordToWord16# + +wordToWord32Compat# :: Word# -> Word32# +wordToWord32Compat# = wordToWord32# + +-- + +narrow8IntCompat# :: Int# -> Int8# +narrow8IntCompat# = intToInt8# + +narrow16IntCompat# :: Int# -> Int16# +narrow16IntCompat# = intToInt16# + +narrow32IntCompat# :: Int# -> Int32# +narrow32IntCompat# = intToInt32# + +narrow8WordCompat# :: Word# -> Word8# +narrow8WordCompat# = wordToWord8# + +narrow16WordCompat# :: Word# -> Word16# +narrow16WordCompat# = wordToWord16# + +narrow32WordCompat# :: Word# -> Word32# +narrow32WordCompat# = wordToWord32# +#else +-- No-ops +int8ToIntCompat# :: Int# -> Int# +int8ToIntCompat# x = x + +int16ToIntCompat# :: Int# -> Int# +int16ToIntCompat# x = x + +int32ToIntCompat# :: Int# -> Int# +int32ToIntCompat# x = x + +word8ToWordCompat# :: Word# -> Word# +word8ToWordCompat# x = x + +word16ToWordCompat# :: Word# -> Word# +word16ToWordCompat# x = x + +word32ToWordCompat# :: Word# -> Word# +word32ToWordCompat# x = x + +intToInt8Compat# :: Int# -> Int# +intToInt8Compat# x = x + +intToInt16Compat# :: Int# -> Int# +intToInt16Compat# x = x + +intToInt32Compat# :: Int# -> Int# +intToInt32Compat# x = x + +wordToWord8Compat# :: Word# -> Word# +wordToWord8Compat# x = x + +wordToWord16Compat# :: Word# -> Word# +wordToWord16Compat# x = x + +wordToWord32Compat# :: Word# -> Word# +wordToWord32Compat# x = x + +-- Actual narrowing +narrow8IntCompat# :: Int# -> Int# +narrow8IntCompat# = narrow8Int# + +narrow16IntCompat# :: Int# -> Int# +narrow16IntCompat# = narrow16Int# + +narrow32IntCompat# :: Int# -> Int# +narrow32IntCompat# = narrow32Int# + +narrow8WordCompat# :: Word# -> Word# +narrow8WordCompat# = narrow8Word# + +narrow16WordCompat# :: Word# -> Word# +narrow16WordCompat# = narrow16Word# + +narrow32WordCompat# :: Word# -> Word# +narrow32WordCompat# = narrow32Word# +#endif diff --git a/Basement/Imports.hs b/Basement/Imports.hs new file mode 100644 --- /dev/null +++ b/Basement/Imports.hs @@ -0,0 +1,125 @@ +-- | +-- Module : Basement.Imports +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/IntegralConv.hs b/Basement/IntegralConv.hs new file mode 100644 --- /dev/null +++ b/Basement/IntegralConv.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +module Basement.IntegralConv + ( IntegralDownsize(..) + , IntegralUpsize(..) + , intToInt64 + , int64ToInt + , wordToWord64 + , word64ToWord32s + , Word32x2(..) + , word64ToWord + , wordToChar + , wordToInt + , charToInt + ) where + +import GHC.Types +import GHC.Prim +#if __GLASGOW_HASKELL__ >= 903 + hiding (word64ToWord#) +#endif +import GHC.Int +import GHC.Word +import Prelude (Integer, fromIntegral) +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.HeadHackageUtils +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# (intToInt16Compat# (int8ToIntCompat# i)) +instance IntegralUpsize Int8 Int32 where + integralUpsize (I8# i) = I32# (intToInt32Compat# (int8ToIntCompat# i)) +instance IntegralUpsize Int8 Int64 where + integralUpsize (I8# i) = intToInt64 (I# (int8ToIntCompat# i)) +instance IntegralUpsize Int8 Int where + integralUpsize (I8# i) = I# (int8ToIntCompat# i) + +instance IntegralUpsize Int16 Int32 where + integralUpsize (I16# i) = I32# (intToInt32Compat# (int16ToIntCompat# i)) +instance IntegralUpsize Int16 Int64 where + integralUpsize (I16# i) = intToInt64 (I# (int16ToIntCompat# i)) +instance IntegralUpsize Int16 Int where + integralUpsize (I16# i) = I# (int16ToIntCompat# i) + +instance IntegralUpsize Int32 Int64 where + integralUpsize (I32# i) = intToInt64 (I# (int32ToIntCompat# i)) +instance IntegralUpsize Int32 Int where + integralUpsize (I32# i) = I# (int32ToIntCompat# i) + +instance IntegralUpsize Int Int64 where + integralUpsize = intToInt64 + +instance IntegralUpsize Word8 Word16 where + integralUpsize (W8# i) = W16# (wordToWord16Compat# (word8ToWordCompat# i)) +instance IntegralUpsize Word8 Word32 where + integralUpsize (W8# i) = W32# (wordToWord32Compat# (word8ToWordCompat# i)) +instance IntegralUpsize Word8 Word64 where + integralUpsize (W8# i) = wordToWord64 (W# (word8ToWordCompat# i)) +instance IntegralUpsize Word8 Word where + integralUpsize (W8# i) = W# (word8ToWordCompat# i) +instance IntegralUpsize Word8 Int16 where + integralUpsize (W8# w) = I16# (intToInt16Compat# (word2Int# (word8ToWordCompat# w))) +instance IntegralUpsize Word8 Int32 where + integralUpsize (W8# w) = I32# (intToInt32Compat# (word2Int# (word8ToWordCompat# w))) +instance IntegralUpsize Word8 Int64 where + integralUpsize (W8# w) = intToInt64 (I# (word2Int# (word8ToWordCompat# w))) +instance IntegralUpsize Word8 Int where + integralUpsize (W8# w) = I# (word2Int# (word8ToWordCompat# w)) + +instance IntegralUpsize Word16 Word32 where + integralUpsize (W16# i) = W32# (wordToWord32Compat# (word16ToWordCompat# i)) +instance IntegralUpsize Word16 Word64 where + integralUpsize (W16# i) = wordToWord64 (W# (word16ToWordCompat# i)) +instance IntegralUpsize Word16 Word where + integralUpsize (W16# i) = W# (word16ToWordCompat# i) + +instance IntegralUpsize Word32 Word64 where + integralUpsize (W32# i) = wordToWord64 (W# (word32ToWordCompat# i)) +instance IntegralUpsize Word32 Word where + integralUpsize (W32# i) = W# (word32ToWordCompat# i) + +instance IntegralUpsize Word Word64 where + integralUpsize = wordToWord64 + +instance IntegralDownsize Int Int8 where + integralDownsize (I# i) = I8# (narrow8IntCompat# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int Int16 where + integralDownsize (I# i) = I16# (narrow16IntCompat# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int Int32 where + integralDownsize (I# i) = I32# (narrow32IntCompat# 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 + integralDownsize (W64# i) = W8# (narrow8WordCompat# (word64ToWord# i)) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word64 Word16 where + integralDownsize (W64# i) = W16# (narrow16WordCompat# (word64ToWord# i)) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word64 Word32 where + integralDownsize (W64# i) = W32# (narrow32WordCompat# (word64ToWord# i)) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word Word8 where + integralDownsize (W# w) = W8# (narrow8WordCompat# w) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word Word16 where + integralDownsize (W# w) = W16# (narrow16WordCompat# w) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word Word32 where + integralDownsize (W# w) = W32# (narrow32WordCompat# w) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word32 Word8 where + integralDownsize (W32# i) = W8# (narrow8WordCompat# (word32ToWordCompat# i)) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word32 Word16 where + integralDownsize (W32# i) = W16# (narrow16WordCompat# (word32ToWordCompat# i)) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word16 Word8 where + integralDownsize (W16# i) = W8# (narrow8WordCompat# (word16ToWordCompat# 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 diff --git a/Basement/Monad.hs b/Basement/Monad.hs new file mode 100644 --- /dev/null +++ b/Basement/Monad.hs @@ -0,0 +1,138 @@ +-- | +-- Module : Basement.Monad +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 #-} +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 diff --git a/Basement/MutableBuilder.hs b/Basement/MutableBuilder.hs new file mode 100644 --- /dev/null +++ b/Basement/MutableBuilder.hs @@ -0,0 +1,31 @@ +{-# 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)) diff --git a/Basement/Nat.hs b/Basement/Nat.hs new file mode 100644 --- /dev/null +++ b/Basement/Nat.hs @@ -0,0 +1,127 @@ +{-# 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 diff --git a/Basement/NonEmpty.hs b/Basement/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/Basement/NonEmpty.hs @@ -0,0 +1,25 @@ +-- | +-- 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 diff --git a/Basement/NormalForm.hs b/Basement/NormalForm.hs new file mode 100644 --- /dev/null +++ b/Basement/NormalForm.hs @@ -0,0 +1,131 @@ +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 diff --git a/Basement/Numerical/Additive.hs b/Basement/Numerical/Additive.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Additive.hs @@ -0,0 +1,253 @@ +{-# 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.Numerical.Number +import qualified Prelude +import GHC.Types +import GHC.Prim +import GHC.Int +import GHC.Word +import Basement.Bounded +import Basement.HeadHackageUtils +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# (narrow8IntCompat# (int8ToIntCompat# a +# int8ToIntCompat# b)) + scale = scaleNum +instance Additive Int16 where + azero = 0 + (I16# a) + (I16# b) = I16# (narrow16IntCompat# (int16ToIntCompat# a +# int16ToIntCompat# b)) + scale = scaleNum +instance Additive Int32 where + azero = 0 + (I32# a) + (I32# b) = I32# (narrow32IntCompat# (int32ToIntCompat# a +# int32ToIntCompat# b)) + scale = scaleNum +instance Additive Int64 where + azero = 0 +#if WORD_SIZE_IN_BITS == 64 + (I64# a) + (I64# b) = I64# (a +# b) +#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# (narrow8WordCompat# (word8ToWordCompat# a `plusWord#` word8ToWordCompat# b)) + scale = scaleNum +instance Additive Word16 where + azero = 0 + (W16# a) + (W16# b) = W16# (narrow16WordCompat# (word16ToWordCompat# a `plusWord#` word16ToWordCompat# b)) + scale = scaleNum +instance Additive Word32 where + azero = 0 + (W32# a) + (W32# b) = W32# (narrow32WordCompat# (word32ToWordCompat# a `plusWord#` word32ToWordCompat# b)) + scale = scaleNum +instance Additive Word64 where + azero = 0 +#if WORD_SIZE_IN_BITS == 64 + (W64# a) + (W64# b) = W64# (a `plusWord#` b) +#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 diff --git a/Basement/Numerical/Conversion.hs b/Basement/Numerical/Conversion.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Conversion.hs @@ -0,0 +1,104 @@ +{-# 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 Basement.HeadHackageUtils +import GHC.Types +import GHC.Prim +#if __GLASGOW_HASKELL__ >= 903 + hiding (word64ToWord#) +#endif +import GHC.Int +import GHC.Word + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +intToInt64 :: Int -> Int64 +#if WORD_SIZE_IN_BITS == 64 +intToInt64 (I# i) = I64# i +#else +intToInt64 (I# i) = I64# (intToInt64# i) +#endif + +int64ToInt :: Int64 -> Int +#if WORD_SIZE_IN_BITS == 64 +int64ToInt (I64# i) = I# i +#else +int64ToInt (I64# i) = I# (int64ToInt# i) +#endif + +wordToWord64 :: Word -> Word64 +#if WORD_SIZE_IN_BITS == 64 +wordToWord64 (W# i) = W64# i +#else +wordToWord64 (W# i) = W64# (wordToWord64# i) +#endif + +word64ToWord :: Word64 -> Word +#if WORD_SIZE_IN_BITS == 64 +word64ToWord (W64# i) = W# i +#else +word64ToWord (W64# i) = W# (word64ToWord# i) +#endif + +word64ToInt64 :: Word64 -> Int64 +#if WORD_SIZE_IN_BITS == 64 +word64ToInt64 (W64# i) = I64# (word2Int# i) +#else +word64ToInt64 (W64# i) = I64# (word64ToInt64# i) +#endif + +int64ToWord64 :: Int64 -> Word64 +#if WORD_SIZE_IN_BITS == 64 +int64ToWord64 (I64# i) = W64# (int2Word# i) +#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 +word64ToWord32s (W64# w64) = Word32x2 (W32# (wordToWord32Compat# (uncheckedShiftRL# w64 32#))) (W32# (narrow32WordCompat# w64)) +#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) diff --git a/Basement/Numerical/Multiplicative.hs b/Basement/Numerical/Multiplicative.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Multiplicative.hs @@ -0,0 +1,326 @@ +{-# 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 diff --git a/Basement/Numerical/Number.hs b/Basement/Numerical/Number.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Number.hs @@ -0,0 +1,123 @@ +{-# 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 diff --git a/Basement/Numerical/Subtractive.hs b/Basement/Numerical/Subtractive.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Subtractive.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE CPP, UndecidableInstances #-} +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.-) diff --git a/Basement/PrimType.hs b/Basement/PrimType.hs new file mode 100644 --- /dev/null +++ b/Basement/PrimType.hs @@ -0,0 +1,763 @@ +-- Module : Basement.PrimType +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 #-} diff --git a/Basement/Runtime.hs b/Basement/Runtime.hs new file mode 100644 --- /dev/null +++ b/Basement/Runtime.hs @@ -0,0 +1,31 @@ +-- | +-- 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 #-} diff --git a/Basement/Show.hs b/Basement/Show.hs new file mode 100644 --- /dev/null +++ b/Basement/Show.hs @@ -0,0 +1,14 @@ +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 diff --git a/Basement/Sized/Block.hs b/Basement/Sized/Block.hs new file mode 100644 --- /dev/null +++ b/Basement/Sized/Block.hs @@ -0,0 +1,278 @@ +-- | +-- 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 diff --git a/Basement/Sized/List.hs b/Basement/Sized/List.hs new file mode 100644 --- /dev/null +++ b/Basement/Sized/List.hs @@ -0,0 +1,384 @@ +-- | +-- Module : Basement.Sized.List +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Basement/Sized/UVect.hs b/Basement/Sized/UVect.hs new file mode 100644 --- /dev/null +++ b/Basement/Sized/UVect.hs @@ -0,0 +1,159 @@ +{-# 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) diff --git a/Basement/Sized/Vect.hs b/Basement/Sized/Vect.hs new file mode 100644 --- /dev/null +++ b/Basement/Sized/Vect.hs @@ -0,0 +1,161 @@ +{-# 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) diff --git a/Basement/String.hs b/Basement/String.hs new file mode 100644 --- /dev/null +++ b/Basement/String.hs @@ -0,0 +1,1465 @@ +-- | +-- Module : Basement.String +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A String type backed by a UTF8 encoded byte array and all the necessary +-- functions to manipulate the string. +-- +-- You can think of String as a specialization of a byte array that +-- have element of type Char. +-- +-- The String data must contain UTF8 valid data. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.String + ( String(..) + , MutableString(..) + , create + , replicate + , length + -- * Binary conversion + , Encoding(..) + , fromBytes + , fromChunkBytes + , fromBytesUnsafe + , fromBytesLenient + , toBytes + , mutableValidate + , copy + , ValidationFailure(..) + , index + , null + , drop + , take + , splitAt + , revDrop + , revTake + , revSplitAt + , splitOn + , sub + , elem + , indices + , intersperse + , span + , spanEnd + , break + , breakEnd + , breakElem + , breakLine + , dropWhile + , singleton + , charMap + , snoc + , cons + , unsnoc + , uncons + , find + , findIndex + , sortBy + , filter + , reverse + , replace + , builderAppend + , builderBuild + , builderBuild_ + , readInteger + , readIntegral + , readNatural + , readDouble + , readRational + , readFloatingExact + , upper + , lower + , caseFold + , isPrefixOf + , isSuffixOf + , isInfixOf + , stripPrefix + , stripSuffix + , all + , any + -- * Legacy utility + , lines + , words + , toBase64 + , toBase64URL + , toBase64OpenBSD + ) where + +import Basement.UArray (UArray) +import qualified Basement.UArray as Vec +import qualified Basement.UArray as C +import qualified Basement.UArray.Mutable as MVec +import Basement.Block.Mutable (Block(..), MutableBlock(..)) +import qualified Basement.Block.Mutable as MBLK +import Basement.Compat.Bifunctor +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Compat.MonadTrans +import Basement.Compat.Primitive +import Basement.Types.OffsetSize +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Numerical.Multiplicative +import Basement.Numerical.Number +import Basement.Cast +import Basement.Monad +import Basement.PrimType +import Basement.FinalPtr +import Basement.IntegralConv +import Basement.Floating +import Basement.MutableBuilder +import Basement.String.CaseMapping (upperMapping, lowerMapping, foldMapping) +import Basement.UTF8.Table +import Basement.UTF8.Helper +import Basement.UTF8.Base +import Basement.UTF8.Types +import Basement.UArray.Base as C (onBackendPrim, onBackend, onBackendPure, offset, ValidRange(..), offsetsValidRange, MUArray(..), MUArrayBackend(..)) +import Basement.Alg.Class (Indexable) +import qualified Basement.Alg.UTF8 as UTF8 +import qualified Basement.Alg.String as Alg +import Basement.Types.Char7 (Char7(..), c7Upper, c7Lower) +import qualified Basement.Types.Char7 as Char7 +import Basement.HeadHackageUtils +import GHC.Prim +import GHC.ST +import GHC.Types +import GHC.Word +#if MIN_VERSION_base(4,9,0) +import GHC.Char +#endif + + -- temporary +import qualified Data.List +import Data.Ratio +import Data.Char (toUpper, toLower) +import qualified Prelude + +import qualified Basement.String.Encoding.Encoding as Encoder +import qualified Basement.String.Encoding.ASCII7 as Encoder +import qualified Basement.String.Encoding.UTF16 as Encoder +import qualified Basement.String.Encoding.UTF32 as Encoder +import qualified Basement.String.Encoding.ISO_8859_1 as Encoder + +-- | UTF8 Encoder +data EncoderUTF8 = EncoderUTF8 + +instance Encoder.Encoding EncoderUTF8 where + type Unit EncoderUTF8 = Word8 + type Error EncoderUTF8 = ValidationFailure + encodingNext _ = \ofs -> Right . nextWithIndexer ofs + encodingWrite _ = writeWithBuilder + +-- | Validate a bytearray for UTF8'ness +-- +-- On success Nothing is returned +-- On Failure the position along with the failure reason +validate :: UArray Word8 + -> Offset8 + -> CountOf Word8 + -> (Offset8, Maybe ValidationFailure) +validate array ofsStart sz = C.unsafeDewrap goBa goAddr array + where + unTranslateOffset start = first (\e -> e `offsetSub` start) + goBa ba start = + unTranslateOffset start $ Alg.validate (start+end) ba (start + ofsStart) + goAddr ptr@(Ptr !_) start = + pure $ unTranslateOffset start $ Alg.validate (start+end) ptr (ofsStart + start) + end = ofsStart `offsetPlusE` sz + +-- | Similar to 'validate' but works on a 'MutableByteArray' +mutableValidate :: PrimMonad prim + => MVec.MUArray Word8 (PrimState prim) + -> Offset Word8 + -> CountOf Word8 + -> prim (Offset Word8, Maybe ValidationFailure) +mutableValidate mba ofsStart sz = do + loop ofsStart + where + end = ofsStart `offsetPlusE` sz + + loop ofs + | ofs > end = error "mutableValidate: internal error: went pass offset" + | ofs == end = return (end, Nothing) + | otherwise = do + r <- one ofs + case r of + (nextOfs, Nothing) -> loop nextOfs + (pos, Just failure) -> return (pos, Just failure) + + one pos = do + h <- StepASCII <$> Vec.unsafeRead mba pos + let nbConts = getNbBytes h + if nbConts == 0xff + then return (pos, Just InvalidHeader) + else if pos + 1 + Offset nbConts > end + then return (pos, Just MissingByte) + else do + case nbConts of + 0 -> return (pos + 1, Nothing) + 1 -> do + c1 <- Vec.unsafeRead mba (pos + 1) + if isContinuation c1 + then return (pos + 2, Nothing) + else return (pos, Just InvalidContinuation) + 2 -> do + c1 <- Vec.unsafeRead mba (pos + 1) + c2 <- Vec.unsafeRead mba (pos + 2) + if isContinuation c1 && isContinuation c2 + then return (pos + 3, Nothing) + else return (pos, Just InvalidContinuation) + 3 -> do + c1 <- Vec.unsafeRead mba (pos + 1) + c2 <- Vec.unsafeRead mba (pos + 2) + c3 <- Vec.unsafeRead mba (pos + 3) + if isContinuation c1 && isContinuation c2 && isContinuation c3 + then return (pos + 4, Nothing) + else return (pos, Just InvalidContinuation) + _ -> error "internal error" + +nextWithIndexer :: (Offset Word8 -> Word8) + -> Offset Word8 + -> (Char, Offset Word8) +nextWithIndexer getter off = + case getNbBytes# (word8ToWordCompat# h) of + 0# -> (toChar (word8ToWordCompat# h), off + 1) + 1# -> (toChar (decode2 (getter $ off + 1)), off + 2) + 2# -> (toChar (decode3 (getter $ off + 1) (getter $ off + 2)), off + 3) + 3# -> (toChar (decode4 (getter $ off + 1) (getter $ off + 2) (getter $ off + 3)) + , off + 4) + r -> error ("next: internal error: invalid input: " <> show (I# r) <> " " <> show (W# (word8ToWordCompat# h))) + where + !(W8# h) = getter off + + toChar :: Word# -> Char + toChar w = C# (chr# (word2Int# w)) + + decode2 :: Word8 -> Word# + decode2 (W8# c1) = + or# (uncheckedShiftL# (and# (word8ToWordCompat# h) 0x1f##) 6#) + (and# (word8ToWordCompat# c1) 0x3f##) + + decode3 :: Word8 -> Word8 -> Word# + decode3 (W8# c1) (W8# c2) = + or# (uncheckedShiftL# (and# (word8ToWordCompat# h) 0xf##) 12#) + (or# (uncheckedShiftL# (and# (word8ToWordCompat# c1) 0x3f##) 6#) + (and# (word8ToWordCompat# c2) 0x3f##)) + + decode4 :: Word8 -> Word8 -> Word8 -> Word# + decode4 (W8# c1) (W8# c2) (W8# c3) = + or# (uncheckedShiftL# (and# (word8ToWordCompat# h) 0x7##) 18#) + (or# (uncheckedShiftL# (and# (word8ToWordCompat# c1) 0x3f##) 12#) + (or# (uncheckedShiftL# (and# (word8ToWordCompat# c2) 0x3f##) 6#) + (and# (word8ToWordCompat# c3) 0x3f##)) + ) + +writeWithBuilder :: (PrimMonad st, Monad st) + => Char + -> Builder (UArray Word8) (MVec.MUArray Word8) Word8 st err () +writeWithBuilder 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 = Vec.builderAppend (W8# (wordToWord8Compat# x)) + + encode2 = do + let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## + x2 = toContinuation x + Vec.builderAppend (W8# (wordToWord8Compat# x1)) >> Vec.builderAppend (W8# (wordToWord8Compat# x2)) + + encode3 = do + let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## + x2 = toContinuation (uncheckedShiftRL# x 6#) + x3 = toContinuation x + Vec.builderAppend (W8# (wordToWord8Compat# x1)) >> Vec.builderAppend (W8# (wordToWord8Compat# x2)) >> Vec.builderAppend (W8# (wordToWord8Compat# x3)) + + encode4 = do + let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## + x2 = toContinuation (uncheckedShiftRL# x 12#) + x3 = toContinuation (uncheckedShiftRL# x 6#) + x4 = toContinuation x + Vec.builderAppend (W8# (wordToWord8Compat# x1)) >> Vec.builderAppend (W8# (wordToWord8Compat# x2)) >> Vec.builderAppend (W8# (wordToWord8Compat# x3)) >> Vec.builderAppend (W8# (wordToWord8Compat# x4)) + + toContinuation :: Word# -> Word# + toContinuation w = or# (and# w 0x3f##) 0x80## + +writeUTF8Char :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> UTF8Char -> prim () +writeUTF8Char (MutableString mba) i (UTF8_1 x1) = + Vec.unsafeWrite mba i x1 +writeUTF8Char (MutableString mba) i (UTF8_2 x1 x2) = do + Vec.unsafeWrite mba i x1 + Vec.unsafeWrite mba (i+1) x2 +writeUTF8Char (MutableString mba) i (UTF8_3 x1 x2 x3) = do + Vec.unsafeWrite mba i x1 + Vec.unsafeWrite mba (i+1) x2 + Vec.unsafeWrite mba (i+2) x3 +writeUTF8Char (MutableString mba) i (UTF8_4 x1 x2 x3 x4) = do + Vec.unsafeWrite mba i x1 + Vec.unsafeWrite mba (i+1) x2 + Vec.unsafeWrite mba (i+2) x3 + Vec.unsafeWrite mba (i+3) x4 +{-# INLINE writeUTF8Char #-} + +unsafeFreezeShrink :: PrimMonad prim => MutableString (PrimState prim) -> CountOf Word8 -> prim String +unsafeFreezeShrink (MutableString mba) s = String <$> Vec.unsafeFreezeShrink mba s +{-# INLINE unsafeFreezeShrink #-} + +------------------------------------------------------------------------ +-- real functions + +-- | Check if a String is null +null :: String -> Bool +null (String ba) = C.length ba == 0 + +-- we don't know in constant time the count of character in string, +-- however if we estimate bounds of what N characters would +-- take in space (between N and N*4). If the count is thus bigger than +-- the number of bytes, then we know for sure that it's going to +-- be out of bounds +countCharMoreThanBytes :: CountOf Char -> UArray Word8 -> Bool +countCharMoreThanBytes (CountOf chars) ba = chars >= bytes + where (CountOf bytes) = C.length ba + +-- | Create a string composed of a number @n of Chars (Unicode code points). +-- +-- if the input @s contains less characters than required, then the input string is returned. +take :: CountOf Char -> String -> String +take n s@(String ba) + | n <= 0 = mempty + | countCharMoreThanBytes n ba = s + | otherwise = String $ Vec.unsafeTake (offsetAsSize $ indexN n s) ba + +-- | Create a string with the remaining Chars after dropping @n Chars from the beginning +drop :: CountOf Char -> String -> String +drop n s@(String ba) + | n <= 0 = s + | countCharMoreThanBytes n ba = mempty + | otherwise = String $ Vec.drop (offsetAsSize $ indexN n s) ba + +-- | Split a string at the Offset specified (in Char) returning both +-- the leading part and the remaining part. +splitAt :: CountOf Char -> String -> (String, String) +splitAt n s@(String ba) + | n <= 0 = (mempty, s) + | countCharMoreThanBytes n ba = (s, mempty) + | otherwise = + let (v1,v2) = C.splitAt (offsetAsSize $ indexN n s) ba + in (String v1, String v2) + +-- | Return the offset (in bytes) of the N'th sequence in an UTF8 String +indexN :: CountOf Char -> String -> Offset Word8 +indexN !n (String ba) = Vec.unsafeDewrap goVec goAddr ba + where + goVec :: Block Word8 -> Offset Word8 -> Offset Word8 + goVec (Block !ma) !start = loop start 0 + where + !len = start `offsetPlusE` Vec.length ba + loop :: Offset Word8 -> Offset Char -> Offset Word8 + loop !idx !i + | idx >= len || i .==# n = sizeAsOffset (idx - start) + | otherwise = loop (idx `offsetPlusE` d) (i + Offset 1) + where d = skipNextHeaderValue (primBaIndex ma idx) + {-# INLINE goVec #-} + + goAddr :: Ptr Word8 -> Offset Word8 -> ST s (Offset Word8) + goAddr (Ptr ptr) !start = return $ loop start (Offset 0) + where + !len = start `offsetPlusE` Vec.length ba + loop :: Offset Word8 -> Offset Char -> Offset Word8 + loop !idx !i + | idx >= len || i .==# n = sizeAsOffset (idx - start) + | otherwise = loop (idx `offsetPlusE` d) (i + Offset 1) + where d = skipNextHeaderValue (primAddrIndex ptr idx) + {-# INLINE goAddr #-} +{-# INLINE indexN #-} + +-- inverse a CountOf that is specified from the end (e.g. take n Chars from the end) +-- +-- rev{Take,Drop,SplitAt} TODO optimise: +-- we can process the string from the end using a skipPrev instead of getting the length +countFromStart :: String -> CountOf Char -> CountOf Char +countFromStart s sz@(CountOf sz') + | sz >= len = CountOf 0 + | otherwise = CountOf (len' - sz') + where len@(CountOf len') = length s + +-- | Similar to 'take' but from the end +revTake :: CountOf Char -> String -> String +revTake n v = drop (countFromStart v n) v + +-- | Similar to 'drop' but from the end +revDrop :: CountOf Char -> String -> String +revDrop n v = take (countFromStart v n) v + +-- | Similar to 'splitAt' but from the end +revSplitAt :: CountOf Char -> String -> (String, String) +revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n + +-- | Split on the input string using the predicate as separator +-- +-- e.g. +-- +-- > splitOn (== ',') "," == ["",""] +-- > splitOn (== ',') ",abc," == ["","abc",""] +-- > splitOn (== ':') "abc" == ["abc"] +-- > splitOn (== ':') "abc::def" == ["abc","","def"] +-- > splitOn (== ':') "::abc::def" == ["","","abc","","def"] +-- +splitOn :: (Char -> Bool) -> String -> [String] +splitOn predicate s + | sz == CountOf 0 = [mempty] + | otherwise = loop azero azero + where + !sz = size s + end = azero `offsetPlusE` sz + loop prevIdx idx + | idx == end = [sub s prevIdx idx] + | otherwise = + let !(Step c idx') = next s idx + in if predicate c + then sub s prevIdx idx : loop idx' idx' + else loop prevIdx idx' + +-- | Internal call to make a substring given offset in bytes. +-- +-- This is unsafe considering that one can create a substring +-- starting and/or ending on the middle of a UTF8 sequence. +sub :: String -> Offset8 -> Offset8 -> String +sub (String ba) start end = String $ Vec.sub ba start end + +-- | Internal call to split at a given index in offset of bytes. +-- +-- This is unsafe considering that one can split in the middle of a +-- UTF8 sequence, so use with care. +splitIndex :: Offset8 -> String -> (String, String) +splitIndex idx (String ba) = (String v1, String v2) + where (v1,v2) = C.splitAt (offsetAsSize idx) ba + +-- | Break a string into 2 strings at the location where the predicate return True +break :: (Char -> Bool) -> String -> (String, String) +break predicate s@(String ba) = runST $ Vec.unsafeIndexer ba go + where + !sz = size s + end = azero `offsetPlusE` sz + + go :: (Offset Word8 -> Word8) -> ST st (String, String) + go getIdx = loop (Offset 0) + where + !nextI = nextWithIndexer getIdx + loop idx + | idx == end = return (s, mempty) + | otherwise = do + let (c, idx') = nextI idx + case predicate c of + True -> return $ splitIndex idx s + False -> loop idx' + {-# INLINE loop #-} +{-# INLINE [2] break #-} + +breakEnd :: (Char -> Bool) -> String -> (String, String) +breakEnd predicate s@(String arr) + | k == end = (s, mempty) + | otherwise = splitIndex (k `offsetSub` start) s + where + k = C.onBackend goVec (\_ -> pure . goAddr) arr + (C.ValidRange !start !end) = offsetsValidRange arr + goVec ba@(Block !_) = let k = Alg.revFindIndexPredicate predicate ba start end + in if k == end then end else UTF8.nextSkip ba k + goAddr ptr@(Ptr !_) = + let k = Alg.revFindIndexPredicate predicate ptr start end + in if k == end then end else UTF8.nextSkip ptr k +{-# INLINE [2] breakEnd #-} + +#if MIN_VERSION_base(4,9,0) +{-# RULES "break (== 'c')" [3] forall c . break (eqChar c) = breakElem c #-} +#else +{-# RULES "break (== 'c')" [3] forall c . break (== c) = breakElem c #-} +#endif + +-- | Break a string into 2 strings at the first occurence of the character +breakElem :: Char -> String -> (String, String) +breakElem !el s@(String ba) + | sz == 0 = (mempty, mempty) + | otherwise = + case asUTF8Char el of + UTF8_1 w -> let !(v1,v2) = Vec.breakElem w ba in (String v1, String v2) + _ -> runST $ Vec.unsafeIndexer ba go + where + sz = size s + end = azero `offsetPlusE` sz + + go :: (Offset Word8 -> Word8) -> ST st (String, String) + go getIdx = loop (Offset 0) + where + !nextI = nextWithIndexer getIdx + loop idx + | idx == end = return (s, mempty) + | otherwise = do + let (c, idx') = nextI idx + case el == c of + True -> return $ splitIndex idx s + False -> loop idx' + +-- | Same as break but cut on a line feed with an optional carriage return. +-- +-- This is the same operation as 'breakElem LF' dropping the last character of the +-- string if it's a CR. +-- +-- Also for efficiency reason (streaming), it returns if the last character was a CR character. +breakLine :: String -> Either Bool (String, String) +breakLine (String arr) = bimap String String <$> Vec.breakLine arr + +-- | Apply a @predicate@ to the string to return the longest prefix that satisfy the predicate and +-- the remaining +span :: (Char -> Bool) -> String -> (String, String) +span predicate s = break (not . predicate) s + +-- | Apply a @predicate@ to the string to return the longest suffix that satisfy the predicate and +-- the remaining +spanEnd :: (Char -> Bool) -> String -> (String, String) +spanEnd predicate s = breakEnd (not . predicate) s + +-- | Drop character from the beginning while the predicate is true +dropWhile :: (Char -> Bool) -> String -> String +dropWhile predicate = snd . break (not . predicate) + +-- | Return whereas the string contains a specific character or not +elem :: Char -> String -> Bool +elem !el s@(String ba) = + case asUTF8Char el of + UTF8_1 w -> Vec.elem w ba + _ -> runST $ Vec.unsafeIndexer ba go + where + sz = size s + end = azero `offsetPlusE` sz + + go :: (Offset Word8 -> Word8) -> ST st Bool + go getIdx = loop (Offset 0) + where + !nextI = nextWithIndexer getIdx + loop !idx + | idx == end = return False + | otherwise = do + let (c, idx') = nextI idx + case el == c of + True -> return True + False -> loop idx' + +-- | Intersperse the character @sep@ between each character in the string +-- +-- > intersperse ' ' "Hello Foundation" +-- "H e l l o F o u n d a t i o n" +intersperse :: Char -> String -> String +intersperse sep src = case length src - 1 of + Nothing -> src + Just 0 -> src + Just gaps -> runST $ unsafeCopyFrom src dstBytes go + where + lastSrcI :: Offset Char + lastSrcI = 0 `offsetPlusE` gaps + dstBytes = (size src :: CountOf Word8) + (gaps `scale` charToBytes (fromEnum sep)) + + go :: String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8) + go src' srcI srcIdx dst dstIdx + | srcI == lastSrcI = do + nextDstIdx <- write dst dstIdx c + return (nextSrcIdx, nextDstIdx) + | otherwise = do + nextDstIdx <- write dst dstIdx c + nextDstIdx' <- write dst nextDstIdx sep + return (nextSrcIdx, nextDstIdx') + where + !(Step c nextSrcIdx) = next src' srcIdx + +-- | Allocate a new @String@ with a fill function that has access to the characters of +-- the source @String@. +unsafeCopyFrom :: String -- ^ Source string + -> CountOf Word8 -- ^ Length of the destination string in bytes + -> (String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8)) + -- ^ Function called for each character in the source String + -> ST s String -- ^ Returns the filled new string +unsafeCopyFrom src dstBytes f = new dstBytes >>= fill (Offset 0) (Offset 0) (Offset 0) f >>= freeze + where + srcLen = length src + end = Offset 0 `offsetPlusE` srcLen + fill srcI srcIdx dstIdx f' dst' + | srcI == end = return dst' + | otherwise = do (nextSrcIdx, nextDstIdx) <- f' src srcI srcIdx dst' dstIdx + fill (srcI + Offset 1) nextSrcIdx nextDstIdx f' dst' + +-- | Length of a String using CountOf +-- +-- this size is available in o(n) +length :: String -> CountOf Char +length (String arr) + | start == end = 0 + | otherwise = C.onBackend goVec (\_ -> pure . goAddr) arr + where + (C.ValidRange !start !end) = offsetsValidRange arr + goVec ma = UTF8.length ma start end + goAddr ptr = UTF8.length ptr start end + +-- | Replicate a character @c@ @n@ times to create a string of length @n@ +replicate :: CountOf Char -> Char -> String +replicate (CountOf n) c = runST (new nbBytes >>= fill) + where + nbBytes = scale (cast n :: Word) sz + sz = charToBytes (fromEnum c) + fill :: PrimMonad prim => MutableString (PrimState prim) -> prim String + fill ms = loop (Offset 0) + where + loop idx + | idx .==# nbBytes = freeze ms + | otherwise = write ms idx c >>= loop + +-- | Copy the String +-- +-- The slice of memory is copied to a new slice, making the new string +-- independent from the original string.. +copy :: String -> String +copy (String s) = String (Vec.copy s) + +-- | Create a single element String +singleton :: Char -> String +singleton c = runST $ do + ms <- new nbBytes + _ <- write ms (Offset 0) c + freeze ms + where + !nbBytes = charToBytes (fromEnum c) + +-- | Unsafely create a string of up to @sz@ bytes. +-- +-- The callback @f@ needs to return the number of bytes filled in the underlaying +-- bytes buffer. No check is made on the callback return values, and if it's not +-- contained without the bounds, bad things will happen. +create :: PrimMonad prim => CountOf Word8 -> (MutableString (PrimState prim) -> prim (Offset Word8)) -> prim String +create sz f = do + ms <- new sz + filled <- f ms + if filled .==# sz + then freeze ms + else do + s <- freeze ms + let (String ba) = s + pure $ String $ C.take (offsetAsSize filled) ba + +-- | Monomorphically map the character in a string and return the transformed one +charMap :: (Char -> Char) -> String -> String +charMap f src + | srcSz == 0 = mempty + | otherwise = + let !(elems, nbBytes) = allocateAndFill [] (Offset 0) (CountOf 0) + in runST $ do + dest <- new nbBytes + copyLoop dest elems (Offset 0 `offsetPlusE` nbBytes) + freeze dest + where + !srcSz = size src + srcEnd = azero `offsetPlusE` srcSz + + allocateAndFill :: [(String, CountOf Word8)] + -> Offset8 + -> CountOf Word8 + -> ([(String,CountOf Word8)], CountOf Word8) + allocateAndFill acc idx bytesWritten + | idx == srcEnd = (acc, bytesWritten) + | otherwise = + let (el@(_,addBytes), idx') = runST $ do + -- make sure we allocate at least 4 bytes for the destination for the last few bytes + -- otherwise allocating less would bring the danger of spinning endlessly + -- and never succeeding. + let !diffBytes = srcEnd - idx + !allocatedBytes = if diffBytes <= CountOf 4 then CountOf 4 else diffBytes + ms <- new allocatedBytes + (dstIdx, srcIdx) <- fill ms allocatedBytes idx + s <- freeze ms + return ((s, dstIdx), srcIdx) + in allocateAndFill (el : acc) idx' (bytesWritten + addBytes) + + fill :: PrimMonad prim + => MutableString (PrimState prim) + -> CountOf Word8 + -> Offset8 + -> prim (CountOf Word8, Offset8) + fill mba dsz srcIdxOrig = + loop (Offset 0) srcIdxOrig + where + endDst = (Offset 0) `offsetPlusE` dsz + loop dstIdx srcIdx + | srcIdx == srcEnd = return (offsetAsSize dstIdx, srcIdx) + | dstIdx == endDst = return (offsetAsSize dstIdx, srcIdx) + | otherwise = + let !(Step c srcIdx') = next src srcIdx + c' = f c -- the mapped char + !nbBytes = charToBytes (fromEnum c') + in -- check if we have room in the destination buffer + if dstIdx `offsetPlusE` nbBytes <= sizeAsOffset dsz + then do dstIdx' <- write mba dstIdx c' + loop dstIdx' srcIdx' + else return (offsetAsSize dstIdx, srcIdx) + + copyLoop _ [] (Offset 0) = return () + copyLoop _ [] n = error ("charMap invalid: " <> show n) + copyLoop ms@(MutableString mba) ((String ba, sz):xs) end = do + let start = end `offsetMinusE` sz + Vec.unsafeCopyAtRO mba start ba (Offset 0) sz + copyLoop ms xs start + +-- | Append a Char to the end of the String and return this new String +snoc :: String -> Char -> String +snoc s@(String ba) c + | len == CountOf 0 = singleton c + | otherwise = runST $ do + ms <- new (len + nbBytes) + let (MutableString mba) = ms + Vec.unsafeCopyAtRO mba (Offset 0) ba (Offset 0) len + _ <- write ms (azero `offsetPlusE` len) c + freeze ms + where + !len = size s + !nbBytes = charToBytes (fromEnum c) + +-- | Prepend a Char to the beginning of the String and return this new String +cons :: Char -> String -> String +cons c s@(String ba) + | len == CountOf 0 = singleton c + | otherwise = runST $ do + ms <- new (len + nbBytes) + let (MutableString mba) = ms + idx <- write ms (Offset 0) c + Vec.unsafeCopyAtRO mba idx ba (Offset 0) len + freeze ms + where + !len = size s + !nbBytes = charToBytes (fromEnum c) + +-- | Extract the String stripped of the last character and the last character if not empty +-- +-- If empty, Nothing is returned +unsnoc :: String -> Maybe (String, Char) +unsnoc s@(String arr) + | sz == 0 = Nothing + | otherwise = + let !(StepBack c idx) = prev s (sizeAsOffset sz) + in Just (String $ Vec.take (offsetAsSize idx) arr, c) + where + sz = size s + +-- | Extract the First character of a string, and the String stripped of the first character. +-- +-- If empty, Nothing is returned +uncons :: String -> Maybe (Char, String) +uncons s@(String ba) + | null s = Nothing + | otherwise = + let !(Step c idx) = next s azero + in Just (c, String $ Vec.drop (offsetAsSize idx) ba) + +-- | Look for a predicate in the String and return the matched character, if any. +find :: (Char -> Bool) -> String -> Maybe Char +find predicate s = loop (Offset 0) + where + !sz = size s + end = Offset 0 `offsetPlusE` sz + loop idx + | idx == end = Nothing + | otherwise = + let !(Step c idx') = next s idx + in case predicate c of + True -> Just c + False -> loop idx' + +-- | Sort the character in a String using a specific sort function +-- +-- TODO: optimise not going through a list +sortBy :: (Char -> Char -> Ordering) -> String -> String +sortBy sortF s = fromList $ Data.List.sortBy sortF $ toList s -- FIXME for tests + +-- | Filter characters of a string using the predicate +filter :: (Char -> Bool) -> String -> String +filter predicate (String arr) = runST $ do + (finalSize, dst) <- newNative sz $ \(MutableBlock mba) -> + C.onBackendPrim (\ba@(Block !_) -> Alg.copyFilter predicate sz mba ba start) + (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> Alg.copyFilter predicate sz mba ptr start) + arr + freezeShrink finalSize dst + where + !sz = C.length arr + !start = C.offset arr + +-- | Reverse a string +reverse :: String -> String +reverse (String arr) = runST $ do + s <- newNative_ (C.length arr) $ \(MutableBlock mba) -> + C.onBackendPrim + (\ba@(Block !_) -> UTF8.reverse mba 0 ba start end) + (\fptr -> withFinalPtr fptr $ \ptr@(Ptr !_) -> UTF8.reverse mba 0 ptr start end) + arr + freeze s + where + !(C.ValidRange start end) = C.offsetsValidRange arr + +-- | Finds where are the insertion points when we search for a `needle` +-- within an `haystack`. +indices :: String -> String -> [Offset8] +indices (String ned) (String hy) = Vec.indices ned hy + +-- | Replace all the occurrencies of `needle` with `replacement` in +-- the `haystack` string. +replace :: String -> String -> String -> String +replace (String needle) (String replacement) (String haystack) = + String $ Vec.replace needle replacement haystack + +-- | Return the nth character in a String +-- +-- Compared to an array, the string need to be scanned from the beginning +-- since the UTF8 encoding is variable. +index :: String -> Offset Char -> Maybe Char +index s n + | ofs >= end = Nothing + | otherwise = + let (Step !c _) = next s ofs + in Just c + where + !nbBytes = size s + end = 0 `offsetPlusE` nbBytes + ofs = indexN (offsetAsSize n) s + +-- | Return the index in unit of Char of the first occurence of the predicate returning True +-- +-- If not found, Nothing is returned +findIndex :: (Char -> Bool) -> String -> Maybe (Offset Char) +findIndex predicate s = loop 0 0 + where + !sz = size s + loop ofs idx + | idx .==# sz = Nothing + | otherwise = + let !(Step c idx') = next s idx + in case predicate c of + True -> Just ofs + False -> loop (ofs+1) idx' + +-- | Various String Encoding that can be use to convert to and from bytes +data Encoding + = ASCII7 + | UTF8 + | UTF16 + | UTF32 + | ISO_8859_1 + deriving (Typeable, Data, Eq, Ord, Show, Enum, Bounded) + +fromEncoderBytes :: ( Encoder.Encoding encoding + , PrimType (Encoder.Unit encoding) + ) + => encoding + -> UArray Word8 + -> (String, Maybe ValidationFailure, UArray Word8) +fromEncoderBytes enc bytes = + case runST $ Encoder.convertFromTo enc EncoderUTF8 (Vec.recast bytes) of + -- TODO: Don't swallow up specific error (second element of pair) + -- TODO: Confused why all this recasting is necessary. I "typed hole"-ed my way to get this function to compile. Feels like there should be a cleaner method. + Left (off, _) -> + let (b1, b2) = Vec.splitAt (offsetAsSize off) (Vec.recast bytes) + in (String $ Vec.recast b1, Just BuildingFailure, Vec.recast b2) + Right converted -> (String converted, Nothing, mempty) + +-- | Convert a ByteArray to a string assuming a specific encoding. +-- +-- It returns a 3-tuple of: +-- +-- * The string that has been succesfully converted without any error +-- * An optional validation error +-- * The remaining buffer that hasn't been processed (either as a result of an error, or because the encoded sequence is not fully available) +-- +-- Considering a stream of data that is fetched chunk by chunk, it's valid to assume +-- that some sequence might fall in a chunk boundary. When converting chunks, +-- if the error is Nothing and the remaining buffer is not empty, then this buffer +-- need to be prepended to the next chunk +fromBytes :: Encoding -> UArray Word8 -> (String, Maybe ValidationFailure, UArray Word8) +fromBytes ASCII7 bytes = fromEncoderBytes Encoder.ASCII7 bytes +fromBytes ISO_8859_1 bytes = fromEncoderBytes Encoder.ISO_8859_1 bytes +fromBytes UTF16 bytes = fromEncoderBytes Encoder.UTF16 bytes +fromBytes UTF32 bytes = fromEncoderBytes Encoder.UTF32 bytes +fromBytes UTF8 bytes + | C.null bytes = (mempty, Nothing, mempty) + | otherwise = + case validate bytes (Offset 0) (C.length bytes) of + (_, Nothing) -> (fromBytesUnsafe bytes, Nothing, mempty) + (pos, Just vf) -> + let (b1, b2) = C.splitAt (offsetAsSize pos) bytes + in (fromBytesUnsafe b1, toErr vf, b2) + where + toErr MissingByte = Nothing + toErr InvalidHeader = Just InvalidHeader + toErr InvalidContinuation = Just InvalidContinuation + toErr BuildingFailure = Just BuildingFailure + +-- | Convert a UTF8 array of bytes to a String. +-- +-- If there's any error in the stream, it will automatically +-- insert replacement bytes to replace invalid sequences. +-- +-- In the case of sequence that fall in the middle of 2 chunks, +-- the remaining buffer is supposed to be preprended to the +-- next chunk, and resume the parsing. +fromBytesLenient :: UArray Word8 -> (String, UArray Word8) +fromBytesLenient bytes + | C.null bytes = (mempty, mempty) + | otherwise = + case validate bytes (Offset 0) (C.length bytes) of + (_, Nothing) -> (fromBytesUnsafe bytes, mempty) + -- TODO: Should anything be done in the 'BuildingFailure' case? + (_, Just BuildingFailure) -> error "fromBytesLenient: FIXME!" + (pos, Just MissingByte) -> + let (b1,b2) = C.splitAt (offsetAsSize pos) bytes + in (fromBytesUnsafe b1, b2) + (pos, Just InvalidHeader) -> + let (b1,b2) = C.splitAt (offsetAsSize pos) bytes + (_,b3) = C.splitAt 1 b2 + (s3, r) = fromBytesLenient b3 + in (mconcat [fromBytesUnsafe b1,replacement, s3], r) + (pos, Just InvalidContinuation) -> + let (b1,b2) = C.splitAt (offsetAsSize pos) bytes + (_,b3) = C.splitAt 1 b2 + (s3, r) = fromBytesLenient b3 + in (mconcat [fromBytesUnsafe b1,replacement, s3], r) + where + -- This is the replacement character U+FFFD used for any invalid header or continuation + replacement :: String + !replacement = fromBytesUnsafe $ fromList [0xef,0xbf,0xbd] + +-- | Decode a stream of binary chunks containing UTF8 encoding in a list of valid String +-- +-- Chunk not necessarily contains a valid string, as +-- a UTF8 sequence could be split over 2 chunks. +fromChunkBytes :: [UArray Word8] -> [String] +fromChunkBytes l = loop l + where + loop [] = [] + loop [bytes] = + case validate bytes (Offset 0) (C.length bytes) of + (_, Nothing) -> [fromBytesUnsafe bytes] + (_, Just err) -> doErr err + loop (bytes:cs@(c1:c2)) = + case validate bytes (Offset 0) (C.length bytes) of + (_, Nothing) -> fromBytesUnsafe bytes : loop cs + (pos, Just MissingByte) -> + let (b1,b2) = C.splitAt (offsetAsSize pos) bytes + in fromBytesUnsafe b1 : loop ((b2 `mappend` c1) : c2) + (_, Just err) -> doErr err + doErr err = error ("fromChunkBytes: " <> show err) + +-- | Convert a Byte Array representing UTF8 data directly to a string without checking for UTF8 validity +-- +-- If the input contains invalid sequences, it will trigger runtime async errors when processing data. +-- +-- In doubt, use 'fromBytes' +fromBytesUnsafe :: UArray Word8 -> String +fromBytesUnsafe = String + +toEncoderBytes :: ( Encoder.Encoding encoding + , PrimType (Encoder.Unit encoding) + , Exception (Encoder.Error encoding) + ) + => encoding + -> UArray Word8 + -> UArray Word8 +toEncoderBytes enc bytes = Vec.recast $ + case runST $ Encoder.convertFromTo EncoderUTF8 enc bytes of + Left _ -> error "toEncoderBytes: FIXME!" + Right converted -> converted + +-- | Convert a String to a bytearray in a specific encoding +-- +-- if the encoding is UTF8, the underlying buffer is returned without extra allocation or any processing +-- +-- In any other encoding, some allocation and processing are done to convert. +toBytes :: Encoding -> String -> UArray Word8 +toBytes UTF8 (String bytes) = bytes +toBytes ASCII7 (String bytes) = toEncoderBytes Encoder.ASCII7 bytes +toBytes ISO_8859_1 (String bytes) = toEncoderBytes Encoder.ISO_8859_1 bytes +toBytes UTF16 (String bytes) = toEncoderBytes Encoder.UTF16 bytes +toBytes UTF32 (String bytes) = toEncoderBytes Encoder.UTF32 bytes + +-- | Split lines in a string using newline as separation. +-- +-- Note that carriage return preceding a newline are also strip for +-- maximum compatibility between Windows and Unix system. +lines :: String -> [String] +lines s = + case breakLine s of + Left _ -> [s] + Right (line,r) -> line : lines r + +-- | Split words in a string using spaces as separation +-- +-- > words "Hello Foundation" +-- [ "Hello", "Foundation" ] +words :: String -> [String] +words = fmap fromList . Prelude.words . toList + +-- | Append a character to a String builder +builderAppend :: PrimMonad state => Char -> Builder String MutableString Word8 state err () +builderAppend c = Builder $ State $ \(i, st, e) -> + if offsetAsSize i + nbBytes >= chunkSize st + then do + cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) + newChunk <- new (chunkSize st) + writeUTF8Char newChunk (Offset 0) utf8Char + return ((), (sizeAsOffset nbBytes, st { prevChunks = cur : prevChunks st + , prevChunksSize = offsetAsSize i + prevChunksSize st + , curChunk = newChunk + }, e)) + else do + writeUTF8Char (curChunk st) i utf8Char + return ((), (i + sizeAsOffset nbBytes, st, e)) + where + utf8Char = asUTF8Char c + nbBytes = numBytes utf8Char + +-- | Create a new String builder using chunks of @sizeChunksI@ +builderBuild :: PrimMonad m => Int -> Builder String MutableString Word8 m err () -> m (Either err String) +builderBuild sizeChunksI sb + | sizeChunksI <= 3 = builderBuild 64 sb + | otherwise = do + firstChunk <- new sizeChunks + (i, st, e) <- snd <$> runState (runBuilder sb) (Offset 0, BuildingState [] (CountOf 0) firstChunk sizeChunks, Nothing) + case e of + Just err -> return (Left err) + Nothing -> do + cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) + -- Build final array + let totalSize = prevChunksSize st + offsetAsSize i + final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze + return . Right . String $ final + where + sizeChunks = CountOf sizeChunksI + + fillFromEnd _ [] mba = return mba + fillFromEnd !end (String x:xs) mba = do + let sz = Vec.length x + let start = end `sizeSub` sz + Vec.unsafeCopyAtRO mba (sizeAsOffset start) x (Offset 0) sz + fillFromEnd start xs mba + +builderBuild_ :: PrimMonad m => Int -> Builder String MutableString Word8 m () () -> m String +builderBuild_ sizeChunksI sb = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI sb + +stringDewrap :: (Block Word8 -> Offset Word8 -> a) + -> (Ptr Word8 -> Offset Word8 -> ST s a) + -> String + -> a +stringDewrap withBa withPtr (String ba) = C.unsafeDewrap withBa withPtr ba +{-# INLINE stringDewrap #-} + +-- | Read an Integer from a String +-- +-- Consume an optional minus sign and many digits until end of string. +readIntegral :: (HasNegation i, IntegralUpsize Word8 i, Additive i, Multiplicative i, IsIntegral i) => String -> Maybe i +readIntegral str + | sz == 0 = Nothing + | otherwise = stringDewrap withBa (\ptr@(Ptr !_) -> pure . withPtr ptr) str + where + !sz = size str + withBa ba ofs = + let negativeSign = UTF8.expectAscii ba ofs 0x2d + startOfs = if negativeSign then succ ofs else ofs + in case decimalDigitsBA 0 ba endOfs startOfs of + (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc + _ -> Nothing + where !endOfs = ofs `offsetPlusE` sz + withPtr addr ofs = + let negativeSign = UTF8.expectAscii addr ofs 0x2d + startOfs = if negativeSign then succ ofs else ofs + in case decimalDigitsPtr 0 addr endOfs startOfs of + (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc + _ -> Nothing + where !endOfs = ofs `offsetPlusE` sz +{-# SPECIALISE readIntegral :: String -> Maybe Integer #-} +{-# SPECIALISE readIntegral :: String -> Maybe Int #-} + +readInteger :: String -> Maybe Integer +readInteger = readIntegral + +-- | Read a Natural from a String +-- +-- Consume many digits until end of string. +readNatural :: String -> Maybe Natural +readNatural str + | sz == 0 = Nothing + | otherwise = stringDewrap withBa (\ptr@(Ptr !_) -> pure . withPtr ptr) str + where + !sz = size str + withBa ba stringStart = + case decimalDigitsBA 0 ba eofs stringStart of + (# acc, True, endOfs #) | endOfs > stringStart -> Just acc + _ -> Nothing + where eofs = stringStart `offsetPlusE` sz + withPtr addr stringStart = + case decimalDigitsPtr 0 addr eofs stringStart of + (# acc, True, endOfs #) | endOfs > stringStart -> Just acc + _ -> Nothing + where eofs = stringStart `offsetPlusE` sz + +-- | Try to read a Double +readDouble :: String -> Maybe Double +readDouble s = + readFloatingExact s $ \isNegative integral floatingDigits mExponant -> + Just $ applySign isNegative $ case (floatingDigits, mExponant) of + (0, Nothing) -> naturalToDouble integral + (0, Just exponent) -> withExponant exponent $ naturalToDouble integral + (floating, Nothing) -> applyFloating floating $ naturalToDouble integral + (floating, Just exponent) -> withExponant exponent $ applyFloating floating $ naturalToDouble integral + where + applySign True = negate + applySign False = id + withExponant e v = v * doubleExponant 10 e + applyFloating digits n = n / (10 Prelude.^ digits) + +-- | Try to read a floating number as a Rational +-- +-- Note that for safety reason, only exponent between -10000 and 10000 is allowed +-- as otherwise DoS/OOM is very likely. if you don't want this behavior, +-- switching to a scientific type (not provided yet) that represent the +-- exponent separately is the advised solution. +readRational :: String -> Maybe Prelude.Rational +readRational s = + readFloatingExact s $ \isNegative integral floatingDigits mExponant -> + case mExponant of + Just exponent + | exponent < -10000 || exponent > 10000 -> Nothing + | otherwise -> Just $ modF isNegative integral % (10 Prelude.^ (cast floatingDigits - exponent)) + Nothing -> Just $ modF isNegative integral % (10 Prelude.^ floatingDigits) + where + modF True = negate . integralUpsize + modF False = integralUpsize + + +type ReadFloatingCallback a = Bool -- sign + -> Natural -- integral part + -> Word -- number of digits in floating section + -> Maybe Int -- optional integer representing exponent in base 10 + -> Maybe a + +-- | Read an Floating like number of the form: +-- +-- [ '-' ] [ '.' ] [ ( 'e' | 'E' ) [ '-' ] ] +-- +-- Call a function with: +-- +-- * A boolean representing if the number is negative +-- * The digits part represented as a single natural number (123.456 is represented as 123456) +-- * The number of digits in the fractional part (e.g. 123.456 => 3) +-- * The exponent if any +-- +-- The code is structured as a simple state machine that: +-- +-- * Optionally Consume a '-' sign +-- * Consume number for the integral part +-- * Optionally +-- * Consume '.' +-- * Consume remaining digits if not already end of string +-- * Optionally Consume a 'e' or 'E' follow by an optional '-' and a number +-- +readFloatingExact :: String -> ReadFloatingCallback a -> Maybe a +readFloatingExact str f + | sz == 0 = Nothing + | otherwise = stringDewrap withBa withPtr str + where + !sz = size str + + withBa ba stringStart = + let !isNegative = UTF8.expectAscii ba stringStart 0x2d + in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart) + where + eofs = stringStart `offsetPlusE` sz + consumeIntegral !isNegative startOfs = + case decimalDigitsBA 0 ba eofs startOfs of + (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.' + (# acc, False, endOfs #) | endOfs > startOfs -> + if UTF8.expectAscii ba endOfs 0x2e + then consumeFloat isNegative acc (endOfs + 1) + else consumeExponant isNegative acc 0 endOfs + _ -> Nothing + + consumeFloat isNegative integral startOfs = + case decimalDigitsBA integral ba eofs startOfs of + (# acc, True, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs + in f isNegative acc (cast diff) Nothing + (# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs + in consumeExponant isNegative acc (cast diff) endOfs + _ -> Nothing + + consumeExponant !isNegative !integral !floatingDigits !startOfs + | startOfs == eofs = f isNegative integral floatingDigits Nothing + | otherwise = + -- consume 'E' or 'e' + case UTF8.nextAscii ba startOfs of + StepASCII 0x45 -> consumeExponantSign (startOfs+1) + StepASCII 0x65 -> consumeExponantSign (startOfs+1) + _ -> Nothing + where + consumeExponantSign ofs + | ofs == eofs = Nothing + | otherwise = let exponentNegative = UTF8.expectAscii ba ofs 0x2d + in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs) + + consumeExponantNumber exponentNegative ofs = + case decimalDigitsBA 0 ba eofs ofs of + (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc) + _ -> Nothing + withPtr ptr@(Ptr !_) stringStart = pure $ + let !isNegative = UTF8.expectAscii ptr stringStart 0x2d + in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart) + where + eofs = stringStart `offsetPlusE` sz + consumeIntegral !isNegative startOfs = + case decimalDigitsPtr 0 ptr eofs startOfs of + (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.' + (# acc, False, endOfs #) | endOfs > startOfs -> + if UTF8.expectAscii ptr endOfs 0x2e + then consumeFloat isNegative acc (endOfs + 1) + else consumeExponant isNegative acc 0 endOfs + _ -> Nothing + + consumeFloat isNegative integral startOfs = + case decimalDigitsPtr integral ptr eofs startOfs of + (# acc, True, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs + in f isNegative acc (cast diff) Nothing + (# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs + in consumeExponant isNegative acc (cast diff) endOfs + _ -> Nothing + + consumeExponant !isNegative !integral !floatingDigits !startOfs + | startOfs == eofs = f isNegative integral floatingDigits Nothing + | otherwise = + -- consume 'E' or 'e' + case UTF8.nextAscii ptr startOfs of + StepASCII 0x45 -> consumeExponantSign (startOfs+1) + StepASCII 0x65 -> consumeExponantSign (startOfs+1) + _ -> Nothing + where + consumeExponantSign ofs + | ofs == eofs = Nothing + | otherwise = let exponentNegative = UTF8.expectAscii ptr ofs 0x2d + in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs) + + consumeExponantNumber exponentNegative ofs = + case decimalDigitsPtr 0 ptr eofs ofs of + (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc) + _ -> Nothing + +-- | Take decimal digits and accumulate it in `acc` +-- +-- The loop starts at the offset specified and finish either when: +-- +-- * It reach the end of the string +-- * It reach a non-ASCII character +-- * It reach an ASCII character that is not a digit (0 to 9) +-- +-- Otherwise each iterations: +-- +-- * Transform the ASCII digits into a number +-- * scale the accumulator by 10 +-- * Add the number (between 0 and 9) to the accumulator +-- +-- It then returns: +-- +-- * The new accumulated value +-- * Whether it stop by end of string or not +-- * The end offset when the loop stopped +-- +-- If end offset == start offset then no digits have been consumed by +-- this function +decimalDigitsBA :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc) + => acc + -> Block Word8 + -> Offset Word8 -- end offset + -> Offset Word8 -- start offset + -> (# acc, Bool, Offset Word8 #) +decimalDigitsBA startAcc ba !endOfs !startOfs = loop startAcc startOfs + where + loop !acc !ofs + | ofs == endOfs = (# acc, True, ofs #) + | otherwise = + case UTF8.nextAsciiDigit ba ofs of + sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs) + | otherwise -> (# acc, False, ofs #) +{-# SPECIALIZE decimalDigitsBA :: Integer -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Natural -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Int -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsBA :: Word -> Block Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-} + +-- | same as decimalDigitsBA specialized for ptr # +decimalDigitsPtr :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc) + => acc + -> Ptr Word8 + -> Offset Word8 -- end offset + -> Offset Word8 -- start offset + -> (# acc, Bool, Offset Word8 #) +decimalDigitsPtr startAcc ptr !endOfs !startOfs = loop startAcc startOfs + where + loop !acc !ofs + | ofs == endOfs = (# acc, True, ofs #) + | otherwise = + case UTF8.nextAsciiDigit ptr ofs of + sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs) + | otherwise -> (# acc, False, ofs #) +{-# SPECIALIZE decimalDigitsPtr :: Integer -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsPtr :: Natural -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsPtr :: Int -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-} +{-# SPECIALIZE decimalDigitsPtr :: Word -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-} + +-- | Convert a 'String' 'Char' by 'Char' using a case mapping function. +caseConvert :: (Char7 -> Char7) -> (Char -> CM) -> String -> String +caseConvert opASCII op s@(String arr) = runST $ do + mba <- MBLK.new iLen + nL <- C.onBackendPrim + (\blk -> go mba blk (Offset 0) start) + (\fptr -> withFinalPtr fptr $ \ptr -> go mba ptr (Offset 0) start) + arr + freeze . MutableString $ MVec.MUArray 0 nL (C.MUArrayMBA mba) + where + !(C.ValidRange start end) = C.offsetsValidRange arr + !iLen = 1 + C.length arr + go :: (Indexable container Word8, PrimMonad prim) + => MutableBlock Word8 (PrimState prim) + -> container + -> Offset Word8 + -> Offset Word8 + -> prim (CountOf Word8) + go !dst !src = loop dst iLen 0 + where + eSize !e = if e == '\0' then 0 else charToBytes (fromEnum e) + loop !dst !allocLen !nLen !dstIdx !srcIdx + | srcIdx == end = return nLen + | nLen == allocLen = realloc + | headerIsAscii h = do + UTF8.writeASCII dst dstIdx (opASCII $ Char7 $ stepAsciiRawValue h) + loop dst allocLen (nLen + 1) (dstIdx+Offset 1) (srcIdx+Offset 1) + | otherwise = do + let !(CM c1 c2 c3) = op c + !(Step c nextSrcIdx) = UTF8.nextWith h src (srcIdx+Offset 1) + nextDstIdx <- UTF8.writeUTF8 dst dstIdx c1 + if c2 == '\0' -- We keep the most common case loop as short as possible. + then loop dst allocLen (nLen + charToBytes (fromEnum c1)) nextDstIdx nextSrcIdx + else do + let !cSize = eSize c1 + eSize c2 + eSize c3 + nextDstIdx <- UTF8.writeUTF8 dst nextDstIdx c2 + nextDstIdx <- if c3 == '\0' then return nextDstIdx else UTF8.writeUTF8 dst nextDstIdx c3 + loop dst allocLen (nLen + cSize) nextDstIdx nextSrcIdx + where + {-# NOINLINE realloc #-} + realloc = do + let nAll = allocLen + allocLen + 1 + nDst <- MBLK.new nAll + MBLK.unsafeCopyElements nDst 0 dst 0 nLen + loop nDst nAll nLen dstIdx srcIdx + h = UTF8.nextAscii src srcIdx + +-- | Convert a 'String' to the upper-case equivalent. +upper :: String -> String +upper = caseConvert c7Upper upperMapping + +-- | Convert a 'String' to the upper-case equivalent. +lower :: String -> String +lower = caseConvert c7Lower lowerMapping + +-- | Convert a 'String' to the unicode case fold equivalent. +-- +-- Case folding is mostly used for caseless comparison of strings. +caseFold :: String -> String +caseFold = caseConvert c7Upper foldMapping + +-- | Check whether the first string is a prefix of the second string. +isPrefixOf :: String -> String -> Bool +isPrefixOf (String needle) (String haystack) = C.isPrefixOf needle haystack + +-- | Check whether the first string is a suffix of the second string. +isSuffixOf :: String -> String -> Bool +isSuffixOf (String needle) (String haystack) + | needleLen > hayLen = False + | otherwise = needle == C.revTake needleLen haystack + where + needleLen = C.length needle + hayLen = C.length haystack + +-- | Check whether the first string is contains within the second string. +-- +-- TODO: implemented the naive way and thus terribly inefficient, reimplement properly +isInfixOf :: String -> String -> Bool +isInfixOf (String needle) (String haystack) + = loop (hayLen - needleLen) haystack + where + needleLen = C.length needle + hayLen = C.length haystack + loop Nothing _ = False + loop (Just cnt) haystack' = needle == C.take needleLen haystack' || loop (cnt-1) (C.drop 1 haystack') + +-- | Try to strip a prefix from the start of a String. +-- +-- If the prefix is not starting the string, then Nothing is returned, +-- otherwise the striped string is returned +stripPrefix :: String -> String -> Maybe String +stripPrefix (String suffix) (String arr) + | C.isPrefixOf suffix arr = Just $ String $ C.drop (C.length suffix) arr + | otherwise = Nothing + +-- | Try to strip a suffix from the end of a String. +-- +-- If the suffix is not ending the string, then Nothing is returned, +-- otherwise the striped string is returned +stripSuffix :: String -> String -> Maybe String +stripSuffix (String prefix) (String arr) + | C.isSuffixOf prefix arr = Just $ String $ C.revDrop (C.length prefix) arr + | otherwise = Nothing + +all :: (Char -> Bool) -> String -> Bool +all predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr + where + !(C.ValidRange start end) = C.offsetsValidRange arr + goBA ba = UTF8.all predicate ba start end + goAddr addr = UTF8.all predicate addr start end + +any :: (Char -> Bool) -> String -> Bool +any predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr + where + !(C.ValidRange start end) = C.offsetsValidRange arr + goBA ba = UTF8.any predicate ba start end + goAddr addr = UTF8.any predicate addr start end + +-- | Transform string @src@ to base64 binary representation. +toBase64 :: String -> String +toBase64 (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ True + where + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# + +-- | Transform string @src@ to URL-safe base64 binary representation. +-- The result will be either padded or unpadded, depending on the boolean +-- @padded@ argument. +toBase64URL :: Bool -> String -> String +toBase64URL padded (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ padded + where + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# + +-- | Transform string @src@ to OpenBSD base64 binary representation. +toBase64OpenBSD :: String -> String +toBase64OpenBSD (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ False + where + !set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"# diff --git a/Basement/String/Builder.hs b/Basement/String/Builder.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Builder.hs @@ -0,0 +1,58 @@ +-- | +-- 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 diff --git a/Basement/String/CaseMapping.hs b/Basement/String/CaseMapping.hs new file mode 100644 --- /dev/null +++ b/Basement/String/CaseMapping.hs @@ -0,0 +1,3240 @@ +{-# LANGUAGE Rank2Types #-} +-- AUTOMATICALLY GENERATED - DO NOT EDIT +-- Generated by scripts/caseMapping/generateCaseMapping.sh +-- CaseFolding-10.0.0.txt +-- Date: 2017-04-14, 05:40:18 GMT +-- SpecialCasing-10.0.0.txt +-- Date: 2017-04-14, 05:40:43 GMT + +module Basement.String.CaseMapping where + +import Data.Char +import Basement.UTF8.Types + +upperMapping :: Char -> CM +{-# NOINLINE upperMapping #-} +-- LATIN SMALL LETTER SHARP S +upperMapping '\x00DF' = CM '\x0053' '\x0053' '\0' +-- LATIN SMALL LIGATURE FF +upperMapping '\xFB00' = CM '\x0046' '\x0046' '\0' +-- LATIN SMALL LIGATURE FI +upperMapping '\xFB01' = CM '\x0046' '\x0049' '\0' +-- LATIN SMALL LIGATURE FL +upperMapping '\xFB02' = CM '\x0046' '\x004C' '\0' +-- LATIN SMALL LIGATURE FFI +upperMapping '\xFB03' = CM '\x0046' '\x0046' '\x0049' +-- LATIN SMALL LIGATURE FFL +upperMapping '\xFB04' = CM '\x0046' '\x0046' '\x004C' +-- LATIN SMALL LIGATURE LONG S T +upperMapping '\xFB05' = CM '\x0053' '\x0054' '\0' +-- LATIN SMALL LIGATURE ST +upperMapping '\xFB06' = CM '\x0053' '\x0054' '\0' +-- ARMENIAN SMALL LIGATURE ECH YIWN +upperMapping '\x0587' = CM '\x0535' '\x0552' '\0' +-- ARMENIAN SMALL LIGATURE MEN NOW +upperMapping '\xFB13' = CM '\x0544' '\x0546' '\0' +-- ARMENIAN SMALL LIGATURE MEN ECH +upperMapping '\xFB14' = CM '\x0544' '\x0535' '\0' +-- ARMENIAN SMALL LIGATURE MEN INI +upperMapping '\xFB15' = CM '\x0544' '\x053B' '\0' +-- ARMENIAN SMALL LIGATURE VEW NOW +upperMapping '\xFB16' = CM '\x054E' '\x0546' '\0' +-- ARMENIAN SMALL LIGATURE MEN XEH +upperMapping '\xFB17' = CM '\x0544' '\x053D' '\0' +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +upperMapping '\x0149' = CM '\x02BC' '\x004E' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +upperMapping '\x0390' = CM '\x0399' '\x0308' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +upperMapping '\x03B0' = CM '\x03A5' '\x0308' '\x0301' +-- LATIN SMALL LETTER J WITH CARON +upperMapping '\x01F0' = CM '\x004A' '\x030C' '\0' +-- LATIN SMALL LETTER H WITH LINE BELOW +upperMapping '\x1E96' = CM '\x0048' '\x0331' '\0' +-- LATIN SMALL LETTER T WITH DIAERESIS +upperMapping '\x1E97' = CM '\x0054' '\x0308' '\0' +-- LATIN SMALL LETTER W WITH RING ABOVE +upperMapping '\x1E98' = CM '\x0057' '\x030A' '\0' +-- LATIN SMALL LETTER Y WITH RING ABOVE +upperMapping '\x1E99' = CM '\x0059' '\x030A' '\0' +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +upperMapping '\x1E9A' = CM '\x0041' '\x02BE' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI +upperMapping '\x1F50' = CM '\x03A5' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +upperMapping '\x1F52' = CM '\x03A5' '\x0313' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +upperMapping '\x1F54' = CM '\x03A5' '\x0313' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +upperMapping '\x1F56' = CM '\x03A5' '\x0313' '\x0342' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +upperMapping '\x1FB6' = CM '\x0391' '\x0342' '\0' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +upperMapping '\x1FC6' = CM '\x0397' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +upperMapping '\x1FD2' = CM '\x0399' '\x0308' '\x0300' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +upperMapping '\x1FD3' = CM '\x0399' '\x0308' '\x0301' +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +upperMapping '\x1FD6' = CM '\x0399' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1FD7' = CM '\x0399' '\x0308' '\x0342' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +upperMapping '\x1FE2' = CM '\x03A5' '\x0308' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +upperMapping '\x1FE3' = CM '\x03A5' '\x0308' '\x0301' +-- GREEK SMALL LETTER RHO WITH PSILI +upperMapping '\x1FE4' = CM '\x03A1' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +upperMapping '\x1FE6' = CM '\x03A5' '\x0342' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1FE7' = CM '\x03A5' '\x0308' '\x0342' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +upperMapping '\x1FF6' = CM '\x03A9' '\x0342' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1F80' = CM '\x1F08' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1F81' = CM '\x1F09' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1F82' = CM '\x1F0A' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1F83' = CM '\x1F0B' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1F84' = CM '\x1F0C' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1F85' = CM '\x1F0D' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1F86' = CM '\x1F0E' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1F87' = CM '\x1F0F' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1F88' = CM '\x1F08' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1F89' = CM '\x1F09' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1F8A' = CM '\x1F0A' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1F8B' = CM '\x1F0B' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1F8C' = CM '\x1F0C' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1F8D' = CM '\x1F0D' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1F8E' = CM '\x1F0E' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1F8F' = CM '\x1F0F' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1F90' = CM '\x1F28' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1F91' = CM '\x1F29' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1F92' = CM '\x1F2A' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1F93' = CM '\x1F2B' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1F94' = CM '\x1F2C' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1F95' = CM '\x1F2D' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1F96' = CM '\x1F2E' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1F97' = CM '\x1F2F' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1F98' = CM '\x1F28' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1F99' = CM '\x1F29' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1F9A' = CM '\x1F2A' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1F9B' = CM '\x1F2B' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1F9C' = CM '\x1F2C' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1F9D' = CM '\x1F2D' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1F9E' = CM '\x1F2E' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1F9F' = CM '\x1F2F' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1FA0' = CM '\x1F68' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1FA1' = CM '\x1F69' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1FA2' = CM '\x1F6A' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1FA3' = CM '\x1F6B' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1FA4' = CM '\x1F6C' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1FA5' = CM '\x1F6D' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FA6' = CM '\x1F6E' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FA7' = CM '\x1F6F' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1FA8' = CM '\x1F68' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1FA9' = CM '\x1F69' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1FAA' = CM '\x1F6A' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1FAB' = CM '\x1F6B' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1FAC' = CM '\x1F6C' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1FAD' = CM '\x1F6D' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1FAE' = CM '\x1F6E' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1FAF' = CM '\x1F6F' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +upperMapping '\x1FB3' = CM '\x0391' '\x0399' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +upperMapping '\x1FBC' = CM '\x0391' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +upperMapping '\x1FC3' = CM '\x0397' '\x0399' '\0' +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +upperMapping '\x1FCC' = CM '\x0397' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +upperMapping '\x1FF3' = CM '\x03A9' '\x0399' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +upperMapping '\x1FFC' = CM '\x03A9' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1FB2' = CM '\x1FBA' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1FB4' = CM '\x0386' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1FC2' = CM '\x1FCA' '\x0399' '\0' +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1FC4' = CM '\x0389' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1FF2' = CM '\x1FFA' '\x0399' '\0' +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1FF4' = CM '\x038F' '\x0399' '\0' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FB7' = CM '\x0391' '\x0342' '\x0399' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FC7' = CM '\x0397' '\x0342' '\x0399' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1FF7' = CM '\x03A9' '\x0342' '\x0399' +upperMapping c = CM (toUpper c) '\0' '\0' + +lowerMapping :: Char -> CM +{-# NOINLINE lowerMapping #-} +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +lowerMapping '\x0130' = CM '\x0069' '\x0307' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +lowerMapping '\x1F88' = CM '\x1F80' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +lowerMapping '\x1F89' = CM '\x1F81' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1F8A' = CM '\x1F82' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1F8B' = CM '\x1F83' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1F8C' = CM '\x1F84' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1F8D' = CM '\x1F85' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1F8E' = CM '\x1F86' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1F8F' = CM '\x1F87' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +lowerMapping '\x1F98' = CM '\x1F90' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +lowerMapping '\x1F99' = CM '\x1F91' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1F9A' = CM '\x1F92' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1F9B' = CM '\x1F93' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1F9C' = CM '\x1F94' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1F9D' = CM '\x1F95' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1F9E' = CM '\x1F96' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1F9F' = CM '\x1F97' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +lowerMapping '\x1FA8' = CM '\x1FA0' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +lowerMapping '\x1FA9' = CM '\x1FA1' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1FAA' = CM '\x1FA2' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +lowerMapping '\x1FAB' = CM '\x1FA3' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1FAC' = CM '\x1FA4' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +lowerMapping '\x1FAD' = CM '\x1FA5' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1FAE' = CM '\x1FA6' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +lowerMapping '\x1FAF' = CM '\x1FA7' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +lowerMapping '\x1FBC' = CM '\x1FB3' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +lowerMapping '\x1FCC' = CM '\x1FC3' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +lowerMapping '\x1FFC' = CM '\x1FF3' '\0' '\0' +lowerMapping c = CM (toLower c) '\0' '\0' + +titleMapping :: Char -> CM +{-# NOINLINE titleMapping #-} +-- LATIN SMALL LETTER SHARP S +titleMapping '\x00DF' = CM '\x0053' '\x0073' '\0' +-- LATIN SMALL LIGATURE FF +titleMapping '\xFB00' = CM '\x0046' '\x0066' '\0' +-- LATIN SMALL LIGATURE FI +titleMapping '\xFB01' = CM '\x0046' '\x0069' '\0' +-- LATIN SMALL LIGATURE FL +titleMapping '\xFB02' = CM '\x0046' '\x006C' '\0' +-- LATIN SMALL LIGATURE FFI +titleMapping '\xFB03' = CM '\x0046' '\x0066' '\x0069' +-- LATIN SMALL LIGATURE FFL +titleMapping '\xFB04' = CM '\x0046' '\x0066' '\x006C' +-- LATIN SMALL LIGATURE LONG S T +titleMapping '\xFB05' = CM '\x0053' '\x0074' '\0' +-- LATIN SMALL LIGATURE ST +titleMapping '\xFB06' = CM '\x0053' '\x0074' '\0' +-- ARMENIAN SMALL LIGATURE ECH YIWN +titleMapping '\x0587' = CM '\x0535' '\x0582' '\0' +-- ARMENIAN SMALL LIGATURE MEN NOW +titleMapping '\xFB13' = CM '\x0544' '\x0576' '\0' +-- ARMENIAN SMALL LIGATURE MEN ECH +titleMapping '\xFB14' = CM '\x0544' '\x0565' '\0' +-- ARMENIAN SMALL LIGATURE MEN INI +titleMapping '\xFB15' = CM '\x0544' '\x056B' '\0' +-- ARMENIAN SMALL LIGATURE VEW NOW +titleMapping '\xFB16' = CM '\x054E' '\x0576' '\0' +-- ARMENIAN SMALL LIGATURE MEN XEH +titleMapping '\xFB17' = CM '\x0544' '\x056D' '\0' +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +titleMapping '\x0149' = CM '\x02BC' '\x004E' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +titleMapping '\x0390' = CM '\x0399' '\x0308' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +titleMapping '\x03B0' = CM '\x03A5' '\x0308' '\x0301' +-- LATIN SMALL LETTER J WITH CARON +titleMapping '\x01F0' = CM '\x004A' '\x030C' '\0' +-- LATIN SMALL LETTER H WITH LINE BELOW +titleMapping '\x1E96' = CM '\x0048' '\x0331' '\0' +-- LATIN SMALL LETTER T WITH DIAERESIS +titleMapping '\x1E97' = CM '\x0054' '\x0308' '\0' +-- LATIN SMALL LETTER W WITH RING ABOVE +titleMapping '\x1E98' = CM '\x0057' '\x030A' '\0' +-- LATIN SMALL LETTER Y WITH RING ABOVE +titleMapping '\x1E99' = CM '\x0059' '\x030A' '\0' +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +titleMapping '\x1E9A' = CM '\x0041' '\x02BE' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI +titleMapping '\x1F50' = CM '\x03A5' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +titleMapping '\x1F52' = CM '\x03A5' '\x0313' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +titleMapping '\x1F54' = CM '\x03A5' '\x0313' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +titleMapping '\x1F56' = CM '\x03A5' '\x0313' '\x0342' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +titleMapping '\x1FB6' = CM '\x0391' '\x0342' '\0' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +titleMapping '\x1FC6' = CM '\x0397' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +titleMapping '\x1FD2' = CM '\x0399' '\x0308' '\x0300' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +titleMapping '\x1FD3' = CM '\x0399' '\x0308' '\x0301' +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +titleMapping '\x1FD6' = CM '\x0399' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1FD7' = CM '\x0399' '\x0308' '\x0342' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +titleMapping '\x1FE2' = CM '\x03A5' '\x0308' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +titleMapping '\x1FE3' = CM '\x03A5' '\x0308' '\x0301' +-- GREEK SMALL LETTER RHO WITH PSILI +titleMapping '\x1FE4' = CM '\x03A1' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +titleMapping '\x1FE6' = CM '\x03A5' '\x0342' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1FE7' = CM '\x03A5' '\x0308' '\x0342' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +titleMapping '\x1FF6' = CM '\x03A9' '\x0342' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +titleMapping '\x1F80' = CM '\x1F88' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +titleMapping '\x1F81' = CM '\x1F89' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1F82' = CM '\x1F8A' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1F83' = CM '\x1F8B' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1F84' = CM '\x1F8C' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1F85' = CM '\x1F8D' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1F86' = CM '\x1F8E' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1F87' = CM '\x1F8F' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +titleMapping '\x1F90' = CM '\x1F98' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +titleMapping '\x1F91' = CM '\x1F99' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1F92' = CM '\x1F9A' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1F93' = CM '\x1F9B' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1F94' = CM '\x1F9C' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1F95' = CM '\x1F9D' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1F96' = CM '\x1F9E' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1F97' = CM '\x1F9F' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +titleMapping '\x1FA0' = CM '\x1FA8' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +titleMapping '\x1FA1' = CM '\x1FA9' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1FA2' = CM '\x1FAA' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +titleMapping '\x1FA3' = CM '\x1FAB' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1FA4' = CM '\x1FAC' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +titleMapping '\x1FA5' = CM '\x1FAD' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FA6' = CM '\x1FAE' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FA7' = CM '\x1FAF' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +titleMapping '\x1FB3' = CM '\x1FBC' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +titleMapping '\x1FC3' = CM '\x1FCC' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +titleMapping '\x1FF3' = CM '\x1FFC' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1FB2' = CM '\x1FBA' '\x0345' '\0' +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1FB4' = CM '\x0386' '\x0345' '\0' +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1FC2' = CM '\x1FCA' '\x0345' '\0' +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1FC4' = CM '\x0389' '\x0345' '\0' +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1FF2' = CM '\x1FFA' '\x0345' '\0' +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1FF4' = CM '\x038F' '\x0345' '\0' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FB7' = CM '\x0391' '\x0342' '\x0345' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FC7' = CM '\x0397' '\x0342' '\x0345' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1FF7' = CM '\x03A9' '\x0342' '\x0345' +titleMapping c = CM (toTitle c) '\0' '\0' + +foldMapping :: Char -> CM +{-# NOINLINE foldMapping #-} +-- LATIN CAPITAL LETTER A +foldMapping '\x0041' = CM '\x0061' '\0' '\0' +-- LATIN CAPITAL LETTER B +foldMapping '\x0042' = CM '\x0062' '\0' '\0' +-- LATIN CAPITAL LETTER C +foldMapping '\x0043' = CM '\x0063' '\0' '\0' +-- LATIN CAPITAL LETTER D +foldMapping '\x0044' = CM '\x0064' '\0' '\0' +-- LATIN CAPITAL LETTER E +foldMapping '\x0045' = CM '\x0065' '\0' '\0' +-- LATIN CAPITAL LETTER F +foldMapping '\x0046' = CM '\x0066' '\0' '\0' +-- LATIN CAPITAL LETTER G +foldMapping '\x0047' = CM '\x0067' '\0' '\0' +-- LATIN CAPITAL LETTER H +foldMapping '\x0048' = CM '\x0068' '\0' '\0' +-- LATIN CAPITAL LETTER I +foldMapping '\x0049' = CM '\x0069' '\0' '\0' +-- LATIN CAPITAL LETTER J +foldMapping '\x004A' = CM '\x006A' '\0' '\0' +-- LATIN CAPITAL LETTER K +foldMapping '\x004B' = CM '\x006B' '\0' '\0' +-- LATIN CAPITAL LETTER L +foldMapping '\x004C' = CM '\x006C' '\0' '\0' +-- LATIN CAPITAL LETTER M +foldMapping '\x004D' = CM '\x006D' '\0' '\0' +-- LATIN CAPITAL LETTER N +foldMapping '\x004E' = CM '\x006E' '\0' '\0' +-- LATIN CAPITAL LETTER O +foldMapping '\x004F' = CM '\x006F' '\0' '\0' +-- LATIN CAPITAL LETTER P +foldMapping '\x0050' = CM '\x0070' '\0' '\0' +-- LATIN CAPITAL LETTER Q +foldMapping '\x0051' = CM '\x0071' '\0' '\0' +-- LATIN CAPITAL LETTER R +foldMapping '\x0052' = CM '\x0072' '\0' '\0' +-- LATIN CAPITAL LETTER S +foldMapping '\x0053' = CM '\x0073' '\0' '\0' +-- LATIN CAPITAL LETTER T +foldMapping '\x0054' = CM '\x0074' '\0' '\0' +-- LATIN CAPITAL LETTER U +foldMapping '\x0055' = CM '\x0075' '\0' '\0' +-- LATIN CAPITAL LETTER V +foldMapping '\x0056' = CM '\x0076' '\0' '\0' +-- LATIN CAPITAL LETTER W +foldMapping '\x0057' = CM '\x0077' '\0' '\0' +-- LATIN CAPITAL LETTER X +foldMapping '\x0058' = CM '\x0078' '\0' '\0' +-- LATIN CAPITAL LETTER Y +foldMapping '\x0059' = CM '\x0079' '\0' '\0' +-- LATIN CAPITAL LETTER Z +foldMapping '\x005A' = CM '\x007A' '\0' '\0' +-- MICRO SIGN +foldMapping '\x00B5' = CM '\x03BC' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH GRAVE +foldMapping '\x00C0' = CM '\x00E0' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH ACUTE +foldMapping '\x00C1' = CM '\x00E1' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX +foldMapping '\x00C2' = CM '\x00E2' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH TILDE +foldMapping '\x00C3' = CM '\x00E3' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DIAERESIS +foldMapping '\x00C4' = CM '\x00E4' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH RING ABOVE +foldMapping '\x00C5' = CM '\x00E5' '\0' '\0' +-- LATIN CAPITAL LETTER AE +foldMapping '\x00C6' = CM '\x00E6' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH CEDILLA +foldMapping '\x00C7' = CM '\x00E7' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH GRAVE +foldMapping '\x00C8' = CM '\x00E8' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH ACUTE +foldMapping '\x00C9' = CM '\x00E9' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX +foldMapping '\x00CA' = CM '\x00EA' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH DIAERESIS +foldMapping '\x00CB' = CM '\x00EB' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH GRAVE +foldMapping '\x00CC' = CM '\x00EC' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH ACUTE +foldMapping '\x00CD' = CM '\x00ED' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH CIRCUMFLEX +foldMapping '\x00CE' = CM '\x00EE' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DIAERESIS +foldMapping '\x00CF' = CM '\x00EF' '\0' '\0' +-- LATIN CAPITAL LETTER ETH +foldMapping '\x00D0' = CM '\x00F0' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH TILDE +foldMapping '\x00D1' = CM '\x00F1' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH GRAVE +foldMapping '\x00D2' = CM '\x00F2' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH ACUTE +foldMapping '\x00D3' = CM '\x00F3' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX +foldMapping '\x00D4' = CM '\x00F4' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH TILDE +foldMapping '\x00D5' = CM '\x00F5' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DIAERESIS +foldMapping '\x00D6' = CM '\x00F6' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH STROKE +foldMapping '\x00D8' = CM '\x00F8' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH GRAVE +foldMapping '\x00D9' = CM '\x00F9' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH ACUTE +foldMapping '\x00DA' = CM '\x00FA' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH CIRCUMFLEX +foldMapping '\x00DB' = CM '\x00FB' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS +foldMapping '\x00DC' = CM '\x00FC' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH ACUTE +foldMapping '\x00DD' = CM '\x00FD' '\0' '\0' +-- LATIN CAPITAL LETTER THORN +foldMapping '\x00DE' = CM '\x00FE' '\0' '\0' +-- LATIN SMALL LETTER SHARP S +foldMapping '\x00DF' = CM '\x0073' '\x0073' '\0' +-- LATIN CAPITAL LETTER A WITH MACRON +foldMapping '\x0100' = CM '\x0101' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE +foldMapping '\x0102' = CM '\x0103' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH OGONEK +foldMapping '\x0104' = CM '\x0105' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH ACUTE +foldMapping '\x0106' = CM '\x0107' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH CIRCUMFLEX +foldMapping '\x0108' = CM '\x0109' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH DOT ABOVE +foldMapping '\x010A' = CM '\x010B' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH CARON +foldMapping '\x010C' = CM '\x010D' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH CARON +foldMapping '\x010E' = CM '\x010F' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH STROKE +foldMapping '\x0110' = CM '\x0111' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH MACRON +foldMapping '\x0112' = CM '\x0113' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH BREVE +foldMapping '\x0114' = CM '\x0115' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH DOT ABOVE +foldMapping '\x0116' = CM '\x0117' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH OGONEK +foldMapping '\x0118' = CM '\x0119' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CARON +foldMapping '\x011A' = CM '\x011B' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH CIRCUMFLEX +foldMapping '\x011C' = CM '\x011D' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH BREVE +foldMapping '\x011E' = CM '\x011F' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH DOT ABOVE +foldMapping '\x0120' = CM '\x0121' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH CEDILLA +foldMapping '\x0122' = CM '\x0123' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH CIRCUMFLEX +foldMapping '\x0124' = CM '\x0125' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH STROKE +foldMapping '\x0126' = CM '\x0127' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH TILDE +foldMapping '\x0128' = CM '\x0129' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH MACRON +foldMapping '\x012A' = CM '\x012B' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH BREVE +foldMapping '\x012C' = CM '\x012D' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH OGONEK +foldMapping '\x012E' = CM '\x012F' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +foldMapping '\x0130' = CM '\x0069' '\x0307' '\0' +-- LATIN CAPITAL LIGATURE IJ +foldMapping '\x0132' = CM '\x0133' '\0' '\0' +-- LATIN CAPITAL LETTER J WITH CIRCUMFLEX +foldMapping '\x0134' = CM '\x0135' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH CEDILLA +foldMapping '\x0136' = CM '\x0137' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH ACUTE +foldMapping '\x0139' = CM '\x013A' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH CEDILLA +foldMapping '\x013B' = CM '\x013C' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH CARON +foldMapping '\x013D' = CM '\x013E' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH MIDDLE DOT +foldMapping '\x013F' = CM '\x0140' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH STROKE +foldMapping '\x0141' = CM '\x0142' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH ACUTE +foldMapping '\x0143' = CM '\x0144' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH CEDILLA +foldMapping '\x0145' = CM '\x0146' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH CARON +foldMapping '\x0147' = CM '\x0148' '\0' '\0' +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +foldMapping '\x0149' = CM '\x02BC' '\x006E' '\0' +-- LATIN CAPITAL LETTER ENG +foldMapping '\x014A' = CM '\x014B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH MACRON +foldMapping '\x014C' = CM '\x014D' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH BREVE +foldMapping '\x014E' = CM '\x014F' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOUBLE ACUTE +foldMapping '\x0150' = CM '\x0151' '\0' '\0' +-- LATIN CAPITAL LIGATURE OE +foldMapping '\x0152' = CM '\x0153' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH ACUTE +foldMapping '\x0154' = CM '\x0155' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH CEDILLA +foldMapping '\x0156' = CM '\x0157' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH CARON +foldMapping '\x0158' = CM '\x0159' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH ACUTE +foldMapping '\x015A' = CM '\x015B' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH CIRCUMFLEX +foldMapping '\x015C' = CM '\x015D' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH CEDILLA +foldMapping '\x015E' = CM '\x015F' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH CARON +foldMapping '\x0160' = CM '\x0161' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH CEDILLA +foldMapping '\x0162' = CM '\x0163' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH CARON +foldMapping '\x0164' = CM '\x0165' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH STROKE +foldMapping '\x0166' = CM '\x0167' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH TILDE +foldMapping '\x0168' = CM '\x0169' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH MACRON +foldMapping '\x016A' = CM '\x016B' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH BREVE +foldMapping '\x016C' = CM '\x016D' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH RING ABOVE +foldMapping '\x016E' = CM '\x016F' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DOUBLE ACUTE +foldMapping '\x0170' = CM '\x0171' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH OGONEK +foldMapping '\x0172' = CM '\x0173' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH CIRCUMFLEX +foldMapping '\x0174' = CM '\x0175' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH CIRCUMFLEX +foldMapping '\x0176' = CM '\x0177' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH DIAERESIS +foldMapping '\x0178' = CM '\x00FF' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH ACUTE +foldMapping '\x0179' = CM '\x017A' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH DOT ABOVE +foldMapping '\x017B' = CM '\x017C' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH CARON +foldMapping '\x017D' = CM '\x017E' '\0' '\0' +-- LATIN SMALL LETTER LONG S +foldMapping '\x017F' = CM '\x0073' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH HOOK +foldMapping '\x0181' = CM '\x0253' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH TOPBAR +foldMapping '\x0182' = CM '\x0183' '\0' '\0' +-- LATIN CAPITAL LETTER TONE SIX +foldMapping '\x0184' = CM '\x0185' '\0' '\0' +-- LATIN CAPITAL LETTER OPEN O +foldMapping '\x0186' = CM '\x0254' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH HOOK +foldMapping '\x0187' = CM '\x0188' '\0' '\0' +-- LATIN CAPITAL LETTER AFRICAN D +foldMapping '\x0189' = CM '\x0256' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH HOOK +foldMapping '\x018A' = CM '\x0257' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH TOPBAR +foldMapping '\x018B' = CM '\x018C' '\0' '\0' +-- LATIN CAPITAL LETTER REVERSED E +foldMapping '\x018E' = CM '\x01DD' '\0' '\0' +-- LATIN CAPITAL LETTER SCHWA +foldMapping '\x018F' = CM '\x0259' '\0' '\0' +-- LATIN CAPITAL LETTER OPEN E +foldMapping '\x0190' = CM '\x025B' '\0' '\0' +-- LATIN CAPITAL LETTER F WITH HOOK +foldMapping '\x0191' = CM '\x0192' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH HOOK +foldMapping '\x0193' = CM '\x0260' '\0' '\0' +-- LATIN CAPITAL LETTER GAMMA +foldMapping '\x0194' = CM '\x0263' '\0' '\0' +-- LATIN CAPITAL LETTER IOTA +foldMapping '\x0196' = CM '\x0269' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH STROKE +foldMapping '\x0197' = CM '\x0268' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH HOOK +foldMapping '\x0198' = CM '\x0199' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED M +foldMapping '\x019C' = CM '\x026F' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH LEFT HOOK +foldMapping '\x019D' = CM '\x0272' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH MIDDLE TILDE +foldMapping '\x019F' = CM '\x0275' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN +foldMapping '\x01A0' = CM '\x01A1' '\0' '\0' +-- LATIN CAPITAL LETTER OI +foldMapping '\x01A2' = CM '\x01A3' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH HOOK +foldMapping '\x01A4' = CM '\x01A5' '\0' '\0' +-- LATIN LETTER YR +foldMapping '\x01A6' = CM '\x0280' '\0' '\0' +-- LATIN CAPITAL LETTER TONE TWO +foldMapping '\x01A7' = CM '\x01A8' '\0' '\0' +-- LATIN CAPITAL LETTER ESH +foldMapping '\x01A9' = CM '\x0283' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH HOOK +foldMapping '\x01AC' = CM '\x01AD' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH RETROFLEX HOOK +foldMapping '\x01AE' = CM '\x0288' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN +foldMapping '\x01AF' = CM '\x01B0' '\0' '\0' +-- LATIN CAPITAL LETTER UPSILON +foldMapping '\x01B1' = CM '\x028A' '\0' '\0' +-- LATIN CAPITAL LETTER V WITH HOOK +foldMapping '\x01B2' = CM '\x028B' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH HOOK +foldMapping '\x01B3' = CM '\x01B4' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH STROKE +foldMapping '\x01B5' = CM '\x01B6' '\0' '\0' +-- LATIN CAPITAL LETTER EZH +foldMapping '\x01B7' = CM '\x0292' '\0' '\0' +-- LATIN CAPITAL LETTER EZH REVERSED +foldMapping '\x01B8' = CM '\x01B9' '\0' '\0' +-- LATIN CAPITAL LETTER TONE FIVE +foldMapping '\x01BC' = CM '\x01BD' '\0' '\0' +-- LATIN CAPITAL LETTER DZ WITH CARON +foldMapping '\x01C4' = CM '\x01C6' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON +foldMapping '\x01C5' = CM '\x01C6' '\0' '\0' +-- LATIN CAPITAL LETTER LJ +foldMapping '\x01C7' = CM '\x01C9' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH SMALL LETTER J +foldMapping '\x01C8' = CM '\x01C9' '\0' '\0' +-- LATIN CAPITAL LETTER NJ +foldMapping '\x01CA' = CM '\x01CC' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH SMALL LETTER J +foldMapping '\x01CB' = CM '\x01CC' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CARON +foldMapping '\x01CD' = CM '\x01CE' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH CARON +foldMapping '\x01CF' = CM '\x01D0' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CARON +foldMapping '\x01D1' = CM '\x01D2' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH CARON +foldMapping '\x01D3' = CM '\x01D4' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON +foldMapping '\x01D5' = CM '\x01D6' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE +foldMapping '\x01D7' = CM '\x01D8' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON +foldMapping '\x01D9' = CM '\x01DA' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE +foldMapping '\x01DB' = CM '\x01DC' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON +foldMapping '\x01DE' = CM '\x01DF' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON +foldMapping '\x01E0' = CM '\x01E1' '\0' '\0' +-- LATIN CAPITAL LETTER AE WITH MACRON +foldMapping '\x01E2' = CM '\x01E3' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH STROKE +foldMapping '\x01E4' = CM '\x01E5' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH CARON +foldMapping '\x01E6' = CM '\x01E7' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH CARON +foldMapping '\x01E8' = CM '\x01E9' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH OGONEK +foldMapping '\x01EA' = CM '\x01EB' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH OGONEK AND MACRON +foldMapping '\x01EC' = CM '\x01ED' '\0' '\0' +-- LATIN CAPITAL LETTER EZH WITH CARON +foldMapping '\x01EE' = CM '\x01EF' '\0' '\0' +-- LATIN SMALL LETTER J WITH CARON +foldMapping '\x01F0' = CM '\x006A' '\x030C' '\0' +-- LATIN CAPITAL LETTER DZ +foldMapping '\x01F1' = CM '\x01F3' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH SMALL LETTER Z +foldMapping '\x01F2' = CM '\x01F3' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH ACUTE +foldMapping '\x01F4' = CM '\x01F5' '\0' '\0' +-- LATIN CAPITAL LETTER HWAIR +foldMapping '\x01F6' = CM '\x0195' '\0' '\0' +-- LATIN CAPITAL LETTER WYNN +foldMapping '\x01F7' = CM '\x01BF' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH GRAVE +foldMapping '\x01F8' = CM '\x01F9' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE +foldMapping '\x01FA' = CM '\x01FB' '\0' '\0' +-- LATIN CAPITAL LETTER AE WITH ACUTE +foldMapping '\x01FC' = CM '\x01FD' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH STROKE AND ACUTE +foldMapping '\x01FE' = CM '\x01FF' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DOUBLE GRAVE +foldMapping '\x0200' = CM '\x0201' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH INVERTED BREVE +foldMapping '\x0202' = CM '\x0203' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH DOUBLE GRAVE +foldMapping '\x0204' = CM '\x0205' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH INVERTED BREVE +foldMapping '\x0206' = CM '\x0207' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DOUBLE GRAVE +foldMapping '\x0208' = CM '\x0209' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH INVERTED BREVE +foldMapping '\x020A' = CM '\x020B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOUBLE GRAVE +foldMapping '\x020C' = CM '\x020D' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH INVERTED BREVE +foldMapping '\x020E' = CM '\x020F' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH DOUBLE GRAVE +foldMapping '\x0210' = CM '\x0211' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH INVERTED BREVE +foldMapping '\x0212' = CM '\x0213' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DOUBLE GRAVE +foldMapping '\x0214' = CM '\x0215' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH INVERTED BREVE +foldMapping '\x0216' = CM '\x0217' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH COMMA BELOW +foldMapping '\x0218' = CM '\x0219' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH COMMA BELOW +foldMapping '\x021A' = CM '\x021B' '\0' '\0' +-- LATIN CAPITAL LETTER YOGH +foldMapping '\x021C' = CM '\x021D' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH CARON +foldMapping '\x021E' = CM '\x021F' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH LONG RIGHT LEG +foldMapping '\x0220' = CM '\x019E' '\0' '\0' +-- LATIN CAPITAL LETTER OU +foldMapping '\x0222' = CM '\x0223' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH HOOK +foldMapping '\x0224' = CM '\x0225' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH DOT ABOVE +foldMapping '\x0226' = CM '\x0227' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CEDILLA +foldMapping '\x0228' = CM '\x0229' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON +foldMapping '\x022A' = CM '\x022B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH TILDE AND MACRON +foldMapping '\x022C' = CM '\x022D' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOT ABOVE +foldMapping '\x022E' = CM '\x022F' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON +foldMapping '\x0230' = CM '\x0231' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH MACRON +foldMapping '\x0232' = CM '\x0233' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH STROKE +foldMapping '\x023A' = CM '\x2C65' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH STROKE +foldMapping '\x023B' = CM '\x023C' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH BAR +foldMapping '\x023D' = CM '\x019A' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH DIAGONAL STROKE +foldMapping '\x023E' = CM '\x2C66' '\0' '\0' +-- LATIN CAPITAL LETTER GLOTTAL STOP +foldMapping '\x0241' = CM '\x0242' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH STROKE +foldMapping '\x0243' = CM '\x0180' '\0' '\0' +-- LATIN CAPITAL LETTER U BAR +foldMapping '\x0244' = CM '\x0289' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED V +foldMapping '\x0245' = CM '\x028C' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH STROKE +foldMapping '\x0246' = CM '\x0247' '\0' '\0' +-- LATIN CAPITAL LETTER J WITH STROKE +foldMapping '\x0248' = CM '\x0249' '\0' '\0' +-- LATIN CAPITAL LETTER SMALL Q WITH HOOK TAIL +foldMapping '\x024A' = CM '\x024B' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH STROKE +foldMapping '\x024C' = CM '\x024D' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH STROKE +foldMapping '\x024E' = CM '\x024F' '\0' '\0' +-- COMBINING GREEK YPOGEGRAMMENI +foldMapping '\x0345' = CM '\x03B9' '\0' '\0' +-- GREEK CAPITAL LETTER HETA +foldMapping '\x0370' = CM '\x0371' '\0' '\0' +-- GREEK CAPITAL LETTER ARCHAIC SAMPI +foldMapping '\x0372' = CM '\x0373' '\0' '\0' +-- GREEK CAPITAL LETTER PAMPHYLIAN DIGAMMA +foldMapping '\x0376' = CM '\x0377' '\0' '\0' +-- GREEK CAPITAL LETTER YOT +foldMapping '\x037F' = CM '\x03F3' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH TONOS +foldMapping '\x0386' = CM '\x03AC' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH TONOS +foldMapping '\x0388' = CM '\x03AD' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH TONOS +foldMapping '\x0389' = CM '\x03AE' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH TONOS +foldMapping '\x038A' = CM '\x03AF' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH TONOS +foldMapping '\x038C' = CM '\x03CC' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH TONOS +foldMapping '\x038E' = CM '\x03CD' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH TONOS +foldMapping '\x038F' = CM '\x03CE' '\0' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +foldMapping '\x0390' = CM '\x03B9' '\x0308' '\x0301' +-- GREEK CAPITAL LETTER ALPHA +foldMapping '\x0391' = CM '\x03B1' '\0' '\0' +-- GREEK CAPITAL LETTER BETA +foldMapping '\x0392' = CM '\x03B2' '\0' '\0' +-- GREEK CAPITAL LETTER GAMMA +foldMapping '\x0393' = CM '\x03B3' '\0' '\0' +-- GREEK CAPITAL LETTER DELTA +foldMapping '\x0394' = CM '\x03B4' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON +foldMapping '\x0395' = CM '\x03B5' '\0' '\0' +-- GREEK CAPITAL LETTER ZETA +foldMapping '\x0396' = CM '\x03B6' '\0' '\0' +-- GREEK CAPITAL LETTER ETA +foldMapping '\x0397' = CM '\x03B7' '\0' '\0' +-- GREEK CAPITAL LETTER THETA +foldMapping '\x0398' = CM '\x03B8' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA +foldMapping '\x0399' = CM '\x03B9' '\0' '\0' +-- GREEK CAPITAL LETTER KAPPA +foldMapping '\x039A' = CM '\x03BA' '\0' '\0' +-- GREEK CAPITAL LETTER LAMDA +foldMapping '\x039B' = CM '\x03BB' '\0' '\0' +-- GREEK CAPITAL LETTER MU +foldMapping '\x039C' = CM '\x03BC' '\0' '\0' +-- GREEK CAPITAL LETTER NU +foldMapping '\x039D' = CM '\x03BD' '\0' '\0' +-- GREEK CAPITAL LETTER XI +foldMapping '\x039E' = CM '\x03BE' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON +foldMapping '\x039F' = CM '\x03BF' '\0' '\0' +-- GREEK CAPITAL LETTER PI +foldMapping '\x03A0' = CM '\x03C0' '\0' '\0' +-- GREEK CAPITAL LETTER RHO +foldMapping '\x03A1' = CM '\x03C1' '\0' '\0' +-- GREEK CAPITAL LETTER SIGMA +foldMapping '\x03A3' = CM '\x03C3' '\0' '\0' +-- GREEK CAPITAL LETTER TAU +foldMapping '\x03A4' = CM '\x03C4' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON +foldMapping '\x03A5' = CM '\x03C5' '\0' '\0' +-- GREEK CAPITAL LETTER PHI +foldMapping '\x03A6' = CM '\x03C6' '\0' '\0' +-- GREEK CAPITAL LETTER CHI +foldMapping '\x03A7' = CM '\x03C7' '\0' '\0' +-- GREEK CAPITAL LETTER PSI +foldMapping '\x03A8' = CM '\x03C8' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA +foldMapping '\x03A9' = CM '\x03C9' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DIALYTIKA +foldMapping '\x03AA' = CM '\x03CA' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA +foldMapping '\x03AB' = CM '\x03CB' '\0' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +foldMapping '\x03B0' = CM '\x03C5' '\x0308' '\x0301' +-- GREEK SMALL LETTER FINAL SIGMA +foldMapping '\x03C2' = CM '\x03C3' '\0' '\0' +-- GREEK CAPITAL KAI SYMBOL +foldMapping '\x03CF' = CM '\x03D7' '\0' '\0' +-- GREEK BETA SYMBOL +foldMapping '\x03D0' = CM '\x03B2' '\0' '\0' +-- GREEK THETA SYMBOL +foldMapping '\x03D1' = CM '\x03B8' '\0' '\0' +-- GREEK PHI SYMBOL +foldMapping '\x03D5' = CM '\x03C6' '\0' '\0' +-- GREEK PI SYMBOL +foldMapping '\x03D6' = CM '\x03C0' '\0' '\0' +-- GREEK LETTER ARCHAIC KOPPA +foldMapping '\x03D8' = CM '\x03D9' '\0' '\0' +-- GREEK LETTER STIGMA +foldMapping '\x03DA' = CM '\x03DB' '\0' '\0' +-- GREEK LETTER DIGAMMA +foldMapping '\x03DC' = CM '\x03DD' '\0' '\0' +-- GREEK LETTER KOPPA +foldMapping '\x03DE' = CM '\x03DF' '\0' '\0' +-- GREEK LETTER SAMPI +foldMapping '\x03E0' = CM '\x03E1' '\0' '\0' +-- COPTIC CAPITAL LETTER SHEI +foldMapping '\x03E2' = CM '\x03E3' '\0' '\0' +-- COPTIC CAPITAL LETTER FEI +foldMapping '\x03E4' = CM '\x03E5' '\0' '\0' +-- COPTIC CAPITAL LETTER KHEI +foldMapping '\x03E6' = CM '\x03E7' '\0' '\0' +-- COPTIC CAPITAL LETTER HORI +foldMapping '\x03E8' = CM '\x03E9' '\0' '\0' +-- COPTIC CAPITAL LETTER GANGIA +foldMapping '\x03EA' = CM '\x03EB' '\0' '\0' +-- COPTIC CAPITAL LETTER SHIMA +foldMapping '\x03EC' = CM '\x03ED' '\0' '\0' +-- COPTIC CAPITAL LETTER DEI +foldMapping '\x03EE' = CM '\x03EF' '\0' '\0' +-- GREEK KAPPA SYMBOL +foldMapping '\x03F0' = CM '\x03BA' '\0' '\0' +-- GREEK RHO SYMBOL +foldMapping '\x03F1' = CM '\x03C1' '\0' '\0' +-- GREEK CAPITAL THETA SYMBOL +foldMapping '\x03F4' = CM '\x03B8' '\0' '\0' +-- GREEK LUNATE EPSILON SYMBOL +foldMapping '\x03F5' = CM '\x03B5' '\0' '\0' +-- GREEK CAPITAL LETTER SHO +foldMapping '\x03F7' = CM '\x03F8' '\0' '\0' +-- GREEK CAPITAL LUNATE SIGMA SYMBOL +foldMapping '\x03F9' = CM '\x03F2' '\0' '\0' +-- GREEK CAPITAL LETTER SAN +foldMapping '\x03FA' = CM '\x03FB' '\0' '\0' +-- GREEK CAPITAL REVERSED LUNATE SIGMA SYMBOL +foldMapping '\x03FD' = CM '\x037B' '\0' '\0' +-- GREEK CAPITAL DOTTED LUNATE SIGMA SYMBOL +foldMapping '\x03FE' = CM '\x037C' '\0' '\0' +-- GREEK CAPITAL REVERSED DOTTED LUNATE SIGMA SYMBOL +foldMapping '\x03FF' = CM '\x037D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IE WITH GRAVE +foldMapping '\x0400' = CM '\x0450' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IO +foldMapping '\x0401' = CM '\x0451' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DJE +foldMapping '\x0402' = CM '\x0452' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GJE +foldMapping '\x0403' = CM '\x0453' '\0' '\0' +-- CYRILLIC CAPITAL LETTER UKRAINIAN IE +foldMapping '\x0404' = CM '\x0454' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZE +foldMapping '\x0405' = CM '\x0455' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I +foldMapping '\x0406' = CM '\x0456' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YI +foldMapping '\x0407' = CM '\x0457' '\0' '\0' +-- CYRILLIC CAPITAL LETTER JE +foldMapping '\x0408' = CM '\x0458' '\0' '\0' +-- CYRILLIC CAPITAL LETTER LJE +foldMapping '\x0409' = CM '\x0459' '\0' '\0' +-- CYRILLIC CAPITAL LETTER NJE +foldMapping '\x040A' = CM '\x045A' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TSHE +foldMapping '\x040B' = CM '\x045B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KJE +foldMapping '\x040C' = CM '\x045C' '\0' '\0' +-- CYRILLIC CAPITAL LETTER I WITH GRAVE +foldMapping '\x040D' = CM '\x045D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHORT U +foldMapping '\x040E' = CM '\x045E' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZHE +foldMapping '\x040F' = CM '\x045F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER A +foldMapping '\x0410' = CM '\x0430' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BE +foldMapping '\x0411' = CM '\x0431' '\0' '\0' +-- CYRILLIC CAPITAL LETTER VE +foldMapping '\x0412' = CM '\x0432' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE +foldMapping '\x0413' = CM '\x0433' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DE +foldMapping '\x0414' = CM '\x0434' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IE +foldMapping '\x0415' = CM '\x0435' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHE +foldMapping '\x0416' = CM '\x0436' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZE +foldMapping '\x0417' = CM '\x0437' '\0' '\0' +-- CYRILLIC CAPITAL LETTER I +foldMapping '\x0418' = CM '\x0438' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHORT I +foldMapping '\x0419' = CM '\x0439' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA +foldMapping '\x041A' = CM '\x043A' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL +foldMapping '\x041B' = CM '\x043B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EM +foldMapping '\x041C' = CM '\x043C' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN +foldMapping '\x041D' = CM '\x043D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER O +foldMapping '\x041E' = CM '\x043E' '\0' '\0' +-- CYRILLIC CAPITAL LETTER PE +foldMapping '\x041F' = CM '\x043F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ER +foldMapping '\x0420' = CM '\x0440' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ES +foldMapping '\x0421' = CM '\x0441' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TE +foldMapping '\x0422' = CM '\x0442' '\0' '\0' +-- CYRILLIC CAPITAL LETTER U +foldMapping '\x0423' = CM '\x0443' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EF +foldMapping '\x0424' = CM '\x0444' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HA +foldMapping '\x0425' = CM '\x0445' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TSE +foldMapping '\x0426' = CM '\x0446' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CHE +foldMapping '\x0427' = CM '\x0447' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHA +foldMapping '\x0428' = CM '\x0448' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHCHA +foldMapping '\x0429' = CM '\x0449' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HARD SIGN +foldMapping '\x042A' = CM '\x044A' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YERU +foldMapping '\x042B' = CM '\x044B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SOFT SIGN +foldMapping '\x042C' = CM '\x044C' '\0' '\0' +-- CYRILLIC CAPITAL LETTER E +foldMapping '\x042D' = CM '\x044D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YU +foldMapping '\x042E' = CM '\x044E' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YA +foldMapping '\x042F' = CM '\x044F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER OMEGA +foldMapping '\x0460' = CM '\x0461' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YAT +foldMapping '\x0462' = CM '\x0463' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED E +foldMapping '\x0464' = CM '\x0465' '\0' '\0' +-- CYRILLIC CAPITAL LETTER LITTLE YUS +foldMapping '\x0466' = CM '\x0467' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS +foldMapping '\x0468' = CM '\x0469' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BIG YUS +foldMapping '\x046A' = CM '\x046B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS +foldMapping '\x046C' = CM '\x046D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KSI +foldMapping '\x046E' = CM '\x046F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER PSI +foldMapping '\x0470' = CM '\x0471' '\0' '\0' +-- CYRILLIC CAPITAL LETTER FITA +foldMapping '\x0472' = CM '\x0473' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IZHITSA +foldMapping '\x0474' = CM '\x0475' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT +foldMapping '\x0476' = CM '\x0477' '\0' '\0' +-- CYRILLIC CAPITAL LETTER UK +foldMapping '\x0478' = CM '\x0479' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ROUND OMEGA +foldMapping '\x047A' = CM '\x047B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER OMEGA WITH TITLO +foldMapping '\x047C' = CM '\x047D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER OT +foldMapping '\x047E' = CM '\x047F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOPPA +foldMapping '\x0480' = CM '\x0481' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL +foldMapping '\x048A' = CM '\x048B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SEMISOFT SIGN +foldMapping '\x048C' = CM '\x048D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ER WITH TICK +foldMapping '\x048E' = CM '\x048F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH UPTURN +foldMapping '\x0490' = CM '\x0491' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH STROKE +foldMapping '\x0492' = CM '\x0493' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK +foldMapping '\x0494' = CM '\x0495' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER +foldMapping '\x0496' = CM '\x0497' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZE WITH DESCENDER +foldMapping '\x0498' = CM '\x0499' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA WITH DESCENDER +foldMapping '\x049A' = CM '\x049B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE +foldMapping '\x049C' = CM '\x049D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA WITH STROKE +foldMapping '\x049E' = CM '\x049F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BASHKIR KA +foldMapping '\x04A0' = CM '\x04A1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH DESCENDER +foldMapping '\x04A2' = CM '\x04A3' '\0' '\0' +-- CYRILLIC CAPITAL LIGATURE EN GHE +foldMapping '\x04A4' = CM '\x04A5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK +foldMapping '\x04A6' = CM '\x04A7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ABKHASIAN HA +foldMapping '\x04A8' = CM '\x04A9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ES WITH DESCENDER +foldMapping '\x04AA' = CM '\x04AB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TE WITH DESCENDER +foldMapping '\x04AC' = CM '\x04AD' '\0' '\0' +-- CYRILLIC CAPITAL LETTER STRAIGHT U +foldMapping '\x04AE' = CM '\x04AF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE +foldMapping '\x04B0' = CM '\x04B1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HA WITH DESCENDER +foldMapping '\x04B2' = CM '\x04B3' '\0' '\0' +-- CYRILLIC CAPITAL LIGATURE TE TSE +foldMapping '\x04B4' = CM '\x04B5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CHE WITH DESCENDER +foldMapping '\x04B6' = CM '\x04B7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE +foldMapping '\x04B8' = CM '\x04B9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHHA +foldMapping '\x04BA' = CM '\x04BB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ABKHASIAN CHE +foldMapping '\x04BC' = CM '\x04BD' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER +foldMapping '\x04BE' = CM '\x04BF' '\0' '\0' +-- CYRILLIC LETTER PALOCHKA +foldMapping '\x04C0' = CM '\x04CF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHE WITH BREVE +foldMapping '\x04C1' = CM '\x04C2' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KA WITH HOOK +foldMapping '\x04C3' = CM '\x04C4' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL WITH TAIL +foldMapping '\x04C5' = CM '\x04C6' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH HOOK +foldMapping '\x04C7' = CM '\x04C8' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH TAIL +foldMapping '\x04C9' = CM '\x04CA' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KHAKASSIAN CHE +foldMapping '\x04CB' = CM '\x04CC' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EM WITH TAIL +foldMapping '\x04CD' = CM '\x04CE' '\0' '\0' +-- CYRILLIC CAPITAL LETTER A WITH BREVE +foldMapping '\x04D0' = CM '\x04D1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER A WITH DIAERESIS +foldMapping '\x04D2' = CM '\x04D3' '\0' '\0' +-- CYRILLIC CAPITAL LIGATURE A IE +foldMapping '\x04D4' = CM '\x04D5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IE WITH BREVE +foldMapping '\x04D6' = CM '\x04D7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SCHWA +foldMapping '\x04D8' = CM '\x04D9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS +foldMapping '\x04DA' = CM '\x04DB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS +foldMapping '\x04DC' = CM '\x04DD' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS +foldMapping '\x04DE' = CM '\x04DF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ABKHASIAN DZE +foldMapping '\x04E0' = CM '\x04E1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER I WITH MACRON +foldMapping '\x04E2' = CM '\x04E3' '\0' '\0' +-- CYRILLIC CAPITAL LETTER I WITH DIAERESIS +foldMapping '\x04E4' = CM '\x04E5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER O WITH DIAERESIS +foldMapping '\x04E6' = CM '\x04E7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BARRED O +foldMapping '\x04E8' = CM '\x04E9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS +foldMapping '\x04EA' = CM '\x04EB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER E WITH DIAERESIS +foldMapping '\x04EC' = CM '\x04ED' '\0' '\0' +-- CYRILLIC CAPITAL LETTER U WITH MACRON +foldMapping '\x04EE' = CM '\x04EF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER U WITH DIAERESIS +foldMapping '\x04F0' = CM '\x04F1' '\0' '\0' +-- CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE +foldMapping '\x04F2' = CM '\x04F3' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS +foldMapping '\x04F4' = CM '\x04F5' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH DESCENDER +foldMapping '\x04F6' = CM '\x04F7' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS +foldMapping '\x04F8' = CM '\x04F9' '\0' '\0' +-- CYRILLIC CAPITAL LETTER GHE WITH STROKE AND HOOK +foldMapping '\x04FA' = CM '\x04FB' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HA WITH HOOK +foldMapping '\x04FC' = CM '\x04FD' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HA WITH STROKE +foldMapping '\x04FE' = CM '\x04FF' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI DE +foldMapping '\x0500' = CM '\x0501' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI DJE +foldMapping '\x0502' = CM '\x0503' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI ZJE +foldMapping '\x0504' = CM '\x0505' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI DZJE +foldMapping '\x0506' = CM '\x0507' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI LJE +foldMapping '\x0508' = CM '\x0509' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI NJE +foldMapping '\x050A' = CM '\x050B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI SJE +foldMapping '\x050C' = CM '\x050D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER KOMI TJE +foldMapping '\x050E' = CM '\x050F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER REVERSED ZE +foldMapping '\x0510' = CM '\x0511' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL WITH HOOK +foldMapping '\x0512' = CM '\x0513' '\0' '\0' +-- CYRILLIC CAPITAL LETTER LHA +foldMapping '\x0514' = CM '\x0515' '\0' '\0' +-- CYRILLIC CAPITAL LETTER RHA +foldMapping '\x0516' = CM '\x0517' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YAE +foldMapping '\x0518' = CM '\x0519' '\0' '\0' +-- CYRILLIC CAPITAL LETTER QA +foldMapping '\x051A' = CM '\x051B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER WE +foldMapping '\x051C' = CM '\x051D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ALEUT KA +foldMapping '\x051E' = CM '\x051F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL WITH MIDDLE HOOK +foldMapping '\x0520' = CM '\x0521' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH MIDDLE HOOK +foldMapping '\x0522' = CM '\x0523' '\0' '\0' +-- CYRILLIC CAPITAL LETTER PE WITH DESCENDER +foldMapping '\x0524' = CM '\x0525' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHHA WITH DESCENDER +foldMapping '\x0526' = CM '\x0527' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EN WITH LEFT HOOK +foldMapping '\x0528' = CM '\x0529' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZZHE +foldMapping '\x052A' = CM '\x052B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DCHE +foldMapping '\x052C' = CM '\x052D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER EL WITH DESCENDER +foldMapping '\x052E' = CM '\x052F' '\0' '\0' +-- ARMENIAN CAPITAL LETTER AYB +foldMapping '\x0531' = CM '\x0561' '\0' '\0' +-- ARMENIAN CAPITAL LETTER BEN +foldMapping '\x0532' = CM '\x0562' '\0' '\0' +-- ARMENIAN CAPITAL LETTER GIM +foldMapping '\x0533' = CM '\x0563' '\0' '\0' +-- ARMENIAN CAPITAL LETTER DA +foldMapping '\x0534' = CM '\x0564' '\0' '\0' +-- ARMENIAN CAPITAL LETTER ECH +foldMapping '\x0535' = CM '\x0565' '\0' '\0' +-- ARMENIAN CAPITAL LETTER ZA +foldMapping '\x0536' = CM '\x0566' '\0' '\0' +-- ARMENIAN CAPITAL LETTER EH +foldMapping '\x0537' = CM '\x0567' '\0' '\0' +-- ARMENIAN CAPITAL LETTER ET +foldMapping '\x0538' = CM '\x0568' '\0' '\0' +-- ARMENIAN CAPITAL LETTER TO +foldMapping '\x0539' = CM '\x0569' '\0' '\0' +-- ARMENIAN CAPITAL LETTER ZHE +foldMapping '\x053A' = CM '\x056A' '\0' '\0' +-- ARMENIAN CAPITAL LETTER INI +foldMapping '\x053B' = CM '\x056B' '\0' '\0' +-- ARMENIAN CAPITAL LETTER LIWN +foldMapping '\x053C' = CM '\x056C' '\0' '\0' +-- ARMENIAN CAPITAL LETTER XEH +foldMapping '\x053D' = CM '\x056D' '\0' '\0' +-- ARMENIAN CAPITAL LETTER CA +foldMapping '\x053E' = CM '\x056E' '\0' '\0' +-- ARMENIAN CAPITAL LETTER KEN +foldMapping '\x053F' = CM '\x056F' '\0' '\0' +-- ARMENIAN CAPITAL LETTER HO +foldMapping '\x0540' = CM '\x0570' '\0' '\0' +-- ARMENIAN CAPITAL LETTER JA +foldMapping '\x0541' = CM '\x0571' '\0' '\0' +-- ARMENIAN CAPITAL LETTER GHAD +foldMapping '\x0542' = CM '\x0572' '\0' '\0' +-- ARMENIAN CAPITAL LETTER CHEH +foldMapping '\x0543' = CM '\x0573' '\0' '\0' +-- ARMENIAN CAPITAL LETTER MEN +foldMapping '\x0544' = CM '\x0574' '\0' '\0' +-- ARMENIAN CAPITAL LETTER YI +foldMapping '\x0545' = CM '\x0575' '\0' '\0' +-- ARMENIAN CAPITAL LETTER NOW +foldMapping '\x0546' = CM '\x0576' '\0' '\0' +-- ARMENIAN CAPITAL LETTER SHA +foldMapping '\x0547' = CM '\x0577' '\0' '\0' +-- ARMENIAN CAPITAL LETTER VO +foldMapping '\x0548' = CM '\x0578' '\0' '\0' +-- ARMENIAN CAPITAL LETTER CHA +foldMapping '\x0549' = CM '\x0579' '\0' '\0' +-- ARMENIAN CAPITAL LETTER PEH +foldMapping '\x054A' = CM '\x057A' '\0' '\0' +-- ARMENIAN CAPITAL LETTER JHEH +foldMapping '\x054B' = CM '\x057B' '\0' '\0' +-- ARMENIAN CAPITAL LETTER RA +foldMapping '\x054C' = CM '\x057C' '\0' '\0' +-- ARMENIAN CAPITAL LETTER SEH +foldMapping '\x054D' = CM '\x057D' '\0' '\0' +-- ARMENIAN CAPITAL LETTER VEW +foldMapping '\x054E' = CM '\x057E' '\0' '\0' +-- ARMENIAN CAPITAL LETTER TIWN +foldMapping '\x054F' = CM '\x057F' '\0' '\0' +-- ARMENIAN CAPITAL LETTER REH +foldMapping '\x0550' = CM '\x0580' '\0' '\0' +-- ARMENIAN CAPITAL LETTER CO +foldMapping '\x0551' = CM '\x0581' '\0' '\0' +-- ARMENIAN CAPITAL LETTER YIWN +foldMapping '\x0552' = CM '\x0582' '\0' '\0' +-- ARMENIAN CAPITAL LETTER PIWR +foldMapping '\x0553' = CM '\x0583' '\0' '\0' +-- ARMENIAN CAPITAL LETTER KEH +foldMapping '\x0554' = CM '\x0584' '\0' '\0' +-- ARMENIAN CAPITAL LETTER OH +foldMapping '\x0555' = CM '\x0585' '\0' '\0' +-- ARMENIAN CAPITAL LETTER FEH +foldMapping '\x0556' = CM '\x0586' '\0' '\0' +-- ARMENIAN SMALL LIGATURE ECH YIWN +foldMapping '\x0587' = CM '\x0565' '\x0582' '\0' +-- GEORGIAN CAPITAL LETTER AN +foldMapping '\x10A0' = CM '\x2D00' '\0' '\0' +-- GEORGIAN CAPITAL LETTER BAN +foldMapping '\x10A1' = CM '\x2D01' '\0' '\0' +-- GEORGIAN CAPITAL LETTER GAN +foldMapping '\x10A2' = CM '\x2D02' '\0' '\0' +-- GEORGIAN CAPITAL LETTER DON +foldMapping '\x10A3' = CM '\x2D03' '\0' '\0' +-- GEORGIAN CAPITAL LETTER EN +foldMapping '\x10A4' = CM '\x2D04' '\0' '\0' +-- GEORGIAN CAPITAL LETTER VIN +foldMapping '\x10A5' = CM '\x2D05' '\0' '\0' +-- GEORGIAN CAPITAL LETTER ZEN +foldMapping '\x10A6' = CM '\x2D06' '\0' '\0' +-- GEORGIAN CAPITAL LETTER TAN +foldMapping '\x10A7' = CM '\x2D07' '\0' '\0' +-- GEORGIAN CAPITAL LETTER IN +foldMapping '\x10A8' = CM '\x2D08' '\0' '\0' +-- GEORGIAN CAPITAL LETTER KAN +foldMapping '\x10A9' = CM '\x2D09' '\0' '\0' +-- GEORGIAN CAPITAL LETTER LAS +foldMapping '\x10AA' = CM '\x2D0A' '\0' '\0' +-- GEORGIAN CAPITAL LETTER MAN +foldMapping '\x10AB' = CM '\x2D0B' '\0' '\0' +-- GEORGIAN CAPITAL LETTER NAR +foldMapping '\x10AC' = CM '\x2D0C' '\0' '\0' +-- GEORGIAN CAPITAL LETTER ON +foldMapping '\x10AD' = CM '\x2D0D' '\0' '\0' +-- GEORGIAN CAPITAL LETTER PAR +foldMapping '\x10AE' = CM '\x2D0E' '\0' '\0' +-- GEORGIAN CAPITAL LETTER ZHAR +foldMapping '\x10AF' = CM '\x2D0F' '\0' '\0' +-- GEORGIAN CAPITAL LETTER RAE +foldMapping '\x10B0' = CM '\x2D10' '\0' '\0' +-- GEORGIAN CAPITAL LETTER SAN +foldMapping '\x10B1' = CM '\x2D11' '\0' '\0' +-- GEORGIAN CAPITAL LETTER TAR +foldMapping '\x10B2' = CM '\x2D12' '\0' '\0' +-- GEORGIAN CAPITAL LETTER UN +foldMapping '\x10B3' = CM '\x2D13' '\0' '\0' +-- GEORGIAN CAPITAL LETTER PHAR +foldMapping '\x10B4' = CM '\x2D14' '\0' '\0' +-- GEORGIAN CAPITAL LETTER KHAR +foldMapping '\x10B5' = CM '\x2D15' '\0' '\0' +-- GEORGIAN CAPITAL LETTER GHAN +foldMapping '\x10B6' = CM '\x2D16' '\0' '\0' +-- GEORGIAN CAPITAL LETTER QAR +foldMapping '\x10B7' = CM '\x2D17' '\0' '\0' +-- GEORGIAN CAPITAL LETTER SHIN +foldMapping '\x10B8' = CM '\x2D18' '\0' '\0' +-- GEORGIAN CAPITAL LETTER CHIN +foldMapping '\x10B9' = CM '\x2D19' '\0' '\0' +-- GEORGIAN CAPITAL LETTER CAN +foldMapping '\x10BA' = CM '\x2D1A' '\0' '\0' +-- GEORGIAN CAPITAL LETTER JIL +foldMapping '\x10BB' = CM '\x2D1B' '\0' '\0' +-- GEORGIAN CAPITAL LETTER CIL +foldMapping '\x10BC' = CM '\x2D1C' '\0' '\0' +-- GEORGIAN CAPITAL LETTER CHAR +foldMapping '\x10BD' = CM '\x2D1D' '\0' '\0' +-- GEORGIAN CAPITAL LETTER XAN +foldMapping '\x10BE' = CM '\x2D1E' '\0' '\0' +-- GEORGIAN CAPITAL LETTER JHAN +foldMapping '\x10BF' = CM '\x2D1F' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HAE +foldMapping '\x10C0' = CM '\x2D20' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HE +foldMapping '\x10C1' = CM '\x2D21' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HIE +foldMapping '\x10C2' = CM '\x2D22' '\0' '\0' +-- GEORGIAN CAPITAL LETTER WE +foldMapping '\x10C3' = CM '\x2D23' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HAR +foldMapping '\x10C4' = CM '\x2D24' '\0' '\0' +-- GEORGIAN CAPITAL LETTER HOE +foldMapping '\x10C5' = CM '\x2D25' '\0' '\0' +-- GEORGIAN CAPITAL LETTER YN +foldMapping '\x10C7' = CM '\x2D27' '\0' '\0' +-- GEORGIAN CAPITAL LETTER AEN +foldMapping '\x10CD' = CM '\x2D2D' '\0' '\0' +-- CHEROKEE SMALL LETTER YE +foldMapping '\x13F8' = CM '\x13F0' '\0' '\0' +-- CHEROKEE SMALL LETTER YI +foldMapping '\x13F9' = CM '\x13F1' '\0' '\0' +-- CHEROKEE SMALL LETTER YO +foldMapping '\x13FA' = CM '\x13F2' '\0' '\0' +-- CHEROKEE SMALL LETTER YU +foldMapping '\x13FB' = CM '\x13F3' '\0' '\0' +-- CHEROKEE SMALL LETTER YV +foldMapping '\x13FC' = CM '\x13F4' '\0' '\0' +-- CHEROKEE SMALL LETTER MV +foldMapping '\x13FD' = CM '\x13F5' '\0' '\0' +-- CYRILLIC SMALL LETTER ROUNDED VE +foldMapping '\x1C80' = CM '\x0432' '\0' '\0' +-- CYRILLIC SMALL LETTER LONG-LEGGED DE +foldMapping '\x1C81' = CM '\x0434' '\0' '\0' +-- CYRILLIC SMALL LETTER NARROW O +foldMapping '\x1C82' = CM '\x043E' '\0' '\0' +-- CYRILLIC SMALL LETTER WIDE ES +foldMapping '\x1C83' = CM '\x0441' '\0' '\0' +-- CYRILLIC SMALL LETTER TALL TE +foldMapping '\x1C84' = CM '\x0442' '\0' '\0' +-- CYRILLIC SMALL LETTER THREE-LEGGED TE +foldMapping '\x1C85' = CM '\x0442' '\0' '\0' +-- CYRILLIC SMALL LETTER TALL HARD SIGN +foldMapping '\x1C86' = CM '\x044A' '\0' '\0' +-- CYRILLIC SMALL LETTER TALL YAT +foldMapping '\x1C87' = CM '\x0463' '\0' '\0' +-- CYRILLIC SMALL LETTER UNBLENDED UK +foldMapping '\x1C88' = CM '\xA64B' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH RING BELOW +foldMapping '\x1E00' = CM '\x1E01' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH DOT ABOVE +foldMapping '\x1E02' = CM '\x1E03' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH DOT BELOW +foldMapping '\x1E04' = CM '\x1E05' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH LINE BELOW +foldMapping '\x1E06' = CM '\x1E07' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE +foldMapping '\x1E08' = CM '\x1E09' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH DOT ABOVE +foldMapping '\x1E0A' = CM '\x1E0B' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH DOT BELOW +foldMapping '\x1E0C' = CM '\x1E0D' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH LINE BELOW +foldMapping '\x1E0E' = CM '\x1E0F' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH CEDILLA +foldMapping '\x1E10' = CM '\x1E11' '\0' '\0' +-- LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW +foldMapping '\x1E12' = CM '\x1E13' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH MACRON AND GRAVE +foldMapping '\x1E14' = CM '\x1E15' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH MACRON AND ACUTE +foldMapping '\x1E16' = CM '\x1E17' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW +foldMapping '\x1E18' = CM '\x1E19' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH TILDE BELOW +foldMapping '\x1E1A' = CM '\x1E1B' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE +foldMapping '\x1E1C' = CM '\x1E1D' '\0' '\0' +-- LATIN CAPITAL LETTER F WITH DOT ABOVE +foldMapping '\x1E1E' = CM '\x1E1F' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH MACRON +foldMapping '\x1E20' = CM '\x1E21' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH DOT ABOVE +foldMapping '\x1E22' = CM '\x1E23' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH DOT BELOW +foldMapping '\x1E24' = CM '\x1E25' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH DIAERESIS +foldMapping '\x1E26' = CM '\x1E27' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH CEDILLA +foldMapping '\x1E28' = CM '\x1E29' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH BREVE BELOW +foldMapping '\x1E2A' = CM '\x1E2B' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH TILDE BELOW +foldMapping '\x1E2C' = CM '\x1E2D' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE +foldMapping '\x1E2E' = CM '\x1E2F' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH ACUTE +foldMapping '\x1E30' = CM '\x1E31' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH DOT BELOW +foldMapping '\x1E32' = CM '\x1E33' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH LINE BELOW +foldMapping '\x1E34' = CM '\x1E35' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH DOT BELOW +foldMapping '\x1E36' = CM '\x1E37' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON +foldMapping '\x1E38' = CM '\x1E39' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH LINE BELOW +foldMapping '\x1E3A' = CM '\x1E3B' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW +foldMapping '\x1E3C' = CM '\x1E3D' '\0' '\0' +-- LATIN CAPITAL LETTER M WITH ACUTE +foldMapping '\x1E3E' = CM '\x1E3F' '\0' '\0' +-- LATIN CAPITAL LETTER M WITH DOT ABOVE +foldMapping '\x1E40' = CM '\x1E41' '\0' '\0' +-- LATIN CAPITAL LETTER M WITH DOT BELOW +foldMapping '\x1E42' = CM '\x1E43' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH DOT ABOVE +foldMapping '\x1E44' = CM '\x1E45' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH DOT BELOW +foldMapping '\x1E46' = CM '\x1E47' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH LINE BELOW +foldMapping '\x1E48' = CM '\x1E49' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW +foldMapping '\x1E4A' = CM '\x1E4B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH TILDE AND ACUTE +foldMapping '\x1E4C' = CM '\x1E4D' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS +foldMapping '\x1E4E' = CM '\x1E4F' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH MACRON AND GRAVE +foldMapping '\x1E50' = CM '\x1E51' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH MACRON AND ACUTE +foldMapping '\x1E52' = CM '\x1E53' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH ACUTE +foldMapping '\x1E54' = CM '\x1E55' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH DOT ABOVE +foldMapping '\x1E56' = CM '\x1E57' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH DOT ABOVE +foldMapping '\x1E58' = CM '\x1E59' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH DOT BELOW +foldMapping '\x1E5A' = CM '\x1E5B' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON +foldMapping '\x1E5C' = CM '\x1E5D' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH LINE BELOW +foldMapping '\x1E5E' = CM '\x1E5F' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH DOT ABOVE +foldMapping '\x1E60' = CM '\x1E61' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH DOT BELOW +foldMapping '\x1E62' = CM '\x1E63' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE +foldMapping '\x1E64' = CM '\x1E65' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE +foldMapping '\x1E66' = CM '\x1E67' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE +foldMapping '\x1E68' = CM '\x1E69' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH DOT ABOVE +foldMapping '\x1E6A' = CM '\x1E6B' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH DOT BELOW +foldMapping '\x1E6C' = CM '\x1E6D' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH LINE BELOW +foldMapping '\x1E6E' = CM '\x1E6F' '\0' '\0' +-- LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW +foldMapping '\x1E70' = CM '\x1E71' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DIAERESIS BELOW +foldMapping '\x1E72' = CM '\x1E73' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH TILDE BELOW +foldMapping '\x1E74' = CM '\x1E75' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW +foldMapping '\x1E76' = CM '\x1E77' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH TILDE AND ACUTE +foldMapping '\x1E78' = CM '\x1E79' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS +foldMapping '\x1E7A' = CM '\x1E7B' '\0' '\0' +-- LATIN CAPITAL LETTER V WITH TILDE +foldMapping '\x1E7C' = CM '\x1E7D' '\0' '\0' +-- LATIN CAPITAL LETTER V WITH DOT BELOW +foldMapping '\x1E7E' = CM '\x1E7F' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH GRAVE +foldMapping '\x1E80' = CM '\x1E81' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH ACUTE +foldMapping '\x1E82' = CM '\x1E83' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH DIAERESIS +foldMapping '\x1E84' = CM '\x1E85' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH DOT ABOVE +foldMapping '\x1E86' = CM '\x1E87' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH DOT BELOW +foldMapping '\x1E88' = CM '\x1E89' '\0' '\0' +-- LATIN CAPITAL LETTER X WITH DOT ABOVE +foldMapping '\x1E8A' = CM '\x1E8B' '\0' '\0' +-- LATIN CAPITAL LETTER X WITH DIAERESIS +foldMapping '\x1E8C' = CM '\x1E8D' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH DOT ABOVE +foldMapping '\x1E8E' = CM '\x1E8F' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH CIRCUMFLEX +foldMapping '\x1E90' = CM '\x1E91' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH DOT BELOW +foldMapping '\x1E92' = CM '\x1E93' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH LINE BELOW +foldMapping '\x1E94' = CM '\x1E95' '\0' '\0' +-- LATIN SMALL LETTER H WITH LINE BELOW +foldMapping '\x1E96' = CM '\x0068' '\x0331' '\0' +-- LATIN SMALL LETTER T WITH DIAERESIS +foldMapping '\x1E97' = CM '\x0074' '\x0308' '\0' +-- LATIN SMALL LETTER W WITH RING ABOVE +foldMapping '\x1E98' = CM '\x0077' '\x030A' '\0' +-- LATIN SMALL LETTER Y WITH RING ABOVE +foldMapping '\x1E99' = CM '\x0079' '\x030A' '\0' +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +foldMapping '\x1E9A' = CM '\x0061' '\x02BE' '\0' +-- LATIN SMALL LETTER LONG S WITH DOT ABOVE +foldMapping '\x1E9B' = CM '\x1E61' '\0' '\0' +-- LATIN CAPITAL LETTER SHARP S +foldMapping '\x1E9E' = CM '\x0073' '\x0073' '\0' +-- LATIN CAPITAL LETTER A WITH DOT BELOW +foldMapping '\x1EA0' = CM '\x1EA1' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH HOOK ABOVE +foldMapping '\x1EA2' = CM '\x1EA3' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE +foldMapping '\x1EA4' = CM '\x1EA5' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE +foldMapping '\x1EA6' = CM '\x1EA7' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE +foldMapping '\x1EA8' = CM '\x1EA9' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE +foldMapping '\x1EAA' = CM '\x1EAB' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW +foldMapping '\x1EAC' = CM '\x1EAD' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND ACUTE +foldMapping '\x1EAE' = CM '\x1EAF' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND GRAVE +foldMapping '\x1EB0' = CM '\x1EB1' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE +foldMapping '\x1EB2' = CM '\x1EB3' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND TILDE +foldMapping '\x1EB4' = CM '\x1EB5' '\0' '\0' +-- LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW +foldMapping '\x1EB6' = CM '\x1EB7' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH DOT BELOW +foldMapping '\x1EB8' = CM '\x1EB9' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH HOOK ABOVE +foldMapping '\x1EBA' = CM '\x1EBB' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH TILDE +foldMapping '\x1EBC' = CM '\x1EBD' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE +foldMapping '\x1EBE' = CM '\x1EBF' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE +foldMapping '\x1EC0' = CM '\x1EC1' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE +foldMapping '\x1EC2' = CM '\x1EC3' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE +foldMapping '\x1EC4' = CM '\x1EC5' '\0' '\0' +-- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW +foldMapping '\x1EC6' = CM '\x1EC7' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH HOOK ABOVE +foldMapping '\x1EC8' = CM '\x1EC9' '\0' '\0' +-- LATIN CAPITAL LETTER I WITH DOT BELOW +foldMapping '\x1ECA' = CM '\x1ECB' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH DOT BELOW +foldMapping '\x1ECC' = CM '\x1ECD' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HOOK ABOVE +foldMapping '\x1ECE' = CM '\x1ECF' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE +foldMapping '\x1ED0' = CM '\x1ED1' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE +foldMapping '\x1ED2' = CM '\x1ED3' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE +foldMapping '\x1ED4' = CM '\x1ED5' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE +foldMapping '\x1ED6' = CM '\x1ED7' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW +foldMapping '\x1ED8' = CM '\x1ED9' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND ACUTE +foldMapping '\x1EDA' = CM '\x1EDB' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND GRAVE +foldMapping '\x1EDC' = CM '\x1EDD' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE +foldMapping '\x1EDE' = CM '\x1EDF' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND TILDE +foldMapping '\x1EE0' = CM '\x1EE1' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW +foldMapping '\x1EE2' = CM '\x1EE3' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH DOT BELOW +foldMapping '\x1EE4' = CM '\x1EE5' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HOOK ABOVE +foldMapping '\x1EE6' = CM '\x1EE7' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND ACUTE +foldMapping '\x1EE8' = CM '\x1EE9' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND GRAVE +foldMapping '\x1EEA' = CM '\x1EEB' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE +foldMapping '\x1EEC' = CM '\x1EED' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND TILDE +foldMapping '\x1EEE' = CM '\x1EEF' '\0' '\0' +-- LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW +foldMapping '\x1EF0' = CM '\x1EF1' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH GRAVE +foldMapping '\x1EF2' = CM '\x1EF3' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH DOT BELOW +foldMapping '\x1EF4' = CM '\x1EF5' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH HOOK ABOVE +foldMapping '\x1EF6' = CM '\x1EF7' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH TILDE +foldMapping '\x1EF8' = CM '\x1EF9' '\0' '\0' +-- LATIN CAPITAL LETTER MIDDLE-WELSH LL +foldMapping '\x1EFA' = CM '\x1EFB' '\0' '\0' +-- LATIN CAPITAL LETTER MIDDLE-WELSH V +foldMapping '\x1EFC' = CM '\x1EFD' '\0' '\0' +-- LATIN CAPITAL LETTER Y WITH LOOP +foldMapping '\x1EFE' = CM '\x1EFF' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI +foldMapping '\x1F08' = CM '\x1F00' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA +foldMapping '\x1F09' = CM '\x1F01' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA +foldMapping '\x1F0A' = CM '\x1F02' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA +foldMapping '\x1F0B' = CM '\x1F03' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA +foldMapping '\x1F0C' = CM '\x1F04' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA +foldMapping '\x1F0D' = CM '\x1F05' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI +foldMapping '\x1F0E' = CM '\x1F06' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI +foldMapping '\x1F0F' = CM '\x1F07' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH PSILI +foldMapping '\x1F18' = CM '\x1F10' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH DASIA +foldMapping '\x1F19' = CM '\x1F11' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH PSILI AND VARIA +foldMapping '\x1F1A' = CM '\x1F12' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH DASIA AND VARIA +foldMapping '\x1F1B' = CM '\x1F13' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH PSILI AND OXIA +foldMapping '\x1F1C' = CM '\x1F14' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA +foldMapping '\x1F1D' = CM '\x1F15' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI +foldMapping '\x1F28' = CM '\x1F20' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA +foldMapping '\x1F29' = CM '\x1F21' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA +foldMapping '\x1F2A' = CM '\x1F22' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA +foldMapping '\x1F2B' = CM '\x1F23' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA +foldMapping '\x1F2C' = CM '\x1F24' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA +foldMapping '\x1F2D' = CM '\x1F25' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI +foldMapping '\x1F2E' = CM '\x1F26' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI +foldMapping '\x1F2F' = CM '\x1F27' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH PSILI +foldMapping '\x1F38' = CM '\x1F30' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DASIA +foldMapping '\x1F39' = CM '\x1F31' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH PSILI AND VARIA +foldMapping '\x1F3A' = CM '\x1F32' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DASIA AND VARIA +foldMapping '\x1F3B' = CM '\x1F33' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH PSILI AND OXIA +foldMapping '\x1F3C' = CM '\x1F34' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DASIA AND OXIA +foldMapping '\x1F3D' = CM '\x1F35' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH PSILI AND PERISPOMENI +foldMapping '\x1F3E' = CM '\x1F36' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI +foldMapping '\x1F3F' = CM '\x1F37' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH PSILI +foldMapping '\x1F48' = CM '\x1F40' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH DASIA +foldMapping '\x1F49' = CM '\x1F41' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH PSILI AND VARIA +foldMapping '\x1F4A' = CM '\x1F42' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH DASIA AND VARIA +foldMapping '\x1F4B' = CM '\x1F43' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH PSILI AND OXIA +foldMapping '\x1F4C' = CM '\x1F44' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA +foldMapping '\x1F4D' = CM '\x1F45' '\0' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI +foldMapping '\x1F50' = CM '\x03C5' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +foldMapping '\x1F52' = CM '\x03C5' '\x0313' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +foldMapping '\x1F54' = CM '\x03C5' '\x0313' '\x0301' +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +foldMapping '\x1F56' = CM '\x03C5' '\x0313' '\x0342' +-- GREEK CAPITAL LETTER UPSILON WITH DASIA +foldMapping '\x1F59' = CM '\x1F51' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA +foldMapping '\x1F5B' = CM '\x1F53' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA +foldMapping '\x1F5D' = CM '\x1F55' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI +foldMapping '\x1F5F' = CM '\x1F57' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI +foldMapping '\x1F68' = CM '\x1F60' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA +foldMapping '\x1F69' = CM '\x1F61' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA +foldMapping '\x1F6A' = CM '\x1F62' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA +foldMapping '\x1F6B' = CM '\x1F63' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA +foldMapping '\x1F6C' = CM '\x1F64' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA +foldMapping '\x1F6D' = CM '\x1F65' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI +foldMapping '\x1F6E' = CM '\x1F66' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI +foldMapping '\x1F6F' = CM '\x1F67' '\0' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1F80' = CM '\x1F00' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1F81' = CM '\x1F01' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1F82' = CM '\x1F02' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1F83' = CM '\x1F03' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1F84' = CM '\x1F04' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1F85' = CM '\x1F05' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1F86' = CM '\x1F06' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1F87' = CM '\x1F07' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1F88' = CM '\x1F00' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1F89' = CM '\x1F01' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1F8A' = CM '\x1F02' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1F8B' = CM '\x1F03' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1F8C' = CM '\x1F04' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1F8D' = CM '\x1F05' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1F8E' = CM '\x1F06' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1F8F' = CM '\x1F07' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1F90' = CM '\x1F20' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1F91' = CM '\x1F21' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1F92' = CM '\x1F22' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1F93' = CM '\x1F23' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1F94' = CM '\x1F24' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1F95' = CM '\x1F25' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1F96' = CM '\x1F26' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1F97' = CM '\x1F27' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1F98' = CM '\x1F20' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1F99' = CM '\x1F21' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1F9A' = CM '\x1F22' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1F9B' = CM '\x1F23' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1F9C' = CM '\x1F24' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1F9D' = CM '\x1F25' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1F9E' = CM '\x1F26' '\x03B9' '\0' +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1F9F' = CM '\x1F27' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1FA0' = CM '\x1F60' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1FA1' = CM '\x1F61' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1FA2' = CM '\x1F62' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1FA3' = CM '\x1F63' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1FA4' = CM '\x1F64' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1FA5' = CM '\x1F65' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FA6' = CM '\x1F66' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FA7' = CM '\x1F67' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1FA8' = CM '\x1F60' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1FA9' = CM '\x1F61' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1FAA' = CM '\x1F62' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1FAB' = CM '\x1F63' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1FAC' = CM '\x1F64' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1FAD' = CM '\x1F65' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1FAE' = CM '\x1F66' '\x03B9' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1FAF' = CM '\x1F67' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1FB2' = CM '\x1F70' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +foldMapping '\x1FB3' = CM '\x03B1' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1FB4' = CM '\x03AC' '\x03B9' '\0' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +foldMapping '\x1FB6' = CM '\x03B1' '\x0342' '\0' +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FB7' = CM '\x03B1' '\x0342' '\x03B9' +-- GREEK CAPITAL LETTER ALPHA WITH VRACHY +foldMapping '\x1FB8' = CM '\x1FB0' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH MACRON +foldMapping '\x1FB9' = CM '\x1FB1' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH VARIA +foldMapping '\x1FBA' = CM '\x1F70' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH OXIA +foldMapping '\x1FBB' = CM '\x1F71' '\0' '\0' +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +foldMapping '\x1FBC' = CM '\x03B1' '\x03B9' '\0' +-- GREEK PROSGEGRAMMENI +foldMapping '\x1FBE' = CM '\x03B9' '\0' '\0' +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1FC2' = CM '\x1F74' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +foldMapping '\x1FC3' = CM '\x03B7' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1FC4' = CM '\x03AE' '\x03B9' '\0' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +foldMapping '\x1FC6' = CM '\x03B7' '\x0342' '\0' +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FC7' = CM '\x03B7' '\x0342' '\x03B9' +-- GREEK CAPITAL LETTER EPSILON WITH VARIA +foldMapping '\x1FC8' = CM '\x1F72' '\0' '\0' +-- GREEK CAPITAL LETTER EPSILON WITH OXIA +foldMapping '\x1FC9' = CM '\x1F73' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH VARIA +foldMapping '\x1FCA' = CM '\x1F74' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH OXIA +foldMapping '\x1FCB' = CM '\x1F75' '\0' '\0' +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +foldMapping '\x1FCC' = CM '\x03B7' '\x03B9' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +foldMapping '\x1FD2' = CM '\x03B9' '\x0308' '\x0300' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +foldMapping '\x1FD3' = CM '\x03B9' '\x0308' '\x0301' +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +foldMapping '\x1FD6' = CM '\x03B9' '\x0342' '\0' +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1FD7' = CM '\x03B9' '\x0308' '\x0342' +-- GREEK CAPITAL LETTER IOTA WITH VRACHY +foldMapping '\x1FD8' = CM '\x1FD0' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH MACRON +foldMapping '\x1FD9' = CM '\x1FD1' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH VARIA +foldMapping '\x1FDA' = CM '\x1F76' '\0' '\0' +-- GREEK CAPITAL LETTER IOTA WITH OXIA +foldMapping '\x1FDB' = CM '\x1F77' '\0' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +foldMapping '\x1FE2' = CM '\x03C5' '\x0308' '\x0300' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +foldMapping '\x1FE3' = CM '\x03C5' '\x0308' '\x0301' +-- GREEK SMALL LETTER RHO WITH PSILI +foldMapping '\x1FE4' = CM '\x03C1' '\x0313' '\0' +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +foldMapping '\x1FE6' = CM '\x03C5' '\x0342' '\0' +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1FE7' = CM '\x03C5' '\x0308' '\x0342' +-- GREEK CAPITAL LETTER UPSILON WITH VRACHY +foldMapping '\x1FE8' = CM '\x1FE0' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH MACRON +foldMapping '\x1FE9' = CM '\x1FE1' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH VARIA +foldMapping '\x1FEA' = CM '\x1F7A' '\0' '\0' +-- GREEK CAPITAL LETTER UPSILON WITH OXIA +foldMapping '\x1FEB' = CM '\x1F7B' '\0' '\0' +-- GREEK CAPITAL LETTER RHO WITH DASIA +foldMapping '\x1FEC' = CM '\x1FE5' '\0' '\0' +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1FF2' = CM '\x1F7C' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +foldMapping '\x1FF3' = CM '\x03C9' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1FF4' = CM '\x03CE' '\x03B9' '\0' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +foldMapping '\x1FF6' = CM '\x03C9' '\x0342' '\0' +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1FF7' = CM '\x03C9' '\x0342' '\x03B9' +-- GREEK CAPITAL LETTER OMICRON WITH VARIA +foldMapping '\x1FF8' = CM '\x1F78' '\0' '\0' +-- GREEK CAPITAL LETTER OMICRON WITH OXIA +foldMapping '\x1FF9' = CM '\x1F79' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH VARIA +foldMapping '\x1FFA' = CM '\x1F7C' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH OXIA +foldMapping '\x1FFB' = CM '\x1F7D' '\0' '\0' +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +foldMapping '\x1FFC' = CM '\x03C9' '\x03B9' '\0' +-- OHM SIGN +foldMapping '\x2126' = CM '\x03C9' '\0' '\0' +-- KELVIN SIGN +foldMapping '\x212A' = CM '\x006B' '\0' '\0' +-- ANGSTROM SIGN +foldMapping '\x212B' = CM '\x00E5' '\0' '\0' +-- TURNED CAPITAL F +foldMapping '\x2132' = CM '\x214E' '\0' '\0' +-- ROMAN NUMERAL ONE +foldMapping '\x2160' = CM '\x2170' '\0' '\0' +-- ROMAN NUMERAL TWO +foldMapping '\x2161' = CM '\x2171' '\0' '\0' +-- ROMAN NUMERAL THREE +foldMapping '\x2162' = CM '\x2172' '\0' '\0' +-- ROMAN NUMERAL FOUR +foldMapping '\x2163' = CM '\x2173' '\0' '\0' +-- ROMAN NUMERAL FIVE +foldMapping '\x2164' = CM '\x2174' '\0' '\0' +-- ROMAN NUMERAL SIX +foldMapping '\x2165' = CM '\x2175' '\0' '\0' +-- ROMAN NUMERAL SEVEN +foldMapping '\x2166' = CM '\x2176' '\0' '\0' +-- ROMAN NUMERAL EIGHT +foldMapping '\x2167' = CM '\x2177' '\0' '\0' +-- ROMAN NUMERAL NINE +foldMapping '\x2168' = CM '\x2178' '\0' '\0' +-- ROMAN NUMERAL TEN +foldMapping '\x2169' = CM '\x2179' '\0' '\0' +-- ROMAN NUMERAL ELEVEN +foldMapping '\x216A' = CM '\x217A' '\0' '\0' +-- ROMAN NUMERAL TWELVE +foldMapping '\x216B' = CM '\x217B' '\0' '\0' +-- ROMAN NUMERAL FIFTY +foldMapping '\x216C' = CM '\x217C' '\0' '\0' +-- ROMAN NUMERAL ONE HUNDRED +foldMapping '\x216D' = CM '\x217D' '\0' '\0' +-- ROMAN NUMERAL FIVE HUNDRED +foldMapping '\x216E' = CM '\x217E' '\0' '\0' +-- ROMAN NUMERAL ONE THOUSAND +foldMapping '\x216F' = CM '\x217F' '\0' '\0' +-- ROMAN NUMERAL REVERSED ONE HUNDRED +foldMapping '\x2183' = CM '\x2184' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER A +foldMapping '\x24B6' = CM '\x24D0' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER B +foldMapping '\x24B7' = CM '\x24D1' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER C +foldMapping '\x24B8' = CM '\x24D2' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER D +foldMapping '\x24B9' = CM '\x24D3' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER E +foldMapping '\x24BA' = CM '\x24D4' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER F +foldMapping '\x24BB' = CM '\x24D5' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER G +foldMapping '\x24BC' = CM '\x24D6' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER H +foldMapping '\x24BD' = CM '\x24D7' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER I +foldMapping '\x24BE' = CM '\x24D8' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER J +foldMapping '\x24BF' = CM '\x24D9' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER K +foldMapping '\x24C0' = CM '\x24DA' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER L +foldMapping '\x24C1' = CM '\x24DB' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER M +foldMapping '\x24C2' = CM '\x24DC' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER N +foldMapping '\x24C3' = CM '\x24DD' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER O +foldMapping '\x24C4' = CM '\x24DE' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER P +foldMapping '\x24C5' = CM '\x24DF' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER Q +foldMapping '\x24C6' = CM '\x24E0' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER R +foldMapping '\x24C7' = CM '\x24E1' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER S +foldMapping '\x24C8' = CM '\x24E2' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER T +foldMapping '\x24C9' = CM '\x24E3' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER U +foldMapping '\x24CA' = CM '\x24E4' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER V +foldMapping '\x24CB' = CM '\x24E5' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER W +foldMapping '\x24CC' = CM '\x24E6' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER X +foldMapping '\x24CD' = CM '\x24E7' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER Y +foldMapping '\x24CE' = CM '\x24E8' '\0' '\0' +-- CIRCLED LATIN CAPITAL LETTER Z +foldMapping '\x24CF' = CM '\x24E9' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER AZU +foldMapping '\x2C00' = CM '\x2C30' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER BUKY +foldMapping '\x2C01' = CM '\x2C31' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER VEDE +foldMapping '\x2C02' = CM '\x2C32' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER GLAGOLI +foldMapping '\x2C03' = CM '\x2C33' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER DOBRO +foldMapping '\x2C04' = CM '\x2C34' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YESTU +foldMapping '\x2C05' = CM '\x2C35' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER ZHIVETE +foldMapping '\x2C06' = CM '\x2C36' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER DZELO +foldMapping '\x2C07' = CM '\x2C37' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER ZEMLJA +foldMapping '\x2C08' = CM '\x2C38' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER IZHE +foldMapping '\x2C09' = CM '\x2C39' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER INITIAL IZHE +foldMapping '\x2C0A' = CM '\x2C3A' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER I +foldMapping '\x2C0B' = CM '\x2C3B' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER DJERVI +foldMapping '\x2C0C' = CM '\x2C3C' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER KAKO +foldMapping '\x2C0D' = CM '\x2C3D' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER LJUDIJE +foldMapping '\x2C0E' = CM '\x2C3E' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER MYSLITE +foldMapping '\x2C0F' = CM '\x2C3F' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER NASHI +foldMapping '\x2C10' = CM '\x2C40' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER ONU +foldMapping '\x2C11' = CM '\x2C41' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER POKOJI +foldMapping '\x2C12' = CM '\x2C42' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER RITSI +foldMapping '\x2C13' = CM '\x2C43' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SLOVO +foldMapping '\x2C14' = CM '\x2C44' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER TVRIDO +foldMapping '\x2C15' = CM '\x2C45' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER UKU +foldMapping '\x2C16' = CM '\x2C46' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER FRITU +foldMapping '\x2C17' = CM '\x2C47' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER HERU +foldMapping '\x2C18' = CM '\x2C48' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER OTU +foldMapping '\x2C19' = CM '\x2C49' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER PE +foldMapping '\x2C1A' = CM '\x2C4A' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SHTA +foldMapping '\x2C1B' = CM '\x2C4B' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER TSI +foldMapping '\x2C1C' = CM '\x2C4C' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER CHRIVI +foldMapping '\x2C1D' = CM '\x2C4D' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SHA +foldMapping '\x2C1E' = CM '\x2C4E' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YERU +foldMapping '\x2C1F' = CM '\x2C4F' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YERI +foldMapping '\x2C20' = CM '\x2C50' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YATI +foldMapping '\x2C21' = CM '\x2C51' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SPIDERY HA +foldMapping '\x2C22' = CM '\x2C52' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YU +foldMapping '\x2C23' = CM '\x2C53' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SMALL YUS +foldMapping '\x2C24' = CM '\x2C54' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SMALL YUS WITH TAIL +foldMapping '\x2C25' = CM '\x2C55' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER YO +foldMapping '\x2C26' = CM '\x2C56' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER IOTATED SMALL YUS +foldMapping '\x2C27' = CM '\x2C57' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER BIG YUS +foldMapping '\x2C28' = CM '\x2C58' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER IOTATED BIG YUS +foldMapping '\x2C29' = CM '\x2C59' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER FITA +foldMapping '\x2C2A' = CM '\x2C5A' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER IZHITSA +foldMapping '\x2C2B' = CM '\x2C5B' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER SHTAPIC +foldMapping '\x2C2C' = CM '\x2C5C' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER TROKUTASTI A +foldMapping '\x2C2D' = CM '\x2C5D' '\0' '\0' +-- GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE +foldMapping '\x2C2E' = CM '\x2C5E' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH DOUBLE BAR +foldMapping '\x2C60' = CM '\x2C61' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH MIDDLE TILDE +foldMapping '\x2C62' = CM '\x026B' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH STROKE +foldMapping '\x2C63' = CM '\x1D7D' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH TAIL +foldMapping '\x2C64' = CM '\x027D' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH DESCENDER +foldMapping '\x2C67' = CM '\x2C68' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH DESCENDER +foldMapping '\x2C69' = CM '\x2C6A' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH DESCENDER +foldMapping '\x2C6B' = CM '\x2C6C' '\0' '\0' +-- LATIN CAPITAL LETTER ALPHA +foldMapping '\x2C6D' = CM '\x0251' '\0' '\0' +-- LATIN CAPITAL LETTER M WITH HOOK +foldMapping '\x2C6E' = CM '\x0271' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED A +foldMapping '\x2C6F' = CM '\x0250' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED ALPHA +foldMapping '\x2C70' = CM '\x0252' '\0' '\0' +-- LATIN CAPITAL LETTER W WITH HOOK +foldMapping '\x2C72' = CM '\x2C73' '\0' '\0' +-- LATIN CAPITAL LETTER HALF H +foldMapping '\x2C75' = CM '\x2C76' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH SWASH TAIL +foldMapping '\x2C7E' = CM '\x023F' '\0' '\0' +-- LATIN CAPITAL LETTER Z WITH SWASH TAIL +foldMapping '\x2C7F' = CM '\x0240' '\0' '\0' +-- COPTIC CAPITAL LETTER ALFA +foldMapping '\x2C80' = CM '\x2C81' '\0' '\0' +-- COPTIC CAPITAL LETTER VIDA +foldMapping '\x2C82' = CM '\x2C83' '\0' '\0' +-- COPTIC CAPITAL LETTER GAMMA +foldMapping '\x2C84' = CM '\x2C85' '\0' '\0' +-- COPTIC CAPITAL LETTER DALDA +foldMapping '\x2C86' = CM '\x2C87' '\0' '\0' +-- COPTIC CAPITAL LETTER EIE +foldMapping '\x2C88' = CM '\x2C89' '\0' '\0' +-- COPTIC CAPITAL LETTER SOU +foldMapping '\x2C8A' = CM '\x2C8B' '\0' '\0' +-- COPTIC CAPITAL LETTER ZATA +foldMapping '\x2C8C' = CM '\x2C8D' '\0' '\0' +-- COPTIC CAPITAL LETTER HATE +foldMapping '\x2C8E' = CM '\x2C8F' '\0' '\0' +-- COPTIC CAPITAL LETTER THETHE +foldMapping '\x2C90' = CM '\x2C91' '\0' '\0' +-- COPTIC CAPITAL LETTER IAUDA +foldMapping '\x2C92' = CM '\x2C93' '\0' '\0' +-- COPTIC CAPITAL LETTER KAPA +foldMapping '\x2C94' = CM '\x2C95' '\0' '\0' +-- COPTIC CAPITAL LETTER LAULA +foldMapping '\x2C96' = CM '\x2C97' '\0' '\0' +-- COPTIC CAPITAL LETTER MI +foldMapping '\x2C98' = CM '\x2C99' '\0' '\0' +-- COPTIC CAPITAL LETTER NI +foldMapping '\x2C9A' = CM '\x2C9B' '\0' '\0' +-- COPTIC CAPITAL LETTER KSI +foldMapping '\x2C9C' = CM '\x2C9D' '\0' '\0' +-- COPTIC CAPITAL LETTER O +foldMapping '\x2C9E' = CM '\x2C9F' '\0' '\0' +-- COPTIC CAPITAL LETTER PI +foldMapping '\x2CA0' = CM '\x2CA1' '\0' '\0' +-- COPTIC CAPITAL LETTER RO +foldMapping '\x2CA2' = CM '\x2CA3' '\0' '\0' +-- COPTIC CAPITAL LETTER SIMA +foldMapping '\x2CA4' = CM '\x2CA5' '\0' '\0' +-- COPTIC CAPITAL LETTER TAU +foldMapping '\x2CA6' = CM '\x2CA7' '\0' '\0' +-- COPTIC CAPITAL LETTER UA +foldMapping '\x2CA8' = CM '\x2CA9' '\0' '\0' +-- COPTIC CAPITAL LETTER FI +foldMapping '\x2CAA' = CM '\x2CAB' '\0' '\0' +-- COPTIC CAPITAL LETTER KHI +foldMapping '\x2CAC' = CM '\x2CAD' '\0' '\0' +-- COPTIC CAPITAL LETTER PSI +foldMapping '\x2CAE' = CM '\x2CAF' '\0' '\0' +-- COPTIC CAPITAL LETTER OOU +foldMapping '\x2CB0' = CM '\x2CB1' '\0' '\0' +-- COPTIC CAPITAL LETTER DIALECT-P ALEF +foldMapping '\x2CB2' = CM '\x2CB3' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC AIN +foldMapping '\x2CB4' = CM '\x2CB5' '\0' '\0' +-- COPTIC CAPITAL LETTER CRYPTOGRAMMIC EIE +foldMapping '\x2CB6' = CM '\x2CB7' '\0' '\0' +-- COPTIC CAPITAL LETTER DIALECT-P KAPA +foldMapping '\x2CB8' = CM '\x2CB9' '\0' '\0' +-- COPTIC CAPITAL LETTER DIALECT-P NI +foldMapping '\x2CBA' = CM '\x2CBB' '\0' '\0' +-- COPTIC CAPITAL LETTER CRYPTOGRAMMIC NI +foldMapping '\x2CBC' = CM '\x2CBD' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC OOU +foldMapping '\x2CBE' = CM '\x2CBF' '\0' '\0' +-- COPTIC CAPITAL LETTER SAMPI +foldMapping '\x2CC0' = CM '\x2CC1' '\0' '\0' +-- COPTIC CAPITAL LETTER CROSSED SHEI +foldMapping '\x2CC2' = CM '\x2CC3' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC SHEI +foldMapping '\x2CC4' = CM '\x2CC5' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC ESH +foldMapping '\x2CC6' = CM '\x2CC7' '\0' '\0' +-- COPTIC CAPITAL LETTER AKHMIMIC KHEI +foldMapping '\x2CC8' = CM '\x2CC9' '\0' '\0' +-- COPTIC CAPITAL LETTER DIALECT-P HORI +foldMapping '\x2CCA' = CM '\x2CCB' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC HORI +foldMapping '\x2CCC' = CM '\x2CCD' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC HA +foldMapping '\x2CCE' = CM '\x2CCF' '\0' '\0' +-- COPTIC CAPITAL LETTER L-SHAPED HA +foldMapping '\x2CD0' = CM '\x2CD1' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC HEI +foldMapping '\x2CD2' = CM '\x2CD3' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC HAT +foldMapping '\x2CD4' = CM '\x2CD5' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC GANGIA +foldMapping '\x2CD6' = CM '\x2CD7' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC DJA +foldMapping '\x2CD8' = CM '\x2CD9' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD COPTIC SHIMA +foldMapping '\x2CDA' = CM '\x2CDB' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD NUBIAN SHIMA +foldMapping '\x2CDC' = CM '\x2CDD' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD NUBIAN NGI +foldMapping '\x2CDE' = CM '\x2CDF' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD NUBIAN NYI +foldMapping '\x2CE0' = CM '\x2CE1' '\0' '\0' +-- COPTIC CAPITAL LETTER OLD NUBIAN WAU +foldMapping '\x2CE2' = CM '\x2CE3' '\0' '\0' +-- COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI +foldMapping '\x2CEB' = CM '\x2CEC' '\0' '\0' +-- COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA +foldMapping '\x2CED' = CM '\x2CEE' '\0' '\0' +-- COPTIC CAPITAL LETTER BOHAIRIC KHEI +foldMapping '\x2CF2' = CM '\x2CF3' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZEMLYA +foldMapping '\xA640' = CM '\xA641' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZELO +foldMapping '\xA642' = CM '\xA643' '\0' '\0' +-- CYRILLIC CAPITAL LETTER REVERSED DZE +foldMapping '\xA644' = CM '\xA645' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTA +foldMapping '\xA646' = CM '\xA647' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DJERV +foldMapping '\xA648' = CM '\xA649' '\0' '\0' +-- CYRILLIC CAPITAL LETTER MONOGRAPH UK +foldMapping '\xA64A' = CM '\xA64B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BROAD OMEGA +foldMapping '\xA64C' = CM '\xA64D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER NEUTRAL YER +foldMapping '\xA64E' = CM '\xA64F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YERU WITH BACK YER +foldMapping '\xA650' = CM '\xA651' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED YAT +foldMapping '\xA652' = CM '\xA653' '\0' '\0' +-- CYRILLIC CAPITAL LETTER REVERSED YU +foldMapping '\xA654' = CM '\xA655' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED A +foldMapping '\xA656' = CM '\xA657' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CLOSED LITTLE YUS +foldMapping '\xA658' = CM '\xA659' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BLENDED YUS +foldMapping '\xA65A' = CM '\xA65B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER IOTIFIED CLOSED LITTLE YUS +foldMapping '\xA65C' = CM '\xA65D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER YN +foldMapping '\xA65E' = CM '\xA65F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER REVERSED TSE +foldMapping '\xA660' = CM '\xA661' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SOFT DE +foldMapping '\xA662' = CM '\xA663' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SOFT EL +foldMapping '\xA664' = CM '\xA665' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SOFT EM +foldMapping '\xA666' = CM '\xA667' '\0' '\0' +-- CYRILLIC CAPITAL LETTER MONOCULAR O +foldMapping '\xA668' = CM '\xA669' '\0' '\0' +-- CYRILLIC CAPITAL LETTER BINOCULAR O +foldMapping '\xA66A' = CM '\xA66B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DOUBLE MONOCULAR O +foldMapping '\xA66C' = CM '\xA66D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DWE +foldMapping '\xA680' = CM '\xA681' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZWE +foldMapping '\xA682' = CM '\xA683' '\0' '\0' +-- CYRILLIC CAPITAL LETTER ZHWE +foldMapping '\xA684' = CM '\xA685' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CCHE +foldMapping '\xA686' = CM '\xA687' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DZZE +foldMapping '\xA688' = CM '\xA689' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TE WITH MIDDLE HOOK +foldMapping '\xA68A' = CM '\xA68B' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TWE +foldMapping '\xA68C' = CM '\xA68D' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TSWE +foldMapping '\xA68E' = CM '\xA68F' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TSSE +foldMapping '\xA690' = CM '\xA691' '\0' '\0' +-- CYRILLIC CAPITAL LETTER TCHE +foldMapping '\xA692' = CM '\xA693' '\0' '\0' +-- CYRILLIC CAPITAL LETTER HWE +foldMapping '\xA694' = CM '\xA695' '\0' '\0' +-- CYRILLIC CAPITAL LETTER SHWE +foldMapping '\xA696' = CM '\xA697' '\0' '\0' +-- CYRILLIC CAPITAL LETTER DOUBLE O +foldMapping '\xA698' = CM '\xA699' '\0' '\0' +-- CYRILLIC CAPITAL LETTER CROSSED O +foldMapping '\xA69A' = CM '\xA69B' '\0' '\0' +-- LATIN CAPITAL LETTER EGYPTOLOGICAL ALEF +foldMapping '\xA722' = CM '\xA723' '\0' '\0' +-- LATIN CAPITAL LETTER EGYPTOLOGICAL AIN +foldMapping '\xA724' = CM '\xA725' '\0' '\0' +-- LATIN CAPITAL LETTER HENG +foldMapping '\xA726' = CM '\xA727' '\0' '\0' +-- LATIN CAPITAL LETTER TZ +foldMapping '\xA728' = CM '\xA729' '\0' '\0' +-- LATIN CAPITAL LETTER TRESILLO +foldMapping '\xA72A' = CM '\xA72B' '\0' '\0' +-- LATIN CAPITAL LETTER CUATRILLO +foldMapping '\xA72C' = CM '\xA72D' '\0' '\0' +-- LATIN CAPITAL LETTER CUATRILLO WITH COMMA +foldMapping '\xA72E' = CM '\xA72F' '\0' '\0' +-- LATIN CAPITAL LETTER AA +foldMapping '\xA732' = CM '\xA733' '\0' '\0' +-- LATIN CAPITAL LETTER AO +foldMapping '\xA734' = CM '\xA735' '\0' '\0' +-- LATIN CAPITAL LETTER AU +foldMapping '\xA736' = CM '\xA737' '\0' '\0' +-- LATIN CAPITAL LETTER AV +foldMapping '\xA738' = CM '\xA739' '\0' '\0' +-- LATIN CAPITAL LETTER AV WITH HORIZONTAL BAR +foldMapping '\xA73A' = CM '\xA73B' '\0' '\0' +-- LATIN CAPITAL LETTER AY +foldMapping '\xA73C' = CM '\xA73D' '\0' '\0' +-- LATIN CAPITAL LETTER REVERSED C WITH DOT +foldMapping '\xA73E' = CM '\xA73F' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH STROKE +foldMapping '\xA740' = CM '\xA741' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH DIAGONAL STROKE +foldMapping '\xA742' = CM '\xA743' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH STROKE AND DIAGONAL STROKE +foldMapping '\xA744' = CM '\xA745' '\0' '\0' +-- LATIN CAPITAL LETTER BROKEN L +foldMapping '\xA746' = CM '\xA747' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH HIGH STROKE +foldMapping '\xA748' = CM '\xA749' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH LONG STROKE OVERLAY +foldMapping '\xA74A' = CM '\xA74B' '\0' '\0' +-- LATIN CAPITAL LETTER O WITH LOOP +foldMapping '\xA74C' = CM '\xA74D' '\0' '\0' +-- LATIN CAPITAL LETTER OO +foldMapping '\xA74E' = CM '\xA74F' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH STROKE THROUGH DESCENDER +foldMapping '\xA750' = CM '\xA751' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH FLOURISH +foldMapping '\xA752' = CM '\xA753' '\0' '\0' +-- LATIN CAPITAL LETTER P WITH SQUIRREL TAIL +foldMapping '\xA754' = CM '\xA755' '\0' '\0' +-- LATIN CAPITAL LETTER Q WITH STROKE THROUGH DESCENDER +foldMapping '\xA756' = CM '\xA757' '\0' '\0' +-- LATIN CAPITAL LETTER Q WITH DIAGONAL STROKE +foldMapping '\xA758' = CM '\xA759' '\0' '\0' +-- LATIN CAPITAL LETTER R ROTUNDA +foldMapping '\xA75A' = CM '\xA75B' '\0' '\0' +-- LATIN CAPITAL LETTER RUM ROTUNDA +foldMapping '\xA75C' = CM '\xA75D' '\0' '\0' +-- LATIN CAPITAL LETTER V WITH DIAGONAL STROKE +foldMapping '\xA75E' = CM '\xA75F' '\0' '\0' +-- LATIN CAPITAL LETTER VY +foldMapping '\xA760' = CM '\xA761' '\0' '\0' +-- LATIN CAPITAL LETTER VISIGOTHIC Z +foldMapping '\xA762' = CM '\xA763' '\0' '\0' +-- LATIN CAPITAL LETTER THORN WITH STROKE +foldMapping '\xA764' = CM '\xA765' '\0' '\0' +-- LATIN CAPITAL LETTER THORN WITH STROKE THROUGH DESCENDER +foldMapping '\xA766' = CM '\xA767' '\0' '\0' +-- LATIN CAPITAL LETTER VEND +foldMapping '\xA768' = CM '\xA769' '\0' '\0' +-- LATIN CAPITAL LETTER ET +foldMapping '\xA76A' = CM '\xA76B' '\0' '\0' +-- LATIN CAPITAL LETTER IS +foldMapping '\xA76C' = CM '\xA76D' '\0' '\0' +-- LATIN CAPITAL LETTER CON +foldMapping '\xA76E' = CM '\xA76F' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR D +foldMapping '\xA779' = CM '\xA77A' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR F +foldMapping '\xA77B' = CM '\xA77C' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR G +foldMapping '\xA77D' = CM '\x1D79' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED INSULAR G +foldMapping '\xA77E' = CM '\xA77F' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED L +foldMapping '\xA780' = CM '\xA781' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR R +foldMapping '\xA782' = CM '\xA783' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR S +foldMapping '\xA784' = CM '\xA785' '\0' '\0' +-- LATIN CAPITAL LETTER INSULAR T +foldMapping '\xA786' = CM '\xA787' '\0' '\0' +-- LATIN CAPITAL LETTER SALTILLO +foldMapping '\xA78B' = CM '\xA78C' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED H +foldMapping '\xA78D' = CM '\x0265' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH DESCENDER +foldMapping '\xA790' = CM '\xA791' '\0' '\0' +-- LATIN CAPITAL LETTER C WITH BAR +foldMapping '\xA792' = CM '\xA793' '\0' '\0' +-- LATIN CAPITAL LETTER B WITH FLOURISH +foldMapping '\xA796' = CM '\xA797' '\0' '\0' +-- LATIN CAPITAL LETTER F WITH STROKE +foldMapping '\xA798' = CM '\xA799' '\0' '\0' +-- LATIN CAPITAL LETTER VOLAPUK AE +foldMapping '\xA79A' = CM '\xA79B' '\0' '\0' +-- LATIN CAPITAL LETTER VOLAPUK OE +foldMapping '\xA79C' = CM '\xA79D' '\0' '\0' +-- LATIN CAPITAL LETTER VOLAPUK UE +foldMapping '\xA79E' = CM '\xA79F' '\0' '\0' +-- LATIN CAPITAL LETTER G WITH OBLIQUE STROKE +foldMapping '\xA7A0' = CM '\xA7A1' '\0' '\0' +-- LATIN CAPITAL LETTER K WITH OBLIQUE STROKE +foldMapping '\xA7A2' = CM '\xA7A3' '\0' '\0' +-- LATIN CAPITAL LETTER N WITH OBLIQUE STROKE +foldMapping '\xA7A4' = CM '\xA7A5' '\0' '\0' +-- LATIN CAPITAL LETTER R WITH OBLIQUE STROKE +foldMapping '\xA7A6' = CM '\xA7A7' '\0' '\0' +-- LATIN CAPITAL LETTER S WITH OBLIQUE STROKE +foldMapping '\xA7A8' = CM '\xA7A9' '\0' '\0' +-- LATIN CAPITAL LETTER H WITH HOOK +foldMapping '\xA7AA' = CM '\x0266' '\0' '\0' +-- LATIN CAPITAL LETTER REVERSED OPEN E +foldMapping '\xA7AB' = CM '\x025C' '\0' '\0' +-- LATIN CAPITAL LETTER SCRIPT G +foldMapping '\xA7AC' = CM '\x0261' '\0' '\0' +-- LATIN CAPITAL LETTER L WITH BELT +foldMapping '\xA7AD' = CM '\x026C' '\0' '\0' +-- LATIN CAPITAL LETTER SMALL CAPITAL I +foldMapping '\xA7AE' = CM '\x026A' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED K +foldMapping '\xA7B0' = CM '\x029E' '\0' '\0' +-- LATIN CAPITAL LETTER TURNED T +foldMapping '\xA7B1' = CM '\x0287' '\0' '\0' +-- LATIN CAPITAL LETTER J WITH CROSSED-TAIL +foldMapping '\xA7B2' = CM '\x029D' '\0' '\0' +-- LATIN CAPITAL LETTER CHI +foldMapping '\xA7B3' = CM '\xAB53' '\0' '\0' +-- LATIN CAPITAL LETTER BETA +foldMapping '\xA7B4' = CM '\xA7B5' '\0' '\0' +-- LATIN CAPITAL LETTER OMEGA +foldMapping '\xA7B6' = CM '\xA7B7' '\0' '\0' +-- CHEROKEE SMALL LETTER A +foldMapping '\xAB70' = CM '\x13A0' '\0' '\0' +-- CHEROKEE SMALL LETTER E +foldMapping '\xAB71' = CM '\x13A1' '\0' '\0' +-- CHEROKEE SMALL LETTER I +foldMapping '\xAB72' = CM '\x13A2' '\0' '\0' +-- CHEROKEE SMALL LETTER O +foldMapping '\xAB73' = CM '\x13A3' '\0' '\0' +-- CHEROKEE SMALL LETTER U +foldMapping '\xAB74' = CM '\x13A4' '\0' '\0' +-- CHEROKEE SMALL LETTER V +foldMapping '\xAB75' = CM '\x13A5' '\0' '\0' +-- CHEROKEE SMALL LETTER GA +foldMapping '\xAB76' = CM '\x13A6' '\0' '\0' +-- CHEROKEE SMALL LETTER KA +foldMapping '\xAB77' = CM '\x13A7' '\0' '\0' +-- CHEROKEE SMALL LETTER GE +foldMapping '\xAB78' = CM '\x13A8' '\0' '\0' +-- CHEROKEE SMALL LETTER GI +foldMapping '\xAB79' = CM '\x13A9' '\0' '\0' +-- CHEROKEE SMALL LETTER GO +foldMapping '\xAB7A' = CM '\x13AA' '\0' '\0' +-- CHEROKEE SMALL LETTER GU +foldMapping '\xAB7B' = CM '\x13AB' '\0' '\0' +-- CHEROKEE SMALL LETTER GV +foldMapping '\xAB7C' = CM '\x13AC' '\0' '\0' +-- CHEROKEE SMALL LETTER HA +foldMapping '\xAB7D' = CM '\x13AD' '\0' '\0' +-- CHEROKEE SMALL LETTER HE +foldMapping '\xAB7E' = CM '\x13AE' '\0' '\0' +-- CHEROKEE SMALL LETTER HI +foldMapping '\xAB7F' = CM '\x13AF' '\0' '\0' +-- CHEROKEE SMALL LETTER HO +foldMapping '\xAB80' = CM '\x13B0' '\0' '\0' +-- CHEROKEE SMALL LETTER HU +foldMapping '\xAB81' = CM '\x13B1' '\0' '\0' +-- CHEROKEE SMALL LETTER HV +foldMapping '\xAB82' = CM '\x13B2' '\0' '\0' +-- CHEROKEE SMALL LETTER LA +foldMapping '\xAB83' = CM '\x13B3' '\0' '\0' +-- CHEROKEE SMALL LETTER LE +foldMapping '\xAB84' = CM '\x13B4' '\0' '\0' +-- CHEROKEE SMALL LETTER LI +foldMapping '\xAB85' = CM '\x13B5' '\0' '\0' +-- CHEROKEE SMALL LETTER LO +foldMapping '\xAB86' = CM '\x13B6' '\0' '\0' +-- CHEROKEE SMALL LETTER LU +foldMapping '\xAB87' = CM '\x13B7' '\0' '\0' +-- CHEROKEE SMALL LETTER LV +foldMapping '\xAB88' = CM '\x13B8' '\0' '\0' +-- CHEROKEE SMALL LETTER MA +foldMapping '\xAB89' = CM '\x13B9' '\0' '\0' +-- CHEROKEE SMALL LETTER ME +foldMapping '\xAB8A' = CM '\x13BA' '\0' '\0' +-- CHEROKEE SMALL LETTER MI +foldMapping '\xAB8B' = CM '\x13BB' '\0' '\0' +-- CHEROKEE SMALL LETTER MO +foldMapping '\xAB8C' = CM '\x13BC' '\0' '\0' +-- CHEROKEE SMALL LETTER MU +foldMapping '\xAB8D' = CM '\x13BD' '\0' '\0' +-- CHEROKEE SMALL LETTER NA +foldMapping '\xAB8E' = CM '\x13BE' '\0' '\0' +-- CHEROKEE SMALL LETTER HNA +foldMapping '\xAB8F' = CM '\x13BF' '\0' '\0' +-- CHEROKEE SMALL LETTER NAH +foldMapping '\xAB90' = CM '\x13C0' '\0' '\0' +-- CHEROKEE SMALL LETTER NE +foldMapping '\xAB91' = CM '\x13C1' '\0' '\0' +-- CHEROKEE SMALL LETTER NI +foldMapping '\xAB92' = CM '\x13C2' '\0' '\0' +-- CHEROKEE SMALL LETTER NO +foldMapping '\xAB93' = CM '\x13C3' '\0' '\0' +-- CHEROKEE SMALL LETTER NU +foldMapping '\xAB94' = CM '\x13C4' '\0' '\0' +-- CHEROKEE SMALL LETTER NV +foldMapping '\xAB95' = CM '\x13C5' '\0' '\0' +-- CHEROKEE SMALL LETTER QUA +foldMapping '\xAB96' = CM '\x13C6' '\0' '\0' +-- CHEROKEE SMALL LETTER QUE +foldMapping '\xAB97' = CM '\x13C7' '\0' '\0' +-- CHEROKEE SMALL LETTER QUI +foldMapping '\xAB98' = CM '\x13C8' '\0' '\0' +-- CHEROKEE SMALL LETTER QUO +foldMapping '\xAB99' = CM '\x13C9' '\0' '\0' +-- CHEROKEE SMALL LETTER QUU +foldMapping '\xAB9A' = CM '\x13CA' '\0' '\0' +-- CHEROKEE SMALL LETTER QUV +foldMapping '\xAB9B' = CM '\x13CB' '\0' '\0' +-- CHEROKEE SMALL LETTER SA +foldMapping '\xAB9C' = CM '\x13CC' '\0' '\0' +-- CHEROKEE SMALL LETTER S +foldMapping '\xAB9D' = CM '\x13CD' '\0' '\0' +-- CHEROKEE SMALL LETTER SE +foldMapping '\xAB9E' = CM '\x13CE' '\0' '\0' +-- CHEROKEE SMALL LETTER SI +foldMapping '\xAB9F' = CM '\x13CF' '\0' '\0' +-- CHEROKEE SMALL LETTER SO +foldMapping '\xABA0' = CM '\x13D0' '\0' '\0' +-- CHEROKEE SMALL LETTER SU +foldMapping '\xABA1' = CM '\x13D1' '\0' '\0' +-- CHEROKEE SMALL LETTER SV +foldMapping '\xABA2' = CM '\x13D2' '\0' '\0' +-- CHEROKEE SMALL LETTER DA +foldMapping '\xABA3' = CM '\x13D3' '\0' '\0' +-- CHEROKEE SMALL LETTER TA +foldMapping '\xABA4' = CM '\x13D4' '\0' '\0' +-- CHEROKEE SMALL LETTER DE +foldMapping '\xABA5' = CM '\x13D5' '\0' '\0' +-- CHEROKEE SMALL LETTER TE +foldMapping '\xABA6' = CM '\x13D6' '\0' '\0' +-- CHEROKEE SMALL LETTER DI +foldMapping '\xABA7' = CM '\x13D7' '\0' '\0' +-- CHEROKEE SMALL LETTER TI +foldMapping '\xABA8' = CM '\x13D8' '\0' '\0' +-- CHEROKEE SMALL LETTER DO +foldMapping '\xABA9' = CM '\x13D9' '\0' '\0' +-- CHEROKEE SMALL LETTER DU +foldMapping '\xABAA' = CM '\x13DA' '\0' '\0' +-- CHEROKEE SMALL LETTER DV +foldMapping '\xABAB' = CM '\x13DB' '\0' '\0' +-- CHEROKEE SMALL LETTER DLA +foldMapping '\xABAC' = CM '\x13DC' '\0' '\0' +-- CHEROKEE SMALL LETTER TLA +foldMapping '\xABAD' = CM '\x13DD' '\0' '\0' +-- CHEROKEE SMALL LETTER TLE +foldMapping '\xABAE' = CM '\x13DE' '\0' '\0' +-- CHEROKEE SMALL LETTER TLI +foldMapping '\xABAF' = CM '\x13DF' '\0' '\0' +-- CHEROKEE SMALL LETTER TLO +foldMapping '\xABB0' = CM '\x13E0' '\0' '\0' +-- CHEROKEE SMALL LETTER TLU +foldMapping '\xABB1' = CM '\x13E1' '\0' '\0' +-- CHEROKEE SMALL LETTER TLV +foldMapping '\xABB2' = CM '\x13E2' '\0' '\0' +-- CHEROKEE SMALL LETTER TSA +foldMapping '\xABB3' = CM '\x13E3' '\0' '\0' +-- CHEROKEE SMALL LETTER TSE +foldMapping '\xABB4' = CM '\x13E4' '\0' '\0' +-- CHEROKEE SMALL LETTER TSI +foldMapping '\xABB5' = CM '\x13E5' '\0' '\0' +-- CHEROKEE SMALL LETTER TSO +foldMapping '\xABB6' = CM '\x13E6' '\0' '\0' +-- CHEROKEE SMALL LETTER TSU +foldMapping '\xABB7' = CM '\x13E7' '\0' '\0' +-- CHEROKEE SMALL LETTER TSV +foldMapping '\xABB8' = CM '\x13E8' '\0' '\0' +-- CHEROKEE SMALL LETTER WA +foldMapping '\xABB9' = CM '\x13E9' '\0' '\0' +-- CHEROKEE SMALL LETTER WE +foldMapping '\xABBA' = CM '\x13EA' '\0' '\0' +-- CHEROKEE SMALL LETTER WI +foldMapping '\xABBB' = CM '\x13EB' '\0' '\0' +-- CHEROKEE SMALL LETTER WO +foldMapping '\xABBC' = CM '\x13EC' '\0' '\0' +-- CHEROKEE SMALL LETTER WU +foldMapping '\xABBD' = CM '\x13ED' '\0' '\0' +-- CHEROKEE SMALL LETTER WV +foldMapping '\xABBE' = CM '\x13EE' '\0' '\0' +-- CHEROKEE SMALL LETTER YA +foldMapping '\xABBF' = CM '\x13EF' '\0' '\0' +-- LATIN SMALL LIGATURE FF +foldMapping '\xFB00' = CM '\x0066' '\x0066' '\0' +-- LATIN SMALL LIGATURE FI +foldMapping '\xFB01' = CM '\x0066' '\x0069' '\0' +-- LATIN SMALL LIGATURE FL +foldMapping '\xFB02' = CM '\x0066' '\x006C' '\0' +-- LATIN SMALL LIGATURE FFI +foldMapping '\xFB03' = CM '\x0066' '\x0066' '\x0069' +-- LATIN SMALL LIGATURE FFL +foldMapping '\xFB04' = CM '\x0066' '\x0066' '\x006C' +-- LATIN SMALL LIGATURE LONG S T +foldMapping '\xFB05' = CM '\x0073' '\x0074' '\0' +-- LATIN SMALL LIGATURE ST +foldMapping '\xFB06' = CM '\x0073' '\x0074' '\0' +-- ARMENIAN SMALL LIGATURE MEN NOW +foldMapping '\xFB13' = CM '\x0574' '\x0576' '\0' +-- ARMENIAN SMALL LIGATURE MEN ECH +foldMapping '\xFB14' = CM '\x0574' '\x0565' '\0' +-- ARMENIAN SMALL LIGATURE MEN INI +foldMapping '\xFB15' = CM '\x0574' '\x056B' '\0' +-- ARMENIAN SMALL LIGATURE VEW NOW +foldMapping '\xFB16' = CM '\x057E' '\x0576' '\0' +-- ARMENIAN SMALL LIGATURE MEN XEH +foldMapping '\xFB17' = CM '\x0574' '\x056D' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER A +foldMapping '\xFF21' = CM '\xFF41' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER B +foldMapping '\xFF22' = CM '\xFF42' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER C +foldMapping '\xFF23' = CM '\xFF43' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER D +foldMapping '\xFF24' = CM '\xFF44' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER E +foldMapping '\xFF25' = CM '\xFF45' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER F +foldMapping '\xFF26' = CM '\xFF46' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER G +foldMapping '\xFF27' = CM '\xFF47' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER H +foldMapping '\xFF28' = CM '\xFF48' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER I +foldMapping '\xFF29' = CM '\xFF49' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER J +foldMapping '\xFF2A' = CM '\xFF4A' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER K +foldMapping '\xFF2B' = CM '\xFF4B' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER L +foldMapping '\xFF2C' = CM '\xFF4C' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER M +foldMapping '\xFF2D' = CM '\xFF4D' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER N +foldMapping '\xFF2E' = CM '\xFF4E' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER O +foldMapping '\xFF2F' = CM '\xFF4F' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER P +foldMapping '\xFF30' = CM '\xFF50' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER Q +foldMapping '\xFF31' = CM '\xFF51' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER R +foldMapping '\xFF32' = CM '\xFF52' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER S +foldMapping '\xFF33' = CM '\xFF53' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER T +foldMapping '\xFF34' = CM '\xFF54' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER U +foldMapping '\xFF35' = CM '\xFF55' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER V +foldMapping '\xFF36' = CM '\xFF56' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER W +foldMapping '\xFF37' = CM '\xFF57' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER X +foldMapping '\xFF38' = CM '\xFF58' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER Y +foldMapping '\xFF39' = CM '\xFF59' '\0' '\0' +-- FULLWIDTH LATIN CAPITAL LETTER Z +foldMapping '\xFF3A' = CM '\xFF5A' '\0' '\0' +-- DESERET CAPITAL LETTER LONG I +foldMapping '\x10400' = CM '\x10428' '\0' '\0' +-- DESERET CAPITAL LETTER LONG E +foldMapping '\x10401' = CM '\x10429' '\0' '\0' +-- DESERET CAPITAL LETTER LONG A +foldMapping '\x10402' = CM '\x1042A' '\0' '\0' +-- DESERET CAPITAL LETTER LONG AH +foldMapping '\x10403' = CM '\x1042B' '\0' '\0' +-- DESERET CAPITAL LETTER LONG O +foldMapping '\x10404' = CM '\x1042C' '\0' '\0' +-- DESERET CAPITAL LETTER LONG OO +foldMapping '\x10405' = CM '\x1042D' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT I +foldMapping '\x10406' = CM '\x1042E' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT E +foldMapping '\x10407' = CM '\x1042F' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT A +foldMapping '\x10408' = CM '\x10430' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT AH +foldMapping '\x10409' = CM '\x10431' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT O +foldMapping '\x1040A' = CM '\x10432' '\0' '\0' +-- DESERET CAPITAL LETTER SHORT OO +foldMapping '\x1040B' = CM '\x10433' '\0' '\0' +-- DESERET CAPITAL LETTER AY +foldMapping '\x1040C' = CM '\x10434' '\0' '\0' +-- DESERET CAPITAL LETTER OW +foldMapping '\x1040D' = CM '\x10435' '\0' '\0' +-- DESERET CAPITAL LETTER WU +foldMapping '\x1040E' = CM '\x10436' '\0' '\0' +-- DESERET CAPITAL LETTER YEE +foldMapping '\x1040F' = CM '\x10437' '\0' '\0' +-- DESERET CAPITAL LETTER H +foldMapping '\x10410' = CM '\x10438' '\0' '\0' +-- DESERET CAPITAL LETTER PEE +foldMapping '\x10411' = CM '\x10439' '\0' '\0' +-- DESERET CAPITAL LETTER BEE +foldMapping '\x10412' = CM '\x1043A' '\0' '\0' +-- DESERET CAPITAL LETTER TEE +foldMapping '\x10413' = CM '\x1043B' '\0' '\0' +-- DESERET CAPITAL LETTER DEE +foldMapping '\x10414' = CM '\x1043C' '\0' '\0' +-- DESERET CAPITAL LETTER CHEE +foldMapping '\x10415' = CM '\x1043D' '\0' '\0' +-- DESERET CAPITAL LETTER JEE +foldMapping '\x10416' = CM '\x1043E' '\0' '\0' +-- DESERET CAPITAL LETTER KAY +foldMapping '\x10417' = CM '\x1043F' '\0' '\0' +-- DESERET CAPITAL LETTER GAY +foldMapping '\x10418' = CM '\x10440' '\0' '\0' +-- DESERET CAPITAL LETTER EF +foldMapping '\x10419' = CM '\x10441' '\0' '\0' +-- DESERET CAPITAL LETTER VEE +foldMapping '\x1041A' = CM '\x10442' '\0' '\0' +-- DESERET CAPITAL LETTER ETH +foldMapping '\x1041B' = CM '\x10443' '\0' '\0' +-- DESERET CAPITAL LETTER THEE +foldMapping '\x1041C' = CM '\x10444' '\0' '\0' +-- DESERET CAPITAL LETTER ES +foldMapping '\x1041D' = CM '\x10445' '\0' '\0' +-- DESERET CAPITAL LETTER ZEE +foldMapping '\x1041E' = CM '\x10446' '\0' '\0' +-- DESERET CAPITAL LETTER ESH +foldMapping '\x1041F' = CM '\x10447' '\0' '\0' +-- DESERET CAPITAL LETTER ZHEE +foldMapping '\x10420' = CM '\x10448' '\0' '\0' +-- DESERET CAPITAL LETTER ER +foldMapping '\x10421' = CM '\x10449' '\0' '\0' +-- DESERET CAPITAL LETTER EL +foldMapping '\x10422' = CM '\x1044A' '\0' '\0' +-- DESERET CAPITAL LETTER EM +foldMapping '\x10423' = CM '\x1044B' '\0' '\0' +-- DESERET CAPITAL LETTER EN +foldMapping '\x10424' = CM '\x1044C' '\0' '\0' +-- DESERET CAPITAL LETTER ENG +foldMapping '\x10425' = CM '\x1044D' '\0' '\0' +-- DESERET CAPITAL LETTER OI +foldMapping '\x10426' = CM '\x1044E' '\0' '\0' +-- DESERET CAPITAL LETTER EW +foldMapping '\x10427' = CM '\x1044F' '\0' '\0' +-- OSAGE CAPITAL LETTER A +foldMapping '\x104B0' = CM '\x104D8' '\0' '\0' +-- OSAGE CAPITAL LETTER AI +foldMapping '\x104B1' = CM '\x104D9' '\0' '\0' +-- OSAGE CAPITAL LETTER AIN +foldMapping '\x104B2' = CM '\x104DA' '\0' '\0' +-- OSAGE CAPITAL LETTER AH +foldMapping '\x104B3' = CM '\x104DB' '\0' '\0' +-- OSAGE CAPITAL LETTER BRA +foldMapping '\x104B4' = CM '\x104DC' '\0' '\0' +-- OSAGE CAPITAL LETTER CHA +foldMapping '\x104B5' = CM '\x104DD' '\0' '\0' +-- OSAGE CAPITAL LETTER EHCHA +foldMapping '\x104B6' = CM '\x104DE' '\0' '\0' +-- OSAGE CAPITAL LETTER E +foldMapping '\x104B7' = CM '\x104DF' '\0' '\0' +-- OSAGE CAPITAL LETTER EIN +foldMapping '\x104B8' = CM '\x104E0' '\0' '\0' +-- OSAGE CAPITAL LETTER HA +foldMapping '\x104B9' = CM '\x104E1' '\0' '\0' +-- OSAGE CAPITAL LETTER HYA +foldMapping '\x104BA' = CM '\x104E2' '\0' '\0' +-- OSAGE CAPITAL LETTER I +foldMapping '\x104BB' = CM '\x104E3' '\0' '\0' +-- OSAGE CAPITAL LETTER KA +foldMapping '\x104BC' = CM '\x104E4' '\0' '\0' +-- OSAGE CAPITAL LETTER EHKA +foldMapping '\x104BD' = CM '\x104E5' '\0' '\0' +-- OSAGE CAPITAL LETTER KYA +foldMapping '\x104BE' = CM '\x104E6' '\0' '\0' +-- OSAGE CAPITAL LETTER LA +foldMapping '\x104BF' = CM '\x104E7' '\0' '\0' +-- OSAGE CAPITAL LETTER MA +foldMapping '\x104C0' = CM '\x104E8' '\0' '\0' +-- OSAGE CAPITAL LETTER NA +foldMapping '\x104C1' = CM '\x104E9' '\0' '\0' +-- OSAGE CAPITAL LETTER O +foldMapping '\x104C2' = CM '\x104EA' '\0' '\0' +-- OSAGE CAPITAL LETTER OIN +foldMapping '\x104C3' = CM '\x104EB' '\0' '\0' +-- OSAGE CAPITAL LETTER PA +foldMapping '\x104C4' = CM '\x104EC' '\0' '\0' +-- OSAGE CAPITAL LETTER EHPA +foldMapping '\x104C5' = CM '\x104ED' '\0' '\0' +-- OSAGE CAPITAL LETTER SA +foldMapping '\x104C6' = CM '\x104EE' '\0' '\0' +-- OSAGE CAPITAL LETTER SHA +foldMapping '\x104C7' = CM '\x104EF' '\0' '\0' +-- OSAGE CAPITAL LETTER TA +foldMapping '\x104C8' = CM '\x104F0' '\0' '\0' +-- OSAGE CAPITAL LETTER EHTA +foldMapping '\x104C9' = CM '\x104F1' '\0' '\0' +-- OSAGE CAPITAL LETTER TSA +foldMapping '\x104CA' = CM '\x104F2' '\0' '\0' +-- OSAGE CAPITAL LETTER EHTSA +foldMapping '\x104CB' = CM '\x104F3' '\0' '\0' +-- OSAGE CAPITAL LETTER TSHA +foldMapping '\x104CC' = CM '\x104F4' '\0' '\0' +-- OSAGE CAPITAL LETTER DHA +foldMapping '\x104CD' = CM '\x104F5' '\0' '\0' +-- OSAGE CAPITAL LETTER U +foldMapping '\x104CE' = CM '\x104F6' '\0' '\0' +-- OSAGE CAPITAL LETTER WA +foldMapping '\x104CF' = CM '\x104F7' '\0' '\0' +-- OSAGE CAPITAL LETTER KHA +foldMapping '\x104D0' = CM '\x104F8' '\0' '\0' +-- OSAGE CAPITAL LETTER GHA +foldMapping '\x104D1' = CM '\x104F9' '\0' '\0' +-- OSAGE CAPITAL LETTER ZA +foldMapping '\x104D2' = CM '\x104FA' '\0' '\0' +-- OSAGE CAPITAL LETTER ZHA +foldMapping '\x104D3' = CM '\x104FB' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER A +foldMapping '\x10C80' = CM '\x10CC0' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER AA +foldMapping '\x10C81' = CM '\x10CC1' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EB +foldMapping '\x10C82' = CM '\x10CC2' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER AMB +foldMapping '\x10C83' = CM '\x10CC3' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EC +foldMapping '\x10C84' = CM '\x10CC4' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ENC +foldMapping '\x10C85' = CM '\x10CC5' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ECS +foldMapping '\x10C86' = CM '\x10CC6' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ED +foldMapping '\x10C87' = CM '\x10CC7' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER AND +foldMapping '\x10C88' = CM '\x10CC8' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER E +foldMapping '\x10C89' = CM '\x10CC9' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER CLOSE E +foldMapping '\x10C8A' = CM '\x10CCA' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EE +foldMapping '\x10C8B' = CM '\x10CCB' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EF +foldMapping '\x10C8C' = CM '\x10CCC' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EG +foldMapping '\x10C8D' = CM '\x10CCD' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EGY +foldMapping '\x10C8E' = CM '\x10CCE' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EH +foldMapping '\x10C8F' = CM '\x10CCF' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER I +foldMapping '\x10C90' = CM '\x10CD0' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER II +foldMapping '\x10C91' = CM '\x10CD1' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EJ +foldMapping '\x10C92' = CM '\x10CD2' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EK +foldMapping '\x10C93' = CM '\x10CD3' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER AK +foldMapping '\x10C94' = CM '\x10CD4' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER UNK +foldMapping '\x10C95' = CM '\x10CD5' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EL +foldMapping '\x10C96' = CM '\x10CD6' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ELY +foldMapping '\x10C97' = CM '\x10CD7' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EM +foldMapping '\x10C98' = CM '\x10CD8' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EN +foldMapping '\x10C99' = CM '\x10CD9' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ENY +foldMapping '\x10C9A' = CM '\x10CDA' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER O +foldMapping '\x10C9B' = CM '\x10CDB' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER OO +foldMapping '\x10C9C' = CM '\x10CDC' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER NIKOLSBURG OE +foldMapping '\x10C9D' = CM '\x10CDD' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER RUDIMENTA OE +foldMapping '\x10C9E' = CM '\x10CDE' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER OEE +foldMapping '\x10C9F' = CM '\x10CDF' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EP +foldMapping '\x10CA0' = CM '\x10CE0' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EMP +foldMapping '\x10CA1' = CM '\x10CE1' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ER +foldMapping '\x10CA2' = CM '\x10CE2' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER SHORT ER +foldMapping '\x10CA3' = CM '\x10CE3' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ES +foldMapping '\x10CA4' = CM '\x10CE4' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ESZ +foldMapping '\x10CA5' = CM '\x10CE5' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ET +foldMapping '\x10CA6' = CM '\x10CE6' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ENT +foldMapping '\x10CA7' = CM '\x10CE7' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ETY +foldMapping '\x10CA8' = CM '\x10CE8' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ECH +foldMapping '\x10CA9' = CM '\x10CE9' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER U +foldMapping '\x10CAA' = CM '\x10CEA' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER UU +foldMapping '\x10CAB' = CM '\x10CEB' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER NIKOLSBURG UE +foldMapping '\x10CAC' = CM '\x10CEC' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER RUDIMENTA UE +foldMapping '\x10CAD' = CM '\x10CED' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EV +foldMapping '\x10CAE' = CM '\x10CEE' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EZ +foldMapping '\x10CAF' = CM '\x10CEF' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER EZS +foldMapping '\x10CB0' = CM '\x10CF0' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER ENT-SHAPED SIGN +foldMapping '\x10CB1' = CM '\x10CF1' '\0' '\0' +-- OLD HUNGARIAN CAPITAL LETTER US +foldMapping '\x10CB2' = CM '\x10CF2' '\0' '\0' +-- WARANG CITI CAPITAL LETTER NGAA +foldMapping '\x118A0' = CM '\x118C0' '\0' '\0' +-- WARANG CITI CAPITAL LETTER A +foldMapping '\x118A1' = CM '\x118C1' '\0' '\0' +-- WARANG CITI CAPITAL LETTER WI +foldMapping '\x118A2' = CM '\x118C2' '\0' '\0' +-- WARANG CITI CAPITAL LETTER YU +foldMapping '\x118A3' = CM '\x118C3' '\0' '\0' +-- WARANG CITI CAPITAL LETTER YA +foldMapping '\x118A4' = CM '\x118C4' '\0' '\0' +-- WARANG CITI CAPITAL LETTER YO +foldMapping '\x118A5' = CM '\x118C5' '\0' '\0' +-- WARANG CITI CAPITAL LETTER II +foldMapping '\x118A6' = CM '\x118C6' '\0' '\0' +-- WARANG CITI CAPITAL LETTER UU +foldMapping '\x118A7' = CM '\x118C7' '\0' '\0' +-- WARANG CITI CAPITAL LETTER E +foldMapping '\x118A8' = CM '\x118C8' '\0' '\0' +-- WARANG CITI CAPITAL LETTER O +foldMapping '\x118A9' = CM '\x118C9' '\0' '\0' +-- WARANG CITI CAPITAL LETTER ANG +foldMapping '\x118AA' = CM '\x118CA' '\0' '\0' +-- WARANG CITI CAPITAL LETTER GA +foldMapping '\x118AB' = CM '\x118CB' '\0' '\0' +-- WARANG CITI CAPITAL LETTER KO +foldMapping '\x118AC' = CM '\x118CC' '\0' '\0' +-- WARANG CITI CAPITAL LETTER ENY +foldMapping '\x118AD' = CM '\x118CD' '\0' '\0' +-- WARANG CITI CAPITAL LETTER YUJ +foldMapping '\x118AE' = CM '\x118CE' '\0' '\0' +-- WARANG CITI CAPITAL LETTER UC +foldMapping '\x118AF' = CM '\x118CF' '\0' '\0' +-- WARANG CITI CAPITAL LETTER ENN +foldMapping '\x118B0' = CM '\x118D0' '\0' '\0' +-- WARANG CITI CAPITAL LETTER ODD +foldMapping '\x118B1' = CM '\x118D1' '\0' '\0' +-- WARANG CITI CAPITAL LETTER TTE +foldMapping '\x118B2' = CM '\x118D2' '\0' '\0' +-- WARANG CITI CAPITAL LETTER NUNG +foldMapping '\x118B3' = CM '\x118D3' '\0' '\0' +-- WARANG CITI CAPITAL LETTER DA +foldMapping '\x118B4' = CM '\x118D4' '\0' '\0' +-- WARANG CITI CAPITAL LETTER AT +foldMapping '\x118B5' = CM '\x118D5' '\0' '\0' +-- WARANG CITI CAPITAL LETTER AM +foldMapping '\x118B6' = CM '\x118D6' '\0' '\0' +-- WARANG CITI CAPITAL LETTER BU +foldMapping '\x118B7' = CM '\x118D7' '\0' '\0' +-- WARANG CITI CAPITAL LETTER PU +foldMapping '\x118B8' = CM '\x118D8' '\0' '\0' +-- WARANG CITI CAPITAL LETTER HIYO +foldMapping '\x118B9' = CM '\x118D9' '\0' '\0' +-- WARANG CITI CAPITAL LETTER HOLO +foldMapping '\x118BA' = CM '\x118DA' '\0' '\0' +-- WARANG CITI CAPITAL LETTER HORR +foldMapping '\x118BB' = CM '\x118DB' '\0' '\0' +-- WARANG CITI CAPITAL LETTER HAR +foldMapping '\x118BC' = CM '\x118DC' '\0' '\0' +-- WARANG CITI CAPITAL LETTER SSUU +foldMapping '\x118BD' = CM '\x118DD' '\0' '\0' +-- WARANG CITI CAPITAL LETTER SII +foldMapping '\x118BE' = CM '\x118DE' '\0' '\0' +-- WARANG CITI CAPITAL LETTER VIYO +foldMapping '\x118BF' = CM '\x118DF' '\0' '\0' +-- ADLAM CAPITAL LETTER ALIF +foldMapping '\x1E900' = CM '\x1E922' '\0' '\0' +-- ADLAM CAPITAL LETTER DAALI +foldMapping '\x1E901' = CM '\x1E923' '\0' '\0' +-- ADLAM CAPITAL LETTER LAAM +foldMapping '\x1E902' = CM '\x1E924' '\0' '\0' +-- ADLAM CAPITAL LETTER MIIM +foldMapping '\x1E903' = CM '\x1E925' '\0' '\0' +-- ADLAM CAPITAL LETTER BA +foldMapping '\x1E904' = CM '\x1E926' '\0' '\0' +-- ADLAM CAPITAL LETTER SINNYIIYHE +foldMapping '\x1E905' = CM '\x1E927' '\0' '\0' +-- ADLAM CAPITAL LETTER PE +foldMapping '\x1E906' = CM '\x1E928' '\0' '\0' +-- ADLAM CAPITAL LETTER BHE +foldMapping '\x1E907' = CM '\x1E929' '\0' '\0' +-- ADLAM CAPITAL LETTER RA +foldMapping '\x1E908' = CM '\x1E92A' '\0' '\0' +-- ADLAM CAPITAL LETTER E +foldMapping '\x1E909' = CM '\x1E92B' '\0' '\0' +-- ADLAM CAPITAL LETTER FA +foldMapping '\x1E90A' = CM '\x1E92C' '\0' '\0' +-- ADLAM CAPITAL LETTER I +foldMapping '\x1E90B' = CM '\x1E92D' '\0' '\0' +-- ADLAM CAPITAL LETTER O +foldMapping '\x1E90C' = CM '\x1E92E' '\0' '\0' +-- ADLAM CAPITAL LETTER DHA +foldMapping '\x1E90D' = CM '\x1E92F' '\0' '\0' +-- ADLAM CAPITAL LETTER YHE +foldMapping '\x1E90E' = CM '\x1E930' '\0' '\0' +-- ADLAM CAPITAL LETTER WAW +foldMapping '\x1E90F' = CM '\x1E931' '\0' '\0' +-- ADLAM CAPITAL LETTER NUN +foldMapping '\x1E910' = CM '\x1E932' '\0' '\0' +-- ADLAM CAPITAL LETTER KAF +foldMapping '\x1E911' = CM '\x1E933' '\0' '\0' +-- ADLAM CAPITAL LETTER YA +foldMapping '\x1E912' = CM '\x1E934' '\0' '\0' +-- ADLAM CAPITAL LETTER U +foldMapping '\x1E913' = CM '\x1E935' '\0' '\0' +-- ADLAM CAPITAL LETTER JIIM +foldMapping '\x1E914' = CM '\x1E936' '\0' '\0' +-- ADLAM CAPITAL LETTER CHI +foldMapping '\x1E915' = CM '\x1E937' '\0' '\0' +-- ADLAM CAPITAL LETTER HA +foldMapping '\x1E916' = CM '\x1E938' '\0' '\0' +-- ADLAM CAPITAL LETTER QAAF +foldMapping '\x1E917' = CM '\x1E939' '\0' '\0' +-- ADLAM CAPITAL LETTER GA +foldMapping '\x1E918' = CM '\x1E93A' '\0' '\0' +-- ADLAM CAPITAL LETTER NYA +foldMapping '\x1E919' = CM '\x1E93B' '\0' '\0' +-- ADLAM CAPITAL LETTER TU +foldMapping '\x1E91A' = CM '\x1E93C' '\0' '\0' +-- ADLAM CAPITAL LETTER NHA +foldMapping '\x1E91B' = CM '\x1E93D' '\0' '\0' +-- ADLAM CAPITAL LETTER VA +foldMapping '\x1E91C' = CM '\x1E93E' '\0' '\0' +-- ADLAM CAPITAL LETTER KHA +foldMapping '\x1E91D' = CM '\x1E93F' '\0' '\0' +-- ADLAM CAPITAL LETTER GBE +foldMapping '\x1E91E' = CM '\x1E940' '\0' '\0' +-- ADLAM CAPITAL LETTER ZAL +foldMapping '\x1E91F' = CM '\x1E941' '\0' '\0' +-- ADLAM CAPITAL LETTER KPO +foldMapping '\x1E920' = CM '\x1E942' '\0' '\0' +-- ADLAM CAPITAL LETTER SHA +foldMapping '\x1E921' = CM '\x1E943' '\0' '\0' +foldMapping c = CM (toLower c) '\0' '\0' diff --git a/Basement/String/Encoding/ASCII7.hs b/Basement/String/Encoding/ASCII7.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/ASCII7.hs @@ -0,0 +1,85 @@ +-- | +-- 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.Types.OffsetSize +import Basement.Numerical.Additive +import Basement.Monad + +import GHC.Prim +import GHC.Word +import GHC.Types +import Basement.UArray +import Basement.UArray.Mutable (MUArray) +import Basement.MutableBuilder + +import Basement.String.Encoding.Encoding +import Basement.HeadHackageUtils + +-- | validate a given byte is within ASCII characters encoring size +-- +-- This function check the 8th bit is set to 0 +-- +isAscii :: Word8 -> Bool +isAscii (W8# w) = W8# (wordToWord8Compat# (and# (word8ToWordCompat# 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 (word8ToWordCompat# w), off + 1) + | otherwise = Left $ ByteOutOfBound w8 + where + !w8@(W8# w) = getter off + toChar :: Word# -> Char + toChar a = C# (chr# (word2Int# a)) + +-- 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# (wordToWord8Compat# (int2Word# (ord# ch))) diff --git a/Basement/String/Encoding/Encoding.hs b/Basement/String/Encoding/Encoding.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/Encoding.hs @@ -0,0 +1,102 @@ +-- | +-- 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 diff --git a/Basement/String/Encoding/ISO_8859_1.hs b/Basement/String/Encoding/ISO_8859_1.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/ISO_8859_1.hs @@ -0,0 +1,65 @@ +-- | +-- 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.Types.OffsetSize +import Basement.Numerical.Additive +import Basement.Monad +import Basement.HeadHackageUtils + +import GHC.Prim +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 (word8ToWordCompat# w), off + aone) + where + !(W8# w) = getter off + toChar :: Word# -> Char + toChar a = C# (chr# (word2Int# a)) + +write :: (PrimMonad st, Monad st) + => Char + -> Builder (UArray Word8) (MUArray Word8) Word8 st err () +write c@(C# ch) + | c <= toEnum 0xFF = builderAppend (W8# (wordToWord8Compat# x)) + | otherwise = throw $ NotISO_8859_1 c + where + x :: Word# + !x = int2Word# (ord# ch) diff --git a/Basement/String/Encoding/UTF16.hs b/Basement/String/Encoding/UTF16.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/UTF16.hs @@ -0,0 +1,98 @@ +-- | +-- 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 Data.Bits +import qualified Prelude +import Basement.Compat.Base +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.Numerical.Additive +import Basement.UArray +import Basement.UArray.Mutable (MUArray) +import Basement.MutableBuilder +import Basement.HeadHackageUtils + +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 (toChar (word16ToWordCompat# hh), off + Offset 1) + | h >= 0xe000 = Right (toChar (word16ToWordCompat# hh), off + Offset 1) + | otherwise = nextContinuation + where + h :: Word16 + !h@(W16# hh) = getter off + toChar :: Word# -> Char + toChar w = C# (chr# (word2Int# w)) + to32 :: Word16 -> Word32 + to32 (W16# w) = W32# (wordToWord32Compat# (word16ToWordCompat# w)) + + nextContinuation + | cont >= 0xdc00 && cont < 0xe00 = + let !(W32# w) = ((to32 h .&. 0x3ff) `shiftL` 10) + .|. (to32 cont .&. 0x3ff) + in Right (toChar (word32ToWordCompat# 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# (wordToWord16Compat# (int2Word# (ord# ch))) + + to16 :: Word32 -> Word16 + to16 = Prelude.fromIntegral + + wHigh :: Char -> (Word16, Word16) + wHigh (C# ch) = + let v = W32# (wordToWord32Compat# (minusWord# (int2Word# (ord# ch)) 0x10000##)) + in (0xdc00 .|. to16 (v `shiftR` 10), 0xd800 .|. to16 (v .&. 0x3ff)) diff --git a/Basement/String/Encoding/UTF32.hs b/Basement/String/Encoding/UTF32.hs new file mode 100644 --- /dev/null +++ b/Basement/String/Encoding/UTF32.hs @@ -0,0 +1,56 @@ +-- | +-- 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.Types.OffsetSize +import Basement.Monad +import Basement.Numerical.Additive +import Basement.UArray +import Basement.UArray.Mutable (MUArray) +import Basement.MutableBuilder +import Basement.HeadHackageUtils + +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# (chr# (word2Int# (word32ToWordCompat# 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# (wordToWord32Compat# (int2Word# (ord# ch))) diff --git a/Basement/Terminal.hs b/Basement/Terminal.hs new file mode 100644 --- /dev/null +++ b/Basement/Terminal.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +module Basement.Terminal + ( initialize + , getDimensions + ) where + +import Basement.Compat.Base +import Basement.Terminal.Size (getDimensions) +#ifdef mingw32_HOST_OS +import System.IO (hSetEncoding, utf8, hPutStrLn, stderr, stdin, stdout) +import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP) +#endif + +initialize :: IO () +initialize = do +#ifdef mingw32_HOST_OS + query getConsoleOutputCP (\e -> setConsoleOutputCP e >> hSetEncoding stdout utf8 >> hSetEncoding stderr utf8) utf8Code + query getConsoleCP (\e -> setConsoleCP e >> hSetEncoding stdin utf8) utf8Code + where + utf8Code = 65001 + query get set expected = do + v <- get + if v == expected then pure () else set expected +#else + pure () +#endif diff --git a/Basement/Terminal/ANSI.hs b/Basement/Terminal/ANSI.hs new file mode 100644 --- /dev/null +++ b/Basement/Terminal/ANSI.hs @@ -0,0 +1,170 @@ +-- | +-- Module : Basement.Terminal.ANSI +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- +-- ANSI Terminal escape for cursor and attributes manipulations +-- +-- On Unix system, it should be supported by most terminal emulators. +-- +-- On Windows system, all escape sequences are empty for maximum +-- compatibility purpose, and easy implementation. newer version +-- of Windows 10 supports ANSI escape now, but we'll need +-- some kind of detection. +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +module Basement.Terminal.ANSI + ( + -- * Types + Escape + , Displacement + , ColorComponent + , GrayComponent + , RGBComponent + -- * Simple ANSI escape factory functions + , cursorUp + , cursorDown + , cursorForward + , cursorBack + , cursorNextLine + , cursorPrevLine + , cursorHorizontalAbsolute + , cursorPosition + , eraseScreenFromCursor + , eraseScreenToCursor + , eraseScreenAll + , eraseLineFromCursor + , eraseLineToCursor + , eraseLineAll + , scrollUp + , scrollDown + , sgrReset + , sgrForeground + , sgrBackground + , sgrForegroundGray24 + , sgrBackgroundGray24 + , sgrForegroundColor216 + , sgrBackgroundColor216 + ) where + +import Basement.String +import Basement.Bounded +import Basement.Imports +import Basement.Numerical.Multiplicative +import Basement.Numerical.Additive + +#ifndef mingw32_HOST_OS +#define SUPPORT_ANSI_ESCAPE +#endif + +type Escape = String + +type Displacement = Word64 + +-- | Simple color component on 8 color terminal (maximum compatibility) +type ColorComponent = Zn64 8 + +-- | Gray color compent on 256colors terminals +type GrayComponent = Zn64 24 + +-- | Color compent on 256colors terminals +type RGBComponent = Zn64 6 + +cursorUp, cursorDown, cursorForward, cursorBack + , cursorNextLine, cursorPrevLine + , cursorHorizontalAbsolute :: Displacement -> Escape +cursorUp n = csi1 n "A" +cursorDown n = csi1 n "B" +cursorForward n = csi1 n "C" +cursorBack n = csi1 n "D" +cursorNextLine n = csi1 n "E" +cursorPrevLine n = csi1 n "F" +cursorHorizontalAbsolute n = csi1 n "G" + +cursorPosition :: Displacement -> Displacement -> Escape +cursorPosition row col = csi2 row col "H" + +eraseScreenFromCursor + , eraseScreenToCursor + , eraseScreenAll + , eraseLineFromCursor + , eraseLineToCursor + , eraseLineAll :: Escape +eraseScreenFromCursor = csi1 0 "J" +eraseScreenToCursor = csi1 1 "J" +eraseScreenAll = csi1 2 "J" +eraseLineFromCursor = csi1 0 "K" +eraseLineToCursor = csi1 1 "K" +eraseLineAll = csi1 2 "K" + +scrollUp, scrollDown :: Displacement -> Escape +scrollUp n = csi1 n "S" +scrollDown n = csi1 n "T" + +-- | All attribute off +sgrReset :: Escape +sgrReset = csi1 0 "m" + +-- | 8 Colors + Bold attribute for foreground +sgrForeground :: ColorComponent -> Bool -> Escape +sgrForeground n bold + | bold = csi2 (30+unZn64 n) 1 "m" + | otherwise = csi1 (30+unZn64 n) "m" + +-- | 8 Colors + Bold attribute for background +sgrBackground :: ColorComponent -> Bool -> Escape +sgrBackground n bold + | bold = csi2 (40+unZn64 n) 1 "m" + | otherwise = csi1 (40+unZn64 n) "m" + +-- 256 colors mode + +sgrForegroundGray24, sgrBackgroundGray24 :: GrayComponent -> Escape +sgrForegroundGray24 v = csi3 38 5 (0xE8 + unZn64 v) "m" +sgrBackgroundGray24 v = csi3 48 5 (0xE8 + unZn64 v) "m" + +sgrForegroundColor216 :: RGBComponent -- ^ Red component + -> RGBComponent -- ^ Green component + -> RGBComponent -- ^ Blue component + -> Escape +sgrForegroundColor216 r g b = csi3 38 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m" + +sgrBackgroundColor216 :: RGBComponent -- ^ Red component + -> RGBComponent -- ^ Green component + -> RGBComponent -- ^ Blue component + -> Escape +sgrBackgroundColor216 r g b = csi3 48 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m" + +#ifdef SUPPORT_ANSI_ESCAPE + +csi0 :: String -> String +csi0 suffix = mconcat ["\ESC[", suffix] + +csi1 :: Displacement -> String -> String +csi1 p1 suffix = mconcat ["\ESC[", pshow p1, suffix] + +csi2 :: Displacement -> Displacement -> String -> String +csi2 p1 p2 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, suffix] + +csi3 :: Displacement -> Displacement -> Displacement -> String -> String +csi3 p1 p2 p3 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, ";", pshow p3, suffix] + +pshow = show + +#else + +csi0 :: String -> String +csi0 _ = "" + +csi1 :: Displacement -> String -> String +csi1 _ _ = "" + +csi2 :: Displacement -> Displacement -> String -> String +csi2 _ _ _ = "" + +csi3 :: Displacement -> Displacement -> Displacement -> String -> String +csi3 _ _ _ _ = "" + +#endif diff --git a/Basement/Terminal/Size.hsc b/Basement/Terminal/Size.hsc new file mode 100644 --- /dev/null +++ b/Basement/Terminal/Size.hsc @@ -0,0 +1,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 +#elif defined FOUNDATION_SYSTEM_UNIX +#include +#ifdef __sun +#include +#endif +#endif + +#include + +#if __GLASGOW_HASKELL__ < 800 +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif + +#ifdef FOUNDATION_SYSTEM_UNIX +data Winsize = Winsize + { ws_row :: !Word16 + , ws_col :: !Word16 + , ws_xpixel :: !Word16 + , ws_ypixel :: !Word16 + } + +instance Storable Winsize where + sizeOf _ = #{size struct winsize} + alignment _ = #{alignment struct winsize} + peek ptr = do + r <- #{peek struct winsize, ws_row} ptr + c <- #{peek struct winsize, ws_col} ptr + x <- #{peek struct winsize, ws_xpixel} ptr + y <- #{peek struct winsize, ws_ypixel} ptr + return (Winsize r c x y) + poke ptr (Winsize r c x y) = do + #{poke struct winsize, ws_row} ptr r + #{poke struct winsize, ws_col} ptr c + #{poke struct winsize, ws_xpixel} ptr x + #{poke struct winsize, ws_ypixel} ptr y + +#elif defined FOUNDATION_SYSTEM_WINDOWS +type Handle = Ptr CChar -- void * + +data SmallRect = SmallRect + { left :: !Int16 + , top :: !Int16 + , right :: !Int16 + , bottom :: !Int16 + } deriving (Show) + +instance Storable SmallRect where + sizeOf _ = #{size SMALL_RECT} + alignment _ = #{alignment SMALL_RECT} + peek ptr = do + l <- #{peek SMALL_RECT, Left} ptr + r <- #{peek SMALL_RECT, Right} ptr + t <- #{peek SMALL_RECT, Top} ptr + b <- #{peek SMALL_RECT, Bottom} ptr + return (SmallRect l t r b) + poke ptr (SmallRect l t r b) = do + #{poke SMALL_RECT, Left} ptr l + #{poke SMALL_RECT, Top} ptr t + #{poke SMALL_RECT, Right} ptr r + #{poke SMALL_RECT, Bottom} ptr b + +data Coord = Coord + { x :: !Int16 + , y :: !Int16 + } deriving (Show) + +instance Storable Coord where + sizeOf _ = #{size COORD} + alignment _ = #{alignment COORD} + peek ptr = do + x <- #{peek COORD, X} ptr + y <- #{peek COORD, Y} ptr + return (Coord x y) + poke ptr (Coord x y) = do + #{poke COORD, X} ptr x + #{poke COORD, Y} ptr y + +data ConsoleScreenBufferInfo = ConsoleScreenBufferInfo + { dwSize :: !Coord + , dwCursorPosition :: !Coord + , wAttributes :: !Word16 + , srWindow :: !SmallRect + , dwMaximumWindowSize :: !Coord + } deriving (Show) + +instance Storable ConsoleScreenBufferInfo where + sizeOf _ = #{size CONSOLE_SCREEN_BUFFER_INFO} + alignment _ = #{alignment CONSOLE_SCREEN_BUFFER_INFO} + peek ptr = do + s <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr + c <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr + a <- #{peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr + w <- #{peek CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr + m <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr + return (ConsoleScreenBufferInfo s c a w m) + poke ptr (ConsoleScreenBufferInfo s c a w m) = do + #{poke CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr s + #{poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr c + #{poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr a + #{poke CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr w + #{poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr m + +invalidHandleValue :: IntPtr +invalidHandleValue = #{const INVALID_HANDLE_VALUE} + +stdOutputHandle :: CULong +stdOutputHandle = #{const STD_OUTPUT_HANDLE} +#endif +-- defined FOUNDATION_SYSTEM_WINDOWS + +#ifdef FOUNDATION_SYSTEM_UNIX + +foreign import capi "sys/ioctl.h ioctl" c_ioctl :: CInt -> CULong -> Ptr a -> IO CInt + +-- | Get the terminal windows size +tiocgwinsz :: CULong +tiocgwinsz = Prelude.fromIntegral (#{const TIOCGWINSZ} :: Word) + +#elif defined FOUNDATION_SYSTEM_WINDOWS +foreign import ccall "GetConsoleScreenBufferInfo" c_get_console_screen_buffer_info + :: HANDLE -> Ptr ConsoleScreenBufferInfo -> IO BOOL +#endif + +#ifdef FOUNDATION_SYSTEM_UNIX +ioctlWinsize :: CInt -> IO (Maybe (CountOf Char, CountOf Char)) +ioctlWinsize fd = alloca $ \winsizePtr -> do + status <- c_ioctl fd tiocgwinsz winsizePtr + if status == (-1 :: CInt) + then pure Nothing + else Just . toDimensions <$> peek winsizePtr + where + toDimensions winsize = + ( CountOf . Prelude.fromIntegral . ws_col $ winsize + , CountOf . Prelude.fromIntegral . ws_row $ winsize) + +#elif defined FOUNDATION_SYSTEM_WINDOWS +getConsoleScreenBufferInfo :: HANDLE -> IO (Maybe ConsoleScreenBufferInfo) +getConsoleScreenBufferInfo handle = alloca $ \infoPtr -> do + status <- c_get_console_screen_buffer_info handle infoPtr + if status + then Just <$> peek infoPtr + else pure Nothing + +winWinsize :: StdHandleId -> IO (Maybe (CountOf Char, CountOf Char)) +winWinsize handleRef = (infoToDimensions <$>) <$> + (getStdHandle handleRef >>= getConsoleScreenBufferInfo) + where + infoToDimensions info = + let window = srWindow info + width = Prelude.fromIntegral (right window - left window + 1) + height = Prelude.fromIntegral (bottom window - top window + 1) + in (CountOf width, CountOf height) +#endif +-- defined FOUNDATION_SYSTEM_WINDOWS + +-- | Return the size of the current terminal +-- +-- If the system is not supported or that querying the system result in an error +-- then a default size of (80, 24) will be given back. +getDimensions :: IO (CountOf Char, CountOf Char) +getDimensions = +#if defined FOUNDATION_SYSTEM_WINDOWS + maybe defaultSize id <$> winWinsize sTD_OUTPUT_HANDLE +#elif defined FOUNDATION_SYSTEM_UNIX + maybe defaultSize id <$> ioctlWinsize 0 +#else + pure defaultSize +#endif + where + defaultSize = (80, 24) diff --git a/Basement/These.hs b/Basement/These.hs new file mode 100644 --- /dev/null +++ b/Basement/These.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Basement.These +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- 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 +import Basement.Compat.Bifunctor + +-- | 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 + +instance Bifunctor These where + bimap fa _ (This a) = This (fa a) + bimap _ fb (That b) = That (fb b) + bimap fa fb (These a b) = These (fa a) (fb b) + +instance Functor (These a) where + fmap = second diff --git a/Basement/Types/AsciiString.hs b/Basement/Types/AsciiString.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/AsciiString.hs @@ -0,0 +1,62 @@ +-- | +-- 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 diff --git a/Basement/Types/Char7.hs b/Basement/Types/Char7.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/Char7.hs @@ -0,0 +1,117 @@ +{-# 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 (bool#) +import Basement.HeadHackageUtils + +-- | 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# (word8ToWordCompat# 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# (wordToWord8Compat# (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# (wordToWord8Compat# (and# (int2Word# (ord# c#)) 0x7f##)) + +-- | Convert a 'Byte' to a 'Char7' ignoring the higher bit +fromByteMask :: Word8 -> Char7 +fromByteMask !(W8# w#) = Char7 $ W8# (wordToWord8Compat# (and# (word8ToWordCompat# 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 diff --git a/Basement/Types/CharUTF8.hs b/Basement/Types/CharUTF8.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/CharUTF8.hs @@ -0,0 +1,8 @@ +module Basement.Types.CharUTF8 + ( CharUTF8(..) + , encodeCharUTF8 + , decodeCharUTF8 + ) where + +import Basement.UTF8.Types +import Basement.UTF8.Helper diff --git a/Basement/Types/OffsetSize.hs b/Basement/Types/OffsetSize.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/OffsetSize.hs @@ -0,0 +1,265 @@ +-- | +-- Module : Basement.Types.OffsetSize +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 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 + mappend = (+) + 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 +csizeOfSize (CountOf (I# sz)) = CSize (W64# (int2Word# sz)) +#endif + +csizeOfOffset :: Offset8 -> CSize +#if WORD_SIZE_IN_BITS < 64 +csizeOfOffset (Offset (I# sz)) = CSize (W32# (int2Word# sz)) +#else +csizeOfOffset (Offset (I# sz)) = CSize (W64# (int2Word# sz)) +#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 +sizeOfCSSize (CSsize (I64# sz)) = CountOf (I# sz) +#endif + +sizeOfCSize :: CSize -> CountOf Word8 +#if WORD_SIZE_IN_BITS < 64 +sizeOfCSize (CSize (W32# sz)) = CountOf (I# (word2Int# sz)) +#else +sizeOfCSize (CSize (W64# sz)) = CountOf (I# (word2Int# sz)) +#endif + +natValCountOf :: forall n ty proxy . (KnownNat n, NatWithinBound (CountOf ty) n) => proxy n -> CountOf ty +natValCountOf n = CountOf $ Prelude.fromIntegral (natVal n) + +natValOffset :: forall n ty proxy . (KnownNat n, NatWithinBound (Offset ty) n) => proxy n -> Offset ty +natValOffset n = Offset $ Prelude.fromIntegral (natVal n) + +type instance NatNumMaxBound (CountOf x) = NatNumMaxBound Int +type instance NatNumMaxBound (Offset x) = NatNumMaxBound Int + +type Countable ty n = NatWithinBound (CountOf ty) n +type Offsetable ty n = NatWithinBound (Offset ty) n diff --git a/Basement/Types/Ptr.hs b/Basement/Types/Ptr.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/Ptr.hs @@ -0,0 +1,40 @@ +{-# 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 diff --git a/Basement/Types/Word128.hs b/Basement/Types/Word128.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/Word128.hs @@ -0,0 +1,250 @@ +{-# 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 +(+) (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 + +-- 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) diff --git a/Basement/Types/Word256.hs b/Basement/Types/Word256.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/Word256.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Basement.Types.Word256 + ( Word256(..) + , (+) + , (-) + , (*) + , 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" + +-- | 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)) = + 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 + +-- 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) diff --git a/Basement/UArray.hs b/Basement/UArray.hs new file mode 100644 --- /dev/null +++ b/Basement/UArray.hs @@ -0,0 +1,942 @@ +-- | +-- Module : Basement.UArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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.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 +import Basement.HeadHackageUtils + +-- | 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 (word8ToWordCompat# w) + unsafeWrite ma dIdx (W8# (wordToWord8Compat# wHi)) + unsafeWrite ma (dIdx+1) (W8# (wordToWord8Compat# 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 (W8# a) (W8# b) (W8# c) = + let !w = narrow8Word# (uncheckedShiftRL# (word8ToWordCompat# a) 2#) + !x = or# (and# (uncheckedShiftL# (word8ToWordCompat# a) 4#) 0x30##) (uncheckedShiftRL# (word8ToWordCompat# b) 4#) + !y = or# (and# (uncheckedShiftL# (word8ToWordCompat# b) 2#) 0x3c##) (uncheckedShiftRL# (word8ToWordCompat# c) 6#) + !z = and# (word8ToWordCompat# c) 0x3f## + in (idx w, idx x, idx y, idx z) + where + idx :: Word# -> Word8 + idx i = W8# (indexWord8OffAddr# table (word2Int# 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 #-} diff --git a/Basement/UArray/Base.hs b/Basement/UArray/Base.hs new file mode 100644 --- /dev/null +++ b/Basement/UArray/Base.hs @@ -0,0 +1,651 @@ +{-# 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.Exts +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 + mappend = append + 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 diff --git a/Basement/UArray/Mutable.hs b/Basement/UArray/Mutable.hs new file mode 100644 --- /dev/null +++ b/Basement/UArray/Mutable.hs @@ -0,0 +1,181 @@ +-- | +-- Module : Basement.UArray.Mutable -- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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.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 diff --git a/Basement/UTF8/Base.hs b/Basement/UTF8/Base.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/Base.hs @@ -0,0 +1,235 @@ +-- | +-- 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 diff --git a/Basement/UTF8/Helper.hs b/Basement/UTF8/Helper.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/Helper.hs @@ -0,0 +1,233 @@ +-- | +-- 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.HeadHackageUtils +import Basement.Types.OffsetSize +import Basement.UTF8.Types +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)) = toChar# (word8ToWordCompat# w) + +toChar2 :: StepASCII -> Word8 -> Char +toChar2 (StepASCII (W8# w1)) (W8# w2) = + toChar# (or# (uncheckedShiftL# (maskHeader2# (word8ToWordCompat# w1)) 6#) (maskContinuation# (word8ToWordCompat# w2))) + +toChar3 :: StepASCII -> Word8 -> Word8 -> Char +toChar3 (StepASCII (W8# w1)) (W8# w2) (W8# w3) = + toChar# (or3# (uncheckedShiftL# (maskHeader3# (word8ToWordCompat# w1)) 12#) + (uncheckedShiftL# (maskContinuation# (word8ToWordCompat# w2)) 6#) + (maskContinuation# (word8ToWordCompat# w3)) + ) + +toChar4 :: StepASCII -> Word8 -> Word8 -> Word8 -> Char +toChar4 (StepASCII (W8# w1)) (W8# w2) (W8# w3) (W8# w4) = + toChar# (or4# (uncheckedShiftL# (maskHeader4# (word8ToWordCompat# w1)) 18#) + (uncheckedShiftL# (maskContinuation# (word8ToWordCompat# w2)) 12#) + (uncheckedShiftL# (maskContinuation# (word8ToWordCompat# w3)) 6#) + (maskContinuation# (word8ToWordCompat# w4)) + ) + +-- | 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# (wordToWord8Compat# x)) + encode2 = + let !x1 = W8# (wordToWord8Compat# (or# (uncheckedShiftRL# x 6#) 0xc0##)) + !x2 = toContinuation x + in UTF8_2 x1 x2 + encode3 = + let !x1 = W8# (wordToWord8Compat# (or# (uncheckedShiftRL# x 12#) 0xe0##)) + !x2 = toContinuation (uncheckedShiftRL# x 6#) + !x3 = toContinuation x + in UTF8_3 x1 x2 x3 + encode4 = + let !x1 = W8# (wordToWord8Compat# (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# (wordToWord8Compat# (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# (wordToWord32Compat# x)) + | bool# (ltWord# x 0x800## ) = CharUTF8 encode2 + | bool# (ltWord# x 0x10000##) = CharUTF8 encode3 + | otherwise = CharUTF8 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 = W32# (wordToWord32Compat# (and# mask2 (or3# set2 + (uncheckedShiftRL# x 6#) -- 5 bits to 1st byte + (uncheckedShiftL# x 8# ) -- move lowest bits to the 2nd byte + ))) + encode3 = W32# (wordToWord32Compat# (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 = W32# (wordToWord32Compat# (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# (word32ToWordCompat# w) + | isCharUTF8Case2 c = encode2 + | isCharUTF8Case3 c = encode3 + | otherwise = encode4 + where + encode2 = + toChar# (or# (uncheckedShiftL# (maskHeader2# (word32ToWordCompat# w)) 6#) + (maskContinuation# (uncheckedShiftRL# (word32ToWordCompat# w) 8#)) + ) + encode3 = + toChar# (or3# (uncheckedShiftL# (maskHeader3# (word32ToWordCompat# w)) 12#) + (uncheckedShiftRL# (and# 0x3f00## (word32ToWordCompat# w)) 8#) + (maskContinuation# (uncheckedShiftRL# (word32ToWordCompat# w) 16#)) + ) + encode4 = + toChar# (or4# (uncheckedShiftL# (maskHeader4# (word32ToWordCompat# w)) 18#) + (uncheckedShiftRL# (and# 0x3f00## (word32ToWordCompat# w)) 10#) + (uncheckedShiftL# (and# 0x3f0000## (word32ToWordCompat# w)) 4#) + (maskContinuation# (uncheckedShiftRL# (word32ToWordCompat# 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 !(W32# w)) = bool# (eqWord# (and# (word32ToWordCompat# w) 0x80##) 0##) +{-# INLINE isCharUTF8Case1 #-} + +isCharUTF8Case2 :: CharUTF8 -> Bool +isCharUTF8Case2 (CharUTF8 !(W32# w)) = bool# (eqWord# (and# (word32ToWordCompat# w) 0x20##) 0##) +{-# INLINE isCharUTF8Case2 #-} + +isCharUTF8Case3 :: CharUTF8 -> Bool +isCharUTF8Case3 (CharUTF8 !(W32# w)) = bool# (eqWord# (and# (word32ToWordCompat# w) 0x10##) 0##) +{-# INLINE isCharUTF8Case3 #-} + +isCharUTF8Case4 :: CharUTF8 -> Bool +isCharUTF8Case4 (CharUTF8 !(W32# w)) = bool# (eqWord# (and# (word32ToWordCompat# w) 0x08##) 0##) +{-# INLINE isCharUTF8Case4 #-} diff --git a/Basement/UTF8/Table.hs b/Basement/UTF8/Table.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/Table.hs @@ -0,0 +1,111 @@ +-- | +-- Module : Basement.UTF8.Table +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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# + , getNbBytes# + ) where + +import GHC.Prim +import GHC.Types +import GHC.Word +import Basement.Compat.Base +import Basement.Compat.Primitive +import Basement.HeadHackageUtils +import Basement.UTF8.Types (StepASCII(..)) + +-- | Check if the byte is a continuation byte +isContinuation :: Word8 -> Bool +isContinuation (W8# w) = isContinuation# (word8ToWordCompat# w) +{-# INLINE isContinuation #-} + +isContinuation2 :: Word8 -> Word8 -> Bool +isContinuation2 (W8# w1) (W8# w2) = + bool# (mask (word8ToWordCompat# w1) `andI#` mask (word8ToWordCompat# w2)) + where + mask v = (and# 0xC0## v) `eqWord#` 0x80## +{-# INLINE isContinuation2 #-} + +isContinuation3 :: Word8 -> Word8 -> Word8 -> Bool +isContinuation3 (W8# w1) (W8# w2) (W8# w3) = + bool# (mask (word8ToWordCompat# w1)) && bool# (mask (word8ToWordCompat# w2)) && bool# (mask (word8ToWordCompat# w3)) + where + mask v = (and# 0xC0## v) `eqWord#` 0x80## +{-# INLINE isContinuation3 #-} + +-- | Number of bytes associated with a specific header byte +-- +-- If the header byte is invalid then NbBytesInvalid is returned, +data NbBytesCont = NbBytesInvalid | NbBytesCont0 | NbBytesCont1 | NbBytesCont2 | NbBytesCont3 + +-- | Identical to 'NbBytesCont' but doesn't allow to represent any failure. +-- +-- Only use in validated place +data NbBytesCont_ = NbBytesCont0_ | NbBytesCont1_ | NbBytesCont2_ | NbBytesCont3_ + +-- | Get the number of following bytes given the first byte of a UTF8 sequence. +getNbBytes :: StepASCII -> Int +getNbBytes (StepASCII (W8# w)) = I# (getNbBytes# (word8ToWordCompat# w)) +{-# INLINE getNbBytes #-} + +-- | Check if the byte is a continuation byte +isContinuation# :: Word# -> Bool +isContinuation# w = W# (word8ToWordCompat# (indexWord8OffAddr# (unTable contTable) (word2Int# w))) == W# 0## +{-# INLINE isContinuation# #-} + +-- | Get the number of following bytes given the first byte of a UTF8 sequence. +getNbBytes# :: Word# -> Int# +getNbBytes# w = word2Int# (word8ToWordCompat# (indexWord8OffAddr# (unTable headTable) (word2Int# 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 #-} diff --git a/Basement/UTF8/Types.hs b/Basement/UTF8/Types.hs new file mode 100644 --- /dev/null +++ b/Basement/UTF8/Types.hs @@ -0,0 +1,68 @@ +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015-2017 Vincent Hanquez +Copyright (c) 2017-2019 Foundation Maintainers + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/basement-cd.cabal b/basement-cd.cabal new file mode 100644 --- /dev/null +++ b/basement-cd.cabal @@ -0,0 +1,163 @@ +name: basement-cd +version: 0.0.12.1 +synopsis: Foundation scrap box of array & string +description: Foundation most basic primitives without any dependencies +license: BSD3 +license-file: LICENSE +copyright: 2015-2017 Vincent Hanquez + , 2017-2018 Foundation Maintainers +maintainer: chris@chrisdornan.com +category: Web +build-type: Simple +homepage: https://github.com/cdornan/basement-cd#readme +bug-reports: https://github.com/cdornan/basement-cd/issues +cabal-version: 1.18 +extra-source-files: cbits/*.h cbits/basement_rts.c + +source-repository head + type: git + location: https://github.com/cdornan/basement-cd + subdir: basement + +library + hs-source-dirs: . + exposed-modules: + Basement.Imports + + Basement.Base16 + Basement.Bindings.Memory + Basement.Endianness + Basement.Environment + Basement.PrimType + + Basement.Exception + Basement.Cast + Basement.From + + Basement.Types.Char7 + Basement.Types.CharUTF8 + Basement.Types.OffsetSize + Basement.Types.Ptr + Basement.Types.AsciiString + Basement.Types.Word128 + Basement.Types.Word256 + Basement.Monad + Basement.MutableBuilder + Basement.FinalPtr + + Basement.Nat + + -- Extended Types + Basement.BoxedArray + Basement.Block + Basement.Block.Mutable + Basement.Block.Builder + Basement.UArray + Basement.UArray.Mutable + Basement.String + Basement.String.Builder + Basement.NonEmpty + + -- Extended Types with explicit type level size + Basement.Sized.Block + Basement.Sized.UVect + Basement.Sized.Vect + Basement.Sized.List + Basement.BlockN + + -- Utils + Basement.NormalForm + Basement.These + + -- Terminal + Basement.Terminal + Basement.Terminal.ANSI + + -- numeric stuff + Basement.IntegralConv + Basement.Floating + Basement.Numerical.Number + Basement.Numerical.Additive + Basement.Numerical.Subtractive + Basement.Numerical.Multiplicative + Basement.Bounded + + -- exported algorithms + Basement.Alg.XorShift + + -- compat / base redefinition + Basement.Compat.AMP + Basement.Compat.Base + Basement.Compat.Bifunctor + Basement.Compat.CallStack + Basement.Compat.C.Types + Basement.Compat.ExtList + Basement.Compat.IsList + Basement.Compat.Identity + Basement.Compat.Primitive + Basement.Compat.PrimTypes + Basement.Compat.MonadTrans + Basement.Compat.Semigroup + Basement.Compat.Natural + Basement.Compat.NumLiteral + Basement.Compat.Typeable + + Basement.Bits + + other-modules: + Basement.Error + Basement.Show + Basement.Runtime + + Basement.Alg.Class + Basement.Alg.Mutable + Basement.Alg.PrimArray + + Basement.Alg.UTF8 + Basement.Alg.String + + Basement.Numerical.Conversion + + Basement.Block.Base + + Basement.UTF8.Base + Basement.UTF8.Helper + Basement.UTF8.Table + Basement.UTF8.Types + + Basement.UArray.Base + + Basement.String.CaseMapping + Basement.String.Encoding.Encoding + Basement.String.Encoding.UTF16 + Basement.String.Encoding.UTF32 + Basement.String.Encoding.ASCII7 + Basement.String.Encoding.ISO_8859_1 + + Basement.Terminal.Size + + Basement.HeadHackageUtils + + -- support and dependencies + if impl(ghc < 8.0) + buildable: False + else + build-depends: base >=4.9 && <4.17 + , ghc-prim + if os(windows) + build-depends: Win32 + + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + RebindableSyntax + TypeFamilies + BangPatterns + DeriveDataTypeable + if (arch(i386) || arch(x86_64)) + cpp-options: -DARCH_IS_LITTLE_ENDIAN + else + cpp-options: -DARCH_IS_UNKNOWN_ENDIAN + include-dirs: cbits + c-sources: cbits/foundation_mem.c + if impl(ghc < 8.2) + c-sources: cbits/basement_rts.c diff --git a/cbits/basement_rts.c b/cbits/basement_rts.c new file mode 100644 --- /dev/null +++ b/cbits/basement_rts.c @@ -0,0 +1,8 @@ +#include "Rts.h" + +#if __GLASGOW_HASKELL__ < 802 +int basement_is_bytearray_pinned(void *p) +{ + return Bdescr((StgPtr) p)->flags & BF_PINNED; +} +#endif diff --git a/cbits/foundation_mem.c b/cbits/foundation_mem.c new file mode 100644 --- /dev/null +++ b/cbits/foundation_mem.c @@ -0,0 +1,14 @@ +#include +#include +#include "foundation_prim.h" + +int _foundation_memcmp(const void *s1, FsOffset off1, const void *s2, FsOffset off2, FsCountOf n) +{ + return memcmp(s1 + off1, s2 + off2, n); +} + +FsOffset _foundation_mem_findbyte(uint8_t * const arr, FsOffset startofs, FsOffset endofs, uint8_t ty) +{ + uint8_t *r = memchr(arr + startofs, ty, endofs - startofs); + return ((r == NULL) ? endofs : r - arr); +} diff --git a/cbits/foundation_prim.h b/cbits/foundation_prim.h new file mode 100644 --- /dev/null +++ b/cbits/foundation_prim.h @@ -0,0 +1,8 @@ +#ifndef FOUNDATION_PRIM_H +#define FOUNDATION_PRIM_H +#include "Rts.h" + +typedef StgInt FsOffset; +typedef StgInt FsCountOf; + +#endif diff --git a/cbits/foundation_system.h b/cbits/foundation_system.h new file mode 100644 --- /dev/null +++ b/cbits/foundation_system.h @@ -0,0 +1,60 @@ +#ifndef FOUNDATION_SYSTEM_H +# define FOUNDATION_SYSTEM_H + +#ifdef _WIN32 + #define FOUNDATION_SYSTEM_WINDOWS + #define FOUNDATION_SYSTEM_API_NO_CLOCK + + //define something for Windows (32-bit and 64-bit, this part is common) + #ifdef _WIN64 + #define FOUNDATION_SYSTEM_WINDOWS_64 + //define something for Windows (64-bit only) + #else + #define FOUNDATION_SYSTEM_WINDOWS_32 + //define something for Windows (32-bit only) + #endif +#elif __APPLE__ + #include "TargetConditionals.h" + #include "Availability.h" + + #if TARGET_OS_MAC + #define FOUNDATION_SYSTEM_UNIX + #define FOUNDATION_SYSTEM_MACOS + + #if !defined(__MAC_10_12) || __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_12 + #define FOUNDATION_SYSTEM_API_NO_CLOCK + #endif + // Other kinds of Mac OS + #else + # error "foundation: system: Unknown Apple platform" + #endif +#elif __linux__ + #define FOUNDATION_SYSTEM_UNIX + #define FOUNDATION_SYSTEM_LINUX + // linux +#elif defined(__FreeBSD__) + #define FOUNDATION_SYSTEM_UNIX + #define FOUNDATION_SYSTEM_BSD + #define FOUNDATION_SYSTEM_FREEBSD + // freeBSD +#elif defined(__NetBSD__) + #define FOUNDATION_SYSTEM_UNIX + #define FOUNDATION_SYSTEM_BSD + #define FOUNDATION_SYSTEM_NETBSD + // NetBSD +#elif defined(__OpenBSD__) + #define FOUNDATION_SYSTEM_UNIX + #define FOUNDATION_SYSTEM_BSD + #define FOUNDATION_SYSTEM_OPENBSD + // OpenBSD +#elif __unix__ // all unices not caught above + #define FOUNDATION_SYSTEM_UNIX + // Unix +#elif defined(_POSIX_VERSION) + #define FOUNDATION_SYSTEM_UNIX + // POSIX +#else +# error "foundation: system: Unknown compiler" +#endif + +#endif