{-# LANGUAGE LambdaCase #-}

-- |
-- Module      : Parser.Text
-- Copyright   : (c) 2021 Pierre Le Marre
--               (c) 2020 Composewell Technologies and Contributors
--               (c) 2016-2017 Harendra Kumar
--               (c) 2014-2015 Antonio Nikishaev
-- License     : Apache-2.0
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental

-- The original Unicode database parser was taken from
-- https://github.com/composewell/unicode-transforms but was completely
-- rewritten from scratch to parse from UCD text files instead of XML, only
-- some types remain the same. That code in turn was originally taken from
-- https://github.com/llelf/prose (Antonio Nikishaev) and heavily modified by
-- Harendra Kumar.
--
module Parser.Text
    ( genCoreModules
    , genNamesModules
    , genScriptsModules
    , genSecurityModules
    ) where

import Control.Applicative (Alternative(..))
import Control.Arrow ((&&&))
import Control.Exception (assert, catch, IOException)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Bifunctor (Bifunctor(..))
import Data.Bits (Bits(..))
import Data.Char (chr, ord, isAlphaNum, isAscii, isSpace, toUpper)
import Data.Foldable (foldl')
import Data.Function (on, (&))
import Data.Functor ((<&>))
import Data.List
    (dropWhileEnd, elemIndex, groupBy, intersperse, sort, sortBy, unfoldr)
import Data.Maybe (fromMaybe)
import Data.Ratio ((%))
import Data.Word (Word8, Word32)
import Numeric (showHex)
import Streamly.Data.Fold (Fold)
import Streamly.Prelude (IsStream, SerialT)
import System.FilePath ((</>))
import System.Directory (createDirectoryIfMissing)
import System.Environment (getEnv)
import System.IO.Unsafe (unsafePerformIO)

import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified GHC.Foreign as Foreign
import qualified GHC.IO.Encoding as Encoding
import qualified Streamly.Prelude as Stream
import qualified Streamly.Data.Fold as Fold
import qualified Streamly.Internal.Data.Fold as Fold
import qualified Streamly.Data.Unfold as Unfold
import qualified Streamly.FileSystem.Handle as Handle
import qualified System.IO as Sys
import qualified Streamly.Unicode.Stream as Unicode

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

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, Bounded, Enum, Read)

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

data Decomp = DCSelf | DC [Char] deriving (Show, Eq)

data DType = Canonical | Kompat

data DetailedChar =
    DetailedChar
        { _char :: Char
        , _name :: String
        , _generalCategory :: GeneralCategory
        , _combiningClass :: Int
        , _decompositionType :: Maybe DecompType
        , _decomposition :: Decomp
        , _simpleUpperCaseMapping :: Maybe Char
        , _simpleLowerCaseMapping :: Maybe Char
        , _simpleTitleCaseMapping :: Maybe Char
        }
    deriving (Show)

type CharRange = Either Char (Char, Char)
data CharRangeStream
    = SingleChar !Char
    | CharRange !Char !Char
    | Stop

-------------------------------------------------------------------------------
-- Helpers
-------------------------------------------------------------------------------

apacheLicense
    :: Word   -- ^ Copyright year
    -> String -- ^ Module name
    -> String
apacheLicense year modName =
    unlines
        [ "-- |"
        , "-- Module      : " <> modName
        , "-- Copyright   : (c) "
            <> show year
            <> " Composewell Technologies and Contributors"
        , "-- License     : Apache-2.0"
        , "-- Maintainer  : streamly@composewell.com"
        , "-- Stability   : experimental"
        ]

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

readCodePointM :: String -> Maybe Char
readCodePointM "" = Nothing
readCodePointM u  = Just (readCodePoint u)

parseCodePointRange :: String -> Either Char (Char, Char)
parseCodePointRange
    = (\(c1, c2) -> maybe (Left c1) (Right . (c1,)) c2)
    . bimap readCodePoint (readCodePointM . drop 2)
    . span (/= '.')

showPaddedHex :: Int -> String
showPaddedHex cp =
    let hex = showHex cp mempty
        padding = 4 - length hex
    in replicate padding '0' <> hex

showPaddedHeX :: Int -> String
showPaddedHeX = fmap toUpper . showPaddedHex

showHexCodepoint :: Char -> String
showHexCodepoint = showPaddedHex . ord

genSignature :: String -> String
genSignature = (<> " :: Char -> Bool")

-- | Check that var is between minimum and maximum of orderList
genRangeCheck :: String -> [Int] -> String
genRangeCheck var ordList =
    var
        <> " >= "
        <> show (minimum ordList)
        <> " && " <> var <> " <= " <> show (maximum ordList)

genBitmap :: String -> [Int] -> String
genBitmap funcName ordList =
    unlines
        [ "{-# INLINE " <> funcName <> " #-}"
        , genSignature funcName
        , funcName <> " = \\c -> let n = ord c in "
              <> genRangeCheck "n" ordList <> " && lookupBit64 bitmap# n"
        , "  where"
        , "    bitmap# = \"" <> bitMapToAddrLiteral (positionsToBitMap ordList) "\"#"
        ]

positionsToBitMap :: [Int] -> [Bool]
positionsToBitMap = go 0

    where

    go _ [] = []
    go i xxs@(x:xs)
        | i < x = False : go (i + 1) xxs
        | otherwise = True : go (i + 1) xs

bitMapToAddrLiteral
  :: [Bool]
  -- ^ Values to encode
  -> String
  -- ^ String to append
  -> String
bitMapToAddrLiteral bs cs = foldr encode cs (unfoldr mkChunks bs)

    where

    mkChunks :: [a] -> Maybe ([a], [a])
    mkChunks [] = Nothing
    mkChunks xs = Just $ splitAt 8 xs

    encode :: [Bool] -> String -> String
    encode chunk acc = '\\' : shows (toByte (padTo8 chunk)) acc

    padTo8 :: [Bool] -> [Bool]
    padTo8 xs
        | length xs >= 8 = xs
        | otherwise = xs ++ replicate (8 - length xs) False

    toByte :: [Bool] -> Int
    toByte xs = sum $ map (\i -> if xs !! i then 1 `shiftL` i else 0) [0..7]

genEnumBitmap
  :: forall a. (Bounded a, Enum a, Show a)
  => String
  -- ^ Function name
  -> a
  -- ^ Default value
  -> [a]
  -- ^ List of values to encode
  -> String
genEnumBitmap funcName def as = unlines
    [ "{-# INLINE " <> funcName <> " #-}"
    , funcName <> " :: Char -> Int"
    , funcName <> " c = let n = ord c in if n >= "
               <> show (length as)
               <> " then "
               <> show (fromEnum def)
               <> " else lookupIntN bitmap# n"
    , "  where"
    , "    bitmap# = \"" <> enumMapToAddrLiteral as "\"#"
    ]

{-| Encode a list of values as a byte map, using their 'Enum' instance.

__Note:__ 'Enum' instance must respect the following:

* @fromEnum minBound >= 0x00@
* @fromEnum maxBound <= 0xff@
-}
enumMapToAddrLiteral
  :: forall a. (Bounded a, Enum a, Show a)
  => [a]
  -- ^ Values to encode
  -> String
  -- ^ String to append
  -> String
enumMapToAddrLiteral xs cs = foldr go cs xs

    where

    go :: a -> String -> String
    go x acc = '\\' : shows (toWord8 x) acc

    toWord8 :: a -> Word8
    toWord8 a = let w = fromEnum a in if 0 <= w && w <= 0xff
        then fromIntegral w
        else error $ "Cannot convert to Word8: " <> show a

-- Encode Word32 to [Word8] little endian
word32ToWord8s :: Word32 -> [Word8]
word32ToWord8s n = (\k -> fromIntegral ((n `shiftR` k) .&. 0xff)) <$> [0,8..24]

-- This bit of code is duplicated but this duplication allows us to reduce 2
-- dependencies on the executable.

jamoLCount :: Int
jamoLCount = 19

jamoVCount :: Int
jamoVCount = 21

jamoTCount :: Int
jamoTCount = 28

hangulFirst :: Int
hangulFirst = 0xac00

hangulLast :: Int
hangulLast = hangulFirst + jamoLCount * jamoVCount * jamoTCount - 1

isHangul :: Char -> Bool
isHangul c = n >= hangulFirst && n <= hangulLast
    where n = ord c

-------------------------------------------------------------------------------
-- Parsers
-------------------------------------------------------------------------------

-- Make a valid Haskell constructor (in CamelCase) from an identifier.
mkHaskellConstructor :: String -> String
mkHaskellConstructor = reverse . fst . foldl' convert (mempty, True)
    where

    convert (acc, newWord) = \case
        -- Skip the following and start a new word
        ' ' -> (acc, True)
        '-' -> (acc, True)
        '_' -> (acc, True)
        -- Letter or number
        c   -> if isAscii c && isAlphaNum c
            then ( if newWord then toUpper c : acc else c : acc
                 , False)
            else error ("Unsupported character: " <> show c)

genBlocksModule
    :: Monad m
    => String
    -> Fold m BlockLine String
genBlocksModule moduleName = done <$> Fold.foldl' step initial
    where

    done (blocks, defs, ranges) = let ranges' = reverse ranges in unlines
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE CPP, MultiWayIf #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(Block(..), BlockDefinition(..), block, blockDefinition)"
        , "where"
        , ""
        , "#include \"MachDeps.h\""
        , ""
        , "import Data.Ix (Ix)"
        , "import GHC.Exts"
        , ""
        , "-- | Unicode [block](https://www.unicode.org/glossary/#block)."
        , "--"
        , "-- There is a total of " <> show (length blocks) <> " blocks."
        , "--"
        , "-- @since 0.3.1"
        , "data Block"
        , "    = " <> mconcat (intersperse "\n    | " (reverse blocks))
        , "    deriving (Enum, Bounded, Eq, Ord, Ix, Show)"
        , ""
        , "-- | Block definition: range and name."
        , "--"
        , "-- @since 0.3.1"
        , "data BlockDefinition = BlockDefinition"
        , "    { blockRange :: !(Int, Int) -- ^ Range"
        , "    , blockName :: !String -- ^ Name"
        , "    } deriving (Eq, Ord, Show)"
        , ""
        , "-- | Block definition"
        , "--"
        , "-- @since 0.3.1"
        , "blockDefinition :: Block -> BlockDefinition"
        , "blockDefinition b = case b of"
        , mconcat (reverse defs)
        , "-- | Character block, if defined."
        , "--"
        , "-- @since 0.3.1"
        , "block :: Char -> Maybe Int"
        , "block (C# c#) = getBlock 0# " <> shows (length ranges - 1) "#"
        , "    where"
        , "    -- [NOTE] Encoding"
        , "    -- A range is encoded as two LE Word32:"
        , "    -- • First one is the lower bound, where the higher 11 bits are the block"
        , "    --   index and the lower 21 bits are the codepoint."
        , "    -- • Second one is the upper bound, which correspond to the codepoint."
        , ""
        , "    cp# = int2Word# (ord# c#)"
        , ""
        , "    -- Binary search"
        , "    getBlock l# u# = if isTrue# (l# ># u#)"
        , "        then Nothing"
        , "        else"
        , "            let k# = l# +# uncheckedIShiftRL# (u# -# l#) 1#"
        , "                j# = k# `uncheckedIShiftL#` 1#"
        , "                cpL0# = getRawCodePoint# j#"
        , "                cpL# = cpL0# `and#` 0x1fffff## -- Mask for codepoint: [0..0x10fff]"
        , "                cpU# = getRawCodePoint# (j# +# 1#)"
        , "            in if isTrue# (cpU# `ltWord#` cp#)"
        , "                -- cp > upper bound"
        , "                then getBlock (k# +# 1#) u#"
        , "                -- check lower bound"
        , "                else if isTrue# (cp# `ltWord#` cpL#)"
        , "                    -- cp < lower bound"
        , "                    then getBlock l# (k# -# 1#)"
        , "                    -- cp in block: get block index"
        , "                    else let block# = cpL0# `uncheckedShiftRL#` 21#"
        , "                         in Just (I# (word2Int# block#))"
        , ""
        , "    getRawCodePoint# k# ="
        , "#ifdef WORDS_BIGENDIAN"
        , "#if MIN_VERSION_base(4,16,0)"
        , "        narrow32Word# (byteSwap32# (word32ToWord# (indexWord32OffAddr# ranges# k#)))"
        , "#else"
        , "        narrow32Word# (byteSwap32# (indexWord32OffAddr# ranges# k#))"
        , "#endif"
        , "#elif MIN_VERSION_base(4,16,0)"
        , "        word32ToWord# (indexWord32OffAddr# ranges# k#)"
        , "#else"
        , "        indexWord32OffAddr# ranges# k#"
        , "#endif"
        , ""
        , "    -- Encoded ranges"
        , "    ranges# = \"" <> enumMapToAddrLiteral (mkRanges ranges') "\"#"
        ]

    initial :: ([String], [String], [(Int, Int)])
    initial = (mempty, mempty, mempty)

    step (blocks, defs, ranges) (blockName, blockRange) =
        let blockID = mkHaskellConstructor blockName
        in ( mkBlockConstructor blockID blockName blockRange : blocks
           , mkBlockDef   blockID blockName blockRange : defs
           , blockRange : ranges )

    mkBlockConstructor blockID blockName (l, u) = mconcat
        [ blockID
        , " -- ^ @U+"
        , showPaddedHeX l
        , "..U+"
        , showPaddedHeX u
        , "@: "
        , blockName
        , "."
        ]

    mkBlockDef blockID blockName (l, u) = mconcat
        [ "    "
        , blockID
        , " -> BlockDefinition (0x"
        , showPaddedHex l
        , ", 0x"
        , showPaddedHex u
        , ") "
        , show blockName
        , "\n"
        ]

    -- [NOTE] Encoding: a range is encoded as two LE Word32:
    -- • First one is the lower bound, where the higher 11 bits are the block
    --   index and the lower 21 bits are the codepoint.
    -- • Second one is upper bound, which correspond to the codepoint.
    mkRanges :: [(Int, Int)] -> [Word8]
    mkRanges = foldMap (uncurry mkBlockRange) . zip [0..]
    mkBlockRange :: Word32 -> (Int, Int) -> [Word8]
    mkBlockRange idx (l, u) = encodeBound idx l <> encodeBound 0 u

    encodeBound :: Word32 -> Int -> [Word8]
    encodeBound idx n = word32ToWord8s ((idx `shiftL` 21) .|. fromIntegral n)

defaultScript :: String
defaultScript = "Unknown"

genScriptsModule
    :: Monad m
    => String
    -> PropertyValuesAliases
    -> Fold m ScriptLine String
genScriptsModule moduleName aliases =
    done <$> Fold.foldl' addRange mempty
    where

    done ranges =
        let scripts = Set.toList
                        (foldr addScript (Set.singleton defaultScript) ranges)
        in unlines
            [ apacheLicense 2022 moduleName
            , "{-# OPTIONS_HADDOCK hide #-}"
            , ""
            , "module " <> moduleName
            , "(Script(..), script, scriptDefinition)"
            , "where"
            , ""
            , "import Data.Char (ord)"
            , "import Data.Int (Int32)"
            , "import Data.Ix (Ix)"
            , "import GHC.Exts (Ptr(..))"
            , "import Unicode.Internal.Bits (lookupIntN)"
            , ""
            , "-- | Unicode [script](https://www.unicode.org/reports/tr24/)."
            , "--"
            , "-- The constructors descriptions are the original Unicode values"
            , "-- (short and long forms)."
            , "--"
            , "-- There is a total of " <> show (length scripts) <> " scripts."
            , "--"
            , "-- @since 0.1.0"
            , "data Script"
            , "  = " <> mkScripts scripts
            , "  deriving (Enum, Bounded, Eq, Ord, Ix, Show)"
            , ""
            , "-- | Script definition: list of corresponding characters."
            , "--"
            , "-- @since 0.1.0"
            , "scriptDefinition :: Script -> (Ptr Int32, Int)"
            , "scriptDefinition b = case b of"
            , mkScriptDefinitions ranges
            , "-- | Script of a character."
            , "--"
            , "-- @since 0.1.0"
            , if length scripts <= 0xff
                then mkCharScripts scripts ranges
                else error "Cannot encode scripts"
            , ""
            ]

    addRange :: [ScriptLine] -> ScriptLine -> [ScriptLine]
    addRange acc l@(script, r) = case acc of
        (script', r'):acc' -> if script == script'
            then case combineRanges r r' of
                Left  r'' -> (script, r'') : acc
                Right r'' -> (script, r'') : acc'
            else l : acc
        _ -> [l]

    combineRanges :: CharRange -> CharRange -> Either CharRange CharRange
    combineRanges r = case r of
        Left c1 -> \case
            Left c2 -> if c1 == succ c2
                then Right (Right (c2, c1))
                else Left r
            Right (c2, c3) -> if c1 == succ c3
                then Right (Right (c2, c1))
                else Left r
        Right (c1, c2) -> \case
            Left c3 -> if c1 == succ c3
                then Right (Right (c3, c2))
                else Left r
            Right (c3, c4) -> if c1 == succ c4
                then Right (Right (c3, c2))
                else Left r

    addScript :: ScriptLine -> Set.Set String -> Set.Set String
    addScript (script, _) = Set.insert script

    mkScripts :: [String] -> String
    mkScripts
        = mconcat
        . intersperse "\n  | "
        . fmap (\script -> mconcat
            [ mkHaskellConstructor script
            , " -- ^ "
            , case Map.lookup script aliasesMap of
                Just as -> mkAliases as
                Nothing -> error ("No abbreviation for script: " <> script)
            , ": @"
            , script
            , "@"
            ])

    -- Map: script long form → short forms
    aliasesMap :: Map.Map String [String]
    aliasesMap = Map.foldrWithKey
        (\abbr as -> Map.insert (head as) (abbr : tail as))
        mempty
        aliases
    mkAliases
        = mconcat
        . intersperse ", "
        . fmap (\abbr -> mconcat ["@", abbr, "@"])

    mkScriptDefinitions :: [ScriptLine] -> String
    mkScriptDefinitions
        = foldMap mkScriptDefinition
        . groupBy ((==) `on` fst)
        . reverse
        . addUnknownRanges

    addUnknownRanges :: [ScriptLine] -> [ScriptLine]
    addUnknownRanges ls =
        let addUnknown (acc, expected) (c, _) = case mkMissingRange expected c of
                Just r -> (,succ c) $ case acc of
                    r':acc' -> either (:acc) (:acc') (combineRanges r r')
                    _       -> [r]
                Nothing -> (acc, succ expected)
            addRest (acc@(r':acc'), expected) =
                let r = Right (expected, maxBound)
                in either (:acc) (:acc') (combineRanges r r')
            addRest _ = error "impossible"
            unknown = fmap (defaultScript,) . addRest $ foldl'
                addUnknown
                (mempty, '\0')
                (sort (foldMap (rangeToCharScripts id) ls))
        in unknown <> ls

    mkMissingRange :: Char -> Char -> Maybe CharRange
    mkMissingRange expected c
        | c == expected      = Nothing
        | c == succ expected = Just (Left expected)
        | otherwise          = Just (Right (expected, pred c))

    mkScriptDefinition :: [ScriptLine] -> String
    mkScriptDefinition ranges = mconcat
        [ "  "
        , mkHaskellConstructor (fst (head ranges))
        , " -> (Ptr \""
        , foldMap encodeRange ranges
        , "\"#, "
        , show (foldr (\r -> either (const (+1)) (const (+2)) (snd r)) 0 ranges :: Word)
        , ")\n"
        ]

    -- Encoding:
    -- • A single char is encoded as an LE Int32.
    -- • A range is encoded as two LE Int32 (first is lower bound, second is
    --   upper bound), which correspond to the codepoints with the 32th bit set.
    encodeRange :: ScriptLine -> String
    encodeRange (_, r) = case r of
        Left  c      -> encodeBytes (fromIntegral (ord c))
        Right (l, u) -> encodeBytes (setBit (fromIntegral (ord l)) 31)
                     <> encodeBytes (setBit (fromIntegral (ord u)) 31)
    encodeBytes = foldr addByte "" . word32ToWord8s
    addByte n acc = '\\' : shows n acc

    mkCharScripts :: [String] -> [ScriptLine] -> String
    mkCharScripts scripts scriptsRanges =
        let charScripts = sort (foldMap (rangeToCharScripts getScript) scriptsRanges)
            charScripts' = fst (foldl' addMissing (mempty, '\0') charScripts)
            addMissing (acc, expected) x@(c, script) = if expected < c
                then addMissing (def:acc, succ expected) x
                else (script:acc, succ c)
            def = getScript defaultScript
            getScript s = fromMaybe (error "script not found") (elemIndex s scripts)
        in genEnumBitmap "script" def (reverse charScripts')

    rangeToCharScripts :: (String -> b) -> ScriptLine -> [(Char, b)]
    rangeToCharScripts f (script, r) = case r of
        Left  cp     -> [(cp, f script)]
        Right (l, u) -> (, f script) <$> [l..u]

genScriptExtensionsModule
    :: Monad m
    => String
    -> PropertyValuesAliases
    -> ScriptExtensions
    -> Fold m ScriptLine String
genScriptExtensionsModule moduleName aliases extensions =
    done <$> Fold.foldl' processLine mempty

    where

    -- [NOTE] We rely on all the scripts having a short form

    -- Map: script → short form
    scriptsAbbr :: Map.Map String String
    scriptsAbbr =
        Map.foldrWithKey (\abbr as -> Map.insert (head as) abbr) mempty aliases
    getScriptAbbr :: String -> String
    getScriptAbbr = fromMaybe (error "script not found") . (scriptsAbbr Map.!?)

    -- All possible values: extensions + scripts
    extensionsSet :: Set.Set [String]
    extensionsSet = Set.fromList (Map.elems extensions)
                  <> Set.map pure (Map.keysSet aliases)
    extensionsList = sortBy
        (compare `on` fmap mkScript)
        (Set.toList extensionsSet)

    encodeExtensions :: [String] -> Int
    encodeExtensions e = fromMaybe
        (error ("extension not found: " <> show e))
        (elemIndex e extensionsList)

    encodedExtensions :: Map.Map [String] Int
    encodedExtensions =
        let l = length extensionsSet
        in if length extensionsSet > 0xff
            then error ("Too many script extensions: " <> show l)
            else Map.fromSet encodeExtensions extensionsSet

    processLine
        :: (Set.Set [String], Map.Map Char Int) -- used exts, encoded char exts
        -> ScriptLine
        -> (Set.Set [String], Map.Map Char Int)
    processLine acc (script, range) = case range of
        Left c         -> addChar script c acc
        Right (c1, c2) -> foldr (addChar script) acc [c1..c2]

    addChar
        :: String -- script
        -> Char   -- processed char
        -> (Set.Set [String], Map.Map Char Int)
        -> (Set.Set [String], Map.Map Char Int)
    addChar script c (extsAcc, charAcc) = case Map.lookup c extensions of
        -- Char has explicit extensions
        Just exts -> ( Set.insert exts extsAcc
                     , Map.insert c (encodedExtensions Map.! exts) charAcc)
        -- Char has no explicit extensions: use its script
        Nothing   ->
            let exts = [getScriptAbbr script]
            in ( Set.insert exts extsAcc
               , Map.insert c (encodedExtensions Map.! exts) charAcc)

    done (usedExts, exts) = unlines
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE OverloadedLists #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(scriptExtensions, decodeScriptExtensions)"
        , "where"
        , ""
        , "import Data.Char (ord)"
        , "import Data.List.NonEmpty (NonEmpty)"
        , "import Unicode.Internal.Char.Scripts (Script(..))"
        , "import Unicode.Internal.Bits (lookupIntN)"
        , ""
        , "-- | Useful to decode the output of 'scriptExtensions'."
        , "decodeScriptExtensions :: Int -> NonEmpty Script"
        , "decodeScriptExtensions = \\case" <> mkDecodeScriptExtensions usedExts
        , "    _   -> [" <> mkHaskellConstructor defaultScript <> "]"
        , ""
        , "-- | Script extensions of a character."
        , "--"
        , "-- @since 0.1.0"
        , genEnumBitmap "scriptExtensions" def (mkScriptExtensions exts)
        ]

    mkDecodeScriptExtensions :: Set.Set [String] -> String
    mkDecodeScriptExtensions
        = mkDecodeScriptExtensions'
        . Set.map (\exts -> (encodedExtensions Map.! exts, exts))
    mkDecodeScriptExtensions' = foldMap $ \(v, exts) -> mconcat
        [ "\n    "
        , show v
        , " -> ["
        , mconcat (intersperse ", " (mkScript <$> exts))
        , "]"
        ]
    mkScript :: String -> String
    mkScript = mkHaskellConstructor . head . (aliases Map.!)

    def :: Int
    def = encodedExtensions Map.! [getScriptAbbr defaultScript]

    mkScriptExtensions
        = reverse
        . snd
        . Map.foldlWithKey addCharExt ('\0', mempty)
    addCharExt (expected, acc) c v = if expected < c
        then addCharExt (succ expected, def : acc) c v
        else (succ c, v : acc)

