{-# LANGUAGE CPP                #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE Trustworthy        #-}

#if MIN_VERSION_base(4,9,0)
#define LIFTED_FUNCTOR_CLASSES 1
#else
#if MIN_VERSION_transformers(0,5,0)
#define LIFTED_FUNCTOR_CLASSES 1
#else
#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)
#define LIFTED_FUNCTOR_CLASSES 1
#endif
#endif
#endif

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable     #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DeriveTraversable  #-}
module Data.Functor.These (
    These1 (..),
    ) where

import Prelude ()
import Prelude.Compat

import Data.Functor.Classes
       (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..), compare1, eq1, readsPrec1,
       showsPrec1)
import GHC.Generics         (Generic)


#if MIN_VERSION_deepseq(1,4,3)
import Control.DeepSeq (NFData (..), NFData1 (..), rnf1)
#endif

#if __GLASGOW_HASKELL__ >= 706
import GHC.Generics (Generic1)
#endif

#if __GLASGOW_HASKELL__ >= 708
import Data.Data     (Data)
import Data.Typeable (Typeable)
#endif

#ifdef MIN_VERSION_aeson
import Data.Aeson
       (FromJSON (..), FromJSON1 (..), ToJSON (..), ToJSON1 (..), (.=))
import qualified Data.Aeson          as Aeson
import qualified Data.Aeson.Encoding as Aeson (pair)
import qualified Data.HashMap.Strict as HM
#endif

#ifdef MIN_VERSION_QuickCheck
import Test.QuickCheck
       (Arbitrary (..), Arbitrary1 (..), arbitrary1, liftShrink2, oneof,
       shrink1)
#endif

-------------------------------------------------------------------------------
-- These1
-------------------------------------------------------------------------------

data These1 f g a
    = This1 (f a)
    | That1 (g a)
    | These1 (f a) (g a)
  deriving (Functor, Foldable, Traversable, Generic
#if __GLASGOW_HASKELL__ >= 706
    , Generic1
#endif
#if __GLASGOW_HASKELL__ >= 708
    , Typeable, Data
#endif
    )

-------------------------------------------------------------------------------
-- Eq1
-------------------------------------------------------------------------------

