{-

Compile: ghc -O2 -W -Wall unicode_groups.hs

This program is a test generator for re2c's support of Unicode encodings.
It generates two kinds of tests:

1) Multiple tests for Unicode categories (like uppercase letters, space
   modifiers, etc.). We cannot test all categories in one file because they
   overlap.

2) Single test for Unicode blocks (like Basic Latin, Hangul, Arabian, etc.).
   These blocks do not overlap, so we can generate one test for all of them.

All tests have the same structure: re2c block for Unicode range is tested on
encoded bytestring, which contains all Unicode runes from this range and ends
with another Unicode rune.

In case of success, generated program runs silently, otherwise it outputs error
to stdout in form "test 'XXX' failed".

-}

import           Data.Char                           (ord, isAlpha)
import qualified Data.CharSet                  as CS (fromCharSet, toAscList, union, empty, complement)
import           Data.CharSet                  as CS (CharSet)
import           Data.CharSet.Unicode.Category       (Category(..), categories)
import           Data.CharSet.Unicode.Block          (Block(..), blocks)
import qualified Data.IntSet                   as IS (foldl')
import qualified Data.List                     as L  (foldl', intercalate)
import           Data.Sort                           (sortBy)
import           Text.Printf                         (printf)


show_int :: Int -> String
show_int c = case c of
    _ | c < 0xFF   -> printf "\\x%02x" c
    _ | c < 0xFFFF -> printf "\\u%04x" c
    _              -> printf "\\U%08x" c


show_range_re2c :: (Int, Int) -> String
show_range_re2c (l, h) = concat
    [ show_int l
    , "-"
    , show_int h
    ]


show_range_c :: (Int, Int) -> String
show_range_c (l, h) = printf "0x%x,0x%x" l h


take_range :: [(Int, Int)] -> Int -> [(Int, Int)]
take_range [] c = [(c, c)]
take_range ((l, h) : xs) c =
    if c == h + 1
        then (l, c) : xs
        else (c, c) : (l, h) : xs


group_charset :: CharSet -> [(Int, Int)]
group_charset cs =
    ( reverse
    . IS.foldl' take_range []
    . snd
    . CS.fromCharSet
    ) cs


show_charset :: CharSet -> (String, String)
show_charset cs =
    let groups = group_charset cs
        last_char = ord $ outer cs
        groups' = groups ++ [(last_char, last_char)]
        s_re2c = "[" ++ concatMap show_range_re2c groups ++ "]"
        s_c = "{" ++ L.intercalate ",  " (map show_range_c groups') ++ "}"
    in  (s_re2c, s_c)


prettify :: String -> String
prettify = map (\ c -> if isAlpha c then c else '_')


outer :: CharSet -> Char
outer cs = head $ CS.toAscList $ CS.complement cs


encode_function_utf8 :: (String, String)
encode_function_utf8 = ("encode_utf8", unlines
    [ "static unsigned int encode_utf8 (const unsigned int * ranges, unsigned int ranges_count, unsigned int * s)"
    , "{"
    , "\tunsigned int * const s_start = s;"
    , "\tfor (unsigned int i = 0; i < ranges_count - 2; i += 2)"
    , "\t\tfor (unsigned int j = ranges[i]; j <= ranges[i + 1]; ++j)"
    , "\t\t\ts += re2c::utf8::rune_to_bytes (s, j);"
    , "\tre2c::utf8::rune_to_bytes (s, ranges[ranges_count - 1]);"
    , "\treturn s - s_start + 1;"
    , "}"
    ])


encode_function_utf16 :: (String, String)
encode_function_utf16 = ("encode_utf16", unlines
    [ "static unsigned int encode_utf16 (const unsigned int * ranges, unsigned int ranges_count, unsigned int * s)"
    , "{"
    , "\tunsigned int * const s_start = s;"
    , "\tfor (unsigned int i = 0; i < ranges_count; i += 2)"
    , "\t\tfor (unsigned int j = ranges[i]; j <= ranges[i + 1]; ++j)"
    , "\t\t{"
    , "\t\t\tif (j <= re2c::utf16::MAX_1WORD_RUNE)"
    , "\t\t\t\t*s++ = j;"
    , "\t\t\telse"
    , "\t\t\t{"
    , "\t\t\t\t*s++ = re2c::utf16::lead_surr(j);"
    , "\t\t\t\t*s++ = re2c::utf16::trail_surr(j);"
    , "\t\t\t}"
    , "\t\t}"
    , "\treturn s - s_start;"
    , "}"
    ])


encode_function_utf32 :: (String, String)
encode_function_utf32 = ("encode_utf32", unlines
    [ "static unsigned int encode_utf32 (const unsigned int * ranges, unsigned int ranges_count, unsigned int * s)"
    , "{"
    , "\tunsigned int * const s_start = s;"
    , "\tfor (unsigned int i = 0; i < ranges_count; i += 2)"
    , "\t\tfor (unsigned int j = ranges[i]; j <= ranges[i + 1]; ++j)"
    , "\t\t\t*s++ = j;"
    , "\treturn s - s_start;"
    , "}"
    ])


gen_categories :: [Category] -> IO ()
gen_categories cats =
    let f :: Category -> String
        f (Category _ name charset _) =
            let name' = prettify name
                (charset', _) = show_charset charset
            in name' ++ " = " ++ charset' ++ ";"

        less (Category _ x _ _) (Category _ y _ _) = compare x y
        content = unlines $ ["/*!re2c"] ++ (map f . sortBy less) cats ++ ["*/"]

    in  writeFile "unicode_categories.re.inc" content


gen_test_category :: Category -> IO ()
gen_test_category (Category _ name cs _) =
    let catname = prettify name

        file8_ignore      = "unicode_group_" ++ catname ++ "_8_encoding_policy_ignore.re"
        file8_substitute  = "unicode_group_" ++ catname ++ "_8_encoding_policy_substitute.re"
        file8_fail        = "unicode_group_" ++ catname ++ "_8_encoding_policy_fail.re"
        file16_ignore     = "unicode_group_" ++ catname ++ "_x_encoding_policy_ignore.re"
        file16_substitute = "unicode_group_" ++ catname ++ "_x_encoding_policy_substitute.re"
        file16_fail       = "unicode_group_" ++ catname ++ "_x_encoding_policy_fail.re"
        file32_ignore     = "unicode_group_" ++ catname ++ "_u_encoding_policy_ignore.re"
        file32_substitute = "unicode_group_" ++ catname ++ "_u_encoding_policy_substitute.re"
        file32_fail       = "unicode_group_" ++ catname ++ "_u_encoding_policy_fail.re"

        opt8_ignore      = "// re2c $INPUT -o $OUTPUT -8 --encoding-policy ignore"
        opt8_substitute  = "// re2c $INPUT -o $OUTPUT -8 --encoding-policy substitute"
        opt8_fail        = "// re2c $INPUT -o $OUTPUT -8 --encoding-policy fail"
        opt16_ignore     = "// re2c $INPUT -o $OUTPUT -x --encoding-policy ignore"
        opt16_substitute = "// re2c $INPUT -o $OUTPUT -x --encoding-policy substitute"
        opt16_fail       = "// re2c $INPUT -o $OUTPUT -x --encoding-policy fail"
        opt32_ignore     = "// re2c $INPUT -o $OUTPUT -u --encoding-policy ignore"
        opt32_substitute = "// re2c $INPUT -o $OUTPUT -u --encoding-policy substitute"
        opt32_fail       = "// re2c $INPUT -o $OUTPUT -u --encoding-policy fail"

        include_utf8  = "#include \"utf8.h\""
        include_utf16 = "#include \"utf16.h\""
        include_utf32 = ""

        (charset_re2c, charset_c) = show_charset cs
        charset_size = (length $ CS.toAscList cs) + 1 -- +1 for outer symbol
        charset_size_utf8  = show $ charset_size * 4
        charset_size_utf16 = show $ charset_size * 2
        charset_size_utf32 = show $ charset_size
        charset_c_name = "chars_" ++ catname
        buffer = "buffer_" ++ catname

        content ctype opt include sz_charset (ef_name, ef_body) = unlines
            [ opt
            , "#include <stdio.h>"
            , include
            , "#define YYCTYPE " ++ ctype
            , "bool scan(const YYCTYPE * start, const YYCTYPE * const limit)"
            , "{"
            , "\t__attribute__((unused)) const YYCTYPE * YYMARKER; // silence compiler warnings when YYMARKER is not used"
            , "#\tdefine YYCURSOR start"
            , catname ++ ":"
            , "\t/*!re2c"
            , "\t\tre2c:yyfill:enable = 0;"
            , "\t\t" ++ catname ++ " = " ++ charset_re2c ++ ";"
            , "\t\t" ++ catname ++ " { goto " ++ catname ++ "; }"
            , "\t\t* { return YYCURSOR == limit; }"
            , "\t*/"
            , "}"
            , "static const unsigned int " ++ charset_c_name ++ " [] = " ++ charset_c ++ ";"
            , ef_body
            , "int main ()"
            , "{"
            , "\tunsigned int * " ++ buffer ++ " = new unsigned int [" ++ sz_charset ++ "];"
            , "\tYYCTYPE * s = (YYCTYPE *) " ++ buffer ++ ";"
            , "\tunsigned int buffer_len = " ++ ef_name ++ " ("
                ++ charset_c_name ++ ", "
                ++ "sizeof (" ++ charset_c_name ++ ") / sizeof (unsigned int)" ++ ", "
                ++ buffer ++ ");"
            , "\t/* convert 32-bit code units to YYCTYPE; reuse the same buffer */"
            , "\tfor (unsigned int i = 0; i < buffer_len; ++i) s[i] = " ++ buffer ++ "[i];"
            , "\tif (!scan (s, s + buffer_len))"
            , "\t\tprintf(\"test '" ++ catname ++ "' failed\\n\");"
            , "\tdelete [] " ++ buffer ++ ";"
            , "\treturn 0;"
            , "}"
            ]

    in  writeFile file8_ignore      (content "unsigned char"  opt8_ignore      include_utf8  charset_size_utf8  encode_function_utf8) >>
        writeFile file8_substitute  (content "unsigned char"  opt8_substitute  include_utf8  charset_size_utf8  encode_function_utf8) >>
        writeFile file8_fail        (content "unsigned char"  opt8_fail        include_utf8  charset_size_utf8  encode_function_utf8) >>

        writeFile file16_ignore     (content "unsigned short" opt16_ignore     include_utf16 charset_size_utf16 encode_function_utf16) >>
        writeFile file16_substitute (content "unsigned short" opt16_substitute include_utf16 charset_size_utf16 encode_function_utf16) >>
        writeFile file16_fail       (content "unsigned short" opt16_fail       include_utf16 charset_size_utf16 encode_function_utf16) >>

        writeFile file32_ignore     (content "unsigned int"   opt32_ignore     include_utf32 charset_size_utf32 encode_function_utf32) >>
        writeFile file32_substitute (content "unsigned int"   opt32_substitute include_utf32 charset_size_utf32 encode_function_utf32) >>
        writeFile file32_fail       (content "unsigned int"   opt32_fail       include_utf32 charset_size_utf32 encode_function_utf32)


gen_test_blocks :: IO ()
gen_test_blocks =
    let (blocknames, charsets) = unzip $ map (\ (Block name cs) -> (prettify name, cs)) blocks
        blocknames' = blocknames ++ ["All"]
        charsets' = charsets ++ [L.foldl' CS.union CS.empty charsets]
        (charsets_re2c, charsets_c) = unzip $ map show_charset charsets'
        charsets_sizes = map ((+ 1) . length . CS.toAscList) charsets' -- +1 for outer symbol
        charsets_sizes_utf8  = map (show . (* 4)) charsets_sizes
        charsets_sizes_utf16 = map (show . (* 2)) charsets_sizes
        charsets_sizes_utf32 = map show charsets_sizes

        include_utf8  = "#include \"utf8.h\""
        include_utf16 = "#include \"utf16.h\""
        include_utf32 = ""

        file8_ignore      = "unicode_blocks_8_encoding_policy_ignore.re"
        file8_substitute  = "unicode_blocks_8_encoding_policy_substitute.re"
        file8_fail        = "unicode_blocks_8_encoding_policy_fail.re"
        file16_ignore     = "unicode_blocks_x_encoding_policy_ignore.re"
        file16_substitute = "unicode_blocks_x_encoding_policy_substitute.re"
        file16_fail       = "unicode_blocks_x_encoding_policy_fail.re"
        file32_ignore     = "unicode_blocks_u_encoding_policy_ignore.re"
        file32_substitute = "unicode_blocks_u_encoding_policy_substitute.re"
        file32_fail       = "unicode_blocks_u_encoding_policy_fail.re"

        opt8_ignore      = "// re2c $INPUT -o $OUTPUT -8 --encoding-policy ignore"
        opt8_substitute  = "// re2c $INPUT -o $OUTPUT -8 --encoding-policy substitute"
        opt8_fail        = "// re2c $INPUT -o $OUTPUT -8 --encoding-policy fail"
        opt16_ignore     = "// re2c $INPUT -o $OUTPUT -x --encoding-policy ignore"
        opt16_substitute = "// re2c $INPUT -o $OUTPUT -x --encoding-policy substitute"
        opt16_fail       = "// re2c $INPUT -o $OUTPUT -x --encoding-policy fail"
        opt32_ignore     = "// re2c $INPUT -o $OUTPUT -u --encoding-policy ignore"
        opt32_substitute = "// re2c $INPUT -o $OUTPUT -u --encoding-policy substitute"
        opt32_fail       = "// re2c $INPUT -o $OUTPUT -u --encoding-policy fail"

        content ctype opt include sz_charsets (ef_name, ef_body) = unlines
            [ opt
            , "#include <stdio.h>"
            , include
            , "#define YYCTYPE " ++ ctype
            , "enum Block"
            , "{"
            , unlines $ map (\ s -> "\t" ++ s ++ ",") blocknames'
            , "\tError"
            , "};"
            , "Block scan(const YYCTYPE * start, const YYCTYPE * const limit, Block blk)"
            , "{"
            , "\t__attribute__((unused)) const YYCTYPE * YYMARKER; // silence compiler warnings when YYMARKER is not used"
            , "#\tdefine YYCURSOR start"
            , "\tswitch (blk)"
            , "\t{"
            , unlines $ map (\ s -> "\t\tcase " ++ s ++ ": goto " ++ s ++ " ;") blocknames'
            , "\t\tdefault: return Error;"
            , "\t}"
            , "\t/*!re2c"
            , unlines $ map (\ (b, s) -> "\t\t" ++ b ++ " = " ++ s ++ ";") $ zip blocknames' charsets_re2c
            , "\t*/"
            , unlines $ map
                (\ s -> unlines
                    [ s ++ ":"
                    , "\t/*!re2c"
                    , "\t\tre2c:yyfill:enable = 0;"
                    , "\t\t" ++ s ++ " { goto " ++ s ++ "; }"
                    , "\t\t* { if (YYCURSOR == limit) return " ++ s ++ "; else return Error; }"
                    , "\t*/"
                    ]
                ) blocknames'
            , "}"
            , unlines $ map
                (\ (s, cs) -> "static const unsigned int chars_" ++ s ++ " [] = " ++ cs ++ ";"
                ) $ zip blocknames' charsets_c
            , ef_body
            , "int main()"
            , "{"
            , unlines $ map
                (\ (s, sz) ->
                    let buffer = "buffer_" ++ s
                        buffer_len = buffer ++ "_len"
                        str = "s_" ++ s
                        charset_c_name = "chars_" ++ s
                    in  unlines
                        [ "\tunsigned int * " ++ buffer ++ " = new unsigned int [" ++ sz ++ "];"
                        , "\tYYCTYPE * " ++ str ++ " = (YYCTYPE *) " ++ buffer ++ ";"
                        , "\tunsigned int " ++ buffer_len ++ " = " ++ ef_name ++ " ("
                            ++ charset_c_name ++ ", "
                            ++ "sizeof (" ++ charset_c_name ++ ") / sizeof (unsigned int)" ++ ", "
                            ++ buffer ++ ");"
                        , "\t/* convert 32-bit code units to YYCTYPE; reuse the same buffer */"
                        , "\tfor (unsigned int i = 0; i < " ++ buffer_len ++ "; ++i) " ++ str ++ "[i] = " ++ buffer ++ "[i];"
                        , "\tif (scan (" ++ str ++ ", " ++ str ++ " + " ++ buffer_len ++ ", " ++ s ++ ") != " ++ s ++ ")"
                        , "\t\tprintf (\"test '" ++ s ++ "' failed\\n\");"
                        , "\tdelete [] " ++ buffer ++ ";"
                        ]
                ) $ zip blocknames' sz_charsets
            , "\treturn 0;"
            , "}"
            ]

    in  writeFile file8_ignore      (content "unsigned char"  opt8_ignore      include_utf8  charsets_sizes_utf8  encode_function_utf8) >>
        writeFile file8_substitute  (content "unsigned char"  opt8_substitute  include_utf8  charsets_sizes_utf8  encode_function_utf8) >>
        writeFile file8_fail        (content "unsigned char"  opt8_fail        include_utf8  charsets_sizes_utf8  encode_function_utf8) >>

        writeFile file16_ignore     (content "unsigned short" opt16_ignore     include_utf16 charsets_sizes_utf16 encode_function_utf16) >>
        writeFile file16_substitute (content "unsigned short" opt16_substitute include_utf16 charsets_sizes_utf16 encode_function_utf16) >>
        writeFile file16_fail       (content "unsigned short" opt16_fail       include_utf16 charsets_sizes_utf16 encode_function_utf16) >>

        writeFile file32_ignore     (content "unsigned int"   opt32_ignore     include_utf32 charsets_sizes_utf32 encode_function_utf32) >>
        writeFile file32_substitute (content "unsigned int"   opt32_substitute include_utf32 charsets_sizes_utf32 encode_function_utf32) >>
        writeFile file32_fail       (content "unsigned int"   opt32_fail       include_utf32 charsets_sizes_utf32 encode_function_utf32)


main :: IO ()
main = do
    gen_categories categories
    mapM_ gen_test_category categories
    gen_test_blocks