-------------------------------------------------------------------------------
-- Parsing UnicodeData.txt
-------------------------------------------------------------------------------

genGeneralCategoryModule
    :: Monad m
    => String
    -> Fold m DetailedChar String
genGeneralCategoryModule moduleName =
    done <$> Fold.foldl' step initial

    where

    -- (categories, expected char)
    initial = ([], '\0')

    step (acc, p) a = if p < _char a
        -- Fill missing char entry with default category Cn
        -- See: https://www.unicode.org/reports/tr44/#Default_Values_Table
        then step (Cn : acc, succ p) a
        -- Regular entry
        else (_generalCategory a : acc, succ (_char a))

    done (acc, _) = unlines
        [ apacheLicense 2020 moduleName
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(generalCategory)"
        , "where"
        , ""
        , "import Data.Char (ord)"
        , "import Unicode.Internal.Bits (lookupIntN)"
        , ""
        , genEnumBitmap "generalCategory" Cn (reverse acc)
        ]

readDecomp :: String -> (Maybe DecompType, Decomp)
readDecomp s =
    if null wrds
    then (Nothing, DCSelf)
    else decmps wrds

    where

    decmps [] = error "Unreachable flow point"
    decmps y@(x:xs) =
        case dtmap x of
            DTCanonical -> (,) (Just DTCanonical) (readCP y)
            other -> (,) (Just other) (readCP xs)

    wrds = words s

    readCP ws = DC $ map readCodePoint ws

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

