Fix CaseMapping generation script to not depend on GHC's Unicode data

Author: Lysxia

scripts/Arsec.hs

@@ -8,7 +8,6 @@ module Arsec
     , unichars
     , module Control.Applicative
     , module Control.Monad
-    , module Data.Char
     , module Text.ParserCombinators.Parsec.Char
     , module Text.ParserCombinators.Parsec.Combinator
     , module Text.ParserCombinators.Parsec.Error

scripts/CaseFolding.hs

@@ -12,6 +12,7 @@ module CaseFolding
 
 import Arsec
 import Data.Bits
+import Data.Char (ord)
 
 data Fold = Fold {
       code :: Char

scripts/CaseMapping.hs

@@ -1,3 +1,5 @@
+import Data.Char (isDigit)
+import Data.Foldable (toList)
 import Data.List (stripPrefix)
 import Data.Maybe (fromJust)
 import System.Environment
@@ -6,6 +8,7 @@ import System.IO
 import Arsec
 import CaseFolding
 import SpecialCasing
+import UnicodeData
 
 main = do
   args <- getArgs
@@ -14,12 +17,16 @@ main = do
                 [o] -> o
   psc <- parseSC "SpecialCasing.txt"
   pcf <- parseCF "CaseFolding.txt"
+  ud <- parseUD "UnicodeData.txt"
   scs <- case psc of
            Left err -> print err >> return undefined
            Right ms -> return ms
   cfs <- case pcf of
            Left err -> print err >> return undefined
            Right ms -> return ms
+  ud <- case ud of
+           Left err -> print err >> return undefined
+           Right ms -> return ms
   h <- openFile oname WriteMode
   let comments = map ("--" ++) $
                  take 2 (cfComments cfs) ++ take 2 (scComments scs)
@@ -40,9 +47,10 @@ main = do
                       ,"unI64 :: Int64 -> _ {- unboxed Int64 -}"
                       ,"unI64 (I64# n) = n"
                       ,""]
-  mapM_ (hPutStrLn h) (mapSC "upper" upper toUpper scs)
-  mapM_ (hPutStrLn h) (mapSC "lower" lower toLower scs)
-  mapM_ (hPutStrLn h) (mapSC "title" title toTitle scs)
+  let get f = [(k, d) | c <- toList ud, Just d <- [f c], let k = charUD c, k /= d]
+  mapM_ (hPutStrLn h) (mapSC "upper" upper (get toUpperUD) scs)
+  mapM_ (hPutStrLn h) (mapSC "lower" lower (get toLowerUD) scs)
+  mapM_ (hPutStrLn h) (mapSC "title" title (get toTitleUD) scs)
   mapM_ (hPutStrLn h) (mapCF cfs)
   hClose h
 

scripts/SpecialCasing.hs

@@ -12,6 +12,7 @@ module SpecialCasing
 
 import Arsec
 import Data.Bits
+import Data.Char (ord)
 
 data SpecialCasing = SC { scComments :: [Comment], scCasing :: [Case] }
                    deriving (Show)
@@ -38,17 +39,17 @@ entries = SC <$> many comment <*> many (entry <* many comment)
 parseSC :: FilePath -> IO (Either ParseError SpecialCasing)
 parseSC name = parse entries name <$> readFile name
 
-mapSC :: String -> (Case -> String) -> (Char -> Char) -> SpecialCasing
+mapSC :: String -> (Case -> String) -> [(Char, Char)] -> SpecialCasing
          -> [String]
 mapSC which access twiddle (SC _ ms) =
     typ ++ map printUnusual ms' ++ map printUsual usual ++ [last]
   where
     ms' = filter p ms
-    p c = [k] /= a && a /= [twiddle k] && null (conditions c)
+    p c = [k] /= a && null (conditions c)
         where a = access c
               k = code c
     unusual = map code ms'
