{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}

module Main where

import           Control.Exception
import qualified Data.ByteString       as B
import qualified Data.ByteString.Lazy  as L
import qualified Data.ByteString.Short as SBS
import           Data.Digest.Keccak
import           Data.Either
import           Data.Foldable
import           Data.Int
import           Data.List
import qualified Data.Map              as M
import           Data.Maybe
import           Data.Model            hiding (Name)
import qualified Data.Sequence         as S
import qualified Data.Text             as T
import           Data.Word
import           Debug.Trace
import           Info
import           System.Exit           (exitFailure)
import           System.TimeIt
import           Test.Data             hiding (Cons, Unit)
import           Test.Data.Flat        hiding (Cons, Unit)
import           Test.Data.Model
import qualified Test.Data2            as Data2
import qualified Test.Data3            as Data3
import           Test.Tasty
import           Test.Tasty.HUnit
import           Test.Tasty.QuickCheck as QC
import           Text.PrettyPrint
import           ZM

-- import Data.Timeless
t = main

main = mainTest
-- main = mainMakeTests
-- main = mainPerformance
-- main = mainShow

mainMakeTests = do
  let code = concat ["codes = [",intercalate "\n," $ map (show . typeName) models,"]"]
  putStrLn code
  exitFailure

mainPerformance = do
  print "Calculate codes"
  mapM_ (timeIt . evaluate . typeName) models
  print "Again"
  mapM_ (timeIt . evaluate . typeName) models
  exitFailure

mainShow = do
  -- prt (Proxy::Proxy Char)
  -- prt (Proxy::Proxy String)
  prt (Proxy::Proxy T.Text)
  prt (Proxy::Proxy (BLOB UTF8Encoding))
  -- prt (Proxy::Proxy (Array Word8))
  -- prtH (Proxy::Proxy (Bool,()))
  -- prt (Proxy::Proxy L.ByteString)
  -- prt (Proxy::Proxy T.Text)
  -- print $ tstDec (Proxy::Proxy L.ByteString) [2,11,22,0,1]
  -- print $ tstDec (Proxy::Proxy (Bool,Bool,Bool)) [128+32]
  -- print $ tstDec (Proxy::Proxy (List Bool)) [72]
  -- print . B.length . flat . timelessSimple $ True
  -- print . B.length . flat . timelessHash $ True
  -- print . B.length . flat . timelessExplicit $ True
  -- print "OK"
  -- prt $ tst (Proxy :: Proxy (List (Data2.List (Bool))))
  exitFailure

    where
      prt = putStrLn . prettyShow . CompactPretty . absTypeModel
      -- pshort = putStrLn . take 1000 . prettyShow

mainTest = defaultMain tests

tests :: TestTree
tests = testGroup "Tests"
          [ sha3DigestTests
          , shakeDigestTests
          , codesTests
          , consistentModelTests
          , mutuallyRecursiveTests
          , customEncodingTests
          , encodingTests
          , transformTests
          , identifiersTests
          --, timelessTests
          ]

sha3DigestTests = testGroup "SHA3 Digest Tests"
                [tst [] [0xa7, 0xff, 0xc6], tst [48, 49, 50, 51] [0x33, 0xbc, 0xc2]]
  where
    tst inp out = testCase (unwords ["SHA3", show inp]) $ B.pack out @?= sha3_256 3 (B.pack inp)

shakeDigestTests = testGroup "Shake Digest Tests"
                [tst [] [0x7f, 0x9c, 0x2b], tst [48, 49, 50, 51] [0x30, 0xc5, 0x1c]]
  where
    tst inp out = testCase (unwords ["Shake128", show inp]) $ shake_128 3 (B.pack inp) @?= B.pack out

codesTests = testGroup "Absolute Types Codes Tests" (map tst $ zip models codes)
  where
    --tst (model,code) = testCase (unwords ["Code",prettyShow model]) $ code @?= typeName model
    tst (model,code) = testCase (unwords ["Code"]) $ code @?= typeName model

consistentModelTests = testGroup "TypeModel Consistency Tests" $ map tst models
 where
  tst tm = testCase (unwords ["Consistency"]) $ internalConsistency tm && externalConsistency tm @?= True

internalConsistency = noErrors . refErrors . typeEnv

