scripts/CaseFolding.hs · text

text/scripts/CaseFolding.hs

42 lines 1.3 kB history raw

1-- This script processes the following source file:

2--

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

5module CaseFolding

6 (

7 Fold(..)

8 , parseCF

9 , mapCF

10 ) where

12import Arsec

14data Fold = Fold {

15 code :: Char

16 , status :: Char

17 , mapping :: [Char]

18 , name :: String

19 } deriving (Eq, Ord, Show)

21entries :: Parser [Fold]

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

23 where

24 entry = Fold <$> unichar <* semi

25 <*> oneOf "CFST" <* semi

26 <*> unichars

27 <*> (string "# " *> manyTill anyToken (char '\n'))

29parseCF :: FilePath -> IO (Either ParseError [Fold])

30parseCF name = parse entries name <$> readFile name

32mapCF :: [Fold] -> [String]

33mapCF ms = typ ++ (map nice . filter p $ ms) ++ [last]

34 where

35 typ = ["foldMapping :: forall s. Char -> s -> Step (PairS (PairS s Char) Char) Char"

36 ,"{-# INLINE foldMapping #-}"]

37 last = "foldMapping c s = Yield (toLower c) (s :!: '\\0' :!: '\\0')"

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

39 "foldMapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (s :!: " ++ y ++ " :!: " ++ z ++ ")"

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

41 p f = status f `elem` "CF" &&

42 mapping f /= [toLower (code f)]