filterNonHangul :: Monad m => Fold m DetailedChar a -> Fold m DetailedChar a
filterNonHangul = Fold.filter (not . isHangul . _char)

filterDecomposableType ::
       Monad m => DType -> Fold m DetailedChar a -> Fold m DetailedChar a
filterDecomposableType dtype =
    Fold.filter ((/= DCSelf) . _decomposition)
        . Fold.filter (predicate . _decompositionType)

    where

    predicate =
        case dtype of
            Canonical -> (== Just DTCanonical)
            Kompat -> const True

genDecomposableModule ::
       Monad m => String -> DType -> Fold m DetailedChar String
genDecomposableModule moduleName dtype =
    filterNonHangul
        $ filterDecomposableType dtype $ done <$> Fold.foldl' step initial

    where

    initial = []

    step st a = ord (_char a) : st

    done st =
        unlines
            [ apacheLicense 2020 moduleName
            , "{-# OPTIONS_HADDOCK hide #-}"
            , ""
            , "module " <> moduleName
            , "(isDecomposable)"
            , "where"
            , ""
            , "import Data.Char (ord)"
            , "import Unicode.Internal.Bits (lookupBit64)"
            , ""
            , genBitmap "isDecomposable" (reverse st)
            ]

genCombiningClassModule :: Monad m => String -> Fold m DetailedChar String
genCombiningClassModule moduleName =
    Fold.filter (\dc -> _combiningClass dc /= 0)
        $ done <$> Fold.foldl' step initial

    where

    initial = ([], [])

    step (st1, st2) a = (genCombiningClassDef a : st1, ord (_char a) : st2)

    done (st1, st2) =
        unlines
            [ apacheLicense 2020 moduleName
            , "{-# LANGUAGE LambdaCase #-}"
            , "{-# OPTIONS_HADDOCK hide #-}"
            , "module " <> moduleName
            , "(combiningClass, isCombining)"
            , "where"
            , ""
            , "import Data.Char (ord)"
            , "import Unicode.Internal.Bits (lookupBit64)"
            , ""
            , "combiningClass :: Char -> Int"
            , "combiningClass = \\case"
            , unlines (reverse st1)
            , "  _ -> 0\n"
            , ""
            , genBitmap "isCombining" (reverse st2)
            ]

    genCombiningClassDef dc = mconcat
        [ "  "
        , show (_char dc)
        , " -> "
        , show (_combiningClass dc)
        ]

genDecomposeDefModule ::
       Monad m
    => String
    -> [String]
    -> [String]
    -> DType
    -> (Int -> Bool)
    -> Fold m DetailedChar String
genDecomposeDefModule moduleName before after dtype predicate =
    Fold.filter (predicate . ord . _char)
        $ filterNonHangul
        $ filterDecomposableType dtype $ done <$> Fold.foldl' step initial

    where

    decomposeChar c DCSelf = [c]
    decomposeChar _c (DC ds) = ds

    genHeader =
        [ apacheLicense 2020 moduleName
        , "{-# LANGUAGE LambdaCase #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(decompose)"
        , "where"
        , ""
        ]
    genSign =
        [ "{-# NOINLINE decompose #-}"
        , "decompose :: Char -> [Char]"
        , "decompose = \\case"
        ]
    initial = []

    step st dc = genDecomposeDef dc : st

    done st =
        let body = mconcat [genHeader, before, genSign, reverse st, after]
        in unlines body

    genDecomposeDef dc = mconcat
        [ "  "
        , show (_char dc)
        , " -> "
        , show (decomposeChar (_char dc) (_decomposition dc))
        ]

genCompositionsModule ::
       Monad m
    => String
    -> [Int]
    -> [Int]
    -> Fold m DetailedChar String
genCompositionsModule moduleName compExclu non0CC =
    Fold.filter (not . flip elem compExclu . ord . _char)
        $ filterNonHangul
        $ Fold.filter (isDecompositionLen2 . _decomposition)
        $ filterDecomposableType Canonical $ done <$> Fold.foldl' step initial

    where

    isDecompositionLen2 DCSelf = False
    isDecompositionLen2 (DC ds) = length ds == 2

    genComposePairDef name dc =
        name
            <> " "
            <> show (head d01)
            <> " " <> show (d01 !! 1) <> " = Just " <> show (_char dc)

        where

        d01 = decompPair dc

    decompPair dc =
        case _decomposition dc of
            DCSelf -> error "toCompFormat: DCSelf"
            (DC ds) ->
                if length ds == 2
                then ds
                else error "toCompFormat: length /= 2"

    initial = ([], [], [])

    step (dec, sp, ss) dc = (dec1, sp1, ss1)

        where

        d01 = decompPair dc
        d1Ord = ord $ d01 !! 1
        dec1 = genComposePairDef "compose" dc : dec
        sp1 =
            if d1Ord `notElem` non0CC
            then genComposePairDef "composeStarters" dc : sp
            else sp
        ss1 =
            if d1Ord `notElem` non0CC
            then d1Ord : ss
            else ss

    header =
        [ apacheLicense 2020 moduleName
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(compose, composeStarters, isSecondStarter)"
        , "where"
        , ""
        , "import Data.Char (ord)"
        , "import Unicode.Internal.Bits (lookupBit64)"
        , ""
        ]

    composePair decomps =
        [ "{-# NOINLINE compose #-}"
        , "compose :: Char -> Char -> Maybe Char"
        , unlines decomps
        , "compose _ _ = " <> "Nothing" <> "\n"
        , ""
        ]

    composeStarterPair starterPairs =
        [ "composeStarters :: Char -> Char -> Maybe Char"
        , unlines starterPairs
        , "composeStarters _ _ = " <> "Nothing" <> "\n"
        , ""
        ]

    isSecondStarter secondStarters =
        [genBitmap "isSecondStarter" secondStarters]

    done (dec, sp, ss) =
        unlines
            $ header
            ++ composePair (reverse dec)
            ++ composeStarterPair (reverse sp)
            ++ isSecondStarter (Set.toList (Set.fromList ss))

genSimpleCaseMappingModule
    :: Monad m
    => String
    -> String
    -> (DetailedChar -> Maybe Char)
    -> Fold m DetailedChar String
genSimpleCaseMappingModule moduleName funcName field =
    done <$> Fold.foldl' step initial

    where

    genHeader =
        [ apacheLicense 2020 moduleName
        , "{-# LANGUAGE LambdaCase #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(" <> funcName <> ")"
        , "where"
        , ""
        ]
    genSign =
        [ "{-# NOINLINE " <> funcName <> " #-}"
        , funcName <> " :: Char -> Char"
        , funcName <> " = \\case"
        ]
    initial = []

    step ds dc = case mkEntry dc of
        Nothing -> ds
        Just d  -> d : ds

    after = ["  c -> c"]

    done st =
        let body = mconcat [genHeader, genSign, reverse st, after]
        in unlines body

    mkEntry dc = field dc <&> \c -> mconcat
        [ "  "
        , show (_char dc)
        , " -> "
        , show c
        ]

