{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Main (main) where
import Text.Collate
import Text.Collate.Normalize (toNFD)
import Text.Printf
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.HUnit
import Data.Either (lefts)
import Data.List (sortBy)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Read as TR
import qualified Data.Text.Normalize as N
import Data.Char
import Data.Maybe
import qualified Data.ByteString.Char8 as B8

main :: IO ()
main = do
  conformanceTree <- conformanceTests
  defaultMain (tests conformanceTree)

tests :: TestTree -> TestTree
tests conformanceTree = testGroup "Tests"
  [ conformanceTree
  , testCase "Sorting test 1" $
    sortBy (collate ourCollator) ["hi", "hit", "hít", "hat", "hot",
                       "naïve", "nag", "name"] @?=
           ["hat","hi","hit","h\237t","hot","nag","naïve","name"]
  , testCase "Sorting test 2" $
    sortBy (collate ourCollator)
                      ["ｶ", "ヵ", "abc", "abç", "ab\xFFFE\&c", "ab©",
                       "𝒶bc", "abC", "𝕒bc", "File-3", "ガ", "が", "äbc", "カ",
                       "か", "Abc", "file-12", "filé-110"]
                      @?=
                       ["ab©", "abc", "abC", "𝒶bc", "𝕒bc", "Abc",
                       "abç", "äbc", "ab\xFFFE\&c",
                       "filé-110", "file-12", "File-3",
                       "か", "ヵ", "カ", "ｶ", "が", "ガ"]

  , testGroup "Variable ordering test"
     $ map variableOrderingCase
      [ (NonIgnorable,
        ["de luge" ,"de Luge" ,"de-luge" ,"de-Luge" ,"de\x2010luge"
        ,"de\x2010Luge" ,"death" ,"deluge" ,"deLuge" ,"demark"])
      , (Blanked,
        ["death" ,"de luge" ,"de-luge" ,"de\x2010luge" ,"deluge"
        ,"de Luge" ,"de-Luge","de\x2010Luge", "deLuge", "demark"])
      , (Shifted,
        ["death" ,"de luge" ,"de-luge" ,"de\x2010luge" ,"deluge"
        ,"de Luge" ,"de-Luge" ,"de\x2010Luge" ,"deLuge" ,"demark"])
      , (ShiftTrimmed,
        ["death" ,"deluge" ,"de luge" ,"de-luge" ,"de\x2010luge" ,"deLuge"
        ,"de Luge" ,"de-Luge" ,"de\x2010Luge" ,"demark"])
      ]
  , testGroup "Localized collations"
    [ testCase "root cha cza" $
        collate "und" "cha" "cza" @?= LT
    , testCase "es traditional cha cza" $
        collate "es-u-co-trad" "cha" "cza" @?= GT
    , testCase "se ö z" $
        collate "se" "ö" "z" @?= GT
    , testCase "tr ö z" $
        collate "tr" "ö" "z" @?= LT
    , testCase "fr-CA sorted list" $
        sortBy (collate (collatorFor "fr-CA-u-kb-true"))
        ["déjà","Meme", "deja", "même", "dejà", "bpef", "bœg", "Boef", "Mémé",
         "bœf", "boef", "bnef", "pêche", "pèché", "pêché", "pêche", "pêché"]
         @?=
        ["bnef", "boef", "Boef", "bœf", "bœg", "bpef", "deja", "dejà", "déjà",
         "Meme", "même", "Mémé", "pêche", "pêche", "pèché", "pêché", "pêché"]
    , testCase "fr with French accents" $
        collate "fr-u-kb-true" "coté" "côte" @?= GT
    , testCase "fr without French accents" $
        collate "fr-u-kb-false" "coté" "côte" @?= LT
    , testCase "fr kb defaults to true" $
        collate "fr-u-kb" "coté" "côte" @?= GT
    , testCase "fr without kb defaults to false" $
        collate "fr" "coté" "côte" @?= LT
    , testCase "en with shifted" $
        collate "en-u-ka-shifted" "de-luge" "de Luge" @?= LT
    , testCase "en with nonignorable" $
        collate "en-u-ka-noignore" "de-luge" "de Luge" @?= GT
    , testCase "de-u-co-phonebk" $
        sortBy (collate "de-u-co-phonebk")
        ["Übelacker", "Üxküll", "Uell", "Ülle", "Udet", "Uffenbach", "Ueve"]
        @?=
        ["Udet", "Übelacker", "Uell", "Ülle", "Ueve", "Üxküll", "Uffenbach"]
    , testCase "zh-u-co-pinyin" $
        collate "zh-u-co-pinyin" "\x963F" "\x5475"  @?= LT
    , testCase "zh-u-co-stroke" $
        collate "zh-u-co-stroke" "\x963F" "\x5475"  @?= GT
    ]
  , testCase "QuasiQuotes" $
       collate [collator|zh-u-co-pinyin|] "\x963F" "\x5475" @?= LT
  , testGroup "BCP 47 Lang parsing"
       (map langParseTest langPairs)
  , testGroup "BCP 47 Lang round-trip"
       (map langRoundTripTest langPairs)
  , testGroup "Lang fallback behavior"
    [ testCase "de => ROOT" $
      (optLang . collatorOptions) "de" @?= Nothing
    , testCase "de-AT => ROOT" $
        (optLang . collatorOptions) "dt-AT" @?= Nothing
    , testCase "es-u-co-trad" $
        (optLang . collatorOptions) "es-ES" @?=
          Just (Lang "es" Nothing Nothing [] [] [])
    , testCase "de-DE-u-co-phonebk" $
        (optLang . collatorOptions) "de-DE-u-co-phonebk" @?=
          Just (Lang "de" Nothing Nothing [] [("u",[("co","phonebk")])] [])
    , testCase "es-u-co-nonexist-kb" $
        (optLang . collatorOptions) "es-u-co-nonexist-kb" @?=
          Just (Lang "es" Nothing Nothing [] [] [])
    ]
  , testGroup "Normalization"
    [ testProperty "toNFD agrees with unicode-transforms"
         (\cs -> toNFD (map ord cs) ==
           (map ord . T.unpack . N.normalize N.NFD . T.pack) cs)
    ]
  ]

emptyLang :: Lang
emptyLang = Lang mempty mempty mempty mempty mempty mempty

langPairs :: [(Text, Lang)]
langPairs = [ ("en", emptyLang{langLanguage = "en"})
            , ("en with garbage following",
                     emptyLang{langLanguage = "en"})
            , ("en--with garbage following", -- CSL allows this
                     emptyLang{langLanguage = "en"})
            , ("en-US", emptyLang{langLanguage = "en", langRegion = Just "US"})
            , ("sr_Latn_RS", emptyLang{langLanguage = "sr",
                                   langScript = Just "Latn",
                                   langRegion = Just "RS"})
            , ("es-419", emptyLang{langLanguage = "es",
                                   langRegion = Just "419"})
            , ("de-CH-1996", emptyLang{langLanguage = "de",
                                       langRegion = Just "CH",
                                       langVariants = ["1996"]})
            , ("en-u-kr-latin-digit", emptyLang{langLanguage = "en",
                     langExtensions = [("u", [("kr", "latin-digit")])]})
            ]

langParseTest :: (Text, Lang) -> TestTree
langParseTest (t, l) =
  testCase (T.unpack t) $ parseLang t @?= Right l

langRoundTripTest :: (Text, Lang) -> TestTree
langRoundTripTest (_,l) =
  let l' = renderLang l
   in testCase (T.unpack l') $ renderLang <$> parseLang l' @?= Right l'

conformanceTests :: IO TestTree
conformanceTests = do
  putStrLn "Loading conformance test data..."
  shifted <- conformanceTestsFor Shifted
              "test/uca-collation-test/CollationTest_SHIFTED_SHORT.txt"
  nonIgnorable <- conformanceTestsFor NonIgnorable
              "test/uca-collation-test/CollationTest_NON_IGNORABLE_SHORT.txt"
  return $ testGroup "Conformance tests" [nonIgnorable, shifted]

conformanceTestsFor :: VariableWeighting -> FilePath -> IO TestTree
conformanceTestsFor weighting fp = do
  xs <- parseConformanceTest fp
  let coll = setVariableWeighting weighting rootCollator
  return $ testCase ("Conformance tests " ++ show weighting ++ " " ++ fp)
         $ (\zs -> case lefts zs of
                     [] -> return ()
                     es -> assertFailure (unlines es))
         $ map (conformanceTestWith coll)
              (zip3 (map fst xs) (map snd xs) (tail (map snd xs)))

conformanceTestWith :: Collator -> (Int, Text, Text) -> Either String ()
conformanceTestWith coll (lineNo, txt1, txt2) =
  let showHexes = unwords . map ((\c -> if c > 0xFFFF
                                           then printf "%05X" c
                                           else printf "%04X" c) . ord)
                          . T.unpack
   in if collate coll txt1 txt2 /= GT
         then Right ()
         else Left $ "[line " ++ show lineNo ++ "] " ++
                      showHexes txt1 ++ " <= " ++ showHexes txt2 ++ "\n" ++
                      "  Calculated sort keys:\n  [" ++
                        showHexes txt1 ++ "] " ++
                        renderSortKey (sortKey coll txt1) ++ "\n  [" ++
                        showHexes txt2 ++ "] " ++
                        renderSortKey (sortKey coll txt2)

variableOrderingCase :: (VariableWeighting , [Text]) -> TestTree
variableOrderingCase (w , expected) =
  testCase (show w) $
     sortBy (collate (setVariableWeighting w rootCollator))
           -- from Table 12
           [ "de luge"
           , "de Luge"
           , "de-luge"
           , "de-Luge"
           , "de\x2010luge"
           , "de\x2010Luge"
           , "death"
           , "deluge"
           , "deLuge"
           , "demark" ]
           @?= expected

ourCollator :: Collator
ourCollator = setVariableWeighting Shifted rootCollator

parseConformanceTest :: FilePath -> IO [(Int, Text)]
parseConformanceTest fp = do
  bs <- B8.readFile fp
  let beginsWithHexDigit = maybe False (isHexDigit . fst) . B8.uncons
  let allLines = B8.lines bs
  let prologue = takeWhile (not . beginsWithHexDigit) allLines
  let lns = drop (length prologue) allLines
  let firstLine = 1 + length prologue
  return $ catMaybes $ zipWith parseConformanceTestLine [firstLine..] lns

parseConformanceTestLine :: Int -> B8.ByteString -> Maybe (Int, Text)
parseConformanceTestLine lineno bs =
  let readhex = either error fst . TR.hexadecimal
      codepoints = map (readhex . TE.decodeLatin1) $ B8.words bs
      t = T.pack (map chr codepoints)
   in if T.any (== '\xFFFD') t || T.null t
         then Nothing
         else Just (lineno, t)