instance (Eq1 f, Eq1 g) => Eq1 (These1 f g) where
#ifdef LIFTED_FUNCTOR_CLASSES
    liftEq eq (This1 f)    (This1 f')     = liftEq eq f f'
    liftEq eq (That1 g)    (That1 g')     = liftEq eq g g'
    liftEq eq (These1 f g) (These1 f' g') = liftEq eq f f' && liftEq eq g g'

    liftEq _ This1  {} _ = False
    liftEq _ That1  {} _ = False
    liftEq _ These1 {} _ = False
#else
    eq1 (This1 f)    (This1 f')     = eq1 f f'
    eq1 (That1 g)    (That1 g')     = eq1 g g'
    eq1 (These1 f g) (These1 f' g') = eq1 f f' && eq1 g g'

    eq1 This1  {} _ = False
    eq1 That1  {} _ = False
    eq1 These1 {} _ = False
#endif

-------------------------------------------------------------------------------
-- Ord1
-------------------------------------------------------------------------------

instance (Ord1 f, Ord1 g) => Ord1 (These1 f g) where
#ifdef LIFTED_FUNCTOR_CLASSES
    liftCompare  cmp (This1 f) (This1 f') = liftCompare cmp f f'
    liftCompare _cmp (This1 _) _          = LT
    liftCompare _cmp _         (This1 _)  = GT

    liftCompare  cmp (That1 g) (That1 g') = liftCompare cmp g g'
    liftCompare _cmp (That1 _) _          = LT
    liftCompare _cmp _         (That1 _)  = GT

    liftCompare  cmp (These1 f g) (These1 f' g') =
        liftCompare cmp f f' `mappend` liftCompare cmp g g'
#else
    compare1 (This1 f) (This1 f') = compare1 f f'
    compare1 (This1 _) _          = LT
    compare1 _         (This1 _)  = GT

    compare1 (That1 g) (That1 g') = compare1 g g'
    compare1 (That1 _) _          = LT
    compare1 _         (That1 _)  = GT

    compare1  (These1 f g) (These1 f' g') =
        compare1 f f' `mappend` compare1 g g'
#endif


-------------------------------------------------------------------------------
-- Show1
-------------------------------------------------------------------------------

instance (Show1 f, Show1 g) => Show1 (These1 f g) where
#ifdef LIFTED_FUNCTOR_CLASSES
    liftShowsPrec sp sl d (This1 f) = showParen (d > 10)
        $ showString "This1 "
        . liftShowsPrec sp sl 11 f
    liftShowsPrec sp sl d (That1 g) = showParen (d > 10)
        $ showString "That1 "
        . liftShowsPrec sp sl 11 g
    liftShowsPrec sp sl d (These1 f g) = showParen (d > 10)
        $ showString "These1 "
        . liftShowsPrec sp sl 11 f
        . showChar ' '
        . liftShowsPrec sp sl 11 g
#else
    showsPrec1 d (This1 f) = showParen (d > 10)
        $ showString "This1 "
        . showsPrec1 11 f
    showsPrec1 d (That1 g) = showParen (d > 10)
        $ showString "That1 "
        . showsPrec1 11 g
    showsPrec1 d (These1 f g) = showParen (d > 10)
        $ showString "These1 "
        . showsPrec1 11 f
        . showChar ' '
        . showsPrec1 11 g
#endif

-------------------------------------------------------------------------------
-- Read1
-------------------------------------------------------------------------------

instance (Read1 f, Read1 g) => Read1 (These1 f g) where
#ifdef LIFTED_FUNCTOR_CLASSES
    liftReadsPrec rp rl d = readParen (d > 10) $ \s0 -> do
        (t, s1) <- lex s0
        case t of
            "This1" -> do
                (x, s2) <- liftReadsPrec rp rl 11 s1
                return (This1 x, s2)
            "That1" -> do
                (y, s2) <- liftReadsPrec rp rl 11 s1
                return (That1 y, s2)
            "These1" -> do
                (x, s2) <- liftReadsPrec rp rl 11 s1
                (y, s3) <- liftReadsPrec rp rl 11 s2
                return (These1 x y, s3)
            _ -> []
#else
    readsPrec1 d = readParen (d > 10) $ \s0 -> do
        (t, s1) <- lex s0
        case t of
            "This1" -> do
                (x, s2) <- readsPrec1 11 s1
                return (This1 x, s2)
            "That1" -> do
                (y, s2) <- readsPrec1 11 s1
                return (That1 y, s2)
            "These1" -> do
                (x, s2) <- readsPrec1 11 s1
                (y, s3) <- readsPrec1 11 s2
                return (These1 x y, s3)
            _ -> []
#endif

-------------------------------------------------------------------------------
-- Eq, Ord, Show, Read
-------------------------------------------------------------------------------

instance (Eq1 f, Eq1 g, Eq a) => Eq (These1 f g a) where (==) = eq1
instance (Ord1 f, Ord1 g, Ord a) => Ord (These1 f g a) where compare = compare1
instance (Show1 f, Show1 g, Show a) => Show (These1 f g a) where showsPrec = showsPrec1
instance (Read1 f, Read1 g, Read a) => Read (These1 f g a) where readsPrec = readsPrec1

-------------------------------------------------------------------------------
-- deepseq
-------------------------------------------------------------------------------

#if MIN_VERSION_deepseq(1,4,3)
-- | This instance is available only with @deepseq >= 1.4.3.0@
instance (NFData1 f, NFData1 g) => NFData1 (These1 f g) where
    liftRnf r (This1 x)    = liftRnf r x
    liftRnf r (That1 y)    = liftRnf r y
    liftRnf r (These1 x y) = liftRnf r x `seq` liftRnf r y

-- | This instance is available only with @deepseq >= 1.4.3.0@
instance (NFData1 f, NFData1 g, NFData a) => NFData (These1 f g a) where
    rnf = rnf1
#endif

-------------------------------------------------------------------------------
-- aeson
-------------------------------------------------------------------------------

#ifdef MIN_VERSION_aeson
instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (These1 f g) where
    liftToJSON tx tl (This1 a)    = Aeson.object [ "This" .= liftToJSON tx tl a ]
    liftToJSON tx tl (That1 b)    = Aeson.object [ "That" .= liftToJSON tx tl b ]
    liftToJSON tx tl (These1 a b) = Aeson.object [ "This" .= liftToJSON tx tl a, "That" .= liftToJSON tx tl b ]

    liftToEncoding tx tl (This1 a)    = Aeson.pairs $ Aeson.pair "This" (liftToEncoding tx tl a)
    liftToEncoding tx tl (That1 b)    = Aeson.pairs $ Aeson.pair "That" (liftToEncoding tx tl b)
    liftToEncoding tx tl (These1 a b) = Aeson.pairs $
        Aeson.pair "This" (liftToEncoding tx tl a) `mappend`
        Aeson.pair "That" (liftToEncoding tx tl b)

instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where
    liftParseJSON px pl = Aeson.withObject "These1" (p . HM.toList)
      where
        p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b
        p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b
        p [("This", a)] = This1 <$> liftParseJSON px pl a
        p [("That", b)] = That1 <$> liftParseJSON px pl b
        p _  = fail "Expected object with 'This' and 'That' keys only"

instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (These1 f g a) where
    toJSON = Aeson.toJSON1
    toEncoding = Aeson.toEncoding1

instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (These1 f g a) where
    parseJSON = Aeson.parseJSON1
#endif

-------------------------------------------------------------------------------
-- QuickCheck
-------------------------------------------------------------------------------

#ifdef MIN_VERSION_QuickCheck
instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (These1 f g) where
    liftArbitrary arb = oneof
        [ This1 <$> liftArbitrary arb
        , That1 <$> liftArbitrary arb
        , These1 <$> liftArbitrary arb <*> liftArbitrary arb
        ]

    liftShrink shr (This1 x) = This1 <$> liftShrink shr x
    liftShrink shr (That1 y) = That1 <$> liftShrink shr y
    liftShrink shr (These1 x y) =
        [ This1 x, That1 y ] ++
        [ These1 x' y'
        | (x', y') <- liftShrink2 (liftShrink shr) (liftShrink shr) (x, y)
        ]

instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (These1 f g a) where
    arbitrary = arbitrary1
    shrink    = shrink1
#endif