{-# LANGUAGE CPP #-}

{- | Description: Data instances


'Data.Data.Data' instances for 'HListFlat' and 'Record' which pretend
to be flat data structures. The @Data@ instance for 'HList' gives a nested
structure.

NOTE: these instances do not work with ghc-7.8 with promoted
string (Symbol) labels because of
<https://ghc.haskell.org/trac/ghc/ticket/9111>

[@HList@]

The data instance for

> a :: HList '[Int, Double, b]

Looks like the same instance for

> type T b = (Int, (Double, (b, ())))


[@HListFlat@]

The Data instance for

> a :: Data b => HListFlat '[Int,Double,b]

will look like the Data instance for:

> data A b = A Int Double b


[@Record@]

For 'Record' similar ideas apply. An

> a :: Record '[ LVPair "x" Int, LVPair "y" Double ]

should behave like a:

> data A = A { x :: Int, y :: Double } deriving (Data)

Many unsafecoerces are necessary here because the Data class includes type
parameters @c@ that cannot be used in the class context for the instance.
Perhaps there is another way.

-}
module Data.HList.Data (
    -- * exports for type signatures/ haddock usage
    DataHListFlatCxt,
    DataRecordCxt,
    TypeRepsList(..),

    -- ** less likely to be used
    RecordLabelsStr(..),
    GfoldlK(..),
    GunfoldK(..),
    HListFlat(..),
    TypeablePolyK,
    ) where

import Data.HList.FakePrelude
import Data.HList.HList
import Data.HList.Record
import Data.HList.Variant
import Data.Data
import Data.HList.TIC
import Data.HList.TIP

-- for Typeable '[] and Typeable '(:) with ghc-7.6
import Data.Orphans ()

#if OLD_TYPEABLE
import Data.List
#endif

import Unsafe.Coerce


deriving instance Typeable (HList '[]) => Data (HList '[])
deriving instance
    (Data x,
     Data (HList xs),
     TypeablePolyK (x ': xs), -- for new typeable
     Typeable (HList (x ': xs) -- for old typeable
     )) => Data (HList (x ': xs))

deriving instance
    (TypeablePolyK xs,
     Typeable (HList xs),
     Data (HList xs)) => Data (TIP xs)
deriving instance
    (TypeablePolyK xs,
     Typeable (Variant xs),
     Data (Variant xs)) => Data (TIC xs)

-- | this data type only exists to have Data instance
newtype HListFlat a = HListFlat (HList a)

type DataHListFlatCxt na g a = (
        g ~ FoldRArrow a (HList a),
        HBuild' '[] g,
        Typeable (HListFlat a),
        TypeablePolyK a,
        HFoldl (GfoldlK  C) (C g) a (C (HList a)),

        HFoldr
            (GunfoldK C)
            (C g)
            (HReplicateR na ())
            (C (HList a)),

        HLengthEq a na,
        HReplicate na ())


-- | ghc-8.0.2 can't work out the type g,
-- in the 2nd argument of gfoldl. ghc <= 7.10
-- don't need it.
--
-- in `instance Data (HListFlat '[a,b,c])`
--
-- > g ~ (a -> b -> c -> HList '[a,b,c])
-- > g ~ GetG '[a,b,c] (HList '[a,b,c])
type family FoldRArrow (xs :: [*]) (r :: *)

type instance FoldRArrow '[] r = r
type instance FoldRArrow (x ': xs) r = x -> FoldRArrow xs r 


instance DataHListFlatCxt na g a => Data (HListFlat a) where
    gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HListFlat a -> c (HListFlat a)
gfoldl forall d b. Data d => c (d -> b) -> d -> c b
k forall g. g -> c g
z (HListFlat HList a
xs) = forall (c :: * -> *). C (HList a) -> c (HListFlat a)
c3 forall a b. (a -> b) -> a -> b
$
                    forall f z (xs :: [*]) r.
HFoldl f z xs r =>
f -> z -> HList xs -> r
hFoldl
                        (forall (c :: * -> *). GfoldlK c -> GfoldlK C
c1 (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b) -> GfoldlK c
GfoldlK forall d b. Data d => c (d -> b) -> d -> c b
k))
                        (forall (c :: * -> *). c g -> C g
c2 (forall g. g -> c g
z forall r. HBuild' '[] r => r
hBuild))
                        HList a
xs
        where
              c1 :: forall c. GfoldlK c -> GfoldlK C
              c1 :: forall (c :: * -> *). GfoldlK c -> GfoldlK C
c1 = forall a b. a -> b
unsafeCoerce

              c2 :: forall c. c g -> C g
              c2 :: forall (c :: * -> *). c g -> C g
c2 = forall a b. a -> b
unsafeCoerce

              c3 :: forall c. C (HList a) -> c (HListFlat a)
              c3 :: forall (c :: * -> *). C (HList a) -> c (HListFlat a)
c3 = forall a b. a -> b
unsafeCoerce

    gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (HListFlat a)
gunfold forall b r. Data b => c (b -> r) -> c r
k forall r. r -> c r
z Constr
_ =
              forall (c :: * -> *). C (HList a) -> c (HListFlat a)
c3 forall a b. (a -> b) -> a -> b
$ forall t (c :: * -> *). (t -> c t) -> c t
withSelf forall a b. (a -> b) -> a -> b
$ \HList a
self ->
                forall f v (l :: [*]) r. HFoldr f v l r => f -> v -> HList l -> r
hFoldr
                    (forall (c :: * -> *). GunfoldK c -> GunfoldK C
c1 (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r) -> GunfoldK c
GunfoldK forall b r. Data b => c (b -> r) -> c r
k))
                    (forall (c :: * -> *). c g -> C g
c2 (forall r. r -> c r
z forall r. HBuild' '[] r => r
hBuild))
                    (forall (n :: HNat) e (es :: [*]).
HReplicateFD n e es =>
Proxy n -> e -> HList es
hReplicate (forall (l :: [*]) (n :: HNat). HLengthEq l n => HList l -> Proxy n
hLength HList a
self) ())
        where
              withSelf :: forall t c. (t -> c t) -> c t
              withSelf :: forall t (c :: * -> *). (t -> c t) -> c t
withSelf t -> c t
x = t -> c t
x forall a. HasCallStack => a
undefined

              c1 :: forall c. GunfoldK c -> GunfoldK C
              c1 :: forall (c :: * -> *). GunfoldK c -> GunfoldK C
c1 = forall a b. a -> b
unsafeCoerce

              c2 :: forall c. c g -> C g
              c2 :: forall (c :: * -> *). c g -> C g
c2 = forall a b. a -> b
unsafeCoerce

              c3 :: forall c. C (HList a) -> c (HListFlat a)
              c3 :: forall (c :: * -> *). C (HList a) -> c (HListFlat a)
c3 = forall a b. a -> b
unsafeCoerce

    dataTypeOf :: HListFlat a -> DataType
dataTypeOf HListFlat a
_ = DataType
hListFlatDataRep
    toConstr :: HListFlat a -> Constr
toConstr HListFlat a
_   = Constr
hListFlatConRep

hListFlatDataRep :: DataType
hListFlatDataRep = String -> [Constr] -> DataType
mkDataType String
"Data.HList.HList" [Constr
hListFlatConRep]
hListFlatConRep :: Constr
hListFlatConRep = DataType -> String -> [String] -> Fixity -> Constr
mkConstr DataType
hListFlatDataRep String
"HListFlat" [] Fixity
Prefix

type DataRecordCxt a =
    (Data (HListFlat (RecordValuesR a)),
            TypeablePolyK a,
            TypeRepsList (Record a),
            RecordValues a,
            RecordLabelsStr a)

instance DataRecordCxt a => Data (Record a) where
    gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Record a -> c (Record a)
gfoldl forall d b. Data d => c (d -> b) -> d -> c b
k forall g. g -> c g
z Record a
xs = forall (c :: * -> *).
c (HListFlat (RecordValuesR a)) -> c (Record a)
c1 (forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
gfoldl forall d b. Data d => c (d -> b) -> d -> c b
k forall g. g -> c g
z (forall (a :: [*]). HList a -> HListFlat a
HListFlat (forall (r :: [*]).
RecordValues r =>
Record r -> HList (RecordValuesR r)
recordValues Record a
xs)))
        where
            c1 :: forall c. c (HListFlat (RecordValuesR a)) -> c (Record a)
            c1 :: forall (c :: * -> *).
c (HListFlat (RecordValuesR a)) -> c (Record a)
c1 = forall a b. a -> b
unsafeCoerce

    gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Record a)
gunfold forall b r. Data b => c (b -> r) -> c r
k forall r. r -> c r
z Constr
con = forall (c :: * -> *).
c (HListFlat (RecordValuesR a)) -> c (Record a)
c1 (forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a
gunfold forall b r. Data b => c (b -> r) -> c r
k forall r. r -> c r
z Constr
con)
        where
            -- LVPair and Record are newtypes, so this should be safe...
            c1 :: forall c. c (HListFlat (RecordValuesR a)) -> c (Record a)
            c1 :: forall (c :: * -> *).
c (HListFlat (RecordValuesR a)) -> c (Record a)
c1 = forall a b. a -> b
unsafeCoerce

    dataTypeOf :: Record a -> DataType
dataTypeOf Record a
x = forall a b. (a, b) -> b
snd ([String] -> (Constr, DataType)
recordReps (forall (xs :: [*]). RecordLabelsStr xs => Record xs -> [String]
recordLabelsStr Record a
x))
    toConstr :: Record a -> Constr
toConstr Record a
x = forall a b. (a, b) -> a
fst ([String] -> (Constr, DataType)
recordReps (forall (xs :: [*]). RecordLabelsStr xs => Record xs -> [String]
recordLabelsStr Record a
x))


recordReps :: [String] -> (Constr, DataType)
recordReps [String]
fields =
    let c :: Constr
c = DataType -> String -> [String] -> Fixity -> Constr
mkConstr DataType
d String
"Record" [String]
fields Fixity
Prefix
        d :: DataType
d = String -> [Constr] -> DataType
mkDataType String
"Data.HList.Record" [Constr
c]
    in (Constr
c,DataType
d)



class RecordLabelsStr (xs :: [*]) where
    recordLabelsStr :: Record xs -> [String]

instance RecordLabelsStr '[] where
    recordLabelsStr :: Record '[] -> [String]
recordLabelsStr Record '[]
_ = []
instance (RecordLabelsStr xs,
          ShowLabel x) => RecordLabelsStr (Tagged x t ': xs) where
    recordLabelsStr :: Record (Tagged x t : xs) -> [String]
recordLabelsStr Record (Tagged x t : xs)
_ = forall {k} (l :: k). ShowLabel l => Label l -> String
showLabel (forall {k} (l :: k). Label l
Label :: Label x) forall a. a -> [a] -> [a]
:
                            forall (xs :: [*]). RecordLabelsStr xs => Record xs -> [String]
recordLabelsStr (forall a. HasCallStack => a
undefined :: Record xs)

{- |

This alternative option works too, but for whatever reason
splitting up recordLabelsStr and recordLabels into two functions
means that a type annotation is needed on the 3, which is not
necessary with the above recordLabelsStr (ghc-7.6.3)

> recordLabelsStr2 (recordLabels (((Label :: Label "x") .=. 3 .*. emptyRecord )))

-}
class RecordLabelsStr2 (xs :: [k]) where
    recordLabelsStr2 :: proxy xs -> [String]

instance RecordLabelsStr2 '[] where
    recordLabelsStr2 :: forall (proxy :: [k] -> *). proxy '[] -> [String]
recordLabelsStr2 proxy '[]
_ = []
instance (RecordLabelsStr2 xs,
          ShowLabel x) => RecordLabelsStr2 (x ': xs) where
    recordLabelsStr2 :: forall (proxy :: [k] -> *). proxy (x : xs) -> [String]
recordLabelsStr2 proxy (x : xs)
_ = forall {k} (l :: k). ShowLabel l => Label l -> String
showLabel (forall {k} (l :: k). Label l
Label :: Label x) forall a. a -> [a] -> [a]
:
                            forall k (xs :: [k]) (proxy :: [k] -> *).
RecordLabelsStr2 xs =>
proxy xs -> [String]
recordLabelsStr2 (forall {k} (t :: k). Proxy t
Proxy :: Proxy xs)


-- | use only with @instance Data (HList a)@. This is because the HFoldl
-- context cannot be written for a @c@ that only appears in the method
-- 'gfoldl'.
data C a

-- typeable isntances... either hand written or derived when possible
#if !OLD_TYPEABLE
deriving instance Typeable Record
deriving instance Typeable HList
deriving instance Typeable HListFlat
deriving instance Typeable Variant
deriving instance Typeable TIC
deriving instance Typeable TIP

-- orphans
deriving instance Typeable 'HZero
deriving instance Typeable 'HSucc

#else
instance TypeRepsList (Record xs) => Typeable (HList xs) where
   typeOf x = mkTyConApp (mkTyCon3 "HList" "Data.HList.HList" "HList")
                [ tyConList (typeRepsList (Record x)) ]

instance (TypeRepsList (Record xs)) => Typeable (Record xs) where
  typeOf x = mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "Record")
                [ tyConList (typeRepsList x) ]

instance TypeRepsList (Record xs) => Typeable (Variant xs) where
  typeOf _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Variant" "Variant")
                [ tyConList (typeRepsList (error "Data.HList.Data:Typeable Variant" :: Record xs)) ]

instance Typeable (Variant xs) => Typeable (TIC xs) where
  typeOf (TIC xs) = mkTyConApp (mkTyCon3 "HList" "Data.HList.TIC" "TIC")
                      [typeOf xs]

instance Typeable (HList xs) => Typeable (TIP xs) where
  typeOf (TIP xs) = mkTyConApp (mkTyCon3 "HList" "Data.HList.TIP" "TIP")
                      [typeOf xs]

instance ShowLabel sy => Typeable1 (Tagged sy) where
  typeOf1 _ = mkTyConApp
        (mkTyCon3 "HList" "Data.HList.Data" (showLabel (Label :: Label sy)))
        []

instance (ShowLabel sy, Typeable x) => Typeable (Tagged sy x) where
  typeOf _ = mkTyConApp
            (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (Label :: Label sy)))
            [mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "=") [],
                    typeOf (error "Data.HList.Data:Typeable Tagged" :: x)
                    ]


instance Typeable (HList a) => Typeable (HListFlat a) where
    typeOf _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Data" "HListFlat")
            [typeOf (error "Typeable HListFlat" :: HList a)]

-- pretty-prints sort of like a real list
tyConList xs = mkTyConApp open ( intersperse comma xs ++ [close] )
    where
    open = mkTyCon3 "GHC" "GHC.TypeLits" "["
    close = mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" "]") []
    comma = mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" ",") []
#endif





class TypeRepsList a where
  typeRepsList :: a -> [TypeRep]


instance (TypeRepsList (HList xs)) => TypeRepsList (Record xs) where
  typeRepsList :: Record xs -> [TypeRep]
typeRepsList (Record HList xs
xs) = forall a. TypeRepsList a => a -> [TypeRep]
typeRepsList HList xs
xs

instance (TypeRepsList (HList xs), Typeable x) => TypeRepsList (HList (x ': xs)) where
  typeRepsList :: HList (x : xs) -> [TypeRep]
typeRepsList (~(x
x `HCons` HList xs
xs))
        = forall a. Typeable a => a -> TypeRep
typeOf x
x forall a. a -> [a] -> [a]
: forall a. TypeRepsList a => a -> [TypeRep]
typeRepsList HList xs
xs

instance TypeRepsList (HList '[]) where
  typeRepsList :: HList '[] -> [TypeRep]
typeRepsList HList '[]
_ = []



-- | wraps up the first argument to 'gfoldl'
data GfoldlK c where
    GfoldlK :: (forall d b . Data d => c (d -> b) -> d -> c b) -> GfoldlK c

instance (Data d, (c (d -> b), d) ~ x, c b ~ y) =>
        ApplyAB (GfoldlK c) x y where
    applyAB :: GfoldlK c -> x -> y
applyAB (GfoldlK forall d b. Data d => c (d -> b) -> d -> c b
f) (c (d -> b)
u,d
v) = forall d b. Data d => c (d -> b) -> d -> c b
f c (d -> b)
u d
v


data GunfoldK c where
    GunfoldK :: (forall b r. Data b => c (b -> r) -> c r) -> GunfoldK c

instance (Data b, x ~ (t, c (b -> r)), y ~ c r) =>
        ApplyAB (GunfoldK c) x y where
    applyAB :: GunfoldK c -> x -> y
applyAB (GunfoldK forall b r. Data b => c (b -> r) -> c r
f) (t
_, c (b -> r)
u) = forall b r. Data b => c (b -> r) -> c r
f c (b -> r)
u