scripts/SpecialCasing.hs · text

text/scripts/SpecialCasing.hs

50 lines 1.6 kB history raw

1-- This script processes the following source file:

2--

3-- http://unicode.org/Public/UNIDATA/SpecialCasing.txt

5module SpecialCasing

6 (

7 Case(..)

8 , parseSC

9 , mapSC

10 ) where

12import Arsec

14data Case = Case {

15 code :: Char

16 , lower :: [Char]

17 , title :: [Char]

18 , upper :: [Char]

19 , conditions :: String

20 , name :: String

21 } deriving (Eq, Ord, Show)

23entries :: Parser [Case]

24entries = many comment *> many (entry <* many comment)

25 where

26 entry = Case <$> unichar <* semi

27 <*> unichars

28 <*> unichars

29 <*> unichars

30 <*> manyTill anyToken (string "# ")

31 <*> manyTill anyToken (char '\n')

33parseSC :: FilePath -> IO (Either ParseError [Case])

34parseSC name = parse entries name <$> readFile name

36mapSC :: String -> (Case -> String) -> (Char -> Char) -> [Case] -> [String]

37mapSC which access twiddle ms = typ ++ (map nice . filter p $ ms) ++ [last]

38 where

39 typ = [which ++ "Mapping :: forall s. Char -> s -> Step (CC s) Char"

40 ,"{-# INLINE " ++ which ++ "Mapping #-}"]

41 last = which ++ "Mapping c s = Yield (to" ++ ucFirst which ++ " c) (CC s '\\0' '\\0')"

42 nice c = "-- " ++ name c ++ "\n" ++

43 which ++ "Mapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (CC s " ++ y ++ " " ++ z ++ ")"

44 where [x,y,z] = (map showC . take 3) (access c ++ repeat '\0')

45 p c = [k] /= a && a /= [twiddle k] && null (conditions c)

46 where a = access c

47 k = code c

49ucFirst (c:cs) = toUpper c : cs

50ucFirst [] = []