{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TupleSections       #-}

-- |
-- Module      : Script to parse Unicode XML database and convert
--               it to Haskell data structures
--
-- Copyright   : (c) 2014–2015 Antonio Nikishaev
--               (c) 2016-2017 Harendra Kumar
--
-- License     : BSD-style
-- Maintainer  : harendra.kumar@gmail.com
-- Stability   : experimental
--
--
module Main where

import           Prelude hiding (pred)
import           Control.DeepSeq      (NFData (..), deepseq)
import           Control.Exception
import           Data.Binary          as Bin
import qualified Data.ByteString.Lazy as L
import           Data.Char            (chr)
import           Data.Char            (ord)
import           Data.Map             ((!))
import qualified Data.Map             as M
import           Data.Monoid          ((<>))
import qualified Data.Set             as S
import           GHC.Generics         (Generic)
import           System.FilePath      ((-<.>))
import           Text.HTML.TagSoup    (Tag (..), parseTags)
import           WithCli              (withCli)

import           Data.Unicode.Properties.DecomposeHangul (isHangul)

data GeneralCategory =
    Lu|Ll|Lt|             --LC
    Lm|Lo|                --L
    Mn|Mc|Me|             --M
    Nd|Nl|No|             --N
    Pc|Pd|Ps|Pe|Pi|Pf|Po| --P
    Sm|Sc|Sk|So|          --S
    Zs|Zl|Zp|             --Z
    Cc|Cf|Cs|Co|Cn        --C
    deriving (Show, Read, Generic, NFData, Binary)

data DecompType =
       DTCanonical | DTCompat  | DTFont
     | DTNoBreak   | DTInitial | DTMedial   | DTFinal
     | DTIsolated  | DTCircle  | DTSuper    | DTSub
     | DTVertical  | DTWide    | DTNarrow
     | DTSmall     | DTSquare  | DTFraction
    deriving (Show,Eq,Generic, NFData, Binary)

data Decomp = DCSelf | DC [Char] deriving (Show,Eq,Generic, NFData, Binary)
data QCValue = QCYes | QCNo | QCMaybe deriving (Show,Generic, NFData, Binary)

data CharProps = CharProps {
      _name                       :: String,
      _generalCategory            :: GeneralCategory,
      _upper                      :: Bool,
      _lower                      :: Bool,
      _otherUpper                 :: Bool,
      _otherLower                 :: Bool,
      _nfc_qc                     :: QCValue,
      _nfd_qc                     :: Bool,
      _nfkc_qc                    :: QCValue,
      _nfkd_qc                    :: Bool,
      _combiningClass             :: Int,
      _dash                       :: Bool,
      _hyphen                     :: Bool,
      _quotationMark              :: Bool,
      _terminalPunctuation        :: Bool,
      _diactric                   :: Bool,
      _extender                   :: Bool,
      _decomposition              :: Decomp,
      _decompositionType          :: Maybe DecompType,
      _fullDecompositionExclusion :: Bool
} deriving (Show,Generic, NFData, Binary)

-------------------------------------------------------------------------------
-- Generate data structures for decompositions
-------------------------------------------------------------------------------

genSignature :: String -> String
genSignature testBit = testBit <> " :: Char -> Bool"

genRangeCheck :: String -> [Int] -> String
genRangeCheck testBit ordList =
      testBit <> " c | (ord c) < "
      <> show (minimum ordList) <> " || (ord c) > "
      <> show (maximum ordList) <> " = False"

genMinMax :: String -> [Int] -> String
genMinMax prefix ordList = unlines
    [ ""
    , prefix <> "Min, " <> prefix <> "Max :: Int"
    , prefix <> "Min = " <> show (minimum ordList)
    , prefix <> "Max = " <> show (maximum ordList)
    ]

genBitmap :: String -> [Int] -> String
genBitmap prefix ordList =
  -- On ARM, compilation fails with llvm optimizer crashing when one big list
  -- is used. Split it into two to avoid the problem.
  let l  = length ordList
      mn = minimum ordList
      mx = maximum ordList
      (ordList1, ordList2) = splitAt (div l 2) ordList
  in  unlines
    [ "bitList1, bitList2 :: [Int]"
    , "bitList1 = " ++ show ordList1
    , "bitList2 = " ++ show ordList2
    , ""
    , prefix <> "Bitmap :: BitArray"
    , prefix <> "Bitmap = bitArraySetBits "
      ++ (show (mn, mx))
      ++ " $ bitList1 ++ bitList2"
    ]

genCombiningClass :: PropertiesDB -> String -> String
genCombiningClass props file = unlines
            [ "-- autogenerated from Unicode data"
            , "module Data.Unicode.Properties." <> file
            , "(getCombiningClass, isCombining)"
            , "where"
            , ""
            , "import Data.Char (ord)"
            , "import Data.BitArray (BitArray, lookupBit)"
            , "import Data.Unicode.Properties.BitArray (bitArraySetBits)"
            , ""
            , "getCombiningClass :: Char -> Int"
            , concat $ map genCombiningClassDef ccmap
            , "getCombiningClass _ = 0\n"
            , ""
            , "{-# INLINE isCombining #-}"
            , genSignature  "isCombining"
            , genRangeCheck "isCombining" ordList
            , "isCombining c = lookupBit combiningBitmap (ord c)"
            , genBitmap "combining" ordList
            ]
    where
        genCombiningClassDef (c, d) =
            "getCombiningClass " <> show c <> " = " <> show d <> "\n"

        ccmap = (filter (\(_,cc) -> cc /= 0)
                 . map (\(c,prop) -> (c, _combiningClass prop))) props

        ordList = map (ord . fst) ccmap

data DType = Canonical | Kompat

decompositions :: DType -> PropertiesDB -> [(Char, [Char])]
decompositions dtype =
      map    (\(c, prop) -> (c, decomposeChar c (_decomposition prop)))
    . filter (predicate   . _decompositionType . snd)
    . filter ((/= DCSelf) . _decomposition . snd)
    where predicate = case dtype of
              Canonical -> (== Just DTCanonical)
              Kompat    -> (const True)

genDecomposable :: DType -> PropertiesDB -> String -> String
genDecomposable dtype props file = unlines
            [ "-- autogenerated from Unicode data"
            , "module Data.Unicode.Properties." <> file
            , "(decomposeBitmap, decomposeMax, decomposeMin)"
            , "where"
            , ""
            , "import Data.BitArray (BitArray)"
            , "import Data.Unicode.Properties.BitArray (bitArraySetBits)"
            , ""
            , genMinMax "decompose" ordList
            , genBitmap "decompose" ordList
            ]
    where
        chrList = filter (not . isHangul)
                         (map fst (decompositions dtype props))
        ordList = map ord chrList

decomposeChar :: Char -> Decomp -> [Char]
decomposeChar c DCSelf   = [c]
decomposeChar _c (DC ds) = ds

genDecomposeModuleHdr :: String -> String
genDecomposeModuleHdr file = unlines
    [ "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
    , "-- autogenerated from Unicode data"
    , "module Data.Unicode.Properties." <> file
    , "(decomposeChar)"
    , "where"
    ]

genDecomposeSign :: String
genDecomposeSign = unlines
    [ ""
    , "-- Note: this is a partial function we do not expect to call"
    , "-- this if isDecomposable returns false."
    , "{-# NOINLINE decomposeChar #-}"
    , "decomposeChar :: Char -> [Char]"
    ]

genDecomposeDefs :: DType -> PropertiesDB -> (Int -> Bool) -> String
genDecomposeDefs dtype props pred =
    concat $ map (genDecomposeDef "decomposeChar") decomps
    where
        decomps =
              filter (pred . ord . fst)
            . filter (not . isHangul . fst)
            $ (decompositions dtype props)
        genDecomposeDef name (c, d) =
            name <> " " <> show c <> " = " <> show d <> "\n"

genDecompositions :: PropertiesDB -> String -> String
genDecompositions props file = unlines
            [ genDecomposeModuleHdr file
            , genDecomposeSign
            , genDecomposeDefs Canonical props (const True)
            ]

-- Compatibility decompositions are split in two parts to keep the file sizes
-- short enough
genDecompositionsK :: PropertiesDB -> String -> String
genDecompositionsK props file = unlines
            [ genDecomposeModuleHdr file
            , "import qualified Data.Unicode.Properties.DecompositionsK2 as DK2"
            , genDecomposeSign
            , genDecomposeDefs Kompat props (< 60000)
            , "decomposeChar c = DK2.decomposeChar c"
            ]

genDecompositionsK2 :: PropertiesDB -> String -> String
genDecompositionsK2 props file = unlines
            [ genDecomposeModuleHdr file
            , genDecomposeSign
            , genDecomposeDefs Kompat props (>= 60000)
            ]

-------------------------------------------------------------------------------
-- Generate data structures for compositions
-------------------------------------------------------------------------------

genCompositions :: PropertiesDB -> String -> String
genCompositions props file = unlines
            [ "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
            , "-- autogenerated from Unicode data"
            , "module Data.Unicode.Properties." <> file
            , "(composePair)"
            , "where"
            , ""
            , "{-# NOINLINE composePair #-}"
            , "composePair :: Char -> Char -> Maybe Char"
            , concat $ map (genComposePair "composePair") decomps
            , "composePair _ _ = " <> "Nothing" <> "\n"
            ]
    where
        genComposePair name (c, [d1, d2]) =
            name <> " " <> show d1 <> " " <> show d2 <> " = Just " <> show c <> "\n"
        genComposePair _ _ = error "Bug: decomp length is not 2"

        decomps =   filter ((flip S.notMember) exclusions . fst)
                  . filter (not . isHangul . fst)
                  . filter ((== 2) . length . snd)
                  $ (decompositions Canonical props)

        exclusions =  S.fromList
                    . map fst
                    . filter (_fullDecompositionExclusion . snd) $ props

-------------------------------------------------------------------------------
-- Create and read binary properties data
-------------------------------------------------------------------------------

readSavedProps :: FilePath -> IO [(Char, CharProps)]
readSavedProps file = Bin.decode <$> L.readFile file

writeBinary :: Binary a => FilePath -> a -> IO ()
writeBinary file props = do
  L.writeFile file (Bin.encode props)

type PropertiesDB = [(Char,CharProps)]

readQCValue :: String -> QCValue
readQCValue "Y" = QCYes
readQCValue "N" = QCNo
readQCValue "M" = QCMaybe
readQCValue x = error $ "Unknown QCValue: " ++ show x

readYN :: String -> Bool
readYN "Y" = True
readYN "N" = False
readYN x = error $ "Unknown YNValue: " ++ show x

readCodePoint :: String -> Char
readCodePoint = chr . read . ("0x"++)

readDecomp :: String -> Decomp
readDecomp "#" = DCSelf
readDecomp s   = DC . map readCodePoint $ words s

readDecompType :: String -> Maybe DecompType
readDecompType "none" = Nothing
readDecompType s      = Just (dtmap!s)
    where
        dtmap = M.fromList
            [
              ("can"       , DTCanonical)
            , ("com"       , DTCompat   )
            , ("enc"       , DTCircle   )
            , ("fin"       , DTFinal    )
            , ("font"      , DTFont     )
            , ("fra"       , DTFraction )
            , ("init"      , DTInitial  )
            , ("iso"       , DTIsolated )
            , ("med"       , DTMedial   )
            , ("nar"       , DTNarrow   )
            , ("nb"        , DTNoBreak  )
            , ("sml"       , DTSmall    )
            , ("sqr"       , DTSquare   )
            , ("sub"       , DTSub      )
            , ("sup"       , DTSuper    )
            , ("vert"      , DTVertical )
            , ("wide"      , DTWide     )
            ]

toProp :: Tag String -> PropertiesDB
toProp (TagOpen _ psml) = [ (c, CharProps{..}) | c <- cps ]
    where
        psm = M.fromList psml
        cps = let readCP = (fmap readCodePoint . (`M.lookup` psm))
              in case readCP <$> ["cp", "first-cp", "last-cp"] of
                [Just c , Nothing, Nothing] -> [c]
                [Nothing, Just c1, Just c2] -> [c1..c2]
                _                           -> undefined

        _name                       =                  psm!"na"
        _generalCategory            = read           $ psm!"gc"
        _nfd_qc                     = readYN         $ psm!"NFD_QC"
        _nfkd_qc                    = readYN         $ psm!"NFKD_QC"
        _nfc_qc                     = readQCValue    $ psm!"NFC_QC"
        _nfkc_qc                    = readQCValue    $ psm!"NFKC_QC"
        _upper                      = readYN         $ psm!"Upper"
        _otherUpper                 = readYN         $ psm!"OUpper"
        _lower                      = readYN         $ psm!"Lower"
        _otherLower                 = readYN         $ psm!"OLower"
        _combiningClass             = read           $ psm!"ccc"
        _dash                       = readYN         $ psm!"Dash"
        _hyphen                     = readYN         $ psm!"Hyphen"
        _quotationMark              = readYN         $ psm!"QMark"
        _terminalPunctuation        = readYN         $ psm!"Term"
        _diactric                   = readYN         $ psm!"Dia"
        _extender                   = readYN         $ psm!"Ext"
        _decomposition              = readDecomp     $ psm!"dm"
        _decompositionType          = readDecompType $ psm!"dt"
        _fullDecompositionExclusion = readYN         $ psm!"Comp_Ex"
toProp _ = undefined

-- | Extract char properties from UCD XML file
xmlToProps :: FilePath -> FilePath -> IO [(Char, CharProps)]
xmlToProps src dst = do
  input <- readFile src
  let props = concatMap toProp (filter isChar $ parseTags input)
              :: [(Char,CharProps)]
  props `deepseq` writeBinary dst props
  return props

  where isChar (TagOpen "char" _) = True
        isChar _                  = False

-- | Convert the unicode data file (ucd.all.flat.xml) to Haskell data
-- structures
processFile :: FilePath -> FilePath -> IO ()
processFile src outdir = do
    props <- (readSavedProps dst
              `catch` \(_e::IOException) -> xmlToProps src dst)
    -- print $ length props
    emitFile "Decomposable"    $ genDecomposable   Canonical props
    emitFile "DecomposableK"   $ genDecomposable   Kompat    props

    emitFile "Decompositions"   $ genDecompositions props
    emitFile "DecompositionsK"  $ genDecompositionsK props
    emitFile "DecompositionsK2" $ genDecompositionsK2 props

    emitFile "Compositions"    $ genCompositions   props
    emitFile "CombiningClass"  $ genCombiningClass props

    where
        -- properties db file
        dst = src -<.> ".pdb"
        emitFile name gen =
            writeFile (outdir <> "/" <> name <> ".hs") $ gen name

main :: IO ()
main = withCli processFile