-- |Check external consistency of absolute environment
-- the key of every ADT in the env is correct (same as calculated directly on the ADT)
externalConsistency = all (\(r,adt) -> absRef adt == r) . M.toList . typeEnv

mutuallyRecursiveTests = testGroup "Mutually Recursion Detection Tests" $ [
    tst (Proxy :: Proxy A0)
    ,tst (Proxy :: Proxy B0)
    ,tst (Proxy :: Proxy (Forest Bool))
    ] where
  tst :: forall a. (Model a) => Proxy a -> TestTree
  tst proxy =
    let r = absTypeModelMaybe proxy
    in testCase (unwords ["Mutual Recursion",show r]) $
       isLeft r && (let Left es = r in all (isInfixOf "mutually recursive") es) @?= True

-- |Test all custom flat instances for conformity to their model
customEncodingTests = testGroup "Typed Unit Tests" [
  em (Proxy :: Proxy T.Text) (Proxy :: Proxy (BLOB UTF8Encoding))
  ,em (Proxy :: Proxy UTF8Text) (Proxy :: Proxy (BLOB UTF8Encoding))
  ,em (Proxy :: Proxy UTF16Text) (Proxy :: Proxy (BLOB UTF16LEEncoding))
  ,e ()
  ,e False
  ,e (Just True)
  ,e (Left True::Either Bool Char)
  ,e (Right ()::Either Bool ())
  ,e (False,'g')
  ,e [(False,'g')]
  ,e (M.fromList ([]::[(Bool,Bool)]))
  ,e (M.fromList [(False,'g')])
  ,e (M.fromList [(33::Int,"abc")])
  ,e (M.fromList [(33::Int,57::Word8),(44,77)])
  ,e $ B.pack []
  ,e $ B.pack [11,22]
  ,e $ L.pack []
  ,e $ L.pack (replicate 11 77)
  ,e $ SBS.pack []
  ,e $ SBS.pack [11,22]
  ,e an
  ,e aw
  ,e ab
  ,e $ seq an
  ,e $ seq ab
  ,e $ seq aw
  ,e $ seq ac
  ,e 'a'
  ,e 'k'
  -- ,e "\n"
  ,e "ab\ncd"
  ,e ac
  ,e $ blob NoEncoding [11::Word8,22,33]
  ,e $ blob UTF8Encoding [97::Word8,98,99]
  ,e $ blob UTF16LEEncoding ([0x24,0x00,0xAC,0x20,0x01,0xD8,0x37,0xDC]::[Word8]) -- $€𐐷
  ,e (T.pack "abc$€𐐷")
  ,e (UTF8Text $ T.pack "abc$€𐐷")
  ,e (UTF16Text $ T.pack "abc$€𐐷")
  ,e (False,True)
  ,e (False,True,44::Word8)
  ,e (False,True,44::Word8,True)
  ,e (False,True,44::Word8,True,False)
  ,e (False,True,44::Word8,True,False,False)
  ,e (False,True,44::Word8,True,False,False,44::Word8)
  ,e (False,True,44::Word8,True,False,False,44::Word8,())
  ,e (False,True,44::Word8,True,False,False,44::Word8,(),'a')
  ,e (33::Word)
  ,e (0::Word8)
  ,e (33::Word8)
  ,e (255::Word8)
  ,e (3333::Word16)
  ,e (333333::Word32)
  ,e (33333333::Word64)
  ,e (maxBound::Word64)
  ,e (-11111111::Int)
  ,e (11111111::Int)
  ,e (88::Int8)
  ,e (1616::Int16)
  ,e (32323232::Int32)
  ,e (6464646464::Int64)
  ,e (minBound::Int32)
  ,e (maxBound::Int32)
  ,e (minBound::Int64)
  ,e (maxBound::Int64)
  ,e (-88::Int8)
  ,e (-1616::Int16)
  ,e (-32323232::Int32)
  ,e (-6464646464::Int64)
  ,e (44323232123::Integer)
  ,e (-4323232123::Integer)
  ,e (12.123::Float)
  ,e (-57.238E-11::Float)
  ,e (12.123::Double)
  ,e (-57.238E-11::Double)
  ]

  where
    seq = S.fromList
    an = []::[()]
    aw = [0,128,127,255::Word8]
    ab = [False,True,False]
    ac = ['v','i','c']

    -- e :: forall a. (Prettier a, Flat a, Show a, Model a) => a -> TestTree
    -- e x = testCase (unwords ["Encoding",show x]) $ dynamicShow x @?= prettierShow x
    e :: forall a. (Pretty a, Flat a, Show a, Model a) => a -> TestTree
    e x = testCase (unwords ["Encoding",show x,prettyShow x,dynamicShow x]) $ dynamicShow x @?= prettyShow x
    em p1 p2 = testCase (unwords ["Model Mapping"]) $ absType p1 @?= absType p2

