{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck

import Data.MessagePack as MP
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as Txt
import qualified Data.IntSet as IS
import Data.Maybe (isJust, fromMaybe)
import GHC.Real (infinity)

import Graphics.Text.Font.Choose
import Graphics.Text.Font.Choose.Internal.Test

main :: IO ()
main = hspec $ do
    describe "Canary" $ do
        it "runs fine" $ do
            True `shouldBe` True
    describe "Roundtrips" $ do
        describe "converts MessagePack & back" $ do
            prop "CharSet" $ \x ->
                MP.unpack (MP.pack x) `shouldBe` Just (x :: CharSet')
            prop "FontSet" $ \x -> let y = Prelude.map unPattern x
                in MP.unpack (MP.pack y) `shouldBe` Just y
            prop "LangSet" $ \x ->
                MP.unpack (MP.pack x) `shouldBe` Just (x :: LangSet')
            prop "ObjectSet" $ \x ->
                MP.unpack (MP.pack x) `shouldBe` Just (x :: ObjectSet)
            prop "Pattern" $ \x ->
                MP.unpack (MP.pack x) `shouldBe` Just (x :: Pattern')
            prop "Range" $ \x ->
                MP.unpack (MP.pack x) `shouldBe` Just (x :: Range)
            prop "StrSet" $ \x ->
                MP.unpack (MP.pack x) `shouldBe` Just (x :: StrSet)
            prop "Value" $ \x ->
                MP.unpack (MP.pack x) `shouldBe` Just (x :: Value)
        describe "through C datastructures" $ do
            prop "StrSet" $ \x -> validStrSet x ==>
                roundtrip testStrSet x `shouldBe` Just (x :: StrSet)
            prop "CharSet" $ \x -> validCharSet' x ==>
                roundtrip testCharSet x `shouldBe` Just (x :: CharSet')
            prop "LangSet" $ \x -> validLangSet' x ==>
                roundtrip testLangSet x `shouldBe` Just (x :: LangSet')
            prop "Range" $ \x -> validRange x ==>
                roundtrip testRange x `shouldBe` Just (x :: Range)
            prop "Matrix" $ \x -> roundtrip testMatrix x `shouldBe`
                    Just (x :: (Double, Double, Double, Double))
            prop "Value" $ \x -> validValue x ==>
                roundtrip testValue x `shouldBe` Just (x :: Value)
            prop "Trivial Pattern" $ \x -> validValue x ==>
                let pat = Pattern' $ M.fromList [("test", [(Strong, x)])]
                in roundtrip testPattern pat `shouldBe` Just pat
            prop "Tuple Pattern" $ \(x, y) -> validValue x && validValue y ==>
                let pat = Pattern' $ M.fromList [("a", [(Strong, x)]), ("b", [(Strong, y)])]
                in roundtrip testPattern pat `shouldBe` Just pat
            let toAscii :: Char -> Char
                toAscii ch = toEnum $ fromEnum ch `mod` 128
            prop "Random-key pattern" $ \x -> all (\y -> toAscii y /= '\0') x ==>
                let pat = Pattern' $ M.fromList [(Txt.pack $ map toAscii $ take 17 x, [(Strong, ValueBool True)])]
                in roundtrip testPattern pat `shouldBe` Just pat
            prop "Pattern" $ \x -> validPattern' x ==>
                roundtrip testPattern x `shouldBe` Just (x :: Pattern')
            prop "FontSet" $ \x -> let y = filter validPattern $ Prelude.map unPattern x
                in validFontSet y ==> roundtrip testFontSet y `shouldBe` Just y
    describe "FontConfig Testsuite transliteration" $ do
        it "All system fonts should have files" $ do
            conf <- current
            res <- fonts conf System
            let files = getValue "file" `map` res :: [Maybe String]
            all isJust files `shouldBe` True
        it "Locale compare" $ do
            S.singleton "ku-am" `cmp` S.singleton "ku-iq" `shouldBe` DifferentTerritory
            S.singleton "ku-am" `cmp` S.singleton "ku-ir" `shouldBe` DifferentTerritory
            S.singleton "ku-am" `cmp` S.singleton "ku-tr" `shouldBe` DifferentTerritory
            S.singleton "ku-iq" `cmp` S.singleton "ku-ir" `shouldBe` DifferentTerritory
            S.singleton "ku-iq" `cmp` S.singleton "ku-tr" `shouldBe` DifferentTerritory
            S.singleton "ku-ir" `cmp` S.singleton "ku-tr" `shouldBe` DifferentTerritory
            S.singleton "ps-af" `cmp` S.singleton "ps-pk" `shouldBe` DifferentTerritory
            S.singleton "ti-er" `cmp` S.singleton "ti-et" `shouldBe` DifferentTerritory
            S.singleton "zh-cn" `cmp` S.singleton "zh-hk" `shouldBe` DifferentTerritory
            S.singleton "zh-cn" `cmp` S.singleton "zh-mo" `shouldBe` DifferentTerritory
            S.singleton "zh-cn" `cmp` S.singleton "zh-sg" `shouldBe` DifferentTerritory
            S.singleton "zh-cn" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory
            S.singleton "zh-hk" `cmp` S.singleton "zh-mo" `shouldBe` DifferentTerritory
            S.singleton "zh-hk" `cmp` S.singleton "zh-sg" `shouldBe` DifferentTerritory
            S.singleton "zh-hk" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory
            S.singleton "zh-mo" `cmp` S.singleton "zh-sg" `shouldBe` DifferentTerritory
            S.singleton "zh-mo" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory
            S.singleton "zh-sg" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory
            S.singleton "mn-mn" `cmp` S.singleton "mn-cn" `shouldBe` DifferentTerritory
            S.singleton "pap-an" `cmp` S.singleton "pap-aw" `shouldBe` DifferentTerritory
            -- A couple additional ones so we know its not always responding with DifferentTerritory!
            S.singleton "mn-mn" `cmp` S.singleton "mn-mn" `shouldBe` SameLang
            S.singleton "mn-mn" `cmp` S.singleton "pap-an" `shouldBe` DifferentLang
        it "Font weights" $ do
            weightFromOpenTypeDouble (fromRational infinity) `shouldBe` 215
            weightFromOpenType maxBound `shouldBe` 215
        it "Name parsing" $ do
            nameParse "sans\\-serif" `shouldBe` M.fromList [
                ("family", [(Strong, ValueString "sans-serif")])
              ]
            nameParse "Foo-10" `shouldBe` M.fromList [
                ("family", [(Strong, ValueString "Foo")]),
                -- NOTE: Equality derived from the pure-Haskell type is stricter than FontConfig's.
                -- This subtest might fail in the future, not sure what to do about that.
                ("size", [(Strong, ValueDouble 10)])
              ]
            nameParse "Foo,Bar-10" `shouldBe` M.fromList [
                ("family", [(Strong, ValueString "Foo"), (Strong, ValueString "Bar")]),
                ("size", [(Strong, ValueDouble 10)])
              ]
            nameParse "Foo:weight=medium" `shouldBe` M.fromList [
                ("family", [(Strong, ValueString "Foo")]),
                ("weight", [(Strong, ValueDouble 100)])
              ]
            nameParse "Foo:weight_medium" `shouldBe` M.fromList [
                ("family", [(Strong, ValueString "Foo")]),
                ("weight", [(Strong, ValueDouble 100)])
              ]
            nameParse ":medium" `shouldBe` M.fromList [
                ("weight", [(Strong, ValueInt 100)])
              ]
            nameParse ":normal" `shouldBe` M.fromList [
                ("width", [(Strong, ValueInt 100)])
              ]
            nameParse ":weight=[medium bold]" `shouldBe` M.fromList [
                ("weight", [(Strong, ValueRange $ Range 100 200)])
              ]
    describe "CSS Parsing" $ do
        it "unicode-range" $ do
            let parseCharSet' = IS.toList . fromMaybe IS.empty . parseCharSet
            parseCharSet' "U+26" `shouldBe` [0x26]
            parseCharSet' "U+26, U+42" `shouldBe` [0x26, 0x42]
            parseCharSet' "U+0-7F" `shouldBe` [0x0..0x7f]
            parseCharSet' "U+0025-00FF" `shouldBe` [0x0025..0x00ff]
            parseCharSet' "U+4??" `shouldBe` [0x400..0x4ff]
            parseCharSet' "U+0025-00FF, U+4??" `shouldBe` [0x0025..0x00ff] ++ [0x400..0x4ff]