Experiment with case conversions

haskell · Aug 22, 2021 · cd45807 · cd45807
1 parent 730cbf6
commit cd45807
Show file tree

Hide file tree

Showing 6 changed files with 814 additions and 781 deletions.
diff --git a/scripts/CaseFolding.hs b/scripts/CaseFolding.hs
@@ -11,6 +11,7 @@ module CaseFolding
     ) where
 
 import Arsec
+import Data.Bits
 
 data Fold = Fold {
       code :: Char
@@ -36,11 +37,12 @@ parseCF name = parse entries name <$> readFile name
 mapCF :: CaseFolding -> [String]
 mapCF (CF _ ms) = typ ++ (map nice . filter p $ ms) ++ [last]
   where
-    typ = ["foldMapping :: forall s. Char -> s -> Step (CC s) Char"
-           ,"{-# NOINLINE foldMapping #-}"]
-    last = "foldMapping c s = Yield (toLower c) (CC s '\\0' '\\0')"
-    nice c = "-- " ++ name c ++ "\n" ++
-             "foldMapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (CC s " ++ y ++ " " ++ z ++ ")"
-       where [x,y,z] = (map showC . take 3) (mapping c ++ repeat '\0')
+    typ = ["foldMapping :: Char# -> _"
+           ,"{-# NOINLINE foldMapping #-}"
+           ,"foldMapping = \\case"]
+    last = "  _ -> unI64 0"
+    nice 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)]
diff --git a/scripts/CaseMapping.hs b/scripts/CaseMapping.hs
@@ -22,14 +22,17 @@ main = do
   let comments = map ("--" ++) $
                  take 2 (cfComments cfs) ++ take 2 (scComments scs)
   mapM_ (hPutStrLn h) $
-                      ["{-# LANGUAGE Rank2Types #-}"
-                      ,"-- AUTOMATICALLY GENERATED - DO NOT EDIT"
+                      ["-- AUTOMATICALLY GENERATED - DO NOT EDIT"
                       ,"-- Generated by scripts/CaseMapping.hs"] ++
                       comments ++
                       [""
+                      ,"{-# LANGUAGE LambdaCase, MagicHash, PartialTypeSignatures #-}"
+                      ,"{-# OPTIONS_GHC -Wno-partial-type-signatures #-}"
                       ,"module Data.Text.Internal.Fusion.CaseMapping where"
-                      ,"import Data.Char"
-                      ,"import Data.Text.Internal.Fusion.Types"
+                      ,"import GHC.Int"
+                      ,"import GHC.Exts"
+                      ,"unI64 :: Int64 -> _"
+                      ,"unI64 (I64# n) = n"
                       ,""]
   mapM_ (hPutStrLn h) (mapSC "upper" upper toUpper scs)
   mapM_ (hPutStrLn h) (mapSC "lower" lower toLower scs)

diff --git a/scripts/SpecialCasing.hs b/scripts/SpecialCasing.hs
@@ -11,6 +11,7 @@ module SpecialCasing
     ) where
 
 import Arsec
+import Data.Bits
 
 data SpecialCasing = SC { scComments :: [Comment], scCasing :: [Case] }
                    deriving (Show)
@@ -42,12 +43,13 @@ mapSC :: String -> (Case -> String) -> (Char -> Char) -> SpecialCasing
 mapSC which access twiddle (SC _ ms) =
     typ ++ (map nice . filter p $ ms) ++ [last]
   where
-    typ = [which ++ "Mapping :: forall s. Char -> s -> Step (CC s) Char"
-           ,"{-# NOINLINE " ++ which ++ "Mapping #-}"]
-    last = which ++ "Mapping c s = Yield (to" ++ ucFirst which ++ " c) (CC s '\\0' '\\0')"
-    nice c = "-- " ++ name c ++ "\n" ++
-             which ++ "Mapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (CC s " ++ y ++ " " ++ z ++ ")"
-       where [x,y,z] = (map showC . take 3) (access c ++ repeat '\0')
+    typ = [which ++ "Mapping :: Char# -> _"
+           ,"{-# NOINLINE " ++ which ++ "Mapping #-}"
+           ,which ++ "Mapping = \\case"]
+    last = "  _ -> unI64 0"
+    nice 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