module Foundation.String.UTF8
( String(..)
, MutableString(..)
, create
, replicate
, length
, Encoding(..)
, fromBytes
, fromChunkBytes
, fromBytesUnsafe
, fromBytesLenient
, toBytes
, mutableValidate
, copy
, ValidationFailure(..)
, index
, null
, drop
, take
, splitAt
, revDrop
, revTake
, revSplitAt
, splitOn
, sub
, elem
, indices
, intersperse
, span
, break
, breakElem
, dropWhile
, singleton
, charMap
, snoc
, cons
, unsnoc
, uncons
, find
, findIndex
, sortBy
, filter
, reverse
, replace
, builderAppend
, builderBuild
, builderBuild_
, readInteger
, readIntegral
, readNatural
, readDouble
, readRational
, readFloatingExact
, upper
, lower
, isPrefixOf
, isSuffixOf
, isInfixOf
, lines
, words
, toBase64
, toBase64URL
, toBase64OpenBSD
) where
import Foundation.Array.Unboxed (UArray)
import qualified Foundation.Array.Unboxed as Vec
import qualified Foundation.Array.Unboxed as C
import Foundation.Array.Unboxed.ByteArray (MutableByteArray)
import qualified Foundation.Array.Unboxed.Mutable as MVec
import Foundation.Class.Bifunctor
import Foundation.Internal.Base
import Foundation.Internal.Natural
import Foundation.Internal.MonadTrans
import Foundation.Internal.Primitive
import Foundation.Primitive.Types.OffsetSize
import Foundation.Numerical
import Foundation.Primitive.Monad
import Foundation.Primitive.Types
import Foundation.Primitive.FinalPtr
import Foundation.Primitive.IntegralConv
import Foundation.Primitive.Floating
import Foundation.Boot.Builder
import Foundation.Primitive.UTF8.Table
import Foundation.Primitive.UTF8.Helper
import Foundation.Primitive.UTF8.Base
import qualified Foundation.Primitive.UTF8.BA as PrimBA
import qualified Foundation.Primitive.UTF8.Addr as PrimAddr
import qualified Foundation.String.UTF8.BA as BackendBA
import qualified Foundation.String.UTF8.Addr as BackendAddr
import GHC.Prim
import GHC.ST
import GHC.Types
import GHC.Word
#if MIN_VERSION_base(4,9,0)
import GHC.Char
#endif
import qualified Data.List
import Data.Ratio
import Data.Char (toUpper, toLower)
import qualified Prelude
import qualified Foundation.String.Encoding.Encoding as Encoder
import qualified Foundation.String.Encoding.ASCII7 as Encoder
import qualified Foundation.String.Encoding.UTF16 as Encoder
import qualified Foundation.String.Encoding.UTF32 as Encoder
import qualified Foundation.String.Encoding.ISO_8859_1 as 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 :: 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 $ BackendBA.validate (start+end) ba (start + ofsStart)
goAddr (Ptr addr) start =
pure $ unTranslateOffset start $ BackendAddr.validate (start+end) addr (ofsStart + start)
end = ofsStart `offsetPlusE` sz
mutableValidate :: PrimMonad prim
=> MutableByteArray (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 <- 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# h of
0# -> (toChar 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# h))
where
!(W8# h) = getter off
toChar :: Word# -> Char
toChar w = C# (chr# (word2Int# w))
decode2 :: Word8 -> Word#
decode2 (W8# c1) =
or# (uncheckedShiftL# (and# h 0x1f##) 6#)
(and# c1 0x3f##)
decode3 :: Word8 -> Word8 -> Word#
decode3 (W8# c1) (W8# c2) =
or# (uncheckedShiftL# (and# h 0xf##) 12#)
(or# (uncheckedShiftL# (and# c1 0x3f##) 6#)
(and# c2 0x3f##))
decode4 :: Word8 -> Word8 -> Word8 -> Word#
decode4 (W8# c1) (W8# c2) (W8# c3) =
or# (uncheckedShiftL# (and# h 0x7##) 18#)
(or# (uncheckedShiftL# (and# c1 0x3f##) 12#)
(or# (uncheckedShiftL# (and# c2 0x3f##) 6#)
(and# 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# x)
encode2 = do
let x1 = or# (uncheckedShiftRL# x 6#) 0xc0##
x2 = toContinuation x
Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2)
encode3 = do
let x1 = or# (uncheckedShiftRL# x 12#) 0xe0##
x2 = toContinuation (uncheckedShiftRL# x 6#)
x3 = toContinuation x
Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2) >> Vec.builderAppend (W8# 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# x1) >> Vec.builderAppend (W8# x2) >> Vec.builderAppend (W8# x3) >> Vec.builderAppend (W8# 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
unsafeFreezeShrink :: PrimMonad prim => MutableString (PrimState prim) -> CountOf Word8 -> prim String
unsafeFreezeShrink (MutableString mba) s = String <$> Vec.unsafeFreezeShrink mba s
null :: String -> Bool
null (String ba) = C.length ba == 0
countCharMoreThanBytes :: CountOf Char -> UArray Word8 -> Bool
countCharMoreThanBytes (CountOf chars) ba = chars >= bytes
where (CountOf bytes) = C.length ba
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
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
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)
indexN :: CountOf Char -> String -> Offset Word8
indexN !n (String ba) = Vec.unsafeDewrap goVec goAddr ba
where
goVec :: ByteArray# -> Offset Word8 -> Offset Word8
goVec !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)
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)
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
revTake :: CountOf Char -> String -> String
revTake n v = drop (countFromStart v n) v
revDrop :: CountOf Char -> String -> String
revDrop n v = take (countFromStart v n) v
revSplitAt :: CountOf Char -> String -> (String, String)
revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n
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 (# c, idx' #) = next s idx
in if predicate c
then sub s prevIdx idx : loop idx' idx'
else loop prevIdx idx'
sub :: String -> Offset8 -> Offset8 -> String
sub (String ba) start end = String $ Vec.sub ba start end
splitIndex :: Offset8 -> String -> (String, String)
splitIndex idx (String ba) = (String v1, String v2)
where (v1,v2) = C.splitAt (offsetAsSize idx) ba
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'
#if MIN_VERSION_base(4,9,0)
#else
#endif
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.splitElem 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'
span :: (Char -> Bool) -> String -> (String, String)
span predicate s = break (not . predicate) s
dropWhile :: (Char -> Bool) -> String -> String
dropWhile predicate = snd . break (not . predicate)
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 :: Char -> String -> String
intersperse sep src
| srcLen <= 1 = src
| otherwise = runST $ unsafeCopyFrom src dstBytes (go sep)
where
!srcBytes = size src
!srcLen = length src
dstBytes = (srcBytes :: Size8)
+ ((srcLen 1) `scale` charToBytes (fromEnum sep))
lastSrcI :: Offset Char
lastSrcI = 0 `offsetPlusE` (srcLen 1)
go :: Char -> String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8)
go sep' 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
(# c, nextSrcIdx #) = next src' srcIdx
unsafeCopyFrom :: String
-> Size8
-> (String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8))
-> ST s 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 :: String -> CountOf Char
length (String ba)
| C.null ba = CountOf 0
| otherwise = Vec.unsafeDewrap goVec goAddr ba
where
goVec ma start = loop start (CountOf 0)
where
!end = start `offsetPlusE` Vec.length ba
loop !idx !i
| idx >= end = i
| otherwise = loop (idx `offsetPlusE` d) (i + CountOf 1)
where d = skipNextHeaderValue (primBaIndex ma idx)
goAddr (Ptr ptr) start = return $ loop start (CountOf 0)
where
!end = start `offsetPlusE` Vec.length ba
loop !idx !i
| idx >= end = i
| otherwise = loop (idx `offsetPlusE` d) (i + CountOf 1)
where d = skipNextHeaderValue (primAddrIndex ptr idx)
replicate :: CountOf Char -> Char -> String
replicate (CountOf n) c = runST (new nbBytes >>= fill)
where
nbBytes = scale (integralCast 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 :: String -> String
copy (String s) = String (Vec.copy s)
singleton :: Char -> String
singleton c = runST $ do
ms <- new nbBytes
_ <- write ms (Offset 0) c
freeze ms
where
!nbBytes = charToBytes (fromEnum c)
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
(String ba) <- freeze ms
pure $ String $ C.take (offsetAsSize filled) ba
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, Size8)]
-> Offset8
-> Size8
-> ([(String,Size8)], Size8)
allocateAndFill acc idx bytesWritten
| idx == srcEnd = (acc, bytesWritten)
| otherwise =
let (el@(_,addBytes), idx') = runST $ do
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)
-> Size8
-> Offset8
-> prim (Size8, 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 (# c, srcIdx' #) = next src srcIdx
c' = f c
!nbBytes = charToBytes (fromEnum c')
in
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
snoc :: String -> Char -> String
snoc s@(String ba) c
| len == CountOf 0 = singleton c
| otherwise = runST $ do
ms@(MutableString mba) <- new (len + nbBytes)
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)
cons :: Char -> String -> String
cons c s@(String ba)
| len == CountOf 0 = singleton c
| otherwise = runST $ do
ms@(MutableString mba) <- new (len + nbBytes)
idx <- write ms (Offset 0) c
Vec.unsafeCopyAtRO mba idx ba (Offset 0) len
freeze ms
where
!len = size s
!nbBytes = charToBytes (fromEnum c)
unsnoc :: String -> Maybe (String, Char)
unsnoc s@(String arr)
| sz == 0 = Nothing
| otherwise =
let (# c, idx #) = prev s (sizeAsOffset sz)
in Just (String $ Vec.take (offsetAsSize idx) arr, c)
where
sz = size s
uncons :: String -> Maybe (Char, String)
uncons s@(String ba)
| null s = Nothing
| otherwise =
let (# c, idx #) = next s azero
in Just (c, String $ Vec.drop (offsetAsSize idx) ba)
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 (# c, idx' #) = next s idx
in case predicate c of
True -> Just c
False -> loop idx'
sortBy :: (Char -> Char -> Ordering) -> String -> String
sortBy sortF s = fromList $ Data.List.sortBy sortF $ toList s
filter :: (Char -> Bool) -> String -> String
filter predicate (String arr) = runST $ do
(finalSize, dst) <- newNative sz $ \mba ->
case arr of
C.UVecBA start _ _ ba -> BackendBA.copyFilter predicate sz mba ba start
C.UVecAddr start _ fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start
freezeShrink finalSize dst
where
!sz = C.length arr
reverse :: String -> String
reverse s@(String ba) = runST $ do
ms <- new len
loop ms (Offset 0) (Offset 0 `offsetPlusE` len)
where
!len = size s
loop :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Offset8 -> prim String
loop ms@(MutableString mba) si didx
| didx == Offset 0 = freeze ms
| otherwise = do
let !h = Vec.unsafeIndex ba si
!nb = CountOf (getNbBytes h + 1)
d = didx `offsetMinusE` nb
case nb of
CountOf 1 -> Vec.unsafeWrite mba d h
CountOf 2 -> do
Vec.unsafeWrite mba d h
Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))
CountOf 3 -> do
Vec.unsafeWrite mba d h
Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))
Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))
CountOf 4 -> do
Vec.unsafeWrite mba d h
Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))
Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))
Vec.unsafeWrite mba (d + 3) (Vec.unsafeIndex ba (si + 3))
_ -> return ()
loop ms (si `offsetPlusE` nb) d
indices :: String -> String -> [Offset8]
indices (String ned) (String hy) = Vec.indices ned hy
replace :: String -> String -> String -> String
replace (String needle) (String replacement) (String haystack) =
String $ Vec.replace needle replacement haystack
index :: String -> Offset Char -> Maybe Char
index s n
| ofs >= end = Nothing
| otherwise =
let (# c, _ #) = next s ofs
in Just c
where
!nbBytes = size s
end = 0 `offsetPlusE` nbBytes
ofs = indexN (offsetAsSize n) s
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 (# c, idx' #) = next s idx
in case predicate c of
True -> Just ofs
False -> loop (ofs+1) idx'
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
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)
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
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)
(_, 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
replacement :: String
!replacement = fromBytesUnsafe $ fromList [0xef,0xbf,0xbd]
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)
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
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
lines :: String -> [String]
lines = fmap fromList . Prelude.lines . toList
words :: String -> [String]
words = fmap fromList . Prelude.words . toList
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
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)) <- 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)
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
Vec.unsafeCopyAtRO mba (sizeAsOffset (end sz)) x (Offset 0) sz
fillFromEnd (end sz) 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 :: (ByteArray# -> Offset Word8 -> a)
-> (Ptr Word8 -> Offset Word8 -> ST s a)
-> String
-> a
stringDewrap withBa withPtr (String ba) = C.unsafeDewrap withBa withPtr ba
readIntegral :: (HasNegation i, IntegralUpsize Word8 i, Additive i, Multiplicative i, IsIntegral i) => String -> Maybe i
readIntegral str
| sz == 0 = Nothing
| otherwise = stringDewrap withBa withPtr str
where
!sz = size str
withBa ba ofs =
let negativeSign = PrimBA.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 (Ptr ptr) ofs = return $
let negativeSign = PrimAddr.expectAscii ptr ofs 0x2d
startOfs = if negativeSign then succ ofs else ofs
in case decimalDigitsPtr 0 ptr endOfs startOfs of
(# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc
_ -> Nothing
where !endOfs = ofs `offsetPlusE` sz
readInteger :: String -> Maybe Integer
readInteger = readIntegral
readNatural :: String -> Maybe Natural
readNatural str
| sz == 0 = Nothing
| otherwise =
case decimalDigits 0 str 0 of
(# acc, True, endOfs #) | endOfs > 0 -> Just acc
_ -> Nothing
where
!sz = size str
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)
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.^ (integralCast floatingDigits exponent))
Nothing -> Just $ modF isNegative integral % (10 Prelude.^ floatingDigits)
where
modF True = negate . integralUpsize
modF False = integralUpsize
type ReadFloatingCallback a = Bool
-> Natural
-> Word
-> Maybe Int
-> Maybe a
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 = PrimBA.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
(# acc, False, endOfs #) | endOfs > startOfs ->
if PrimBA.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 (integralCast diff) Nothing
(# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs startOfs
in consumeExponant isNegative acc (integralCast diff) endOfs
_ -> Nothing
consumeExponant !isNegative !integral !floatingDigits !startOfs
| startOfs == eofs = f isNegative integral floatingDigits Nothing
| otherwise =
case PrimBA.nextAscii ba startOfs of
(# 0x45, True #) -> consumeExponantSign (startOfs+1)
(# 0x65, True #) -> consumeExponantSign (startOfs+1)
(# _ , _ #) -> Nothing
where
consumeExponantSign ofs
| ofs == eofs = Nothing
| otherwise = let exponentNegative = PrimBA.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 = return $
let !isNegative = PrimAddr.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
(# acc, False, endOfs #) | endOfs > startOfs ->
if PrimAddr.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 (integralCast diff) Nothing
(# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs startOfs
in consumeExponant isNegative acc (integralCast diff) endOfs
_ -> Nothing
consumeExponant !isNegative !integral !floatingDigits !startOfs
| startOfs == eofs = f isNegative integral floatingDigits Nothing
| otherwise =
case PrimAddr.nextAscii ptr startOfs of
(# 0x45, True #) -> consumeExponantSign (startOfs+1)
(# 0x65, True #) -> consumeExponantSign (startOfs+1)
(# _ , _ #) -> Nothing
where
consumeExponantSign ofs
| ofs == eofs = Nothing
| otherwise = let exponentNegative = PrimAddr.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
decimalDigits :: (IntegralUpsize Word8 acc, Additive acc)
=> acc
-> String
-> Offset Word8
-> (# acc, Bool, Offset Word8 #)
decimalDigits startAcc str startOfs = loop startAcc startOfs
where
!sz = size str
loop acc ofs
| ofs .==# sz = (# acc, True, ofs #)
| otherwise =
case nextAscii str ofs of
(# d, True #) | isDigit d -> loop (scale (10::Word) acc + fromDigit d) (ofs+1)
(# _, _ #) -> (# acc, False, ofs #)
ascii0 = 0x30
ascii9 = 0x39
isDigit c = c >= ascii0 && c <= ascii9
fromDigit c = integralUpsize (c ascii0)
decimalDigitsBA :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc)
=> acc
-> ByteArray#
-> Offset Word8
-> Offset Word8
-> (# acc, Bool, Offset Word8 #)
decimalDigitsBA startAcc ba !endOfs !startOfs = loop startAcc startOfs
where
loop !acc !ofs
| ofs == endOfs = (# acc, True, ofs #)
| otherwise =
case PrimBA.nextAsciiDigit ba ofs of
(# d, True #) -> loop (10 * acc + integralUpsize d) (succ ofs)
(# _, _ #) -> (# acc, False, ofs #)
decimalDigitsPtr :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc)
=> acc
-> Addr#
-> Offset Word8
-> Offset Word8
-> (# acc, Bool, Offset Word8 #)
decimalDigitsPtr startAcc ptr !endOfs !startOfs = loop startAcc startOfs
where
loop !acc !ofs
| ofs == endOfs = (# acc, True, ofs #)
| otherwise =
case PrimAddr.nextAsciiDigit ptr ofs of
(# d, True #) -> loop (10 * acc + integralUpsize d) (succ ofs)
(# _, _ #) -> (# acc, False, ofs #)
upper :: String -> String
upper = charMap toUpper
lower :: String -> String
lower = charMap toLower
isPrefixOf :: String -> String -> Bool
isPrefixOf (String needle) (String haystack)
| needleLen > hayLen = False
| otherwise = needle == C.take needleLen haystack
where
needleLen = C.length needle
hayLen = C.length haystack
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
isInfixOf :: String -> String -> Bool
isInfixOf (String needle) (String haystack)
| needleLen > hayLen = False
| otherwise = loop 0
where
endOfs = hayLen needleLen
needleLen = C.length needle
hayLen = C.length haystack
loop i
| i == endOfs = needle == haystackSub
| needle == haystackSub = True
| otherwise = loop (i+1)
where haystackSub = C.take needleLen $ C.drop i haystack
toBase64 :: String -> String
toBase64 (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ True
where
!set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"#
toBase64URL :: Bool -> String -> String
toBase64URL padded (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ padded
where
!set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"#
toBase64OpenBSD :: String -> String
toBase64OpenBSD (String src) = fromBytesUnsafe . Vec.toBase64Internal set src $ False
where
!set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"#