{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}
module Elm.String
  ( String
  , toChars
  , toBuilder
  , Chunk(..)
  , fromChunks
  )
  where


import Prelude hiding (String)
import Data.Binary (Binary, get, put)
import Data.Bits ((.&.), shiftR)
import qualified Data.ByteString.Builder as B
import qualified Data.Utf8 as Utf8
import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
import GHC.Exts (RealWorld, Ptr)
import GHC.IO (stToIO, unsafeDupablePerformIO)
import GHC.ST (ST)
import GHC.Word (Word8)



-- STRINGS


type String =
  Utf8.Utf8 ELM_STRING


data ELM_STRING



-- HELPERS


toChars :: String -> [Char]
toChars =
  Utf8.toChars


{-# INLINE toBuilder #-}
toBuilder :: String -> B.Builder
toBuilder =
  Utf8.toBuilder



-- FROM CHUNKS


data Chunk
  = Slice (Ptr Word8) Int
  | Escape Word8
  | CodePoint Int


fromChunks :: [Chunk] -> String
fromChunks chunks =
  unsafeDupablePerformIO (stToIO (
    do  let !len = sum (map chunkToWidth chunks)
        mba <- newByteArray len
        writeChunks mba 0 chunks
        freeze mba
  ))


chunkToWidth :: Chunk -> Int
chunkToWidth chunk =
  case chunk of
    Slice _ len -> len
    Escape _    -> 2
    CodePoint c -> if c < 0xFFFF then 6 else 12


writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
writeChunks mba offset chunks =
  case chunks of
    [] ->
      return ()

    chunk : chunks ->
      case chunk of
        Slice ptr len ->
          do  copyFromPtr ptr mba offset len
              let !newOffset = offset + len
              writeChunks mba newOffset chunks

        Escape word ->
          do  writeWord8 mba offset 0x5C {- \ -}
              writeWord8 mba (offset + 1) word
              let !newOffset = offset + 2
              writeChunks mba newOffset chunks

        CodePoint code ->
          if code < 0xFFFF then
            do  writeCode mba offset code
                let !newOffset = offset + 6
                writeChunks mba newOffset chunks
          else
            do  let (hi,lo) = divMod (code - 0x10000) 0x400
                writeCode mba (offset    ) (hi + 0xD800)
                writeCode mba (offset + 6) (lo + 0xDC00)
                let !newOffset = offset + 12
                writeChunks mba newOffset chunks


writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
writeCode mba offset code =
  do  writeWord8 mba offset 0x5C {- \ -}
      writeWord8 mba (offset + 1) 0x75 {- u -}
      writeHex mba (offset + 2) (shiftR code 12)
      writeHex mba (offset + 3) (shiftR code 8)
      writeHex mba (offset + 4) (shiftR code 4)
      writeHex mba (offset + 5) code


writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
writeHex mba !offset !bits =
  do  let !n = fromIntegral bits .&. 0x0F
      writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)



-- BINARY


instance Binary (Utf8.Utf8 ELM_STRING) where
  get = Utf8.getVeryLong
  put = Utf8.putVeryLong