{-# LANGUAGE EmptyDataDecls, FlexibleContexts
  , FlexibleInstances, MultiParamTypeClasses
  , PatternSignatures, RankNTypes, ScopedTypeVariables
  , TemplateHaskell, UndecidableInstances #-}
{-# OPTIONS -Wall -fno-warn-missing-signatures #-}

module TestSybOuter
    ( sybOuterTests, sybOuterQuickTests )
where

import Test.HUnit

import qualified SybWidgetQuickCheck as QC

import Graphics.UI.SybWidget.PriLabel
import Graphics.UI.SybWidget.SybOuter
import Graphics.UI.SybWidget.MySYB hiding (NoCtx, noCtx)
import SYBInstances

import Data.Maybe
import Control.Monad.Writer

import Data.STRef
import Data.IORef
import Control.Monad.ST

sybOuterTests = "SybOuter" ~: 
    TestList
    [ isSingleConstructorTest
    , spliterTest
    , valueMapTest
    , numericGetSetTest
    , testmkSpliterSingleConstr
    , testSetAndGetFieldFun
    ]

-- *** isSingleConstructorTest
isSingleConstructorTest = "isSingleConstructor" ~:
    TestList
    [ "Maybe Int"          ~: assertSingleConstr (undefined :: Maybe Int)  False
    , "Eternal"            ~: assertSingleConstr (undefined :: Eternal) True
    ]

assertSingleConstr x expected =
    assertEqual "Single constructor" expected (isSingleConstructor noCtx x)

-- *** Spliter

data P a = P { unP :: a }
data Q a = Q { unQ :: P a }
type ThreeProdInt = ThreeProd Int Int Int

intThreeProd :: Spliter P ThreeProdInt ThreeProdInt
intThreeProd = Part (P 9) (Part (P 7) (Part (P 5) (Constructor ThreeProd)))

assertSpliter :: [Int] -> (forall x. part x -> x) -> Spliter part a b -> Assertion
assertSpliter xs f spliter = xs @=? (catMaybes $ spliterToList (\p -> cast (f p)) spliter)

tellInt :: (Typeable q) => P q -> Writer [Int] (P q)
tellInt p = case (cast $ unP p) :: Maybe Int of
               Nothing -> return p
               Just x  -> tell [x] >> return p

delayFive p = case (cast $ unP p) :: Maybe Int of
                Just 5  -> True
                _       -> False

addP :: Int -> (forall q. (Typeable q) => P q -> P q)
addP x p = case (cast $ unP p) :: Maybe Int of
             Just y -> case cast (x + y) of
                         Nothing -> p
                         Just z  -> P z
             _      -> p

assertZip add expected = assertSpliter expected unP (zipSpliterWithList addP add intThreeProd)

spliterTest = "Test Spliter" ~:
    TestList
    [ "spliterToList"   ~: assertSpliter [5,7,9] unP intThreeProd
    , "mapParts"        ~: assertSpliter [5,7,9] (unP . unQ) (mapParts Q intThreeProd)
    , "mapPartsM"       ~: [5::Int,7,9] @=? (execWriter $ mapPartsM tellInt intThreeProd)
    , "mapPartsMDelay always" ~: [5::Int,7,9] @=?
           (execWriter $ mapPartsMDelay (const True) tellInt intThreeProd)
    , "mapPartsMDelay 5" ~: [7::Int,9,5] @=?
           (execWriter $ mapPartsMDelay delayFive tellInt intThreeProd)
    , "zipSpliterWithList"       ~: assertZip [1,2,3] [6,9,12]
    , "zipSpliterWithList short" ~: assertZip [1] [6,7,9]
    , "zipSpliterWithList long"  ~: assertZip [1..] [6,9,12]
    , "zipSpliterWithList empty" ~: assertZip [] [5,7,9]
    ]

-- *** Value memory

valueMapTest = "Value map test" ~:
    TestList
    [ "Lookup newly created leaf" ~: (Just leaf) @=? lookupSimple leaf leaf
    , "Lookup newly Nothing"      ~: Nothing @=? lookupSimple leaf tree
    , "Lookup newly Tree"         ~: (Just tree) @=? lookupSimple tree tree
    , "Update (init leaf)" ~: TestList
                   [ "Update leaf" ~: Just (Leaf 1) @=? updateMemory leaf leaf [Leaf 1]
                   , "Update many" ~: Just (Leaf 7) @=? updateMemory leaf leaf [tree, leaf, Leaf 5, leaf, Leaf 7]
                   , "Update tree (1)" ~: Just leaf @=? updateMemory leaf leaf [tree]
                   , "Update tree (2)" ~: Just tree @=? updateMemory leaf tree [tree]
                   ]
    , "alwaysValue" ~: TestList
                   [ "Lookup newly created leaf" ~: leaf @=? alwaysMemory leaf leaf
                   , "Lookup newly Nothing"      ~: assert (isTree $ alwaysMemory leaf tree)
                   ]
    ]

leaf :: Tree Int
leaf = Leaf 3

tree = Tree (Leaf 2) (Leaf 1)

treeValMap :: Tree Int -> ST s (ConstrValMap (STRef s) NoCtx (Tree Int))
treeValMap = mkConstrValMap noCtx

lookupSimple :: Tree Int -> Tree Int -> Maybe (Tree Int)
lookupSimple initial x = runST $
    do m <- treeValMap initial
       lookupValue m (toConstr noCtx x)

alwaysMemory :: Tree Int -> Tree Int -> Tree Int
alwaysMemory initial x = runST $
    do m <- treeValMap initial
       alwaysValue m (toConstr noCtx x)

updateMemory initial x xs = runST $
    do m <- treeValMap initial
       mapM_ (updateConstrValMap m) xs
       lookupValue m (toConstr noCtx x)

-- *** Numeric read/show

sybOuterQuickTests =
    do QC.test "sybReadShowInt"          (\(x::Int) -> sybShowRead x)
       QC.test "sybReadShowDouble"       (\(x::Double) -> sybShowRead x)
       QC.test "sybReadStringInt"        (sybStringRead (0::Int))
       QC.test "prop_sybReadStringFloat" (sybStringRead (0::Float))
       QC.test "prop_sybShowShowInt"     (\(x::Int) -> sybShowShow x)
       QC.test "prop_sybShowShowDouble"  (\(x::Double) -> sybShowShow x)

maybeRead xs = case reads xs of
                 [(x, "")] -> Just x
                 _         -> Nothing

sybShowRead x = sybRead noCtx x (show x) == Just x
sybStringRead typeProxy xs = sybRead noCtx typeProxy xs == maybeRead xs
sybShowShow x = sybShow noCtx x == show x

-- We do this with HUnit as if it works with one set of values it will
-- with all sets. It is testing the state rather than different values.
numericGetSetTest = "numericGetSetTest" ~:
    do let (initial, replacement) = (5 :: Int, 7)
       (getter, setter) <- numericGetSet noCtx initial
       getter "not number" >>= assertEqual "not number initial" initial
       getter "3"          >>= assertEqual "number initial" 3
       setter replacement
       getter "not number" >>= assertEqual "not number replacement" replacement
       getter "9"          >>= assertEqual "number replacement" 9
       return ()

-- *** mkSpliterSingleConstr

data Outer a = Outer { val :: a, lbl :: PriLabel }

instance OuterWidget Outer where
    updateLabel f outer = outer { lbl = f (lbl outer) }

initTuple, otherTuple :: (Int, String, Float)
initTuple  = (5, "foobar", 3.3)
otherTuple = (15, "barfoo", 13.3)

initOuterTuple = mkSpliterSingleConstr noCtx (\x -> Outer x labelless) initTuple
initRefTuple = mapPartsM (newIORef . val) initOuterTuple

testmkSpliterSingleConstr = "mkSpliterSingleConstr and others" ~:
    do refTuple <- initRefTuple
       let (getter, setter) = mkGetterSetter noCtx readIORef writeIORef refTuple
       getter >>= assertEqual "Initial value" initTuple
       setter otherTuple
       getter >>= assertEqual "Initial value" otherTuple

testSetAndGetFieldFun = "testSetAndGetFieldFun" ~:
    do let (init1, init2, init3) = initTuple
       case mkFullSpliter noCtx initOuterTuple of
         Part (FullPart _ get3rd set3rd) (Part (FullPart _ get2nd set2nd) (Part (FullPart _ get1st set1st) _))
               -> case (cast set1st, cast set2nd, cast set3rd
                       , cast get1st, cast get2nd, cast get3rd) of
                    (Just set1, Just set2, Just set3, Just get1, Just get2, Just get3)
                        -> do assertEqual "set 1st" (17::Int, init2, init3) (set1 initTuple (17::Int))
                              assertEqual "set 2nd" (init1, "2nd", init3) (set2 initTuple "2nd")
                              assertEqual "set 3rd" (init1, init2, 127.5::Float) (set3 initTuple (127.5::Float))
                              assertEqual "get 1st" init1 (get1 initTuple)
                              assertEqual "get 2nd" init2 (get2 initTuple)
                              assertEqual "get 3rd" init3 (get3 initTuple)
                    _ -> assertFailure "Cast failed (testSetFieldFun)"
         _ -> assertFailure "should always match other pattern (testSetFieldFun)"