git.iko.soy/text
on master help sign in
text/scripts/SpecialCasing.hs
56 lines 1.8 kB history raw
1-- This script processes the following source file:
2--
3-- http://unicode.org/Public/UNIDATA/SpecialCasing.txt
5module SpecialCasing
6 (
7 SpecialCasing(..)
8 , Case(..)
9 , parseSC
10 , mapSC
11 ) where
13import Arsec
15data SpecialCasing = SC { scComments :: [Comment], scCasing :: [Case] }
16 deriving (Show)
18data Case = Case {
19 code :: Char
20 , lower :: [Char]
21 , title :: [Char]
22 , upper :: [Char]
23 , conditions :: String
24 , name :: String
25 } deriving (Eq, Ord, Show)
27entries :: Parser SpecialCasing
28entries = SC <$> many comment <*> many (entry <* many comment)
29 where
30 entry = Case <$> unichar <* semi
31 <*> unichars
32 <*> unichars
33 <*> unichars
34 <*> manyTill anyToken (string "# ")
35 <*> manyTill anyToken (char '\n')
37parseSC :: FilePath -> IO (Either ParseError SpecialCasing)
38parseSC name = parse entries name <$> readFile name
40mapSC :: String -> (Case -> String) -> (Char -> Char) -> SpecialCasing
41 -> [String]
42mapSC which access twiddle (SC _ ms) =
43 typ ++ (map nice . filter p $ ms) ++ [last]
44 where
45 typ = [which ++ "Mapping :: forall s. Char -> s -> Step (CC s) Char"
46 ,"{-# NOINLINE " ++ which ++ "Mapping #-}"]
47 last = which ++ "Mapping c s = Yield (to" ++ ucFirst which ++ " c) (CC s '\\0' '\\0')"
48 nice c = "-- " ++ name c ++ "\n" ++
49 which ++ "Mapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (CC s " ++ y ++ " " ++ z ++ ")"
50 where [x,y,z] = (map showC . take 3) (access c ++ repeat '\0')
51 p c = [k] /= a && a /= [twiddle k] && null (conditions c)
52 where a = access c
53 k = code c
55ucFirst (c:cs) = toUpper c : cs
56ucFirst [] = []