text / 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

instance Applicative (GenParser s a) where
    pure = return
    (<*>) = ap
    
instance Alternative (GenParser s a) where
    empty = mzero
    (<|>) = mplus

data Case = Case {
      code :: Char
    , lower :: [Char]
    , title :: [Char]
    , upper :: [Char]
    , conditions :: String
    , name :: String
    } deriving (Eq, Ord, Show)

entries :: Parser [Case]
entries = many comment *> many (entry <* many comment)
  where
    entry = Case <$> unichar <* semi
                 <*> unichars
                 <*> unichars
                 <*> 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

mapFunc 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 #-}"]
    last = which ++ "Mapping c s = Yield (to" ++ ucFirst which ++ " c) (s :!: '\\0' :!: '\\0')"
    nice c = "-- " ++ name c ++ "\n" ++
             which ++ "Mapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (s :!: " ++ y ++ " :!: " ++ z ++ ")"
       where [x,y,z] = (map showC . take 3) (access c ++ repeat '\0')
    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
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.