{- |
Copyright : (c) 2024 Pierre Le Marre
Maintainer: dev@wismill.eu
Stability   : experimental

Parser for [UnicodeData.txt](https://www.unicode.org/reports/tr44/#UnicodeData.txt).

@since 0.1.0
-}
module UCD.Parser.UnicodeData (
  GeneralCategory (..),
  DecompositionType (..),
  Decomposition (..),
  Entry (..),
  NumericValue (..),
  CharDetails (..),
  parse,
) where

import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as B8
import Data.ByteString.Short qualified as BS
import Data.List qualified as L
import Data.Ratio ((%))
import Data.Word (Word8)
import UCD.Parser.Common (
  UnicodeRange (..),
  readCodePoint,
  readCodePointM,
  pattern Comma,
  pattern NewLine,
  pattern SemiColon,
  pattern Slash,
 )

-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------

{- | See: https://www.unicode.org/reports/tr44/#General_Category

@since 0.1.0
-}
data GeneralCategory
  = -- | Letter, Uppercase
    Lu
  | -- | Letter, Lowercase
    Ll
  | -- | Letter, Titlecase
    Lt
  | -- | Letter, Modifier
    Lm
  | -- | Letter, Other
    Lo
  | -- | Mark, Non-Spacing
    Mn
  | -- | Mark, Spacing Combining
    Mc
  | -- | Mark, Enclosing
    Me
  | -- | Number, Decimal
    Nd
  | -- | Number, Letter
    Nl
  | -- | Number, Other
    No
  | -- | Punctuation, Connector
    Pc
  | -- | Punctuation, Dash
    Pd
  | -- | Punctuation, Open
    Ps
  | -- | Punctuation, Close
    Pe
  | -- | Punctuation, Initial quote
    Pi
  | -- | Punctuation, Final quote
    Pf
  | -- | Punctuation, Other
    Po
  | -- | Symbol, Math
    Sm
  | -- | Symbol, Currency
    Sc
  | -- | Symbol, Modifier
    Sk
  | -- | Symbol, Other
    So
  | -- | Separator, Space
    Zs
  | -- | Separator, Line
    Zl
  | -- | Separator, Paragraph
    Zp
  | -- | Other, Control
    Cc
  | -- | Other, Format
    Cf
  | -- | Other, Surrogate
    Cs
  | -- | Other, Private Use
    Co
  | -- | Other, Not Assigned
    Cn
  deriving (Bounded, Enum, Eq, Show, Read)

{- | See: https://www.unicode.org/reports/tr44/#Character_Decomposition_Mappings

@since 0.1.0
-}
data DecompositionType
  = DTCanonical
  | DTCompat
  | DTFont
  | DTNoBreak
  | DTInitial
  | DTMedial
  | DTFinal
  | DTIsolated
  | DTCircle
  | DTSuper
  | DTSub
  | DTVertical
  | DTWide
  | DTNarrow
  | DTSmall
  | DTSquare
  | DTFraction
  deriving (Show, Eq)

{- | Unicode decomposition of a code point

@since 0.1.0
-}
data Decomposition
  = Self
  | Decomposition !DecompositionType ![Char]
  deriving (Show, Eq)

{- | Numeric value of a code point, if relevant

@since 0.1.0
-}
data NumericValue
  = NotNumeric
  | Digit !Word8
  | Integer !Integer
  | Rational !Rational
  deriving (Eq, Show)

{- | Core characteristics of a Unicode code point

@since 0.1.0
-}
data CharDetails
  = CharDetails
  { _generalCategory ∷ !GeneralCategory
  , _combiningClass ∷ !Int
  , _decomposition ∷ !Decomposition
  , _numericValue ∷ !NumericValue
  , _simpleUpperCaseMapping ∷ !(Maybe Char)
  , _simpleLowerCaseMapping ∷ !(Maybe Char)
  , _simpleTitleCaseMapping ∷ !(Maybe Char)
  }
  deriving (Eq, Show)

{- | An entry in @UnicodeData.txt@.

@since 0.1.0
-}
data Entry = Entry
  { _range ∷ !(UnicodeRange BS.ShortByteString)
  , _details ∷ !CharDetails
  }
  deriving (Eq, Show)

--------------------------------------------------------------------------------
-- Parser
--------------------------------------------------------------------------------

newtype Name = Name BS.ShortByteString

data PendingUnicodeDataRange
  = NoRange
  | -- | A partial range for entry with a name as: @\<RANGE_IDENTIFIER, First\>@
    FirstCode !BS.ShortByteString !Char !CharDetails

data UnicodeDataAcc = UnicodeDataAcc !B.ByteString !PendingUnicodeDataRange

data RawEntry = Complete !Entry | Incomplete !PendingUnicodeDataRange

{- | Parser for [UnicodeData.txt file](https://www.unicode.org/reports/tr44/#UnicodeData.txt)

@since 0.1.0
-}
parse ∷ B.ByteString → [Entry]
parse = L.unfoldr go . (`UnicodeDataAcc` NoRange)
 where
  go ∷ UnicodeDataAcc → Maybe (Entry, UnicodeDataAcc)
  go (UnicodeDataAcc raw pending)
    | B.null raw = Nothing
    | otherwise = case B.span (/= NewLine) raw of
        (B8.strip → line, B.drop 1 → raw')
          | B.null line → go (UnicodeDataAcc raw' pending)
          | otherwise → case combine pending (parseDetailedChar line) of
              Complete dc → Just (dc, UnicodeDataAcc raw' NoRange)
              Incomplete pending' → go (UnicodeDataAcc raw' pending')

{- | Combine with previous line

A range requires 2 continuous entries with respective names:

* @\<RANGE_IDENTIFIER, First\>@
* @\<RANGE_IDENTIFIER, Last\>@

See: https://www.unicode.org/reports/tr44/#Name
-}
combine ∷ PendingUnicodeDataRange → (Char, Name, CharDetails) → RawEntry
combine = \case
  NoRange → \(ch, Name name, dc) → case BS.span (/= Comma) name of
    (charRange, suffix) | suffix == ", First>" → Incomplete (FirstCode charRange ch dc)
    _ → Complete (Entry (SingleChar ch) dc)
  FirstCode range1 ch1 dc1 → \(ch2, Name name, dc2) → case BS.span (/= Comma) name of
    (range2, suffix)
      | suffix == ", Last>" →
          if range1 == range2 && ch1 < ch2
            then Complete (Entry (CharRange ch1 ch2 (BS.drop 1 range1)) dc1)
            else error $ "Cannot create range: incompatible ranges" <> show (dc1, dc2)
    _ → error $ "Cannot create range: missing <range, Last> entry corresponding to: " <> show range1

-- | Parse a single entry of @UnicodeData.txt@
parseDetailedChar ∷ B.ByteString → (Char, Name, CharDetails)
parseDetailedChar line =
  ( readCodePoint codePoint
  , Name (BS.toShort name)
  , CharDetails
      { _generalCategory = read (B8.unpack gc)
      , _combiningClass = read (B8.unpack combining)
      , _decomposition = decomposition
      , _numericValue = numericValue
      , _simpleUpperCaseMapping = readCodePointM sUpper
      , _simpleLowerCaseMapping = readCodePointM sLower
      , _simpleTitleCaseMapping = readCodePointM sTitle
      }
  )
 where
  (codePoint, line1) = B.span (/= SemiColon) line
  (name, line2) = B.span (/= SemiColon) (B.tail line1)
  (gc, line3) = B.span (/= SemiColon) (B.tail line2)
  (combining, line4) = B.span (/= SemiColon) (B.tail line3)
  (__bidiClass, line5) = B.span (/= SemiColon) (B.tail line4) -- TODO
  (rawDecomposition, line6) = B.span (/= SemiColon) (B.tail line5)
  decomposition = parseDecomposition rawDecomposition
  (__decimal, line7) = B.span (/= SemiColon) (B.tail line6)
  (__digit, line8) = B.span (/= SemiColon) (B.tail line7)
  (numeric, line9) = B.span (/= SemiColon) (B.tail line8)
  numericValue = parseNumber numeric
  (__bidiMirrored, line10) = B.span (/= SemiColon) (B.tail line9) -- TODO
  (__uni1Name, line11) = B.span (/= SemiColon) (B.tail line10)
  (__iso, line12) = B.span (/= SemiColon) (B.tail line11)
  (sUpper, line13) = B.span (/= SemiColon) (B.tail line12)
  (sLower, line14) = B.span (/= SemiColon) (B.tail line13)
  sTitle = B.tail line14

-- | See: https://www.unicode.org/reports/tr44/#Decomposition_Type
parseDecomposition ∷ B.ByteString → Decomposition
parseDecomposition (B8.words → wrds)
  | null wrds = Self
  | otherwise = go wrds
 where
  go = \case
    [] → error ("parseDecomposition: invalid entry: " <> show wrds)
    ys@(x : xs) → case parseDecompositionType x of
      DTCanonical → Decomposition DTCanonical (readCodePoints ys)
      other → Decomposition other (readCodePoints xs)

  readCodePoints = map readCodePoint

  parseDecompositionType = \case
    "<compat>" → DTCompat
    "<circle>" → DTCircle
    "<final>" → DTFinal
    "<font>" → DTFont
    "<fraction>" → DTFraction
    "<initial>" → DTInitial
    "<isolated>" → DTIsolated
    "<medial>" → DTMedial
    "<narrow>" → DTNarrow
    "<noBreak>" → DTNoBreak
    "<small>" → DTSmall
    "<square>" → DTSquare
    "<sub>" → DTSub
    "<super>" → DTSuper
    "<vertical>" → DTVertical
    "<wide>" → DTWide
    _ → DTCanonical

-- | See: https://www.unicode.org/reports/tr44/#Numeric_Value
parseNumber ∷ B.ByteString → NumericValue
parseNumber raw
  | B.null raw = NotNumeric
  | B.elem Slash raw = case B.span (/= Slash) raw of
      (num, denum) → Rational (readB num % (readB . B.drop 1) denum)
       where
        readB = read . B8.unpack
  | otherwise = Integer (read (B8.unpack raw))

--------------------------------------------------------------------------------
-- Doctest
--------------------------------------------------------------------------------

-- TODO: add more examples and move to proper test suite

{- $
>>> parse "0000;<control>;Cc;0;BN;;;;;N;NULL;;;;"
[Entry {_range = SingleChar {_first = '\NUL'}, _details = CharDetails {_generalCategory = Cc, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}]

>>> parse "0041;LATIN CAPITAL LETTER A;Lu;0;L;;;;;N;;;;0061;"
[Entry {_range = SingleChar {_first = 'A'}, _details = CharDetails {_generalCategory = Lu, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Just 'a', _simpleTitleCaseMapping = Nothing}}]

>>> parse "00A8;DIAERESIS;Sk;0;ON;<compat> 0020 0308;;;;N;SPACING DIAERESIS;;;;"
[Entry {_range = SingleChar {_first = '\168'}, _details = CharDetails {_generalCategory = Sk, _combiningClass = 0, _decomposition = Decomposition DTCompat " \776", _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}]

>>> parse "1E8E;LATIN CAPITAL LETTER Y WITH DOT ABOVE;Lu;0;L;0059 0307;;;;N;;;;1E8F;"
[Entry {_range = SingleChar {_first = '\7822'}, _details = CharDetails {_generalCategory = Lu, _combiningClass = 0, _decomposition = Decomposition DTCanonical "Y\775", _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Just '\7823', _simpleTitleCaseMapping = Nothing}}]

>>> parse "320E;PARENTHESIZED HANGUL KIYEOK A;So;0;L;<compat> 0028 1100 1161 0029;;;;N;PARENTHESIZED HANGUL GA;;;;"
[Entry {_range = SingleChar {_first = '\12814'}, _details = CharDetails {_generalCategory = So, _combiningClass = 0, _decomposition = Decomposition DTCompat "(\4352\4449)", _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}]

>>> parse "FDFA;ARABIC LIGATURE SALLALLAHOU ALAYHE WASALLAM;Lo;0;AL;<isolated> 0635 0644 0649 0020 0627 0644 0644 0647 0020 0639 0644 064A 0647 0020 0648 0633 0644 0645;;;;N;ARABIC LETTER SALLALLAHOU ALAYHE WASALLAM;;;;"
[Entry {_range = SingleChar {_first = '\65018'}, _details = CharDetails {_generalCategory = Lo, _combiningClass = 0, _decomposition = Decomposition DTIsolated "\1589\1604\1609 \1575\1604\1604\1607 \1593\1604\1610\1607 \1608\1587\1604\1605", _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}]
-}

{- $
Consecutive single chars

>>> parse "1F34E;RED APPLE;So;0;ON;;;;;N;;;;;\n1F34F;GREEN APPLE;So;0;ON;;;;;N;;;;;"
[Entry {_range = SingleChar {_first = '\127822'}, _details = CharDetails {_generalCategory = So, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}},Entry {_range = SingleChar {_first = '\127823'}, _details = CharDetails {_generalCategory = So, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}]
-}

{- $
Consecutive ranges
>>> :{
parse "30000;<CJK Ideograph Extension G, First>;Lo;0;L;;;;;N;;;;;\n\
      \3134A;<CJK Ideograph Extension G, Last>;Lo;0;L;;;;;N;;;;;\n\
      \31350;<CJK Ideograph Extension H, First>;Lo;0;L;;;;;N;;;;;\n\
      \323AF;<CJK Ideograph Extension H, Last>;Lo;0;L;;;;;N;;;;;"
      ==
      [ Entry {_range = CharRange {_first = '\196608', _last = '\201546', _rangeName = "CJK Ideograph Extension G"}, _details = CharDetails {_generalCategory = Lo, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}
      , Entry {_range = CharRange {_first = '\201552', _last = '\205743', _rangeName = "CJK Ideograph Extension H"}, _details = CharDetails {_generalCategory = Lo, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}} ]
:}
True
-}

{- $
Range bewtween single chars

>>> vietnamese_alternate_reading_mark_nhay = Entry {_range = SingleChar {_first = '\94193'}, _details = CharDetails {_generalCategory = Mc, _combiningClass = 6, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}
>>> parse "16FF1;VIETNAMESE ALTERNATE READING MARK NHAY;Mc;6;L;;;;;N;;;;;" == [vietnamese_alternate_reading_mark_nhay]
True
>>> tangut_ideograph = Entry {_range = CharRange {_first = '\94208', _last = '\100343', _rangeName = "Tangut Ideograph"}, _details = CharDetails {_generalCategory = Lo, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}
>>> parse "17000;<Tangut Ideograph, First>;Lo;0;L;;;;;N;;;;;\n187F7;<Tangut Ideograph, Last>;Lo;0;L;;;;;N;;;;;" == [tangut_ideograph]
True
>>> tangut_component_001 = Entry {_range = SingleChar {_first = '\100352'}, _details = CharDetails {_generalCategory = Lo, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}
>>> parse "18800;TANGUT COMPONENT-001;Lo;0;L;;;;;N;;;;;" == [tangut_component_001]
True
>>> :{
parse "16FF1;VIETNAMESE ALTERNATE READING MARK NHAY;Mc;6;L;;;;;N;;;;;\n\
      \17000;<Tangut Ideograph, First>;Lo;0;L;;;;;N;;;;;\n\
      \187F7;<Tangut Ideograph, Last>;Lo;0;L;;;;;N;;;;;\n\
      \18800;TANGUT COMPONENT-001;Lo;0;L;;;;;N;;;;;"
      == [vietnamese_alternate_reading_mark_nhay, tangut_ideograph, tangut_component_001]
:}
True
-}

{- $
Multiple consecutive ranges

>>> :{
parse "2FA1D;CJK COMPATIBILITY IDEOGRAPH-2FA1D;Lo;0;L;2A600;;;;N;;;;;\n\
      \30000;<CJK Ideograph Extension G, First>;Lo;0;L;;;;;N;;;;;\n\
      \3134A;<CJK Ideograph Extension G, Last>;Lo;0;L;;;;;N;;;;;\n\
      \31350;<CJK Ideograph Extension H, First>;Lo;0;L;;;;;N;;;;;\n\
      \323AF;<CJK Ideograph Extension H, Last>;Lo;0;L;;;;;N;;;;;\n\
      \E0001;LANGUAGE TAG;Cf;0;BN;;;;;N;;;;;"
      ==
      [ Entry {_range = SingleChar {_first = '\195101'}, _details = CharDetails {_generalCategory = Lo, _combiningClass = 0, _decomposition = Decomposition DTCanonical "\173568", _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}
      , Entry {_range = CharRange {_first = '\196608', _last = '\201546', _rangeName = "CJK Ideograph Extension G"}, _details = CharDetails {_generalCategory = Lo, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}
      , Entry {_range = CharRange {_first = '\201552', _last = '\205743', _rangeName = "CJK Ideograph Extension H"}, _details = CharDetails {_generalCategory = Lo, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}}
      , Entry {_range = SingleChar {_first = '\917505'}, _details = CharDetails {_generalCategory = Cf, _combiningClass = 0, _decomposition = Self, _numericValue = NotNumeric, _simpleUpperCaseMapping = Nothing, _simpleLowerCaseMapping = Nothing, _simpleTitleCaseMapping = Nothing}} ]
:}
True
-}