-- As previous test but using Arbitrary values
encodingTests = testGroup "Encoding Tests"
                  [ ce "()" (prop_encoding :: RT ())
                  , ce "Bool" (prop_encoding :: RT Bool)
                  , ce "Maybe Bool" (prop_encoding :: RT (Maybe Bool))
                  , ce "Word" (prop_encoding :: RT Word)
                  , ce "Word8" (prop_encoding :: RT Word8)
                  , ce "Word16" (prop_encoding :: RT Word16)
                  , ce "Word32" (prop_encoding :: RT Word32)
                  , ce "Word64" (prop_encoding :: RT Word64)
                  , ce "Int" (prop_encoding :: RT Int)
                  , ce "Int16" (prop_encoding :: RT Int16)
                  , ce "Int16" (prop_encoding :: RT Int16)
                  , ce "Int32" (prop_encoding :: RT Int32)
                  , ce "Int64" (prop_encoding :: RT Int64)
                  , ce "Integer" (prop_encoding :: RT Integer)
                  , ce "Char" (prop_encoding :: RT Char)
                  , ce "String" (prop_encoding :: RT String) -- too slow
                  , ce "[Maybe (Bool,Char)]" (prop_encoding :: RT ([Maybe (Bool,Char)]))
                  ]
  where
    ce n = QC.testProperty (unwords ["Encoding", n])

identifiersTests = testGroup "Identifier Tests" $ concat [
  testId "Tuple2" $ Name (UnicodeLetter 'T') [UnicodeLetterOrNumberOrLine 'u',UnicodeLetterOrNumberOrLine 'p',UnicodeLetterOrNumberOrLine 'l',UnicodeLetterOrNumberOrLine 'e',UnicodeLetterOrNumberOrLine '2']
  ,testId "abc" $ Name (UnicodeLetter 'a') [UnicodeLetterOrNumberOrLine 'b',UnicodeLetterOrNumberOrLine 'c']
  ,testId "<>" $ Symbol (Cons (UnicodeSymbol '<') (Elem (UnicodeSymbol '>')))
  ]
   where
    testId s i = [testCase (unwords ["identifier parse",s]) $ convert s @?= i
                 ,testCase (unwords ["identifier roundtrip",s]) $ convert (convert s::Identifier) @?= s]

transformTests = testGroup "Transform Tests" [
  testRecDeps (Proxy :: Proxy Bool) 1
  ,testRecDeps (Proxy :: Proxy (Bool,[Bool])) 3
  ]
  where
    testRecDeps proxy len =
      let tm = absTypeModel proxy
      in let Right deps = typeDefinition (typeEnv tm) (typeName tm) -- $ length (typeDefinition (typeEnv tm) (typeName tm)) @?= len
         in testCase (unwords ["recursiveDependencies",prettyShow $ typeName tm]) $ length deps @?= len

-- prop_encoding x = dynamicShow x == prettierShow x

prop_encoding :: forall a. (Pretty a,Flat a, Model a) => RT a
prop_encoding x = dynamicShow x == prettyShow x

dynamicShow :: forall a. (Flat a, Model a) => a -> String
--dynamicShow a = prettyShow (let Right v = decodeAbsTypeModel (absTypeModel (Proxy::Proxy a)) (flat a) in v)
dynamicShow a = case decodeAbsTypeModel (absTypeModel (Proxy::Proxy a)) (flat a) of
                  Left e  -> error (show e)
                  Right v -> prettyShow v

type RT a = a -> Bool

-- timelessTests = t True
--   where
--     t n = testGroup (unwords ["Timeless",show n]) [
--       testCase "simple" (untimeless (timelessSimple n) @?= Right n)
--       ,testCase "hash" (untimeless (timelessHash n) @?= Right n)
--       ,testCase "explicit" (untimeless (timelessExplicit n) @?= Right n)
--       ]