Source

text / scripts / SpecialCasing.hs

Diff from to

File scripts/SpecialCasing.hs

-import Control.Applicative
-import Control.Monad
-import Data.Char
-import Numeric
-import System.Environment
-import System.IO
-import Text.ParserCombinators.Parsec hiding (many, optional, upper, lower, (<|>))
-import Text.ParserCombinators.Parsec.Combinator
+-- This script processes the following source file:
+--
+--   http://unicode.org/Public/UNIDATA/SpecialCasing.txt
 
-instance Applicative (GenParser s a) where
-    pure = return
-    (<*>) = ap
-    
-instance Alternative (GenParser s a) where
-    empty = mzero
-    (<|>) = mplus
+module SpecialCasing
+    (
+      Case(..)
+    , parseSC
+    , mapSC
+    ) where
+
+import Arsec
 
 data Case = Case {
       code :: Char
                  <*> unichars
                  <*> manyTill anyToken (string "# ")
                  <*> manyTill anyToken (char '\n')
-    unichar = chr . fst . head . readHex <$> replicateM 4 (satisfy isHexDigit)
-    unichars = manyTill (unichar <* spaces) semi
-    semi = char ';' *> spaces *> pure ()
-    comment = (char '#' *> manyTill anyToken (char '\n')) <|> string "\n"
 
-parseFile :: FilePath -> IO (Either ParseError [Case])
-parseFile name = parse entries name <$> readFile name
+parseSC :: FilePath -> IO (Either ParseError [Case])
+parseSC name = parse entries name <$> readFile name
 
-mapFunc which access twiddle ms = typ ++ (map nice . filter p $ ms) ++ [last]
+mapSC :: String -> (Case -> String) -> (Char -> Char) -> [Case] -> [String]
+mapSC which access twiddle ms = typ ++ (map nice . filter p $ ms) ++ [last]
   where
     typ = [which ++ "Mapping :: forall s. Char -> s -> Step (PairS (PairS s Char) Char) Char"
            ,"{-# INLINE " ++ which ++ "Mapping #-}"]
     p c = [k] /= a && a /= [twiddle k] && null (conditions c)
         where a = access c
               k = code c
-    showC c = "'\\x" ++ d ++ "'"
-        where h = showHex (ord c) ""
-              d = replicate (4 - length h) '0' ++ h
 
 ucFirst (c:cs) = toUpper c : cs
 ucFirst [] = []
-
-main = do
-  args <- getArgs
-  let (iname, oname) = case args of
-                         [] -> ("SpecialCasing.txt", "CaseMapping.hs")
-                         [i] -> (i, "CaseMapping.hs")
-                         [i,o] -> (i,o)
-  p <- parseFile iname
-  ms <- case p of
-          Left err -> print err >> return undefined
-          Right ms -> return ms
-  h <- openFile oname WriteMode
-  mapM_ (hPutStrLn h) ["{-# LANGUAGE Rank2Types #-}"
-                      ,"-- AUTOMATICALLY GENERATED - DO NOT EDIT"
-                      ,"-- Generated by scripts/SpecialCasing.hs"
-                      ,"module Data.Text.Fusion.CaseMapping where"
-                      ,"import Data.Char"
-                      ,"import Data.Text.Fusion.Internal"
-                      ,""]
-  mapM_ (hPutStrLn h) (mapFunc "upper" upper toUpper ms)
-  mapM_ (hPutStrLn h) (mapFunc "lower" lower toLower ms)
-  hClose h