{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Map.Syntax.Tests where

------------------------------------------------------------------------------
import qualified Data.List as L
import           Data.Function (on)
import qualified Data.Map as M
import           Data.Monoid (mempty,(<>))
import           Test.Framework (Test)
import           Test.Framework.Providers.HUnit (testCase)
import           Test.Framework.Providers.QuickCheck2 (testProperty)
import           Test.HUnit (assertEqual)

import           Data.Map.Syntax
import           Data.Map.Syntax.Util (mkMapABC, mkMapDEF,mkMapAEF,
                                       ArbMapSyntax(..))
------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- |Simple tests for not-nested maps
insTests :: [Test]
insTests =
  [testCase "Insert overwrite" overDup
  ,testCase "Insert over fail" failDup
  ,testCase "Reject duplicate" skipDup
  ,testCase "Trying dupFunc" dupFunc
  ,testProperty "Insert overwrite from list" prop_syntaxMatchesNubOver
  ,testProperty "Insert conditional from list" prop_syntaxMatchesNubCond
  ,testProperty "Insert error on dup from list" prop_syntaxMatchesNubErr]

monoidLaws :: [Test]
monoidLaws =
  [testProperty "Left identity"  prop_leftId
  ,testProperty "Right identity" prop_rightId
  ,testProperty "Associativity"  prop_assoc
  ]

  
------------------------------------------------------------------------------
-- |Simple tests of ##, #!, #?
overDup :: IO ()
overDup = assertEqual "Failed to overwrite duplicate entry"
          (Right $ M.fromList [("firstName","Egon") :: (String,String)])
          (runMap $ mkDupMap (##))

failDup :: IO ()
failDup = assertEqual "Failed to error on duplicate entry"
          (Left [("firstName" :: String)])
          (runMap $ mkDupMap (#!))

skipDup :: IO ()
skipDup = assertEqual "Failed to reject duplicate entry"
          (Right $ M.fromList [("firstName","Peter")])
          (runMap $ mkDupMap (#?))

dupFunc :: IO ()
dupFunc = assertEqual "Failed use dupFunc"
          (Right $ M.fromList [("firstName","firstNamePeterEgon")
            :: (String,String)])
          (runMapSyntax' f M.lookup M.insert $ mkDupMap (#!))
  where
    f k v v1 = Just (k <> v1 <> v)

mkDupMap :: (String -> String -> MapSyntax String String)
            -> MapSyntax String String
mkDupMap strat = do
  "firstName" `strat` "Peter"
  "firstName" `strat` "Egon"


------------------------------------------------------------------------------
prop_syntaxMatchesNubOver :: [(String,Int)] -> Bool
prop_syntaxMatchesNubOver pairs = Right revNubMap == (runMap mSyntax)
  where mSyntax   = mapM_ (\(k,v) -> (k ## v)) pairs
        revNubMap = M.fromList . L.nubBy ((==) `on` fst) . L.reverse $ pairs
        -- Nub keeps the first of each unique entry, so reverse list to
        -- simulate keeping the last

prop_syntaxMatchesNubCond :: [(String,Int)] -> Bool
prop_syntaxMatchesNubCond pairs = Right nubMap == (runMap mSyntax)
  where mSyntax = mapM_ (\(k,v) -> (k #? v)) pairs 
        nubMap  = M.fromList . L.nubBy ((==) `on` fst) $ pairs

prop_syntaxMatchesNubErr :: [(String,Int)] -> Bool
prop_syntaxMatchesNubErr pairs =
  let mMap = runMap $ mapM_ (\(k,v) -> (k #! v)) pairs
  in if   pairs == L.nubBy ((==) `on` fst) pairs
     then mMap == (Right . M.fromList $ pairs)
     else case mMap of
       Right _ -> False  -- We expected (Left dupKeys)
       Left  _ -> True   -- Wasn't sure about semantics here
                         -- runMap ... ("a" #! 1) >> ("a" #! 2) >> ("a" #! 3)
                         -- should be (Left ["a"]), or (Left ["a","a"])?


------------------------------------------------------------------------------
-- |Tests for #! when do blocks are nested
nestingTests :: [Test]
nestingTests =
  [testCase "Nested error dups"          nestedErr
  ,testCase "Nested error dups mapK"     nestedErrMapK
  ,testCase "Nester error dups mapV"     nestedErrMapV
  ,testCase "Nested overwrite dups"      nestedOver
  ,testCase "Nested overwrite dups mapK" nestedOverMapK
  ,testCase "Nested overwrite dups mapV" nestedOverMapV
  ,testCase "Nested ignore dups mixed"   nestedIgnoreMix
  ,testCase "Nested complex pass"        nestedComplex
  ,testCase "Nested complex error"       nestedComplexErr]


nestedErr :: IO ()
nestedErr = assertEqual "Failed to error on duplicates across do blocks"
            (Left ['E','F'])
            (runMap $ do {mkMapDEF (#!); mkMapAEF (#!)})

nestedErrMapK :: IO ()
nestedErrMapK = assertEqual "Failed to error on mapK'ed dups across blocks"
                (Left ['B'])
                (runMap $ do
                    mapK succ $ mkMapABC (#!)
                    mapK succ $ mkMapAEF (#!)
                )

nestedErrMapV :: IO ()
nestedErrMapV = assertEqual "Failed to error on mapV'ed dups across blocks"
                (Left ['A'])
                (runMap $ do
                    mapV succ $ mkMapABC (#!)
                    mapV succ $ mkMapAEF (#!)
                    )

nestedOver :: IO ()
nestedOver = assertEqual "Failed to overwrite dup entries across blocks"
             (Right $ M.fromList
              [('A',100),('B',2),('C',3),('E',200),('F',300)])
             (runMap $ do
                 mkMapABC (##)
                 mkMapAEF (##)
             )

nestedOverMapK :: IO ()
nestedOverMapK = assertEqual "Failed to mapK in nested blocks"
                 (Right $ M.fromList
                  [('A',100),('E',200),('F',300),('C',10),('D',20),('B',2)])
                 (runMap $ do
                     mkMapABC (##)
                     mapK pred $ mkMapDEF (##)
                     mkMapAEF (##)
                 )

nestedOverMapV :: IO ()
nestedOverMapV = assertEqual "Failed to mapV in nested blocks"
                 (Right $ M.fromList
                  [('A',99),('B',2),('C',3),('E',199),('F',299)])
                 (runMap $ do
                     mkMapABC (##)
                     mapV pred $ mkMapAEF (##)
                 )

nestedIgnoreMix :: IO ()
nestedIgnoreMix = assertEqual "Failed to mapK/mapV in 'Ignore' do blocks"
                 (Right $ M.fromList
                  [('B',0),('C',1),('D',2),('E',31),('@',101)])
                 (runMap $ do
                     mapV pred . mapK succ $ mkMapABC (#?)
                     mapV succ . mapK pred $ mkMapDEF (#?)
                     mapK pred . mapV succ $ mkMapAEF (#?)
                 )

nestedComplex :: IO ()
nestedComplex = assertEqual "Failed a mix of dup strategies in nested block"
                (Right $ M.fromList
                  [('@',1),('A',2),('B',1000),('C',1000),('D',10),('E',20),('F',30),('G',300),('H',199),('I',299)])
                (runMap $ do
                    mapK succ . mapK succ $ mkMapABC (##)
                    mapK succ . mapK succ . mapK succ . mapV pred $
                      mkMapAEF (#?)                 
                    mapK succ ((mapV (const 1000) $ mkMapABC (##)) >>
                               mkMapAEF (#?))                 
                    mkMapDEF (##)                    
                    mapK pred $ mkMapABC (#?)                 
                )

nestedComplexErr :: IO ()
nestedComplexErr = assertEqual
                   "Failed to detect dup in complex nested block"
                   (Left ['B'])
                   (runMap $ do
                       mapK succ . mapK succ $ mkMapABC (##)
                       mapK succ . mapK succ . mapK succ . mapV pred $
                         mkMapAEF (#?)                 
                       mapK succ ((mapV (const 1000) $ mkMapABC (##)) >>
                                  mkMapAEF (#?))
                       mapK pred $ mkMapABC (#!)
                       mkMapDEF (##)                    
                       mapK pred $ mkMapABC (#?)
                   )


------------------------------------------------------------------------------
-- |Monoid Laws
prop_leftId :: ArbMapSyntax String Int -> Bool
prop_leftId a = runMap (mempty <> m) == runMap m
  where m = unArbSyntax a

prop_rightId :: ArbMapSyntax String Int -> Bool
prop_rightId a = runMap (m <> mempty) == runMap m
  where m = unArbSyntax a

prop_assoc :: ArbMapSyntax String Int
              -> ArbMapSyntax String Int
              -> ArbMapSyntax String Int
              -> Bool
prop_assoc a' b' c' = runMap ((a <> b) <> c) == runMap (a <> (b <> c))
  where a = unArbSyntax a'
        b = unArbSyntax b'
        c = unArbSyntax c'