git.iko.soy/streamly
on a05abfc help sign in
streamly/test/Streamly/Test/Unicode/Char.hs
136 lines 4.5 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TupleSections #-}
5-- |
6-- Copyright : (c) 2020 Composewell Technologies
7--
8-- License : BSD-3-Clause
9-- Maintainer : streamly@composewell.com
10-- Stability : experimental
11-- Portability : GHC
12--
14module Streamly.Test.Unicode.Char (main) where
16import Control.Monad (when)
17import Data.Char (chr, isSpace, ord, toUpper)
18import Data.List (intercalate, isPrefixOf)
19#if MIN_VERSION_base(4,8,0)
20import Data.Function ((&))
21#endif
22import Streamly.Internal.Unicode.Char
23 ( NormalizationMode(NFC, NFD, NFKC, NFKD)
24 , normalize
25 )
26import Streamly.Internal.Data.Stream.IsStream (SerialT)
27import Text.Printf (printf)
28import System.FilePath.Posix ((</>))
30import qualified Streamly.Internal.Data.Stream.IsStream as S
31import qualified Streamly.Internal.Data.Fold as FL
32import qualified System.Directory as Dir
34#if !MIN_VERSION_base(4,8,0)
35(&) :: a -> (a -> b) -> b
36x & f = f x
37#endif
39chrToHex :: Char -> [Char]
40chrToHex = map toUpper . printf "%.4x" . ord
42strToHex :: [Char] -> String
43strToHex = unwords . map chrToHex
45type Text = SerialT IO Char
47checkEqual :: String -> (Text -> Text) -> (Text, Text) -> IO Bool
48checkEqual opName op (mc1, mc2) = do
49 c1 <- S.toList mc1
50 c2 <- S.toList mc2
51 opc2 <- S.toList $ op mc2
52 if c1 /= opc2 then do
53 putStrLn $ opName ++ " " ++ strToHex c2
54 ++ " = " ++ strToHex opc2
55 ++ "; Expected: " ++ strToHex c1
56 return False
57 else return True
59checkOp :: String -> NormalizationMode -> [(Text, Text)] -> IO Bool
60checkOp name op pairs = do
61 res <- mapM (checkEqual name (normalize op)) pairs
62 return $ all (== True) res
64checkNFC :: (Text, Text, Text, Text, Text) -> IO Bool
65checkNFC (c1, c2, c3, c4, c5) =
66 checkOp "toNFC" NFC $ map (c2, ) [c1, c2, c3] ++ map (c4, ) [c4, c5]
68checkNFD :: (Text, Text, Text, Text, Text) -> IO Bool
69checkNFD (c1, c2, c3, c4, c5) =
70 checkOp "toNFD" NFD $ map (c3, ) [c1, c2, c3] ++ map (c5, ) [c4, c5]
72checkNFKC :: (Text, Text, Text, Text, Text) -> IO Bool
73checkNFKC (c1, c2, c3, c4, c5) =
74 checkOp "toNFKC" NFKC $ map (c4,) [c1, c2, c3, c4, c5]
76checkNFKD :: (Text, Text, Text, Text, Text) -> IO Bool
77checkNFKD (c1, c2, c3, c4, c5) =
78 checkOp "toNFKD" NFKD $ map (c5,) [c1, c2, c3, c4, c5]
80checkAllTestCases :: Int -> String -> IO ()
81checkAllTestCases lineno line = do
82 cs <- S.toList $ S.splitOn (== ';') FL.toList $ S.fromList line
83 case cs of
84 c1 : c2 : c3 : c4 : c5 : _ -> do
85 let cps = map cpToText [c1, c2, c3, c4, c5]
86 mapM_ (checkOneTestCase cps)
87 [checkNFD, checkNFKD, checkNFC, checkNFKC]
88 _ -> error $ "Unrecognized line: " ++ line
89 where
90 cpToText xs = S.fromList $ map (chr . read . ("0x" ++)) (words xs)
92 checkOneTestCase cps f = do
93 res <- f (tuplify cps)
94 when (not res) $ do
95 strs <- mapM S.toList cps
96 let codes = intercalate ";" $ map strToHex strs
97 txt = intercalate "; " strs
98 putStrLn ("Failed at line: " ++ show lineno)
99 putStrLn line
100 putStrLn $ codes ++ "; # (" ++ txt
101 error "Bailing out"
103 tuplify [c1, c2, c3, c4, c5] = (c1, c2, c3, c4, c5)
104 tuplify _ = error "tuplify bad arguments"
106checkLine :: (Int, String) -> IO ()
107checkLine (lineno, line) = do
108 -- marker lines indicating a test block start with @
109 if "@" `isPrefixOf` line
110 then
111 putStrLn line
112 else
113 checkAllTestCases lineno line
115testNormalize :: FilePath -> IO ()
116testNormalize file = do
117 contents <- readFile file
118 let ls = lines contents -- split into lines
119 & map (dropWhile isSpace) -- trim leading spaces
120 & zip [1..] -- add numbering
121 & filter (not . null . snd) -- remove blank lines
122 & filter (not . ("#" `isPrefixOf`) . snd) -- remove comments
123 checkAll ls
124 where
125 checkAll (x:xs) = checkLine x >> checkAll xs
126 checkAll [] = return ()
128filesDir :: String
129filesDir = "test/Streamly/Test/Unicode"
131main :: IO ()
132main = do
133 cdir <- Dir.getCurrentDirectory
134 testNormalize $ cdir </> filesDir </> "ucd/NormalizationTest.txt"
135 -- Additional test cases not in the unicode standard suite
136 testNormalize $ cdir </> filesDir </> "extra/NormalizationTest.txt"