module Data.Text.Glyphize.Buffer where

import Data.Text.Lazy as Lazy
import Data.ByteString.Lazy as Lazy
import Data.ByteString.Lazy as LBS
import Data.Text.Short

import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.C.Types
import Data.Word
import System.IO.Unsafe (unsafePerformIO)

import Data.Text.Lazy.Encoding
import Data.ByteString.Lazy.Internal as Lazy
import Data.ByteString.Internal as Strict
import Data.ByteString.Short.Internal as Strict
import Data.Bits ((.|.))
import Data.Char (ord)

data Buffer = Buffer {
    text :: Either Lazy.Text Lazy.ByteString,
    -- ^ The Unicode text, in visual order, for HarfBuzz to convert into glyphs.
    contentType :: Maybe ContentType,
    -- ^ What the bytes of the ByteString contents represents,
    -- namely unicode characters (before shaping) or glyphs (result of shaping).
    -- Typically callers should leave this as `Just ContentTypeUnicode`.
    direction :: Maybe Direction,
    -- ^ The text flow direction of the buffer.
    -- No shaping can happen without setting buffer direction, and it controls
    -- the visual direction for the output glyphs; for RTL direction the glyphs
    -- will be reversed. Many layout features depend on the proper setting of
    -- the direction, for example, reversing RTL text before shaping,
    -- then shaping with LTR direction is not the same as keeping the text in
    -- logical order and shaping with RTL direction.
    script :: Maybe ShortText,
    -- ^ Script is crucial for choosing the proper shaping behaviour for scripts
    -- that require it (e.g. Arabic) and the which OpenType features defined in
    -- the font to be applied.
    language :: Maybe ShortText,
    -- ^ Languages are crucial for selecting which OpenType feature to apply to
    -- the buffer which can result in applying language-specific behaviour.
    -- Languages are orthogonal to the scripts, and though they are related,
    -- they are different concepts and should not be confused with each other.
    beginsText :: Bool,
    -- ^ special handling of the beginning of text paragraph can be applied to
    -- this buffer. Should usually be set, unless you are passing to the buffer
    -- only part of the text without the full context.
    endsText :: Bool,
    -- ^ special handling of the end of text paragraph can be applied to this buffer.
    preserveDefaultIgnorables :: Bool,
    -- ^ character with Default_Ignorable Unicode property should use the
    -- corresponding glyph from the font, instead of hiding them (done by
    -- replacing them with the space glyph and zeroing the advance width.)
    -- Takes precedance over `removeDefaultIgnorables`.
    removeDefaultIgnorables :: Bool,
    -- ^ character with Default_Ignorable Unicode property should be removed
    -- from glyph string instead of hiding them (done by replacing them with
    -- the space glyph and zeroing the advance width.)
    don'tInsertDottedCircle :: Bool,
    -- ^ a dotted circle should not be inserted in the rendering of incorrect
    -- character sequences (such at <0905 093E>).
    clusterLevel :: ClusterLevel,
    -- ^ dictates one aspect of how HarfBuzz will treat non-base characters
    -- during shaping.
    invisibleGlyph :: Int,
    -- ^ The glyph number that replaces invisible characters in the
    -- shaping result. If set to zero (default), the glyph for the U+0020
    -- SPACE character is used. Otherwise, this value is used verbatim.
    notFoundGlyph :: Int,
    -- ^ the glyph number that replaces characters not found in the font during shaping.
    -- The not-found glyph defaults to zero, sometimes knows as the ".notdef" glyph.
    -- This API allows for differentiating the two.
    replacementCodepoint :: Char
    -- ^ the hb_codepoint_t that replaces invalid entries for a given encoding
    -- when adding text to buffer .
}

-- | An empty buffer with sensible default properties.
defaultBuffer = Buffer {
        text = Right LBS.empty,
        contentType = Just ContentTypeUnicode,
        direction = Nothing,
        script = Nothing,
        language = Nothing,
        beginsText = True,
        endsText = True,
        preserveDefaultIgnorables = False,
        removeDefaultIgnorables = False,
        don'tInsertDottedCircle = False,
        clusterLevel = ClusterMonotoneGraphemes,
        invisibleGlyph = 0,
        notFoundGlyph = 0,
        replacementCodepoint = '\xFFFD'
    }

data ContentType = ContentTypeUnicode | ContentTypeGlyphs deriving (Eq, Show)
data Direction = DirLTR | DirRTL | DirTTB | DirBTT deriving (Eq, Show)
data ClusterLevel = ClusterMonotoneGraphemes | ClusterMonotoneChars | ClusterChars deriving (Eq, Show)

data GlyphInfo = GlyphInfo {
    codepoint :: Int,
    cluster :: Int
}
data GlyphPos = GlyphPos {
    x_advance :: Int, y_advance :: Int,
    x_offset :: Int, y_offset :: Int
}

-- guessSegmentProperties :: Buffer -> Buffer
-- glyphInfo & glyphPositions to be zipped & return from shape function
-- scriptHorizontalDir :: ShortText -> Direction

dirReverse DirLTR = DirRTL
dirReverse DirRTL = DirLTR
dirReverse DirTTB = DirBTT
dirReverse DirBTT = DirTTB
dirBackward dir = dir `Prelude.elem` [DirRTL, DirBTT]
dirForward dir = dir `Prelude.elem` [DirLTR, DirTTB]
dirHorizontal dir = dir `Prelude.elem` [DirLTR, DirRTL]
dirVertical dir = dir `Prelude.elem` [DirTTB, DirBTT]

