{-# OPTIONS_GHC -fno-warn-orphans  #-}
{-# language DataKinds             #-}
{-# language FlexibleInstances     #-}
{-# language MultiParamTypeClasses #-}
{-# language ScopedTypeVariables   #-}
{-# language TypeOperators         #-}
module Generics.Kind.Derive.Examples where

import           Data.Aeson                           (FromJSON (..), ToJSON (..))
import           Data.PolyKinded.Functor
import           Data.Traversable                     (foldMapDefault)

import           Generics.Kind
import           Generics.Kind.Derive.Eq
import           Generics.Kind.Derive.FunctorOne
import           Generics.Kind.Derive.FunctorPosition
import           Generics.Kind.Derive.Json
import           Generics.Kind.Derive.KFunctor
import           Generics.Kind.Derive.Traversable
import           Generics.Kind.Examples

-- Maybe
instance KFunctor Maybe '[ 'Co ] (a ':&&: 'LoT0) (b ':&&: 'LoT0) where
  kfmap :: Mappings
  @(* -> *)
  ((':) @Variance 'Co ('[] @Variance))
  ((':&&:) @(*) @(*) a 'LoT0)
  ((':&&:) @(*) @(*) b 'LoT0)
-> (:@@:) @(* -> *) Maybe ((':&&:) @(*) @(*) a 'LoT0)
-> (:@@:) @(* -> *) Maybe ((':&&:) @(*) @(*) b 'LoT0)
kfmap = forall k (f :: k) (v :: Variances) (as :: LoT k) (bs :: LoT k).
(GenericK @k f, GenericK @k f, GFunctor @k (RepK @k f) v as bs) =>
Mappings @k v as bs -> (:@@:) @k f as -> (:@@:) @k f bs
kfmapDefault

-- Tree
instance Eq a => Eq (Tree a) where
  == :: Tree a -> Tree a -> Bool
(==) = forall t.
(GenericK @(*) t, GEq @(*) (RepK @(*) t),
 ReqsEq @(*) (RepK @(*) t) 'LoT0) =>
t -> t -> Bool
geq'
instance ToJSON a => ToJSON (Tree a) where
  toJSON :: Tree a -> Value
toJSON = forall t.
(GenericK @(*) t, GToJSONK @(*) (RepK @(*) t) 'LoT0) =>
t -> Value
gtoJSON'
instance FromJSON a => FromJSON (Tree a) where
  parseJSON :: Value -> Parser (Tree a)
parseJSON = forall t.
(GenericK @(*) t, GFromJSONK @(*) (RepK @(*) t) 'LoT0) =>
Value -> Parser t
gfromJSON'
instance KFunctor Tree '[ 'Co ] (a ':&&: 'LoT0) (b ':&&: 'LoT0) where
  kfmap :: Mappings
  @(* -> *)
  ((':) @Variance 'Co ('[] @Variance))
  ((':&&:) @(*) @(*) a 'LoT0)
  ((':&&:) @(*) @(*) b 'LoT0)
-> (:@@:) @(* -> *) Tree ((':&&:) @(*) @(*) a 'LoT0)
-> (:@@:) @(* -> *) Tree ((':&&:) @(*) @(*) b 'LoT0)
kfmap = forall k (f :: k) (v :: Variances) (as :: LoT k) (bs :: LoT k).
(GenericK @k f, GenericK @k f, GFunctor @k (RepK @k f) v as bs) =>
Mappings @k v as bs -> (:@@:) @k f as -> (:@@:) @k f bs
kfmapDefault
instance Functor Tree where
  -- fmap = fmapDefault
  fmap :: forall a b. (a -> b) -> Tree a -> Tree b
fmap = forall (f :: * -> *) a b.
(GenericK @(* -> *) f, GenericK @(* -> *) f,
 GFunctorOne (RepK @(* -> *) f), Reqs (RepK @(* -> *) f) a b) =>
(a -> b) -> f a -> f b
fmapDefaultOne
instance Foldable Tree where
  foldMap :: forall m a. Monoid m => (a -> m) -> Tree a -> m
foldMap = forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault
instance Traversable Tree where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tree a -> f (Tree b)
traverse = forall (f :: * -> *) a b (g :: * -> *).
(GenericK @(* -> *) f, GenericK @(* -> *) f,
 GTraversable
   @(* -> *)
   (RepK @(* -> *) f)
   ('VZ @(*) @(*))
   (LoT1 @(*) a)
   (LoT1 @(*) b),
 Applicative g) =>
(a -> g b) -> f a -> g (f b)
traverseDefault

-- TTY (from https://gitlab.com/trupill/kind-generics/issues/3)
instance Eq (TTY m a) where
  == :: TTY @(*) m a -> TTY @(*) m a -> Bool
(==) = forall t.
(GenericK @(*) t, GEq @(*) (RepK @(*) t),
 ReqsEq @(*) (RepK @(*) t) 'LoT0) =>
t -> t -> Bool
geq'
instance ToJSON (TTY m a) where
  toJSON :: TTY @(*) m a -> Value
toJSON = forall t.
(GenericK @(*) t, GToJSONK @(*) (RepK @(*) t) 'LoT0) =>
t -> Value
gtoJSON'
{-
instance FromJSON (TTY m a) where
  parseJSON = gfromJSON'

Fails with:
• Couldn't match type ‘a’ with ‘()’ arising from a use of ‘gfromJSON'’
-}

fmapEither :: (a -> b) -> Either e a -> Either e b
fmapEither :: forall a b e. (a -> b) -> Either e a -> Either e b
fmapEither = forall (f :: * -> *) a b.
(GenericK @(* -> *) f, GenericK @(* -> *) f,
 GFunctor
   @(* -> *)
   (RepK @(* -> *) f)
   ((':) @Variance 'Co ('[] @Variance))
   ((':&&:) @(*) @(*) a 'LoT0)
   ((':&&:) @(*) @(*) b 'LoT0)) =>
(a -> b) -> f a -> f b
fmapDefault'

-- WeirdTree
instance Show b => KFunctor WeirdTree '[ 'Co ] (a ':&&: 'LoT0) (b ':&&: 'LoT0) where
  kfmap :: Mappings
  @(* -> *)
  ((':) @Variance 'Co ('[] @Variance))
  ((':&&:) @(*) @(*) a 'LoT0)
  ((':&&:) @(*) @(*) b 'LoT0)
-> (:@@:) @(* -> *) WeirdTree ((':&&:) @(*) @(*) a 'LoT0)
-> (:@@:) @(* -> *) WeirdTree ((':&&:) @(*) @(*) b 'LoT0)
kfmap = forall k (f :: k) (v :: Variances) (as :: LoT k) (bs :: LoT k).
(GenericK @k f, GenericK @k f, GFunctor @k (RepK @k f) v as bs) =>
Mappings @k v as bs -> (:@@:) @k f as -> (:@@:) @k f bs
kfmapDefault

-- WeirdTree with reflected existentials
-- instance (Eq a) => Eq (WeirdTreeR a) where
  -- (==) = geq'

instance Functor (SimpleIndex a) where
  fmap :: forall a b. (a -> b) -> SimpleIndex a a -> SimpleIndex a b
fmap = forall (f :: * -> *) a b.
(GenericK @(* -> *) f, GenericK @(* -> *) f,
 GFunctorPos
   @(* -> *)
   (RepK @(* -> *) f)
   ('VZ @(*) @(*))
   (LoT1 @(*) a)
   (LoT1 @(*) b)) =>
(a -> b) -> f a -> f b
fmapDefault
instance Foldable (SimpleIndex a) where
  foldMap :: forall m a. Monoid m => (a -> m) -> SimpleIndex a a -> m
foldMap = forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault
instance Traversable (SimpleIndex a) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SimpleIndex a a -> f (SimpleIndex a b)
traverse = forall (f :: * -> *) a b (g :: * -> *).
(GenericK @(* -> *) f, GenericK @(* -> *) f,
 GTraversable
   @(* -> *)
   (RepK @(* -> *) f)
   ('VZ @(*) @(*))
   (LoT1 @(*) a)
   (LoT1 @(*) b),
 Applicative g) =>
(a -> g b) -> f a -> g (f b)
traverseDefault

instance EFunctor f => Functor (Hkd f) where
  fmap :: forall a b. (a -> b) -> Hkd @(*) f a -> Hkd @(*) f b
fmap = forall (f :: * -> *) a b.
(GenericK @(* -> *) f, GenericK @(* -> *) f,
 GFunctorOne (RepK @(* -> *) f), Reqs (RepK @(* -> *) f) a b) =>
(a -> b) -> f a -> f b
fmapDefaultOne