-- [NOTE] Case mapping encodes up to 3 code points on 21 bits each in an Int64.
genSpecialCaseMappingModule
    :: Monad m
    => String
    -> String
    -> SpecialCasings
    -- ^ Special casings
    -> (SpecialCasing -> String)
    -- ^ Special case selector
    -> (DetailedChar -> Maybe Char)
    -- ^ Simple case selector
    -> Fold m DetailedChar String
genSpecialCaseMappingModule moduleName funcName specialCasings special simple =
    done <$> Fold.foldl' step initial

    where

    genHeader =
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE LambdaCase #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(" <> funcName <> ")"
        , "where"
        , ""
        , "import Data.Int (Int64)"
        , ""
        , "{-# NOINLINE " <> funcName <> " #-}"
        , funcName <> " :: Char -> Int64"
        , funcName <> " = \\case"
        ]
    initial = []

    step xs dc = case mkEntry dc of
        Nothing -> xs
        Just x  -> x : xs

    after = ["  _ -> 0"]

    done st =
        let body = mconcat [genHeader, reverse st, after]
        in unlines body

    mkEntry dc = (mkSpecial dc <|> mkSimple dc) <&> \k -> mconcat
        [ "  "
        , show (_char dc)
        , " -> 0x"
        , showHex k ""
        ]

    mkSimple = fmap ord . simple
    mkSpecial = fmap (encode . special) . (specialCasings Map.!?) . _char
    encode :: String -> Int
    encode
        = foldr (\(k, c) -> (+) (ord c `shiftL` k)) 0
        . zip [0, 21, 42]
        -- Check min 1 character, max 3 characters
        . (\cs -> if null cs || length cs > 3 then error (show cs) else cs)

-- [NOTE] Case folding encodes up to 3 code points on 21 bits each in an Int64.
genCaseFolding
    :: Monad m
    => String
    -> Fold m CaseFoldings String
genCaseFolding moduleName =
    done <$> Fold.foldl' step initial

    where

    genHeader =
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE LambdaCase #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(toCasefold)"
        , "where"
        , ""
        , "import Data.Int (Int64)"
        , ""
        , "{-# NOINLINE toCasefold #-}"
        , "toCasefold :: Char -> Int64"
        , "toCasefold = \\case"
        ]
    initial = []

    step xs cf = maybe xs (:xs) (mkEntry cf)

    after = ["  _ -> 0"]

    done st =
        let body = mconcat [genHeader, reverse st, after]
        in unlines body

    mkEntry (c, cfs)
        = (lookup FullCaseFolding cfs <|> lookup CommonCaseFolding cfs)
        <&> \cf -> mconcat
            [ "  "
            , show c
            , " -> 0x"
            , showHex (encode cf) ""
            ]

    encode :: String -> Int
    encode
        = foldr (\(k, c) -> (+) (ord c `shiftL` k)) 0
        . zip [0, 21, 42]
        -- Check min 1 character, max 3 characters
        . (\cs -> if null cs || length cs > 3 then error (show cs) else cs)

genCorePropertiesModule ::
       Monad m => String -> (String -> Bool) -> Fold m (String, [Int]) String
genCorePropertiesModule moduleName isProp =
    Fold.filter (\(name, _) -> isProp name) $ done <$> Fold.foldl' step initial

    where

    prop2FuncName x = "is" ++ x

    initial = ([], [])

    step (props, bitmaps) (name, bits) =
        (name : props, genBitmap (prop2FuncName name) bits : bitmaps)

    done (props, bitmaps) = unlines $ header props ++ bitmaps

    header exports =
        [ apacheLicense 2020 moduleName
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(" ++ unwords (intersperse "," (map prop2FuncName exports)) ++ ")"
        , "where"
        , ""
        , "import Data.Char (ord)"
        , "import Unicode.Internal.Bits (lookupBit64)"
        ]

genNamesModule
    :: Monad m
    => String
    -> Fold m CharName String
genNamesModule moduleName =
    done <$> Fold.foldl' addCharName (mempty, mempty, 0)

    where

    addCharName (names, offsets, offset) (CharName char name) =
        ( name <> ['\0'] : names
        , encodeOffset char offset : offsets
        , offset + length name + 1
        )

    encodeOffset char offset = encode32LE (ord char) (encode32LE offset mempty)
    encode32LE v acc
        = (v             .&. 0xff)
        : (v `shiftR` 8  .&. 0xff)
        : (v `shiftR` 16 .&. 0xff)
        :  v `shiftR` 24
        : acc

    done (names, offsets, _) = unlines
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE CPP #-}"
        , "{-# LANGUAGE OverloadedStrings #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(name)"
        , "where"
        , ""
        , "#include \"MachDeps.h\""
        , ""
        , "import Foreign.C.String (CString)"
        , "import GHC.Exts"
        , ""
        , "-- | Name of a character, if defined."
        , "--"
        , "-- @since 0.1.0"
        , "{-# INLINE name #-}"
        , "name :: Char -> Maybe CString"
        , "name (C# c#) = getName 0# " <> shows (length names - 1) "#"
        , "    where"
        , "    -- [NOTE] Encoding"
        , "    -- • The names are ASCII. Each name is encoded as a NUL-terminated CString."
        , "    -- • The names are concatenated in names#."
        , "    -- • The name of a character, if defined, is referenced by an offset in names#."
        , "    -- • The offsets are stored in offsets#. A character entry is composed of two"
        , "    --   LE Word32: the first one is the codepoint, the second one is the offset."
        , "    -- • We use binary search on offsets# to extract names from names#."
        , "    cp# = ord# c#"
        , "    -- Binary search"
        , "    getName l# u# = if isTrue# (l# ># u#)"
        , "        then Nothing"
        , "        else"
        , "            let k# = l# +# uncheckedIShiftRL# (u# -# l#) 1#"
        , "                j# = k# `uncheckedIShiftL#` 1#"
        , "                cp'# = indexInt32OffAddr'# j#"
        , "            in if isTrue# (cp'# <# cp#)"
        , "                then getName (k# +# 1#) u#"
        , "                else if isTrue# (cp'# ==# cp#)"
        , "                    then let offset# = indexInt32OffAddr'# (j# +# 1#)"
        , "                         in Just (Ptr (names# `plusAddr#` offset#))"
        , "                    else getName l# (k# -# 1#)"
        , "    indexInt32OffAddr'# :: Int# -> Int#"
        , "    indexInt32OffAddr'# k# ="
        , "#ifdef WORDS_BIGENDIAN"
        , "#if MIN_VERSION_base(4,16,0)"
        , "        word2Int# (narrow32Word# (byteSwap32# (word32ToWord# (indexWord32OffAddr# offsets# k#))))"
        , "#else"
        , "        word2Int# (narrow32Word# (byteSwap32# (indexWord32OffAddr# offsets# k#)))"
        , "#endif"
        , "#elif MIN_VERSION_base(4,16,0)"
        , "        int32ToInt# (indexInt32OffAddr# offsets# k#)"
        , "#else"
        , "        indexInt32OffAddr# offsets# k#"
        , "#endif"
        , ""
        , "    names# = "
        -- Note: names are ASCII
            <> shows (mconcat (reverse names)) "#"
        , "    offsets# = \""
            <> enumMapToAddrLiteral (mconcat (reverse offsets)) "\"#"
        ]

genAliasesModule
    :: Monad m
    => String
    -> Fold m CharAliases String
genAliasesModule moduleName =
    done <$> Fold.foldr (\a -> (:) (mkCharAliases a)) mempty

    where

    mkCharAliases :: CharAliases -> String
    mkCharAliases (CharAliases char aliases) = mconcat
        [ "  '\\x"
        , showHexCodepoint char
        , "' -> "
        , show . Map.toList
               . Map.fromListWith (flip (<>))
               $ fmap ((:[])) <$> aliases
        , "\n"
        ]

    done names = unlines
        [ apacheLicense 2022 moduleName
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(NameAliasType(..), nameAliases, nameAliasesByType, nameAliasesWithTypes)"
        , "where"
        , ""
        , "import Data.Ix (Ix)"
        , "import Data.Maybe (fromMaybe)"
        , "import Foreign.C.String (CString)"
        , "import GHC.Exts (Ptr(..))"
        , ""
        , "-- | Type of name alias. See Unicode Standard 15.0.0, section 4.8."
        , "--"
        , "-- @since 0.1.0"
        , "data NameAliasType"
        , "    = Correction"
        , "    -- ^ Corrections for serious problems in the character names."
        , "    | Control"
        , "    -- ^ ISO&#xa0;6429 names for @C0@ and @C1@ control functions, and other"
        , "    --   commonly occurring names for control codes."
        , "    | Alternate"
        , "    -- ^ A few widely used alternate names for format characters."
        , "    | Figment"
        , "    -- ^ Several documented labels for @C1@ control code points which"
        , "    --   were never actually approved in any standard."
        , "    | Abbreviation"
        , "    -- ^ Commonly occurring abbreviations (or acronyms) for control codes,"
        , "    --   format characters, spaces, and variation selectors."
        , "    deriving (Enum, Bounded, Eq, Ord, Ix, Show)"
        , ""
        , "-- | All name aliases of a character."
        , "-- The names are listed in the original order of the UCD."
        , "--"
        , "-- See 'nameAliasesWithTypes' for the detailed list by alias type."
        , "--"
        , "-- @since 0.1.0"
        , "{-# INLINE nameAliases #-}"
        , "nameAliases :: Char -> [CString]"
        , "nameAliases = mconcat . fmap snd . nameAliasesWithTypes"
        , ""
        , "-- | Name aliases of a character for a specific name alias type."
        , "--"
        , "-- @since 0.1.0"
        , "{-# INLINE nameAliasesByType #-}"
        , "nameAliasesByType :: NameAliasType -> Char -> [CString]"
        , "nameAliasesByType t = fromMaybe mempty . lookup t . nameAliasesWithTypes"
        , ""
        , "-- | Detailed character names aliases."
        , "-- The names are listed in the original order of the UCD."
        , "--"
        , "-- See 'nameAliases' if the alias type is not required."
        , "--"
        , "-- @since 0.1.0"
        , "nameAliasesWithTypes :: Char -> [(NameAliasType, [CString])]"
        , "nameAliasesWithTypes = \\case"
        , mconcat names
        , "  _ -> mempty"
        ]

genNumericValuesModule
    :: Monad m
    => String
    -> Fold m CharNumericValue String
genNumericValuesModule moduleName =
    done . foldMap mkNumericValue . sort <$> Fold.toListRev

    where

    mkNumericValue (char, value) = mconcat
        [ "\n  "
        , show char
        , " -> "
        , either show show (bimap Just Just value)
        ]

    done values = unlines
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE LambdaCase #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(numericValue)"
        , "where"
        , ""
        , "import Data.Ratio ((%))"
        , ""
        , "numericValue :: Char -> Maybe Rational"
        , "numericValue = \\case" <> values
        , "  _ -> Nothing"
        ]

genIdentifierStatusModule
    :: Monad m
    => String
    -> Fold m CharIdentifierStatus String
