content: -- |
  -- Module      : UCD2Haskell.ModuleGenerators
  -- Copyright   : (c) 2020 Composewell Technologies and Contributors
  --               (c) 2016-2017 Harendra Kumar
  --               (c) 2014-2015 Antonio Nikishaev
  --               (c) 2022-2024 Pierre Le Marre
  -- License     : BSD-3-Clause
  -- Maintainer  : The GHC Developers <ghc-devs@haskell.org>"
  -- Stability   : internal
  
  -- Code history:
  --
  -- This code was adapted from https://github.com/composewell/unicode-data/
  -- (around commit c4aa52ed932ad8badf97296858932c3389b275b8) by Pierre Le Marre.
  -- 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 UCD2Haskell.ModuleGenerators (genModules) where
  
  import Control.Exception (catch, IOException)
  import Data.Bits (Bits(..))
  import Data.Word (Word8)
  import Data.Char (ord)
  import Data.Functor ((<&>), ($>))
  import Data.List (intersperse, unfoldr)
  import System.Directory (createDirectoryIfMissing)
  import System.Environment (getEnv)
  import System.FilePath ((</>), (<.>))
  import Data.String (IsString)
  import Data.Foldable (Foldable(..))
  
  import qualified Data.ByteString.Builder as BB
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Lazy as BL
  import qualified Data.ByteString.Short as BS
  
  import qualified Unicode.CharacterDatabase.Parser.Common as C
  import qualified Unicode.CharacterDatabase.Parser.UnicodeData as UD
  import qualified Unicode.CharacterDatabase.Parser.Properties.Multiple as P
  
  import Generator.GeneralCategory (generateGeneralCategoryCode)
  import Generator.ByteString (unlinesBB, unwordsBB)
  
  import Prelude hiding (pred)
  
  --------------------------------------------------------------------------------
  -- Helpers
  --------------------------------------------------------------------------------
  
  headerRule :: BB.Builder
  headerRule = "-----------------------------------------------------------------------------"
  
  mkModuleHeader :: BB.Builder -> BB.Builder
  mkModuleHeader modName =
      unlinesBB
          [ headerRule
          , "-- |"
          , "-- Module      : " <> modName
          , "-- License     : BSD-3-Clause"
          , "-- Maintainer  : The GHC Developers <ghc-devs@haskell.org>"
          , "-- Stability   : internal"
          , headerRule
          ]
  
  genSignature :: BB.Builder -> BB.Builder
  genSignature = (<> " :: Char -> Bool")
  
  -- | Check that var is between minimum and maximum of orderList
  genRangeCheck :: BB.Builder -> [Int] -> BB.Builder
  genRangeCheck var ordList =
      var
          <> " >= "
          <> BB.intDec (minimum ordList)
          <> " && " <> var <> " <= " <> BB.intDec (maximum ordList)
  
  genBitmap :: BB.Builder -> [Int] -> BB.Builder
  genBitmap funcName ordList =
      unlinesBB
          [ "{-# 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 ::
    -- | Values to encode
    [Bool] ->
    -- | String to append
    BB.Builder ->
    BB.Builder
  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] -> BB.Builder -> BB.Builder
      encode chunk acc = BB.char7 '\\' <> BB.intDec (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]
  
  genUnicodeVersion :: FilePath -> IO ()
  genUnicodeVersion outdir = do
    version <- catch
                (getEnv "UNICODE_VERSION")
                (\(_ :: IOException) -> return "<unknown>")
    runFold f [body version]
    where
      moduleName :: (IsString a) => a
      moduleName = "GHC.Internal.Unicode.Version"
      f = moduleFileEmitter Nothing outdir
            (moduleName, \_ -> Fold (\_ x -> x) mempty id)
      body :: String -> BB.Builder
      body version = unlinesBB
        [ "{-# LANGUAGE NoImplicitPrelude #-}"
        , "{-# OPTIONS_HADDOCK hide #-}"
        , ""
        , mkModuleHeader moduleName
        , "module " <> moduleName
        , "(unicodeVersion)"
        , "where"
        , ""
        , "import {-# SOURCE #-} GHC.Internal.Data.Version"
        , ""
        , "-- | Version of Unicode standard used by @base@:"
        , "-- [" <> BB.string7 version <> "](https://www.unicode.org/versions/Unicode" <> BB.string7 version <> "/)."
        , "--"
        , "-- @since base-4.15.0.0"
        , "unicodeVersion :: Version"
        , "unicodeVersion = makeVersion [" <> mkVersion version <> "]" ]
      mkVersion = foldMap (\c -> case c of {'.' -> BB.char7 ',' <> BB.char7 ' '; _ -> BB.char7 c})
  
  --------------------------------------------------------------------------------
  -- Fold
  --------------------------------------------------------------------------------
  
  data Fold a b = forall s. Fold
    { _step :: s -> a -> s
    , _initial :: s
    , _final :: s -> b }
  
  data Pair a b = Pair !a !b
  
  teeWith :: (a -> b -> c) -> Fold x a -> Fold x b -> Fold x c
  teeWith f (Fold stepL initialL finalL) (Fold stepR initialR finalR) =
    Fold step initial final
    where
      step (Pair sL sR) x = Pair (stepL sL x) (stepR sR x)
      initial = Pair initialL initialR
      final (Pair sL sR) = f (finalL sL) (finalR sR)
  
  distribute :: [Fold a b] -> Fold a [b]
  distribute = foldr (teeWith (:)) (Fold const () (const []))
  
  rmapFold :: (b -> c) -> Fold a b -> Fold a c
  rmapFold f (Fold step initial final) = Fold step initial (f . final)
  
  runFold :: Fold a b -> [a] -> b
  runFold (Fold step initial final) = final . foldl' step initial
  
  --------------------------------------------------------------------------------
  -- Modules generators
  --------------------------------------------------------------------------------
  
  data GeneralCategoryAcc = GeneralCategoryAcc
    { _categories :: ![UD.GeneralCategory]
    , _expectedChar :: !Char
    }
  
  genGeneralCategoryModule :: BB.Builder -> Fold UD.Entry BB.Builder
  genGeneralCategoryModule moduleName = Fold step initial done
  
      where
  
      -- (categories, expected char)
      initial = GeneralCategoryAcc [] '\0'
  
      step (GeneralCategoryAcc acc p) e@(UD.Entry r d)
        | p < r.start
        -- Fill missing char entry with default category Cn
        -- See: https://www.unicode.org/reports/tr44/#Default_Values_Table
        = step (GeneralCategoryAcc (replicate (ord r.start - ord p) UD.Cn <> acc) r.start) e
        -- Regular entry
        | otherwise = case r of
          C.SingleChar ch -> GeneralCategoryAcc
            (d.generalCategory : acc)
            (succ ch)
          C.CharRange ch1 ch2 -> GeneralCategoryAcc
            (replicate (ord ch2 - ord ch1 + 1) d.generalCategory <> acc)
            (succ ch2)
  
      done (GeneralCategoryAcc acc _) = generateGeneralCategoryCode mkModuleHeader moduleName 50 (reverse acc)
  
  genSimpleCaseMappingModule
      :: BB.Builder
      -> BB.Builder
      -> (UD.CharDetails -> Maybe Char)
      -> Fold UD.Entry BB.Builder
  genSimpleCaseMappingModule moduleName funcName field =
      Fold step initial done
  
      where
  
      genHeader =
          [ "{-# LANGUAGE NoImplicitPrelude, LambdaCase #-}"
          , "{-# OPTIONS_HADDOCK hide #-}"
          , ""
          , mkModuleHeader moduleName
          , "module " <> moduleName
          , "(" <> funcName <> ")"
          , "where"
          , ""
          , "import GHC.Internal.Base (Char)"
          , ""
          ]
      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 unlinesBB body
  
      mkEntry (UD.Entry r dc) = case r of
        C.SingleChar ch -> field dc <&> \c -> mconcat
          [ "  '\\x"
          , showHexChar ch
          , "' -> '\\x"
          , showHexChar c
          , "'"
          ]
        C.CharRange{} -> field dc $> error ("genSimpleCaseMappingModule: unexpected char range: " <> show r)
  
      showHexChar c = BB.wordHex (fromIntegral (ord c))
  
  data PropertiesAcc = PropertiesAcc
    { _properties :: ![BS.ShortByteString]
    , _bitmaps :: ![BB.Builder]
    , _currentBitmap :: ![[Int]] }
  
  genCorePropertiesModule ::
         BB.Builder -> (BS.ShortByteString -> Bool) -> Fold P.Entry BB.Builder
  genCorePropertiesModule moduleName isProp = Fold step initial done
      where
      prop2FuncName x = "is" <> BB.shortByteString x
  
      initial = PropertiesAcc [] [] []
  
      step acc@(PropertiesAcc props bitmaps bits) P.Entry{..}
        | not (isProp property) = acc -- property filtered out
        | otherwise = case props of
          prop' : _
            | prop' == property -> PropertiesAcc props bitmaps (rangeToBits range : bits)
            | otherwise -> PropertiesAcc
                { _properties = property : props
                , _bitmaps = genBitmap' prop' bits : bitmaps
                , _currentBitmap = [rangeToBits range] }
          _ -> PropertiesAcc [property] bitmaps [rangeToBits range]
  
      rangeToBits = \case
        C.SingleChar ch -> [ord ch]
        C.CharRange ch1 ch2 -> [ord ch1 .. ord ch2]
  
      genBitmap' prop bits = genBitmap (prop2FuncName prop) (mconcat (reverse bits))
  
      done (PropertiesAcc props bitmaps bits) = unlinesBB (header props <> bitmaps')
        where
          lastProp = case props of
            prop : _ -> prop
            [] -> error "impossible"
          bitmaps' = genBitmap' lastProp bits : bitmaps
  
      header exports =
          [ "{-# LANGUAGE NoImplicitPrelude #-}"
          , "{-# LANGUAGE MagicHash #-}"
          , "{-# OPTIONS_HADDOCK hide #-}"
          , ""
          , mkModuleHeader moduleName
          , "module " <> moduleName
          , "(" <> unwordsBB (intersperse "," (map prop2FuncName exports)) <> ")"
          , "where"
          , ""
          , "import GHC.Internal.Base (Bool, Char, Ord(..), (&&), ord)"
          , "import GHC.Internal.Unicode.Bits (lookupBit64)"
          , ""
          ]
  
  --------------------------------------------------------------------------------
  -- Generation
  --------------------------------------------------------------------------------
  
  moduleToFileName :: String -> String
  moduleToFileName = map (\x -> if x == '.' then '/' else x)
  
  dirFromFileName :: String -> String
  dirFromFileName = reverse . dropWhile (/= '/') . reverse
  
  data FileRecipe a
      = ModuleRecipe
        -- ^ A recipe to create a Haskell module file.
          String
          -- ^ Module name
          (BB.Builder -> Fold a BB.Builder)
          -- ^ Function that generate the module, given the module name.
      | TestOutputRecipe
        -- ^ A recipe to create a test output file.
          String
          -- ^ Test name
          (Fold a BB.Builder)
          -- ^ Test output generator
  
  -- ModuleRecipe is a tuple of the module name and a function that generates the
  -- module using the module name
  type ModuleRecipe a = (String, BB.Builder -> Fold a BB.Builder)
  type TestOutputRecipe a = (FilePath, Fold a BB.Builder)
  
  -- GeneratorRecipe is a list of ModuleRecipe
  type GeneratorRecipe a = [FileRecipe a]
  
  moduleFileEmitter :: Maybe FilePath -> FilePath -> ModuleRecipe a -> Fold a (IO ())
  moduleFileEmitter mfile outdir (modName, fldGen) = rmapFold action $ fldGen (BB.string7 modName)
  
      where
  
      pretext version = case mfile of
        Just file -> mconcat
          [ "-- DO NOT EDIT: This file is automatically generated by the internal tool ucd2haskell,\n"
          , "-- with data from: https://www.unicode.org/Public/"
          , BB.string7 version
          , "/ucd/"
          , BB.string7 file
          ,".\n\n"
          ]
        Nothing -> "-- DO NOT EDIT: This file is automatically generated by the internal tool ucd2haskell.\n\n"
      outfile = outdir </> moduleToFileName modName <.> ".hs"
      outfiledir = dirFromFileName outfile
      action c = do
          version <-
              catch
                  (getEnv "UNICODE_VERSION")
                  (\(_ :: IOException) -> return "<unknown>")
          createDirectoryIfMissing True outfiledir
          B.writeFile outfile (BL.toStrict (BB.toLazyByteString (pretext version <> c)))
  
  testOutputFileEmitter :: FilePath -> TestOutputRecipe a -> Fold a (IO ())
  testOutputFileEmitter outdir (name, fldGen) = rmapFold action fldGen
  
      where
  
      outfile = outdir </> "tests" </> name <.> ".stdout"
      outfiledir = dirFromFileName outfile
      action c
          = createDirectoryIfMissing True outfiledir
          *> B.writeFile outfile (BL.toStrict (BB.toLazyByteString c))
  
  runGenerator ::
         FilePath
      -> FilePath
      -> (B.ByteString -> [a])
      -> FilePath
      -> GeneratorRecipe a
      -> IO ()
  runGenerator indir file transformLines outdir recipes = do
      raw <- B.readFile (indir <> file)
      sequence_ (runFold combinedFld (transformLines raw))
  
      where
  
      generatedFolds = recipes <&> \case
        ModuleRecipe     name f -> moduleFileEmitter (Just file) outdir (name, f)
        TestOutputRecipe name f -> testOutputFileEmitter         outdir (name, f)
      combinedFld = distribute generatedFolds
  
  genModules :: FilePath -> FilePath -> [BS.ShortByteString] -> IO ()
  genModules indir outdir props = do
      genUnicodeVersion outdir
  
      runGenerator
          indir
          "UnicodeData.txt"
          UD.parse
          outdir
          [ generalCategory
          , simpleUpperCaseMapping
          , simpleLowerCaseMapping
          , simpleTitleCaseMapping
          ]
  
      runGenerator
          indir
          "DerivedCoreProperties.txt"
          P.parse
          outdir
          [ derivedCoreProperties ]
  
      where
  
      derivedCoreProperties = ModuleRecipe
          "GHC.Internal.Unicode.Char.DerivedCoreProperties"
          (`genCorePropertiesModule` (`elem` props))
  
      generalCategory = ModuleRecipe
           "GHC.Internal.Unicode.Char.UnicodeData.GeneralCategory"
           genGeneralCategoryModule
  
      simpleUpperCaseMapping = ModuleRecipe
           "GHC.Internal.Unicode.Char.UnicodeData.SimpleUpperCaseMapping"
           (\m -> genSimpleCaseMappingModule m "toSimpleUpperCase" UD.simpleUpperCaseMapping)
  
      simpleLowerCaseMapping = ModuleRecipe
           "GHC.Internal.Unicode.Char.UnicodeData.SimpleLowerCaseMapping"
           (\m -> genSimpleCaseMappingModule m "toSimpleLowerCase" UD.simpleLowerCaseMapping)
  
      simpleTitleCaseMapping = ModuleRecipe
           "GHC.Internal.Unicode.Char.UnicodeData.SimpleTitleCaseMapping"
           (\m -> genSimpleCaseMappingModule m "toSimpleTitleCase" UD.simpleTitleCaseMapping)
  