---

type Buffer' = ForeignPtr Buffer''
data Buffer''

freeze = unsafePerformIO . freeze'
freeze' buf = do
    buffer <- hb_buffer_create
    case text buf of
        Right bs -> hb_buffer_add_bytestring buffer bs
        -- Convert text to bytestring for now due to the text 2.0 UTF-8 transition.
        -- Unfortunately this may prevent Harfbuzz from reading opening context
        -- So for correctness we'll eventually want to depend on text>2.0
        Left txt -> hb_buffer_add_bytestring buffer $ encodeUtf8 txt
    hb_buffer_set_content_type buffer $ case contentType buf of
        Nothing -> 0
        Just ContentTypeUnicode -> 1
        Just ContentTypeGlyphs -> 2
    hb_buffer_set_direction buffer $ case direction buf of
        Nothing -> 0
        Just DirLTR -> 4
        Just DirRTL -> 5
        Just DirTTB -> 6
        Just DirBTT -> 7
    case script buf of
        Just script' -> hb_buffer_set_script buffer =<< hb_script_from_txt script'
        Nothing -> return ()
    case language buf of
        Just lang' -> hb_buffer_set_language buffer =<< hb_language_from_txt lang'
        Nothing -> return ()
    hb_buffer_set_flags buffer $ Prelude.foldl (.|.) 0 [
        if beginsText buf then 1 else 0,
        if endsText buf then 2 else 0,
        if preserveDefaultIgnorables buf then 4 else 0,
        if removeDefaultIgnorables buf then 8 else 0,
        if don'tInsertDottedCircle buf then 16 else 0
      ]
    hb_buffer_set_cluster_level buffer $ case clusterLevel buf of
        ClusterMonotoneGraphemes -> 0
        ClusterMonotoneChars -> 1
        ClusterChars -> 2
    hb_buffer_set_invisible_glyph buffer $ invisibleGlyph buf
    hb_buffer_set_not_found_glyph buffer $ notFoundGlyph buf
    hb_buffer_set_replacement_codepoint buffer $ ord $ replacementCodepoint buf
    case (contentType buf, direction buf, script buf, language buf) of
        (Just ContentTypeUnicode, Nothing, _, _) -> hb_buffer_guess_segment_properties buffer
        (Just ContentTypeUnicode, _, Nothing, _) -> hb_buffer_guess_segment_properties buffer
        (Just ContentTypeUnicode, _, _, Nothing) -> hb_buffer_guess_segment_properties buffer
    newForeignPtr hb_buffer_destroy buffer

thaw buf' = ()

foreign import ccall "hb_buffer_create" hb_buffer_create :: IO (Ptr Buffer'')
foreign import ccall "&hb_buffer_destroy" hb_buffer_destroy :: FunPtr (Ptr Buffer'' -> IO ())
foreign import ccall "hb_buffer_add_utf8" hb_buffer_add_utf8
    :: Ptr Buffer'' -> Ptr Word8 -> Int -> Int -> Int -> IO ()
hb_buffer_add_bytestring _ Lazy.Empty = return ()
hb_buffer_add_bytestring buf (Lazy.Chunk (Strict.PS ptr offset length) next) = do
    withForeignPtr ptr $ \ptr' -> hb_buffer_add_utf8 buf ptr' length offset (length - offset)
    hb_buffer_add_bytestring buf next
foreign import ccall "hb_buffer_set_content_type" hb_buffer_set_content_type
    :: Ptr Buffer'' -> Int -> IO ()
foreign import ccall "hb_buffer_set_direction" hb_buffer_set_direction
    :: Ptr Buffer'' -> Int -> IO ()
foreign import ccall "hb_script_from_string" hb_script_from_string
    :: Ptr Word8 -> Int -> Int
hb_script_from_txt txt = let Strict.PS ptr offset size = toByteString txt
    in withForeignPtr ptr $ \ptr' -> return $ hb_script_from_string ptr' size
foreign import ccall "hb_buffer_set_script" hb_buffer_set_script
    :: Ptr Buffer'' -> Int -> IO ()
foreign import ccall "hb_language_from_string" hb_language_from_string
    :: Ptr Word8 -> Int -> Int
hb_language_from_txt txt = let Strict.PS ptr offset size = toByteString txt
    in withForeignPtr ptr $ \ptr' -> return $ hb_script_from_string ptr' size
foreign import ccall "hb_buffer_set_language" hb_buffer_set_language
    :: Ptr Buffer'' -> Int -> IO ()
foreign import ccall "hb_buffer_set_flags" hb_buffer_set_flags :: Ptr Buffer'' -> Int -> IO ()
foreign import ccall "hb_buffer_set_cluster_level" hb_buffer_set_cluster_level
    :: Ptr Buffer'' -> Int -> IO ()
foreign import ccall "hb_buffer_set_invisible_glyph" hb_buffer_set_invisible_glyph
    :: Ptr Buffer'' -> Int -> IO ()
foreign import ccall "hb_buffer_set_not_found_glyph" hb_buffer_set_not_found_glyph
    :: Ptr Buffer'' -> Int -> IO ()
foreign import ccall "hb_buffer_set_replacement_codepoint" hb_buffer_set_replacement_codepoint
    :: Ptr Buffer'' -> Int -> IO ()
foreign import ccall "hb_buffer_guess_segment_properties" hb_buffer_guess_segment_properties
    :: Ptr Buffer'' -> IO ()