genIdentifierStatusModule moduleName =
    done <$> Fold.lmap mkAllowed Fold.toList

    where

    mkAllowed = \case
        CharIdentifierStatus c Allowed -> ord c
        x                              -> error ("Unexpected " <> show x)

    done values = unlines
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE LambdaCase #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(isAllowedInIdentifier)"
        , "where"
        , ""
        , "import Data.Char (ord)"
        , "import Unicode.Internal.Bits (lookupBit64)"
        , ""
        , genBitmap "isAllowedInIdentifier" values
        ]

genIdentifierTypeModule
    :: Monad m
    => String
    -> Fold m CharIdentifierTypes String
genIdentifierTypeModule moduleName =
    done . mkIdentifiersTypes <$> Fold.foldl' addIdentifierType mempty

    where

    addIdentifierType
        :: Map.Map Char [IdentifierType]
        -> CharIdentifierTypes
        -> Map.Map Char [IdentifierType]
    addIdentifierType acc (CharIdentifierTypes c types) =
        Map.insertWith (flip (<>)) c types acc

    mkIdentifiersTypes
        :: Map.Map Char [IdentifierType]
        -> (String, [Int])
    mkIdentifiersTypes types =
        let encoding = Set.toList (Set.fromList (def : Map.elems types))
        in assert (length encoding < 0xff)
            ( foldMap addEncoding (zip [0..] encoding)
            , snd (Map.foldlWithKey' (addChar encoding) ('\0', mempty) types) )

    -- Default value
    def = [Not_Character]

    addEncoding :: (Int, [IdentifierType]) -> String
    addEncoding (n, e) = mconcat
        [ "\n    "
        , show n
        , " -> "
        , hackHaskellConstructor e ]

    addChar
        :: [[IdentifierType]]
        -> (Char, [Int])
        -> Char
        -> [IdentifierType]
        -> (Char, [Int])
    addChar encoding (expected, acc) c types = if expected < c
        then
            let acc' = encodeTypes encoding def : acc
            in addChar encoding (succ expected, acc') c types
        else (succ c, encodeTypes encoding types : acc)

    encodeTypes :: [[IdentifierType]] -> [IdentifierType] -> Int
    encodeTypes encoding types
        = assert (elemIndex def encoding == Just 0)
        $ fromMaybe 0 (elemIndex types encoding)

    hackHaskellConstructor = filter (/= '_') . show

    done (encoding, identifiersTypes) = unlines
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE LambdaCase, OverloadedLists #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(IdentifierType(..), identifierTypes, decodeIdentifierTypes)"
        , "where"
        , ""
        , "import Data.Char (ord)"
        , "import Data.List.NonEmpty (NonEmpty)"
        , "import Unicode.Internal.Bits (lookupIntN)"
        , ""
        , "-- | Identifier type"
        , "--"
        , "-- @since 0.1.0"
        , "data IdentifierType"
        , "    = NotCharacter"
        , "    -- ^ Unassigned characters, private use characters, surrogates,"
        , "    -- non-whitespace control characters."
        , "    | Deprecated"
        , "    -- ^ Characters with the Unicode property @Deprecated=Yes@."
        , "    | DefaultIgnorable"
        , "    -- ^ Characters with the Unicode property \
                   \@Default_Ignorable_Code_Point=Yes@."
        , "    | NotNFKC"
        , "    -- ^ Characters that cannot occur in strings normalized to NFKC."
        , "    | NotXID"
        , "    -- ^ Characters that do not qualify as default Unicode identifiers;"
        , "    -- that is, they do not have the Unicode property XID_Continue=True."
        , "    | Exclusion"
        , "    -- ^ Characters with @Script_Extensions@ values containing a script"
        , "    -- in /Excluded Scripts/, and no script from /Limited Use Scripts/"
        , "    -- or /Recommended Scripts/, other than “Common” or “Inherited”."
        , "    | Obsolete"
        , "    -- ^ Characters that are no longer in modern use, or that are not"
        , "    -- commonly used in modern text."
        , "    | Technical"
        , "    -- ^ Specialized usage: technical, liturgical, etc."
        , "    | UncommonUse"
        , "    -- ^ Characters that are uncommon, or are limited in use, or"
        , "    -- whose usage is uncertain."
        , "    | LimitedUse"
        , "    -- ^ Characters from scripts that are in limited use."
        , "    | Inclusion"
        , "    -- ^ Exceptionally allowed characters."
        , "    | Recommended"
        , "    -- ^ Characters from scripts that are in widespread everyday common use."
        , "    deriving (Eq, Ord, Bounded, Enum, Show)"
        , ""
        , "-- | Useful to decode the output of 'identifierTypes'."
        , "decodeIdentifierTypes :: Int -> NonEmpty IdentifierType"
        , "decodeIdentifierTypes = \\case" <> encoding
        , "    _ -> " <> hackHaskellConstructor def
        , ""
        , "-- | Returns the 'IdentifierType's corresponding to a character."
        , genEnumBitmap "identifierTypes" 0 (reverse identifiersTypes)
        ]

genConfusablesModule
    :: Monad m
    => String
    -> Fold m Confusable String
genConfusablesModule moduleName =
    done . foldMap mkConfusable . sort <$> Fold.toList

    where

    mkConfusable :: Confusable -> String
    mkConfusable (Confusable c s) = mconcat
        [ "\n    "
        , show c
        , " -> Just (Ptr \""
        , stringToAddrLiteral s
        , "\\0\"#)"
        ]

    -- Encode string as a null-terminated utf-8
    stringToAddrLiteral = foldMap toWord8 . encodeUtf8
    -- [HACK] Encode in utf-8, then decode in latin1 in order to get bytes
    encodeUtf8 s
        = unsafePerformIO
        $ Foreign.withCString Encoding.utf8 s
            (Foreign.peekCString Encoding.latin1)
    toWord8 = ('\\' :) . show . ord

    done confusables = unlines
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE LambdaCase #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(confusablePrototype)"
        , "where"
        , ""
        , "import Foreign.C.String (CString)"
        , "import GHC.Exts (Ptr(..))"
        , ""
        , "-- | Returns the /prototype/ of a character, if it is confusable."
        , "--"
        , "-- The resulting 'CString' is null-terminated and encoded in UTF-8."
        , "--"
        , "-- @since 0.1.0"
        , "confusablePrototype :: Char -> Maybe CString"
        , "confusablePrototype = \\case" <> confusables
        , "    _ -> Nothing"
        ]

genIntentionalConfusablesModule
    :: Monad m
    => String
    -> Fold m IntentionalConfusable String
genIntentionalConfusablesModule moduleName =
    done . Map.foldMapWithKey mkConfusable <$> Fold.foldl' addEntry mempty

    where

    addEntry
        :: Map.Map Char (Set.Set Char)
        -> IntentionalConfusable
        -> Map.Map Char (Set.Set Char)
    addEntry acc (IntentionalConfusable c1 c2)
        = Map.insertWith (flip (<>)) c1 (Set.singleton c2)
        . Map.insertWith (flip (<>)) c2 (Set.singleton c1)
        $ acc

    mkConfusable :: Char -> Set.Set Char -> String
    mkConfusable c cs = mconcat
        [ "\n    "
        , show c
        , " -> Just (Ptr \""
        , stringToAddrLiteral (Set.toList cs)
        , "\\0\"#)"
        ]

    -- Encode string as a null-terminated utf-8
    stringToAddrLiteral = foldMap toWord8 . encodeUtf8
    -- [HACK] Encode in utf-8, then decode in latin1 in order to get bytes
    encodeUtf8 s
        = unsafePerformIO
        $ Foreign.withCString Encoding.utf8 s
            (Foreign.peekCString Encoding.latin1)
    toWord8 = ('\\' :) . show . ord

    done confusables = unlines
        [ apacheLicense 2022 moduleName
        , "{-# LANGUAGE LambdaCase #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , "module " <> moduleName
        , "(intentionalConfusables)"
        , "where"
        , ""
        , "import Foreign.C.String (CString)"
        , "import GHC.Exts (Ptr(..))"
        , ""
        , "-- | Returns the /intentional/ confusables of a character, if any."
        , "--"
        , "-- The resulting 'CString' is null-terminated and encoded in UTF-8."
        , "--"
        , "-- @since 0.1.0"
        , "intentionalConfusables :: Char -> Maybe CString"
        , "intentionalConfusables = \\case" <> confusables
        , "    _ -> Nothing"
        ]

-------------------------------------------------------------------------------
-- Parsing blocks file
-------------------------------------------------------------------------------

type BlockLine = (String, (Int, Int))

parseBlockLine :: String -> Maybe BlockLine
parseBlockLine ln
    | null ln = Nothing
    | head ln == '#' = Nothing
    | otherwise = Just (parseLine ln)

    where

    parseLine line =
        let (rangeLn, line1) = span (/= ';') line
            name = takeWhile (/= '#') (tail line1)

        in (trim' name, parseRange (trim rangeLn))

    parseRange
        = bimap parseCodePoint (parseCodePoint . drop 2)
        . span (/= '.')

    parseCodePoint = read . ("0x" <>)

parseBlockLines
    :: (IsStream t, Monad m)
    => t m String
    -> t m BlockLine
parseBlockLines = Stream.mapMaybe parseBlockLine

-------------------------------------------------------------------------------
-- Parsing script file
-------------------------------------------------------------------------------

type ScriptLine = (String, Either Char (Char, Char))

parseScriptLine :: String -> Maybe ScriptLine
parseScriptLine ln
    | null ln = Nothing
    | head ln == '#' = Nothing
    | otherwise = Just (parseLine ln)

    where

    parseLine line =
        let (rangeLn, line1) = span (/= ';') line
            script = takeWhile (/= '#') (tail line1)

        in (trim script, parseRange (trim rangeLn))

    parseRange :: String -> Either Char (Char, Char)
    parseRange
        = (\(c1, c2) -> maybe (Left c1) (Right . (c1,)) c2)
        . bimap readCodePoint (readCodePointM . drop 2)
        . span (/= '.')

parseScriptLines
    :: (IsStream t, Monad m)
    => t m String
    -> t m ScriptLine
parseScriptLines = Stream.mapMaybe parseScriptLine

-------------------------------------------------------------------------------
-- Parsing ScriptExtensions.txt
-------------------------------------------------------------------------------

type ScriptExtensionsLine = (CharRangeStream, [String])

data CharScriptExtensions = CharScriptExtensions
    { _scriptExtensionsChar    :: !Char
    , _scriptExtensionsScripts :: ![String] }
type ScriptExtensions = Map.Map Char [String]

parseScriptExtensionsLine :: String -> Maybe ScriptExtensionsLine
parseScriptExtensionsLine = \case
    ""    -> Nothing -- empty line
    '#':_ -> Nothing -- comment
    line  -> Just (parseLine line)

    where

    parseLine line =
        let (rangeLn, line1) = span (/= ';') line
            range = parseCodePointRange rangeLn
            scripts = words (takeWhile (/= '#') (tail line1))
        in (either SingleChar (uncurry CharRange) range, scripts)

parseScriptExtensionsLines
    :: (IsStream t, Monad m)
    => t m String
    -> t m CharScriptExtensions
parseScriptExtensionsLines
    = Stream.unfoldMany (Unfold.unfoldr mkScriptExtension)
    . Stream.mapMaybe parseScriptExtensionsLine

    where

    mkScriptExtension
        :: ScriptExtensionsLine
        -> Maybe (CharScriptExtensions, ScriptExtensionsLine)
    mkScriptExtension (step, scripts) = case step of
        SingleChar c    -> Just (CharScriptExtensions c scripts, (Stop, mempty))
        CharRange c1 c2 -> Just ( CharScriptExtensions c1 scripts
                                , if c1 < c2
                                    then (CharRange (succ c1) c2, scripts)
                                    else (Stop, mempty) )
        Stop            -> Nothing

-------------------------------------------------------------------------------
-- Parsing property files
-------------------------------------------------------------------------------

trim :: String -> String
trim = takeWhile (not . isSpace) . dropWhile isSpace

trim' :: String -> String
trim' = dropWhileEnd isSpace . dropWhile isSpace

type PropertyLine = (String, [Int])

emptyPropertyLine :: PropertyLine
emptyPropertyLine = ("", [])

combinePropertyLines :: PropertyLine -> PropertyLine -> PropertyLine
combinePropertyLines t1@(n1, o1) t2@(n2, o2)
    | n1 == "" = t2
    | n2 == "" = t1
    | n1 == n2 = (n1, o1 ++ o2)
    | otherwise = error $ "Cannot group " ++ n1 ++ " with " ++ n2

parsePropertyLine :: String -> PropertyLine
parsePropertyLine ln
    | null ln = emptyPropertyLine
    | head ln == '#' = emptyPropertyLine
    | otherwise = parseLineJ ln

    where

    parseLineJ :: String -> (String, [Int])
    parseLineJ line =
        let (rangeLn, line1) = span (/= ';') line
            propLn = takeWhile (/= '#') (tail line1)
        in (trim propLn, parseRange (trim rangeLn))

    parseRange :: String -> [Int]
    parseRange rng =
        if '.' `elem` rng
        then let low = read $ "0x" ++ takeWhile (/= '.') rng
                 high =
                     read $ "0x" ++ reverse (takeWhile (/= '.') (reverse rng))
              in [low .. high]
        else [read $ "0x" ++ rng]

isDivider :: String -> Bool
isDivider x = x == "# ================================================"

parsePropertyLines :: (IsStream t, Monad m) => t m String -> t m PropertyLine
parsePropertyLines =
    Stream.splitOn isDivider
        $ Fold.lmap parsePropertyLine
        $ Fold.foldl' combinePropertyLines emptyPropertyLine

-------------------------------------------------------------------------------
-- Parsing UnicodeData.txt
-------------------------------------------------------------------------------

data PropertyValueAliasesLine = PropertyValueAliasesLine
    { _prop             :: !String
    , _propValue        :: !String
    , _propValueAliases :: [String] }

type PropertyValuesAliases      = Map.Map String [String]
type PropertyValuesAliasesEntry = (String, PropertyValuesAliases)

parsePropertyValueAliasesLine :: String -> Maybe PropertyValueAliasesLine
parsePropertyValueAliasesLine = \case
    ""    -> Nothing -- empty line
    '#':_ -> Nothing -- comment
    line  -> case split line of
        prop : value : as -> Just (PropertyValueAliasesLine prop value as)
        _                 -> error ("Unsupported line: " <> line)

    where

    split s = case s' of
        ""    -> [v']
        '#':_ -> [v']
        s''   -> v' : split (tail s'')
        where (v, s') = span (\c -> c /= ';' && c /= '#') (dropWhile isSpace s)
              v' = dropWhileEnd isSpace v

parsePropertyValueAliasesLines
    :: forall t m. (IsStream t, Monad m)
    => t m String
    -> t m PropertyValuesAliasesEntry
parsePropertyValueAliasesLines
    = Stream.groupsBy ((==) `on` _prop) (Fold.foldr addEntry mempty)
    . Stream.mapMaybe parsePropertyValueAliasesLine

    where

    addEntry (PropertyValueAliasesLine prop value aliases) (_, acc) =
        ( prop
        , Map.insert value aliases acc )

-------------------------------------------------------------------------------
-- Parsing UnicodeData.txt
-------------------------------------------------------------------------------

-- | A range entry in @UnicodeData.txt@.
data UnicodeDataRange
    = SingleCode    !DetailedChar
    -- ^ Regular entry for one code point
    | FirstCode     !String !DetailedChar
    -- ^ A partial range for entry with a name as: @\<RANGE_IDENTIFIER, First\>@
    | CompleteRange !String !DetailedChar !DetailedChar
    -- ^ A complete range, requiring 2 continuous entries with respective names:
    --
    -- * @\<RANGE_IDENTIFIER, First\>@
    -- * @\<RANGE_IDENTIFIER, Last\>@

{-| Parse UnicodeData.txt lines

Parse ranges according to https://www.unicode.org/reports/tr44/#Code_Point_Ranges.

__Note:__ this does /not/ fill missing char entries,
i.e. entries with no explicit entry nor within a range.
-}
parseUnicodeDataLines :: forall t m. (IsStream t, Monad m) => t m String -> t m DetailedChar
parseUnicodeDataLines
    = Stream.unfoldMany (Unfold.unfoldr unitToRange)
    . Stream.foldMany ( Fold.lmap parseDetailedChar
                      $ Fold.mkFold_ step initial )

    where

    step :: Maybe UnicodeDataRange
         -> DetailedChar
         -> Fold.Step (Maybe UnicodeDataRange) (Maybe UnicodeDataRange)
    step Nothing dc = case span (/= ',') (_name dc) of
        (range, ", First>") -> Fold.Partial (Just (FirstCode range dc))
        _                   -> Fold.Done (Just (SingleCode dc))
    step (Just (FirstCode range1 dc1)) dc2 = case span (/= ',') (_name dc2) of
        (range2, ", Last>") -> if range1 == range2 && _char dc1 < _char dc2
            then Fold.Done (Just (CompleteRange range1 dc1 dc2))
            else error $ "Cannot create range: incompatible ranges" <> show (dc1, dc2)
        _ -> error $ "Cannot create range: missing <range, Last> entry corresponding to: " <> show range1
    step _ _ = error "impossible case"

    initial :: Fold.Step (Maybe UnicodeDataRange) (Maybe UnicodeDataRange)
    initial = Fold.Partial Nothing

    unitToRange :: Maybe UnicodeDataRange -> Maybe (DetailedChar, Maybe UnicodeDataRange)
    unitToRange = fmap $ \case
        SingleCode          dc      -> (dc, Nothing)
        FirstCode     _     dc      -> error $ "Incomplete range: " <> show dc
        CompleteRange range dc1 dc2 -> if _char dc1 < _char dc2
            -- [TODO] Create the proper name
            then (dc1{_name="TODO"}, Just (CompleteRange range dc1{_char=succ (_char dc1)} dc2))
            else (dc2{_name="TODO"}, Nothing)

-- | Parse a single entry of @UnicodeData.txt@
parseDetailedChar :: String -> DetailedChar
parseDetailedChar line =
    DetailedChar
        { _char = readCodePoint char
        , _name = name
        , _generalCategory = read gc
        , _combiningClass = read combining
        , _decompositionType = dctype
        , _decomposition = dcval
        , _simpleUpperCaseMapping = readCodePointM sUpper
        , _simpleLowerCaseMapping = readCodePointM sLower
        , _simpleTitleCaseMapping = readCodePointM sTitle
        }

    where

    (char, line1) = span (/= ';') line
    (name, line2) = span (/= ';') (tail line1)
    (gc, line3) = span (/= ';') (tail line2)
    (combining, line4) = span (/= ';') (tail line3)
    (_bidi, line5) = span (/= ';') (tail line4)
    (decomposition, line6) = span (/= ';') (tail line5)
    (dctype, dcval) = readDecomp decomposition
    (_decimal, line7) = span (/= ';') (tail line6)
    (_digit, line8) = span (/= ';') (tail line7)
    (_numeric, line9) = span (/= ';') (tail line8)
    (_bidiM, line10) = span (/= ';') (tail line9)
    (_uni1Name, line11) = span (/= ';') (tail line10)
    (_iso, line12) = span (/= ';') (tail line11)
    (sUpper, line13) = span (/= ';') (tail line12)
    (sLower, line14) = span (/= ';') (tail line13)
    sTitle = tail line14

-------------------------------------------------------------------------------
-- Parse SpecialCasing.txt
-------------------------------------------------------------------------------

-- type SpecialCasings = Map.Map Char [SpecialCasing]
type SpecialCasings = Map.Map Char SpecialCasing

data SpecialCasing = SpecialCasing
    { _scChar       :: Char
    , _scLower      :: String
    , _scTitle      :: String
    , _scUpper      :: String
    -- , _scConditions :: [SpecialCasingCondition]
    }

parseSpecialCasingLines
    :: forall m. (Monad m)
    => SerialT m String
    -> m SpecialCasings
parseSpecialCasingLines
    = Stream.fold
        ( Fold.mapMaybe parseSpecialCasing
        $ Fold.foldl' combineSpecialCasings mempty
        )

    where

    -- combineSpecialCasings acc x = Map.insertWith (++) (_scChar x) [x] acc
    combineSpecialCasings acc sc = Map.insert (_scChar sc) sc acc

parseSpecialCasing :: String -> Maybe SpecialCasing
parseSpecialCasing line
    | null line        = Nothing
    | head line == '#' = Nothing
    -- Keep only entries without condititions
    | null conditions  = Just specialCasing
    | otherwise        = Nothing

    where

    (rawChar, line1) = span (/= ';') line
    char = readCodePoint rawChar
    (rawLower, line2) = span (/= ';') (tail line1)
    lower = toChars rawLower
    (rawTitle, line3) = span (/= ';') (tail line2)
    title = toChars rawTitle
    (rawUpper, line4) = span (/= ';') (tail line3)
    upper = toChars rawUpper
    (rawConditions, _line5) = span (/= ';') (tail line4)
    (rawConditions', _comment) = span (/= '#') rawConditions
    conditions = words (trim' rawConditions')
    specialCasing = SpecialCasing
        { _scChar  = char
        , _scLower = lower
        , _scTitle = title
        , _scUpper = upper
        -- , _scConditions = conditions
        }

    toChars = fmap readCodePoint . words

-------------------------------------------------------------------------------
-- Parsing CaseFolding.txt
-------------------------------------------------------------------------------

data CaseFoldingType
    = CommonCaseFolding
    | FullCaseFolding
    | SimpleCaseFolding
    | SpecialCaseFolding
    deriving (Eq, Ord)

type CaseFoldings = (Char, [(CaseFoldingType, String)])
type CaseFoldingLine = (Char, CaseFoldingType, String)

parseCaseFoldingLines
    :: forall t m. (IsStream t, Monad m)
    => t m String
    -> t m CaseFoldings
parseCaseFoldingLines
    = Stream.groupsBy sameChar combine
    . Stream.mapMaybe parseCaseFoldingLine

    where

    sameChar (c1, _, _) (c2, _, _) = c1 == c2

    combine = Fold.foldr
        (\(c, ty, cs) (_, xs) -> (c, (ty, cs):xs))
        ('\0', mempty)

parseCaseFoldingLine :: String -> Maybe CaseFoldingLine
parseCaseFoldingLine line
    | null line        = Nothing
    | head line == '#' = Nothing
    | otherwise        = Just (char, caseFoldingType, caseFolding)

    where

    (rawChar, line1) = span (/= ';') line
    char = readCodePoint rawChar
    (rawCaseFoldType, line2) = span (/= ';') (tail line1)
    caseFoldingType = case trim rawCaseFoldType of
        "C" -> CommonCaseFolding
        "F" -> FullCaseFolding
        "S" -> SimpleCaseFolding
        "T" -> SpecialCaseFolding
        ty  -> error ("Unsupported case folding type: " <> ty)
    (rawCaseFolding, _) = span (/= ';') (tail line2)
    caseFolding = toChars rawCaseFolding

    toChars = fmap readCodePoint . words

-------------------------------------------------------------------------------
-- Parsing DerivedNumericValues.txt
-------------------------------------------------------------------------------

type NumericValue = Either Int Rational
type CharNumericValue = (Char, NumericValue)
type CharRangeNumericValue = (Char, Char, NumericValue)
type DerivedNumericValuesLine = Either CharNumericValue CharRangeNumericValue

parseDerivedNumericValuesLine :: String -> Maybe DerivedNumericValuesLine
parseDerivedNumericValuesLine line
    | null line        = Nothing
    | head line == '#' = Nothing
    | otherwise        =
        let (range  , line1) = span (/= ';') line
            (_field1, line2) = span (/= ';') (tail line1)
            (_field2, line3) = span (/= ';') (tail line2)
            value            = takeWhile (/= '#') (tail line3)
            value' = parseValue (trim' value)
        in Just (bimap (,value') (mkRange value') (parseCodePointRange range))

    where

    mkRange :: NumericValue -> (Char, Char) -> CharRangeNumericValue
    mkRange value (c1, c2) = (c1, c2, value)

    parseValue :: String -> NumericValue
    parseValue raw =
        let (numerator, denominator) = span (/= '/') raw
        in if null denominator
            then Left  (read numerator)
            else Right (read numerator % read (tail denominator))

parseDerivedNumericValuesLines
    :: (IsStream t, Monad m)
    => t m String
    -> t m CharNumericValue
parseDerivedNumericValuesLines
    = Stream.unfoldMany (Unfold.unfoldr mkCharNumericValue)
    . Stream.mapMaybe parseDerivedNumericValuesLine

    where

    mkCharNumericValue
        :: DerivedNumericValuesLine
        -> Maybe (CharNumericValue, DerivedNumericValuesLine)
    mkCharNumericValue = \case
        Left charValue -> Just (charValue, Right ((fst charValue),  '\0', Left 0))
        Right (c1, c2, value) -> if c1 <= c2
            then Just ((c1, value), Right (succ c1, c2, value))
            else Nothing

-------------------------------------------------------------------------------
-- Parsing Aliases
-------------------------------------------------------------------------------

data AliasType
    = Correction
    | Control
    | Alternate
    | Figment
    | Abbreviation
    deriving (Eq, Ord, Read, Show)

newtype Alias = Alias String
instance Show Alias where
    show (Alias s) = "Ptr \"" <> s <> "\\0\"#"

type Aliases = [(AliasType, Alias)]
data CharAliases = CharAliases
    { _aChar    :: !Char
    , _aAliases :: !Aliases }
type AliasesLine = (Char, Alias, AliasType)

parseAliasesLine :: String -> Maybe AliasesLine
parseAliasesLine line
    | null line        = Nothing
    | head line == '#' = Nothing
    | otherwise        =
        let (char , line1) = span (/= ';') line
            (alias, line2) = span (/= ';') (tail line1)
            type_          = tail line2
        in Just (readCodePoint char, Alias alias, readAliasType type_)

    where

    readAliasType :: String -> AliasType
    readAliasType a = read (toUpper (head a) : tail a)


parseAliasesLines :: (IsStream t, Monad m) => t m String -> t m CharAliases
parseAliasesLines
    = Stream.groupsBy compareChar
        (Fold.foldr combineAliases (CharAliases '\0' mempty))
    . Stream.mapMaybe parseAliasesLine

    where

    compareChar :: AliasesLine -> AliasesLine -> Bool
    compareChar (char1, _, _) (char2, _, _) = char1 == char2

    combineAliases :: AliasesLine -> CharAliases -> CharAliases
    combineAliases (char, alias, type_) (CharAliases _ as) =
        CharAliases char ((type_, alias):as)

-------------------------------------------------------------------------------
-- Parsing Names
-------------------------------------------------------------------------------

data CharName = CharName
    { _nChar    :: !Char
    , _nName    :: !String }

type CharRangeName = (Char, Char, String)
type DerivedNameLine = Either CharName CharRangeName

parseDerivedNameLine :: String -> Maybe DerivedNameLine
parseDerivedNameLine line
    | null line        = Nothing
    | head line == '#' = Nothing
    | otherwise        =
        let (range, line1) = span (/= ';') line
            name = trim' (tail line1)
        in Just (bimap (`CharName` name) (mkRange name) (parseCodePointRange range))
    where

    mkRange :: String -> (Char, Char) -> CharRangeName
    mkRange name (c1, c2) = case elemIndex '*' name of
        Nothing -> error
            $ "Range name should contain “*”: "
            <> show (showHexCodepoint c1, showHexCodepoint c2, name)
        Just k  -> if k == length name - 1
            then (c1, c2, init name)
            else error
                $ "Unexpected “*” before the end of range name: "
                <> show (showHexCodepoint c1, showHexCodepoint c2, name)

parseDerivedNameLines
    :: forall t m. (IsStream t, Monad m) =>
    t m String ->
    t m CharName
parseDerivedNameLines
    = Stream.unfoldMany (Unfold.unfoldr mkCharsNames)
    . Stream.mapMaybe parseDerivedNameLine

    where

    mkCharsNames :: DerivedNameLine -> Maybe (CharName, DerivedNameLine)
    mkCharsNames = \case
        Left named -> Just (named, Right ((_nChar named),  '\0', mempty))
        Right (c1, c2, template) -> if c1 <= c2
            then Just ( mkName template c1
                      , Right (succ c1, c2, template) )
            else Nothing

    mkName :: String -> Char -> CharName
    mkName template char = CharName
        { _nChar = char
        , _nName = template <> fmap toUpper (showHexCodepoint char) }

-------------------------------------------------------------------------------
-- Parsing Identifier_Status
-------------------------------------------------------------------------------

data IdentifierStatus = Restricted | Allowed
    deriving (Eq, Show, Read)

data CharIdentifierStatus = CharIdentifierStatus
    { _idStatusChar :: !Char
    , _idStatus     :: !IdentifierStatus }
    deriving (Show)

type IdentifierStatusLine = (Char, Char, IdentifierStatus)

parseIdentifierStatusLine :: String -> Maybe IdentifierStatusLine
parseIdentifierStatusLine = \case
    ""         -> Nothing -- empty line
    '#':_      -> Nothing -- comment
    '\xFEFF':_ -> Nothing -- BOM
    line       ->
        let (rawRange, line1) = span (/= ';') line
            line2 = takeWhile (/= '#') (tail line1)
            range = parseCodePointRange rawRange
            status = read (trim' (tail line2))
        in Just (either (mkRange status . (id &&& id)) (mkRange status) range)

    where

    mkRange :: IdentifierStatus -> (Char, Char) -> IdentifierStatusLine
    mkRange status (c1, c2) = (c1, c2, status)

parseIdentifierStatusLines
    :: forall t m. (IsStream t, Monad m)
    => t m String
    -> t m CharIdentifierStatus
parseIdentifierStatusLines
    = Stream.unfoldMany (Unfold.unfoldr mkIdentifiersStatus)
    . Stream.mapMaybe parseIdentifierStatusLine

    where

    mkIdentifiersStatus
        :: IdentifierStatusLine
        -> Maybe (CharIdentifierStatus, IdentifierStatusLine)
    mkIdentifiersStatus (c1, c2, status) = if c1 <= c2
        then Just (CharIdentifierStatus c1 status, (succ c1, c2, status))
        else Nothing

-------------------------------------------------------------------------------
-- Parsing Identifier_Type
-------------------------------------------------------------------------------

data IdentifierType
    = Not_Character
    | Deprecated
    | Default_Ignorable
    | Not_NFKC
    | Not_XID
    | Exclusion
    | Obsolete
    | Technical
    | Uncommon_Use
    | Limited_Use
    | Inclusion
    | Recommended
    deriving (Eq, Ord, Bounded, Enum, Show, Read)

data CharIdentifierTypes = CharIdentifierTypes
    { _idTypesChar :: !Char
    , _idTypes     :: ![IdentifierType] }
    deriving (Show)

type IdentifierTypeLine = (Char, Char, [IdentifierType])

parseIdentifierTypeLine :: String -> Maybe IdentifierTypeLine
parseIdentifierTypeLine = \case
    ""         -> Nothing -- empty line
    '#':_      -> Nothing -- comment
    '\xFEFF':_ -> Nothing -- BOM
    line       ->
        let (rawRange, line1) = span (/= ';') line
            line2 = takeWhile (/= '#') (tail line1)
            range = parseCodePointRange rawRange
            types = read <$> words (trim' (tail line2))
        in Just (either (mkRange types . (id &&& id)) (mkRange types) range)

    where

    mkRange :: [IdentifierType] -> (Char, Char) -> IdentifierTypeLine
    mkRange type_ (c1, c2) = (c1, c2, type_)

parseIdentifierTypeLines
    :: forall t m. (IsStream t, Monad m)
    => t m String
    -> t m CharIdentifierTypes
parseIdentifierTypeLines
    = Stream.unfoldMany (Unfold.unfoldr mkIdentifiersStatus)
    . Stream.mapMaybe parseIdentifierTypeLine

    where

    mkIdentifiersStatus
        :: IdentifierTypeLine
        -> Maybe (CharIdentifierTypes, IdentifierTypeLine)
    mkIdentifiersStatus (c1, c2, types) = if c1 <= c2
        then Just (CharIdentifierTypes c1 types, (succ c1, c2, types))
        else Nothing

-------------------------------------------------------------------------------
-- Parsing Confusables
-------------------------------------------------------------------------------

data Confusable = Confusable
    { _confusableChar     :: !Char
    , _confusablePrototype :: !String }
    deriving (Eq, Ord, Show)

parseConfusablesLine :: String -> Maybe Confusable
parseConfusablesLine = \case
    ""         -> Nothing -- empty line
    '#':_      -> Nothing -- comment
    '\xFEFF':_ -> Nothing -- BOM
    line       ->
        let (rawChar, line1) = span (/= ';') line
            line2 = takeWhile (/= ';') (tail line1)
            char = readCodePoint rawChar
            prototype = readCodePoint <$> words (trim' (tail line2))
        in Just (Confusable char prototype)

parseConfusablesLines
    :: forall t m. (IsStream t, Monad m)
    => t m String
    -> t m Confusable
parseConfusablesLines
    = Stream.mapMaybe parseConfusablesLine

-------------------------------------------------------------------------------
-- Parsing Intentional Confusables
-------------------------------------------------------------------------------

data IntentionalConfusable = IntentionalConfusable
    { _intantionConfusableChar      :: !Char
    , _intantionConfusablePrototype :: !Char }
    deriving (Eq, Ord, Show)

parseIntentionalConfusablesLine :: String -> Maybe IntentionalConfusable
parseIntentionalConfusablesLine = \case
    ""         -> Nothing -- empty line
    '#':_      -> Nothing -- comment
    '\xFEFF':_ -> Nothing -- BOM
    line       ->
        let (rawChar, line1) = span (/= ';') line
            line2 = takeWhile (/= '#') (tail line1)
            char = readCodePoint rawChar
            prototype = readCodePoint (trim' (tail line2))
        in Just (IntentionalConfusable char prototype)

parseIntentionalConfusablesLines
    :: forall t m. (IsStream t, Monad m)
    => t m String
    -> t m IntentionalConfusable
parseIntentionalConfusablesLines
    = Stream.mapMaybe parseIntentionalConfusablesLine

-------------------------------------------------------------------------------
-- Generation
-------------------------------------------------------------------------------

readLinesFromFile :: String -> SerialT IO String
readLinesFromFile file =
    withFile file Sys.ReadMode
        $ \h ->
              Stream.unfold Handle.read h & Unicode.decodeUtf8
                  & unicodeLines Fold.toList

    where

    unicodeLines = Stream.splitOnSuffix (== '\n')

    withFile file_ mode =
        Stream.bracket (liftIO $ Sys.openFile file_ mode) (liftIO . Sys.hClose)


moduleToFileName :: String -> String
moduleToFileName = map (\x -> if x == '.' then '/' else x)

dirFromFileName :: String -> String
dirFromFileName = reverse . dropWhile (/= '/') . reverse

-- ModuleRecipe is a tuple of the module name and a function that generates the
-- module using the module name
type ModuleRecipe a = (String, String -> Fold IO a String)

-- GeneratorRecipe is a list of ModuleRecipe
type GeneratorRecipe a = [ModuleRecipe a]

fileEmitter :: String -> String -> ModuleRecipe a -> Fold IO a ()
fileEmitter file outdir (modName, fldGen) = Fold.rmapM action $ fldGen modName

    where

    pretext version = mconcat
        [ "-- autogenerated from https://www.unicode.org/Public/"
        , version
        , "/ucd/"
        , file
        ,"\n"
        ]
    outfile = outdir <> moduleToFileName modName <> ".hs"
    outfiledir = dirFromFileName outfile
    action c = do
        version <-
            catch
                (getEnv "UNICODE_VERSION")
                (\(_ :: IOException) -> return "<unknown>")
        createDirectoryIfMissing True outfiledir
        writeFile outfile (pretext version ++ c)

runGenerator ::
       String
    -> String
    -> (SerialT IO String -> SerialT IO a)
    -> String
    -> GeneratorRecipe a
    -> IO ()
runGenerator indir file transformLines outdir recipes =
    readLinesFromFile (indir </> file) & transformLines & Stream.fold combinedFld

    where

    generatedFolds = map (fileEmitter file outdir) recipes
    combinedFld = void $ Fold.distribute generatedFolds

genCoreModules :: String -> String -> [String] -> IO ()
genCoreModules indir outdir props = do

    compExclu <-
        readLinesFromFile (indir </> "DerivedNormalizationProps.txt")
            & parsePropertyLines
            & Stream.find (\(name, _) -> name == "Full_Composition_Exclusion")
            & fmap (snd . fromMaybe ("", []))

    non0CC <-
        readLinesFromFile (indir </> "extracted/DerivedCombiningClass.txt")
            & parsePropertyLines
            & Stream.filter (\(name, _) -> name /= "0")
            & Stream.map snd
            & Stream.fold (Fold.foldl' (++) [])

    specialCasings <-
        readLinesFromFile (indir </> "SpecialCasing.txt")
            & parseSpecialCasingLines

    runGenerator
        indir
        "Blocks.txt"
        parseBlockLines
        outdir
        [ blocks ]

    runGenerator
        indir
        "UnicodeData.txt"
        parseUnicodeDataLines
        outdir
        [ compositions compExclu non0CC
        , combiningClass
        , decomposable
        , decomposableK
        , decompositions
        , decompositionsK2
        , decompositionsK
        , generalCategory
        , simpleUpperCaseMapping
        , simpleLowerCaseMapping
        , simpleTitleCaseMapping
        , specialUpperCaseMapping specialCasings
        , specialLowerCaseMapping specialCasings
        , specialTitleCaseMapping specialCasings
        ]

    runGenerator
        indir
        "PropList.txt"
        parsePropertyLines
        outdir
        [ propList ]

    runGenerator
        indir
        "DerivedCoreProperties.txt"
        parsePropertyLines
        outdir
        [ derivedCoreProperties ]

    runGenerator
        indir
        "extracted/DerivedNumericValues.txt"
        parseDerivedNumericValuesLines
        outdir
        [ derivedNumericValues ]

    runGenerator
        indir
        "CaseFolding.txt"
        parseCaseFoldingLines
        outdir
        [ caseFolding ]

    where

    blocks =
        ( "Unicode.Internal.Char.Blocks"
        , genBlocksModule)

    propList =
        ("Unicode.Internal.Char.PropList"
        , (`genCorePropertiesModule` (`elem` props)))

    derivedCoreProperties =
        ("Unicode.Internal.Char.DerivedCoreProperties"
        , (`genCorePropertiesModule` (`elem` props)))

    compositions exc non0 =
        ( "Unicode.Internal.Char.UnicodeData.Compositions"
        , \m -> genCompositionsModule m exc non0)

    combiningClass =
        ( "Unicode.Internal.Char.UnicodeData.CombiningClass"
        , genCombiningClassModule)

    decomposable =
        ( "Unicode.Internal.Char.UnicodeData.Decomposable"
        , (`genDecomposableModule` Canonical))

    decomposableK =
        ( "Unicode.Internal.Char.UnicodeData.DecomposableK"
        , (`genDecomposableModule` Kompat))

    decompositions =
        let post = ["  c -> [c]"]
        in  ( "Unicode.Internal.Char.UnicodeData.Decompositions"
            , \m -> genDecomposeDefModule m [] post Canonical (const True))

    decompositionsK2 =
        let post = ["  c -> [c]"]
        in  ( "Unicode.Internal.Char.UnicodeData.DecompositionsK2"
            , \m -> genDecomposeDefModule m [] post Kompat (>= 60000))

    decompositionsK =
        let pre = ["import qualified " <> fst decompositionsK2 <> " as DK2", ""]
            post = ["  c -> DK2.decompose c"]
        in  ( "Unicode.Internal.Char.UnicodeData.DecompositionsK"
            , \m -> genDecomposeDefModule m pre post Kompat (< 60000))

    generalCategory =
         ( "Unicode.Internal.Char.UnicodeData.GeneralCategory"
         , genGeneralCategoryModule)

    simpleUpperCaseMapping =
         ( "Unicode.Internal.Char.UnicodeData.SimpleUpperCaseMapping"
         , \m -> genSimpleCaseMappingModule m "toSimpleUpperCase" _simpleUpperCaseMapping)

    simpleLowerCaseMapping =
         ( "Unicode.Internal.Char.UnicodeData.SimpleLowerCaseMapping"
         , \m -> genSimpleCaseMappingModule m "toSimpleLowerCase" _simpleLowerCaseMapping)

    simpleTitleCaseMapping =
         ( "Unicode.Internal.Char.UnicodeData.SimpleTitleCaseMapping"
         , \m -> genSimpleCaseMappingModule m "toSimpleTitleCase" _simpleTitleCaseMapping)

    specialUpperCaseMapping sc =
         ( "Unicode.Internal.Char.SpecialCasing.UpperCaseMapping"
         , \m -> genSpecialCaseMappingModule m
                    "toSpecialUpperCase"
                    sc
                    _scUpper
                    _simpleUpperCaseMapping )

    specialLowerCaseMapping sc =
         ( "Unicode.Internal.Char.SpecialCasing.LowerCaseMapping"
         , \m -> genSpecialCaseMappingModule m
                    "toSpecialLowerCase"
                    sc
                    _scLower
                    _simpleLowerCaseMapping )

    specialTitleCaseMapping sc =
         ( "Unicode.Internal.Char.SpecialCasing.TitleCaseMapping"
         , \m -> genSpecialCaseMappingModule m
                    "toSpecialTitleCase"
                    sc
                    _scTitle
                    _simpleTitleCaseMapping )

    caseFolding =
         ( "Unicode.Internal.Char.CaseFolding"
         , genCaseFolding )

    derivedNumericValues =
         ( "Unicode.Internal.Char.DerivedNumericValues"
         , genNumericValuesModule )

genNamesModules :: String -> String -> IO ()
genNamesModules indir outdir = do
    runGenerator
        indir
        "extracted/DerivedName.txt"
        parseDerivedNameLines
        outdir
        [names]

    runGenerator
        indir
        "NameAliases.txt"
        parseAliasesLines
        outdir
        [aliases]

    where

    names =
         ( "Unicode.Internal.Char.UnicodeData.DerivedName"
         , genNamesModule )
    aliases =
         ( "Unicode.Internal.Char.UnicodeData.NameAliases"
         , genAliasesModule )

genScriptsModules :: String -> String -> IO ()
genScriptsModules indir outdir = do
    scriptAliases <-
        readLinesFromFile (indir </> "PropertyValueAliases.txt")
            & parsePropertyValueAliasesLines
            & Stream.lookup "sc"
            & fmap (fromMaybe mempty)

    extensions <-
        readLinesFromFile (indir </> "ScriptExtensions.txt")
            & parseScriptExtensionsLines
            & Stream.foldr
                (\(CharScriptExtensions c s) -> Map.insertWith (<>) c s)
                mempty

    runGenerator
        indir
        "Scripts.txt"
        parseScriptLines
        outdir
        [ scripts scriptAliases
        , scriptExtensions scriptAliases extensions ]

    where

    scripts scriptAliases =
        ( "Unicode.Internal.Char.Scripts"
        , \m -> genScriptsModule m scriptAliases )

    scriptExtensions scriptAliases extensions =
        ( "Unicode.Internal.Char.ScriptExtensions"
        , \m -> genScriptExtensionsModule m scriptAliases extensions )

genSecurityModules :: String -> String -> IO ()
genSecurityModules indir outdir = do
    runGenerator
        indir
        "IdentifierStatus.txt"
        parseIdentifierStatusLines
        outdir
        [isAllowedInIdentifier]

    runGenerator
        indir
        "IdentifierType.txt"
        parseIdentifierTypeLines
        outdir
        [identifierTypes]

    runGenerator
        indir
        "confusables.txt"
        parseConfusablesLines
        outdir
        [confusables]

    runGenerator
        indir
        "intentional.txt"
        parseIntentionalConfusablesLines
        outdir
        [intentional]

    where

    isAllowedInIdentifier =
         ( "Unicode.Internal.Char.Security.IdentifierStatus"
         , genIdentifierStatusModule )

    identifierTypes =
         ( "Unicode.Internal.Char.Security.IdentifierType"
         , genIdentifierTypeModule )

    confusables =
         ( "Unicode.Internal.Char.Security.Confusables"
         , genConfusablesModule )

    intentional =
         ( "Unicode.Internal.Char.Security.IntentionalConfusables"
         , genIntentionalConfusablesModule )