tricu

UTF8.hs (3245B)

---

 {-# LANGUAGE BangPatterns #-}
 -- Stateless bounded Unicode transport. Source owns the <=3-byte carry between
 -- calls, text/source policy and sequencing; no shared mutable decoder context.
 module IO.UTF8 (encode, decode, scalarLimit) where
 
 import qualified IO.Resources as R
 import qualified Data.ByteString as BS
 import qualified Data.Text as Text
 import Data.Text.Encoding (encodeUtf8)
 import Data.Char (chr, ord)
 import Data.Bits ((.&.))
 import Data.List (foldl')
 
 scalarLimit :: Int
 scalarLimit = R.chunkLimit `div` 4
 
 fault op message = R.Problem "invalid-data" op message "none"
 
 encode :: String -> Either R.Problem BS.ByteString
 encode text = encodeUtf8 . Text.pack <$> checked scalarLimit text
   where
     checked _ [] = Right []
     checked 0 _ = Left (R.Problem "invalid-bound" "encode" "Unicode chunk exceeds scalar limit" "none")
     checked n (c:rest)
       | ord c >= 0xd800 && ord c <= 0xdfff = Left (fault "encode" "surrogate is not a Unicode scalar")
       | otherwise = (c:) <$> checked (n-1) rest
 
 -- Strict UTF-8, including overlong/surrogate/range controls. A nonfinal valid
 -- incomplete suffix is copied (not a slice retaining the input buffer). Invalid
 -- prefixes fail immediately, even when incomplete. No partial output on error.
 decode :: Bool -> BS.ByteString -> Either R.Problem (String, BS.ByteString)
 decode final bytes
   | BS.length bytes > R.chunkLimit = Left (R.Problem "invalid-bound" "decode" "UTF-8 chunk exceeds byte limit" "none")
   | otherwise = walk 0 []
   where
     end = BS.length bytes
     at i = fromIntegral (BS.index bytes i) :: Int
     bad offset why = Left (fault "decode" (why ++ " at byte " ++ show offset))
     walk !offset chars
       | offset == end = Right (reverse chars, BS.empty)
       | otherwise =
           let lead = at offset
               emit code count = let !c = chr code in walk (offset + count) (c:chars)
               sequenceOf count low high mask =
                 let valid i = let c = at (offset+i)
                               in c >= (if i == 1 then low else 0x80)
                                  && c <= (if i == 1 then high else 0xbf)
                     available = min (count-1) (end-offset-1)
                 in if not (all valid [1..available]) then bad offset "invalid UTF-8 sequence"
                    else if end-offset < count then
                      if final then bad offset "incomplete UTF-8 sequence"
                      else Right (reverse chars, BS.copy (BS.drop offset bytes))
                    else emit (foldl' (\code i -> code*64 + (at (offset+i) .&. 0x3f))
                          (lead .&. mask) [1..count-1]) count
           in if lead <= 0x7f then emit lead 1
              else if lead >= 0xc2 && lead <= 0xdf then sequenceOf 2 0x80 0xbf 0x1f
              else if lead == 0xe0 then sequenceOf 3 0xa0 0xbf 0x0f
              else if lead == 0xed then sequenceOf 3 0x80 0x9f 0x0f
              else if lead >= 0xe1 && lead <= 0xef then sequenceOf 3 0x80 0xbf 0x0f
              else if lead == 0xf0 then sequenceOf 4 0x90 0xbf 0x07
              else if lead == 0xf4 then sequenceOf 4 0x80 0x8f 0x07
              else if lead >= 0xf1 && lead <= 0xf3 then sequenceOf 4 0x80 0xbf 0x07
              else bad offset "invalid UTF-8 leading byte"