-    usual = filter (\c -> twiddle c /= c && c `notElem` unusual) [minBound..maxBound]
+    usual = filter (\(c, _) -> c `notElem` unusual) twiddle
 
     typ = [which ++ "Mapping :: Char# -> _ {- unboxed Int64 -}"
            ,"{-# NOINLINE " ++ which ++ "Mapping #-}"
@@ -57,7 +58,4 @@ mapSC which access twiddle (SC _ ms) =
     printUnusual c = "  -- " ++ name c ++ "\n" ++
              "  " ++ showC (code c) ++ "# -> unI64 " ++ show (ord x + (ord y `shiftL` 21) + (ord z `shiftL` 42))
        where x:y:z:_ = access c ++ repeat '\0'
-    printUsual c = "  " ++ showC c ++ "# -> unI64 " ++ show (ord (twiddle c))
-
-ucFirst (c:cs) = toUpper c : cs
-ucFirst [] = []
+    printUsual (c, c') = "  " ++ showC c ++ "# -> unI64 " ++ show (ord c')

scripts/UnicodeData.hs

@@ -0,0 +1,51 @@
+-- This script processes the following source file:
+--
+--   http://unicode.org/Public/UNIDATA/UnicodeData.txt
+--
+-- Format description: https://www.unicode.org/reports/tr44/tr44-36.html#UnicodeData.txt
+
+module UnicodeData
+    ( UnicodeData
+    , Data(..)
+    , toTitleUD
+    , parseUD
+    ) where
+
+import Debug.Trace
+import Arsec hiding (semi)
+import Data.Array
+import Data.Functor (void)
+import Data.List (sort)
+import Data.Maybe (fromMaybe)
+
+type UnicodeData = Array Int Data
+
+-- "Simple_Titlecase_Mapping: If this field is null, then the Simple_Titlecase_Mapping
+-- is the same as the Simple_Uppercase_Mapping for this character."
+-- -- https://www.unicode.org/reports/tr44/tr44-36.html#UnicodeData.txt
+toTitleUD :: Data -> Maybe Char
+toTitleUD d = toTitleUD_ d <|> toUpperUD d
+
+data Data = Data {
+      charUD :: {-# UNPACK #-} !Char
+    , toUpperUD :: {-# UNPACK #-} !(Maybe Char)
+    , toLowerUD :: {-# UNPACK #-} !(Maybe Char)
+    , toTitleUD_ :: {-# UNPACK #-} !(Maybe Char)
+    } deriving (Eq, Ord, Show)
+
+-- I'm pretty sure UnicodeData.txt is sorted but still sort it to be 100% certain.
+entries :: Parser UnicodeData
+entries = (\xs -> listArray (0, length xs - 1) xs) <$> many entry <* eof
+  where
+    entry = Data <$> unichar <* semi
+                <* replicateM_ 11 (ignoreField <* semi)
+                <*> optional unichar <* semi
+                <*> optional unichar <* semi
+                <*> optional unichar <* char '\n'
+    semi = char ';'
+
+ignoreField :: Parser ()
+ignoreField = void (many (satisfy (\c -> c /= ';')))
+
+parseUD :: FilePath -> IO (Either ParseError UnicodeData)
+parseUD name = parse entries name <$> readFile name

scripts/regenerate.sh

@@ -1,7 +1,7 @@
 #!/bin/bash
-set -eu
+set -exu
 cd "${BASH_SOURCE%/*}/"
-wget http://www.unicode.org/Public/UCD/latest/ucd/SpecialCasing.txt http://www.unicode.org/Public/UCD/latest/ucd/CaseFolding.txt
-runghc-9.12 CaseMapping
-rm SpecialCasing.txt CaseFolding.txt
+wget http://www.unicode.org/Public/UCD/latest/ucd/SpecialCasing.txt http://www.unicode.org/Public/UCD/latest/ucd/CaseFolding.txt http://www.unicode.org/Public/UCD/latest/ucd/UnicodeData.txt
+runghc CaseMapping
+rm SpecialCasing.txt CaseFolding.txt UnicodeData.txt
 cd -