{-# LANGUAGE TypeOperators,StandaloneDeriving #-}
module Test.QuickCheck.ZoomEq where

import Control.Invariant 
import Control.Lens hiding (from,to)

import Data.List.NonEmpty as NE (toList,NonEmpty)
import qualified Data.Map as M
import Data.Functor.Classes
import Data.Functor.Compose
import Data.Proxy
import Data.Word

import GHC.Generics

import Test.QuickCheck hiding ((===),counterexample)

infix 4 .==

newtype ShallowZoom a = ShallowZoom { unShallowZoom :: a } 
    deriving (Eq, Show)

class (Eq a,Show a) => ZoomEq a where
    (.==) :: a -> a -> Invariant
    default (.==) :: (GZoomEq (Rep a),Generic a,Eq a) 
                   => a -> a -> Invariant
    (.==) = genericZoomEq

genericZoomEq :: (GZoomEq (Rep a),Generic a,Eq a,Show a) 
              => a -> a -> Invariant
genericZoomEq x y | x == y    = return ()
                  | otherwise = xs
    where
        xs = gZoomEq (from x) (from y)

instance (Eq a,Show a) => ZoomEq (ShallowZoom a) where
    (.==) = (===)

instance ZoomEq (Proxy a) where
deriving instance ZoomEq a => ZoomEq (Identity a) 
instance ZoomEq Char where
    (.==) = (===)
instance ZoomEq Float where
    (.==) = (===)
instance ZoomEq Double where
    (.==) = (===)
instance ZoomEq Int where
    (.==) = (===)
instance ZoomEq Word16 where
    (.==) = (===)
instance ZoomEq Word32 where
    (.==) = (===)
instance ZoomEq Word64 where
    (.==) = (===)
instance (ZoomEq a,ZoomEq b) => ZoomEq (Either a b) where
deriving instance (ZoomEq (f (g a)),Eq a,Eq1 f,Eq1 g,Show a,Functor f,Show1 f,Show1 g) 
        => ZoomEq (Compose f g a) 
instance ZoomEq a => ZoomEq (Checked a) where
    x .== y = (x^.content') .== (y^.content')
instance ZoomEq a => ZoomEq (Maybe a) where
instance ZoomEq () where
    () .== () = return ()
instance (ZoomEq a,ZoomEq b) => ZoomEq (a,b) where
instance (ZoomEq a,ZoomEq b,ZoomEq c) => ZoomEq (a,b,c) where
instance (ZoomEq a,ZoomEq b,ZoomEq c,ZoomEq d) => ZoomEq (a,b,c,d) where
instance (ZoomEq a,ZoomEq b,ZoomEq c,ZoomEq d,ZoomEq e) => ZoomEq (a,b,c,d,e) where

instance ZoomEq a => ZoomEq (NonEmpty a) where
    xs .== ys = NE.toList xs .== NE.toList ys

instance (Ord k,Show k,ZoomEq a) => ZoomEq (M.Map k a) where
    xs .== ys = pXS >> pYS >> sequence_ (M.elems $ M.intersectionWithKey prop xs ys)
        where
            xs' = xs `M.difference` ys
            ys' = ys `M.difference` xs
            pXS = ("left keys:  " ++ show (M.keys xs')) ## M.null xs'
            pYS = ("right keys: " ++ show (M.keys ys')) ## M.null ys'
            prop k x y = ("key: " ++ show k) ## (x .== y)

instance ZoomEq a => ZoomEq [a] where
    xs .== ys = sequence_ $
                    zipWith3 (\i x y -> show i ## x .== y) [0..] xs ys
                ++ ["length" ## (length xs === length ys)]

class GZoomEq a where
    gZoomEq :: a p -> a p -> Invariant

instance GZoomEq a => GZoomEq (D1 z a) where
    gZoomEq (M1 x) (M1 y) = gZoomEq x y

instance (GZoomEq a,Constructor c) => GZoomEq (C1 c a) where
    gZoomEq c@(M1 x) (M1 y) = conName c ## gZoomEq x y

instance (ZoomEq a,Show a) => GZoomEq (K1 k a) where
    gZoomEq (K1 x) (K1 y) = x .== y

conjProp :: (Property -> Property) 
         -> [Property] -> [Property]
conjProp _ [] = []
conjProp f xs = [conjoin $ map f xs]

instance (GZoomEq a,Selector s) => GZoomEq (S1 s a) where
    gZoomEq s@(M1 x) (M1 y) = 
            (selName s ++ " = ") ## gZoomEq x y

instance (GZoomEq a,GZoomEq b) => GZoomEq (a :*: b) where
    gZoomEq (x0 :*: x1) (y0 :*: y1) = gZoomEq x0 y0 >> gZoomEq x1 y1

instance (GZoomEq a,GZoomEq b) => GZoomEq (a :+: b) where
    gZoomEq (L1 x) (L1 y) = gZoomEq x y
    gZoomEq (R1 x) (R1 y) = gZoomEq x y
    gZoomEq _ _ = return ()

instance GZoomEq U1 where
    gZoomEq _ _ = return ()