Generate full paradigm for case conversions, GHC is extremely good at compiling huge cases

Author: Bodigrim

scripts/CaseFolding.hs

@@ -35,14 +35,19 @@ parseCF :: FilePath -> IO (Either ParseError CaseFolding)
 parseCF name = parse entries name <$> readFile name
 
 mapCF :: CaseFolding -> [String]
-mapCF (CF _ ms) = typ ++ (map nice . filter p $ ms) ++ [last]
+mapCF (CF _ ms) = typ ++ map printUnusual ms' ++ map printUsual usual ++ [last]
  where
+ ms' = filter p ms
+ p f = status f `elem` "CF" &&
+ mapping f /= [toLower (code f)]
+ unusual = map code ms'
+ usual = filter (\c -> toLower c /= c && c `notElem` unusual) [minBound..maxBound]
+
  typ = ["foldMapping :: Char# -> _"
  ,"{-# NOINLINE foldMapping #-}"
  ,"foldMapping = \\case"]
  last = " _ -> unI64 0"
- nice c = " -- " ++ name c ++ "\n" ++
+ printUnusual c = " -- " ++ name c ++ "\n" ++
  " " ++ showC (code c) ++ "# -> unI64 " ++ show (ord x + (ord y `shiftL` 21) + (ord z `shiftL` 42))
  where x:y:z:_ = mapping c ++ repeat '\0'
- p f = status f `elem` "CF" &&
- mapping f /= [toLower (code f)]
+ printUsual c = " " ++ showC c ++ "# -> unI64 " ++ show (ord (toLower c))

scripts/SpecialCasing.hs

@@ -41,18 +41,23 @@ parseSC name = parse entries name <$> readFile name
 mapSC :: String -> (Case -> String) -> (Char -> Char) -> SpecialCasing
  -> [String]
 mapSC which access twiddle (SC _ ms) =
- typ ++ (map nice . filter p $ ms) ++ [last]
+ typ ++ map printUnusual ms' ++ map printUsual usual ++ [last]
  where
+ ms' = filter p ms
+ p c = [k] /= a && a /= [twiddle k] && 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]
+
  typ = [which ++ "Mapping :: Char# -> _"
  ,"{-# NOINLINE " ++ which ++ "Mapping #-}"
  ,which ++ "Mapping = \\case"]
  last = " _ -> unI64 0"
- nice c = " -- " ++ name c ++ "\n" ++
+ 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'
- p c = [k] /= a && a /= [twiddle k] && null (conditions c)
- where a = access c
- k = code c
+ printUsual c = " " ++ showC c ++ "# -> unI64 " ++ show (ord (twiddle c))
 
 ucFirst (c:cs) = toUpper c : cs
 ucFirst [] = []