{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 806
{-# LANGUAGE StarIsType #-}   
#endif
{-# LANGUAGE DeriveGeneric #-}            
{-# LANGUAGE GeneralizedNewtypeDeriving #-}            
{-# LANGUAGE DerivingStrategies #-}            
{-# LANGUAGE DeriveFunctor #-}            
{-# LANGUAGE RankNTypes #-}            
{-# LANGUAGE StandaloneDeriving #-}            
{-# LANGUAGE DataKinds #-}            
{-# LANGUAGE TypeOperators #-}            
{-# LANGUAGE GADTs #-}            
{-# LANGUAGE KindSignatures #-}            
{-# LANGUAGE TypeFamilies #-}            
{-# LANGUAGE FlexibleContexts #-}            
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}



module Types where
import           Arity
import           Control.Monad.IO.Class
import           Data.Binary
import           Data.Derive.Superclass
import           Data.Derive.TopDown
import           Data.Proxy
import           Data.Ratio
import           GHC.Generics            hiding ( C
                                                , D
                                                )
import           Language.Haskell.Syntax
-- types for testing

-- ^ simple cases
type Age = Int
data Person = Person
  { pname :: String
  , age   :: Age
  }
data Department = Department
  { head   :: Person
  , staffs :: [Person]
  }
data Company = Company
  { manager     :: Person
  , departments :: [Department]
  }

$(deriving_superclasses ''Ord ''Person)
$(deriving_ ''Show ''Company)
$(deriving_ ''Generic ''Company)
$(instance_ ''Binary ''Company)
$(deriving_th_with (''TypeArity, makeTypeArity) ''Company [int, char])

-- for enumeration
data E0 = E01 | E02 | E03 | E04

$(deriving_superclasses ''Ord ''E0)
$(deriving_ ''Show ''E0)
$(deriving_ ''Generic ''E0)
$(deriving_th (''TypeArity, makeTypeArity) ''E0)
data I a = I a
data B a b = B a b
data T a b c = T a b c

$(deriving_superclasses ''Ord ''I)
$(deriving_superclasses ''Ord ''B)
$(deriving_superclasses ''Ord ''T)

$(deriving_ ''Show ''I)
$(deriving_ ''Show ''B)
$(deriving_ ''Show ''T)

$(deriving_ ''Generic ''I)
$(deriving_ ''Generic ''B)
$(deriving_ ''Generic ''T)

$(instance_ ''Binary ''I)
$(instance_ ''Binary ''B)
$(instance_ ''Binary ''T)

$(deriving_th (''TypeArity, makeTypeArity) ''I)
$(deriving_th (''TypeArity, makeTypeArity) ''B)
$(deriving_th (''TypeArity, makeTypeArity) ''T)

-- regular constructor
data T1 = T11 Int Bool Char
        | T12 String
        | T13 [Int]
        | T14 (Int, Bool, Char)

$(deriving_superclasses ''Ord ''T1)
$(deriving_ ''Show ''T1)
$(deriving_ ''Generic ''T1)
$(instance_ ''Binary ''T1)
$(deriving_th (''TypeArity, makeTypeArity) ''T1)

data T2 a b = T21 a [b]
            | T22 b (Bool) (Either a b)
            | T23 Int ((a, b)) (Maybe a)
            | T24 (T3 Maybe a b)


data T3 (k :: * -> *) (a :: *) b = T31 (k a) [b]
                                 | T32 b Bool (a) (Maybe a)
                                 | T33 Int (a, k b)
                                 | T34 (T2 a b)
-- 2 mutual recursive declaration
$(deriving_ ''Show ''T2)
$(deriving_ ''Show ''T3)

-- $(deriving_superclasses ''Ord ''T2)
-- $(deriving_superclasses ''Ord ''T3)
fmap concat (sequence [(deriving_superclasses ''Ord ''T2), (deriving_superclasses ''Ord ''T3)])
$(deriving_ ''Generic ''T2)
$(deriving_ ''Generic ''T3)
$(instance_ ''Binary ''T2)
$(instance_ ''Binary ''T3)

$(deriving_th (''TypeArity, makeTypeArity) ''T2)

-- mutual recursive declaration tests
data R0 a = R01 (R1 a)
data R1 x = R11 (R2 x) x
data R2 f = R21 (R3 f)
data R3 v = R31 (R4 v)
data R4 v = R41 (R5 v)
data R5 b = R51 (R6 b)
data R6 b = R61 (R1 b)
$(deriving_ ''Show ''R0)
$(deriving_ ''Generic ''R0)
$(deriving_ ''Generic1 ''R0)
$(instance_ ''Binary ''R0)
$(deriving_th (''TypeArity, makeTypeArity) ''R0)

data Rx0 a b c = Rx01 a (Rx1 Int a c) (Rx2 b c)
data Rx1 x y z = Rx11 z (Rx2 z x) | Rx12 (Rx0 Bool Char y)
data Rx2 f g = Rx21 (Rx3 Int g) (Rx1 f g f)
data Rx3 v b = Rx31 v | Rx32 (Rx1 Int Char b) b
$(deriving_th (''TypeArity, makeTypeArity) ''Rx0)

$(deriving_ ''Show ''Rx0)
$(deriving_ ''Generic ''Rx0)
$(deriving_with ''Generic1 ''Rx0 Nothing [''Rx1, ''Rx2] genInferredContext)
$(deriving_with ''Generic1 ''Rx3 Nothing [''Rx1] genInferredContext)
$(instance_ ''Binary ''Rx0)


-- forall type
-- deriving for this is unsupported by GHC
data T4 a = T41 (forall b . Show b => Either a b)
$(deriving_th_with (''TypeArity, makeTypeArity) ''T4 [''Either])

-- Type Operator
data (:=:) a b = E11 a b | E12 (a,b) | E13 [b] Int
$(deriving_ ''Show ''(:=:))
$(deriving_ ''Generic ''(:=:))


data T5 a b = T5 (a :=: b)

$(deriving_ ''Show ''T5)
$(deriving_ ''Generic ''T5)
$(deriving_ ''Generic1 ''T5)
$(deriving_th (''TypeArity, makeTypeArity) ''T5)
-- data type record

-- GADTs
data Exp a where
    Add :: Int  -> Int -> Exp Int
    And :: Bool -> Bool -> Exp Bool
    Le  :: Int  -> Int -> Exp Bool

$(deriving_ ''Show ''Exp)
$(deriving_th (''TypeArity, makeTypeArity) ''Exp)

-- Cannot derive Generic for GADT
-- must be a vanilla data constructor to derive
-- $(deriving_ ''Generic ''Exp)

data Aggregator = SUM | AVG | MIN | MAX | CNT | CNTD | ATTR

data Granularity = G0 | G1

data DataQL a where
  DimRaw :: String -> DataQL G0
  MsrRaw :: String -> DataQL G0
  Agg :: Aggregator -> DataQL G0 -> DataQL G1
  Include :: [DataQL G0] -> DataQL G1 -> DataQL G0
  Exclude :: [DataQL G0] -> DataQL G1 -> DataQL G0
  Fixed   :: [DataQL G0] -> DataQL G1 -> DataQL G0

$(deriving_ ''Show ''DataQL)
$(deriving_th (''TypeArity, makeTypeArity) ''DataQL)
-- TODO: Record GADTs

-- ^ phantom
-- TODO: test a is not in the context
data P1 a = P1C1 (P2 a)
data P2 b = P2C1 Int

$(deriving_ ''Show ''P1)
$(deriving_ ''Generic ''P1)
$(deriving_th (''TypeArity, makeTypeArity) ''P1)

-- ^ type family
type family F a b

type instance F Int Char = Bool
type instance F String Char = String
type instance F a Int = Maybe a

type family G x

-- TODO: test G b is not in the context
data T6 a b c = T61 (Maybe (F a c)) a (Proxy (G b))
$(deriving_ ''Show ''T6)
$(deriving_ ''Generic ''T6)
-- TODO: template instance generation need to handle type family
-- $(deriving_th (''TypeArity, makeTypeArity) ''T6)

-- ^ recursive definition
data List a = Nil | Cons a (List a)
$(deriving_ ''Show ''List)
$(deriving_ ''Generic ''List)
$(deriving_ ''Generic1 ''List)
$(deriving_th (''TypeArity, makeTypeArity) ''List)

-- ^ recursive defintion
data Stream k a b c = S (k a) | S2 a (Stream k b c Int)
    -- deriving Eq
{-
deriving Eq in GHC for Stream will not put (k Int) in the context
-}
-- context is (k b),(k b), a, b, c should be 
$(deriving_ ''Show ''Stream)
$(deriving_ ''Generic ''Stream)
$(deriving_th (''TypeArity, makeTypeArity) ''Stream)

-- ^ composite 
-- TODO: test b is not in context
data P a b = P (E a (Px b))
data E x y = L x | R y
data Px z = Px
$(deriving_ ''Show ''P)
$(deriving_ ''Generic ''P)
$(deriving_ ''Functor ''P)
$(deriving_ ''Generic1 ''P)
$(deriving_th (''TypeArity, makeTypeArity) ''P)
#if __GLASGOW_HASKELL__ >= 804
$(deriving_with ''Binary ''E Nothing [] genHoleContext)
#else
$(deriving_with ''Binary ''E Nothing [] genInferredContext)
#endif

-- $(instance_with ''Binary ''E  [] Nothing genHoleContext)
-- GHC deriving does not work on ForallT 
data C b = C (forall a. Show a => a) b | C2 Int b (Maybe Bool)

-- C must not have exotic unlifted or polymorphic argument
-- $(deriving_ ''Generic ''C)
$(deriving_th (''TypeArity, makeTypeArity) ''C)

-- ^ ForallC
data D a = forall b. Show b => D b | D2 a
$(deriving_ ''Show ''D)
$(deriving_th (''TypeArity, makeTypeArity) ''D)

-- ^ for superclass MonadIO 
newtype IO_ a = IO_ (IO a)
$(strategy_deriving_superclasses NewtypeStrategy ''MonadIO ''IO_)
$(deriving_th (''TypeArity, makeTypeArity) ''IO_)

-- ^ for superclass RealFloat
newtype F32 = F32 Float
$(strategy_deriving_superclasses NewtypeStrategy ''RealFloat ''F32)
$(deriving_th (''TypeArity, makeTypeArity) ''F32)

-- deriving GHC syntax tree in haskell-src
$(deriving_ ''Ord ''HsModule)
$(deriving_with ''Generic ''HsModule Nothing [''Ratio] genInferredContext)
$(instance_ ''Binary ''HsModule)
$(deriving_th (''TypeArity, makeTypeArity) ''HsModule)