UTF8.hs

-- | An implementation of UTF-8 (RFC 3629): <https://doi.org/10.17487/RFC3629>
module Mini.String.UTF8 (
  encode,
  decode,
) where

import Control.Applicative (
  (<|>),
 )
import Control.Monad (
  guard,
 )
import Data.Bits (
  complement,
  shiftL,
  shiftR,
  (.&.),
  (.|.),
 )
import Data.Bool (
  bool,
 )
import Data.Word (
  Word8,
 )
import Mini.Transformers.Parser (
  ParserT,
  sat,
 )
import Prelude (
  Char,
  Monad,
  fmap,
  fromEnum,
  fromIntegral,
  pure,
  toEnum,
  ($),
  (.),
  (/=),
  (<$>),
  (==),
  (||),
 )

-- | Turn a character into a byte sequence in UTF-8 format
encode :: Char -> [Word8]
encode = fmap fromIntegral . go . fromEnum
 where
  go n =
    bool
      ( bool
          ( bool
              [ 0xf0 .|. (n `shiftR` 18)
              , 0x80 .|. ((n `shiftR` 12) .&. 0x3f)
              , 0x80 .|. ((n `shiftR` 6) .&. 0x3f)
              , 0x80 .|. (n .&. 0x3f)
              ] -- up to 21 bits 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
              [ 0xe0 .|. (n `shiftR` 12)
              , 0x80 .|. ((n `shiftR` 6) .&. 0x3f)
              , 0x80 .|. (n .&. 0x3f)
              ] -- up to 16 bits 1110xxxx 10xxxxxx 10xxxxxx
              $ n .&. complement 0xffff == 0
          )
          [ 0xc0 .|. (n `shiftR` 6)
          , 0x80 .|. (n .&. 0x3f)
          ] -- up to 11 bits 110xxxxx 10xxxxxx
          $ n .&. complement 0x7ff == 0
      )
      [n] -- up to 7 bits 0xxxxxxx
      $ n .&. complement 0x7f == 0

-- | Parse a byte sequence in UTF-8 format into a character
decode :: (Monad m) => ParserT Word8 m Char
decode = toEnum <$> (one <|> two <|> three <|> four)
 where
  one = mask 0x80
  two = do
    w0 <- mask 0xe0
    guard $ w0 .&. 0x1e /= 0 -- bits [8..11] /= 0
    w1 <- next
    pure $ ((w0 .&. 0x1f) `shiftL` 6) .|. w1
  three = do
    w0 <- mask 0xf0
    w1 <- next
    guard $ w0 .&. 0x0f /= 0 || w1 .&. 0x20 /= 0 -- bits [12..16] /= 0
    w2 <- next
    let n = ((w0 .&. 0x0f) `shiftL` 12) .|. (w1 `shiftL` 6) .|. w2
    pure . bool n 0xfffd $ -- decode into replacement character U+FFFD for
      (n .&. complement 0x7ff == 0xd800) -- surrogates U+D800..U+DFFF
        || (n .&. complement 0x1 == 0xfffe) -- noncharacters U+FFFE and U+FFFF
  four = do
    w0 <- mask 0xf8
    w1 <- next
    guard $ w0 .&. 0x07 /= 0 || w1 .&. 0x30 /= 0 -- bits [17..21] /= 0
    w2 <- next
    w3 <- next
    pure $
      ((w0 .&. 0x07) `shiftL` 18)
        .|. (w1 `shiftL` 12)
        .|. (w2 `shiftL` 6)
        .|. w3
  mask m = fromEnum <$> sat (\w -> w .&. m == m `shiftL` 1)
  next = (.&. 0x3f) <$> mask 0xc0