{-# language AllowAmbiguousTypes #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language DefaultSignatures #-}
{-# language ExistentialQuantification #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language MultiParamTypeClasses #-}
{-# language PolyKinds #-}
{-# language QuantifiedConstraints #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneDeriving #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
{-# language UndecidableSuperClasses #-}
module Generics.Kind (
(:+:)(..), (:*:)(..), V1, U1(..), M1(..)
, Field(..), (:=>:)(..), Exists(..)
, Atom(..), TyVar(..), (:$:), (:~:), (:~~:)
, Var0, Var1, Var2, Var3, Var4, Var5, Var6, Var7, Var8, Var9
, LoT(..), (:@@:), LoT1, LoT2, TyEnv(..)
, GenericK(..)
, GenericF, fromF, toF
, GenericN, fromN, toN
, fromRepK, toRepK, SubstRep, SubstRep', SubstAtom
, Conv(..)
, Interpret, InterpretVar, Satisfies, ContainsTyVar
, ForAllI(..), SuchThatI(..)
, WrappedI(..), toWrappedI, fromWrappedI
) where
import Data.Kind
import Data.PolyKinded
import Data.PolyKinded.Atom
import GHC.Generics.Extra hiding (SuchThat, (:=>:))
import qualified GHC.Generics.Extra as GG
newtype Field (t :: Atom d Type) (x :: LoT d) where
Field :: { forall {d} (t :: Atom d (*)) (x :: LoT d).
Field t x -> Interpret t x
unField :: Interpret t x } -> Field t x
deriving instance Eq (Interpret t x) => Eq (Field t x)
deriving instance Ord (Interpret t x) => Ord (Field t x)
deriving instance Semigroup (Interpret t x) => Semigroup (Field t x)
deriving instance Monoid (Interpret t x) => Monoid (Field t x)
deriving instance Show (Interpret t x) => Show (Field t x)
data (:=>:) (c :: Atom d Constraint) (f :: LoT d -> Type) (x :: LoT d) where
SuchThat :: Interpret c x => f x -> (c :=>: f) x
deriving instance (Interpret c x => Eq (f x)) => Eq ((c :=>: f) x)
deriving instance (Interpret c x => Ord (f x)) => Ord ((c :=>: f) x)
deriving instance (Interpret c x => Show (f x)) => Show ((c :=>: f) x)
data Exists k (f :: LoT (k -> d) -> Type) (x :: LoT d) where
Exists :: forall k (t :: k) d (f :: LoT (k -> d) -> Type) (x :: LoT d)
.{ ()
unExists :: f (t ':&&: x) } -> Exists k f x
deriving instance (forall t. Show (f (t ':&&: x))) => Show (Exists k f x)
class GenericK (f :: k) where
type family RepK f :: LoT k -> Type
fromK :: f :@@: x -> RepK f x
default
fromK :: (Generic (f :@@: x), Conv (Rep (f :@@: x)) (RepK f) x)
=> f :@@: x -> RepK f x
fromK = forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
gg a -> kg tys
toKindGenerics forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from
toK :: RepK f x -> f :@@: x
default
toK :: (Generic (f :@@: x), Conv (Rep (f :@@: x)) (RepK f) x)
=> RepK f x -> f :@@: x
toK = forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
kg tys -> gg a
toGhcGenerics
type GenericF t f x = (GenericK f, x ~ SplitF t f, t ~ (f :@@: x))
fromF :: forall f t x. GenericF t f x => t -> RepK f x
fromF :: forall {k} (f :: k) t (x :: LoT k). GenericF t f x => t -> RepK f x
fromF = forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
fromK @_ @f
toF :: forall f t x. GenericF t f x => RepK f x -> t
toF :: forall {k} (f :: k) t (x :: LoT k). GenericF t f x => RepK f x -> t
toF = forall k (f :: k) (x :: LoT k). GenericK f => RepK f x -> f :@@: x
toK @_ @f
type GenericN n t f x = (GenericK f, 'TyEnv f x ~ SplitN n t, t ~ (f :@@: x))
fromN :: forall n t f x. GenericN n t f x => t -> RepK f x
fromN :: forall {k} (n :: Nat) t (f :: k) (x :: LoT k).
GenericN n t f x =>
t -> RepK f x
fromN = forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
fromK @_ @f
toN :: forall n t f x. GenericN n t f x => RepK f x -> t
toN :: forall {k} (n :: Nat) t (f :: k) (x :: LoT k).
GenericN n t f x =>
RepK f x -> t
toN = forall k (f :: k) (x :: LoT k). GenericK f => RepK f x -> f :@@: x
toK @_ @f
fromRepK :: forall f x xs. (GenericK f, SubstRep' (RepK f) x xs)
=> f x :@@: xs -> SubstRep (RepK f) x xs
fromRepK :: forall {t} {k} (f :: t -> k) (x :: t) (xs :: LoT k).
(GenericK f, SubstRep' (RepK f) x xs) =>
(f x :@@: xs) -> SubstRep (RepK f) x xs
fromRepK = forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
f (x ':&&: xs) -> SubstRep f x xs
substRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
fromK @_ @f @(x ':&&: xs)
toRepK :: forall f x xs. (GenericK f, SubstRep' (RepK f) x xs)
=> SubstRep (RepK f) x xs -> f x :@@: xs
toRepK :: forall {t} {k} (f :: t -> k) (x :: t) (xs :: LoT k).
(GenericK f, SubstRep' (RepK f) x xs) =>
SubstRep (RepK f) x xs -> f x :@@: xs
toRepK = forall k (f :: k) (x :: LoT k). GenericK f => RepK f x -> f :@@: x
toK @_ @f @(x ':&&: xs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
SubstRep f x xs -> f (x ':&&: xs)
unsubstRep
class SubstRep' (f :: LoT (t -> k) -> Type) (x :: t) (xs :: LoT k) where
type family SubstRep f x :: LoT k -> Type
substRep :: f (x ':&&: xs) -> SubstRep f x xs
unsubstRep :: SubstRep f x xs -> f (x ':&&: xs)
instance SubstRep' U1 x xs where
type SubstRep U1 x = U1
substRep :: U1 (x ':&&: xs) -> SubstRep U1 x xs
substRep U1 (x ':&&: xs)
U1 = forall k (p :: k). U1 p
U1
unsubstRep :: SubstRep U1 x xs -> U1 (x ':&&: xs)
unsubstRep U1 xs
SubstRep U1 x xs
U1 = forall k (p :: k). U1 p
U1
instance (SubstRep' f x xs, SubstRep' g x xs) => SubstRep' (f :+: g) x xs where
type SubstRep (f :+: g) x = SubstRep f x :+: SubstRep g x
substRep :: (:+:) f g (x ':&&: xs) -> SubstRep (f :+: g) x xs
substRep (L1 f (x ':&&: xs)
x) = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
f (x ':&&: xs) -> SubstRep f x xs
substRep f (x ':&&: xs)
x)
substRep (R1 g (x ':&&: xs)
x) = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
f (x ':&&: xs) -> SubstRep f x xs
substRep g (x ':&&: xs)
x)
unsubstRep :: SubstRep (f :+: g) x xs -> (:+:) f g (x ':&&: xs)
unsubstRep (L1 SubstRep f x xs
x) = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
SubstRep f x xs -> f (x ':&&: xs)
unsubstRep SubstRep f x xs
x)
unsubstRep (R1 SubstRep g x xs
x) = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
SubstRep f x xs -> f (x ':&&: xs)
unsubstRep SubstRep g x xs
x)
instance (SubstRep' f x xs, SubstRep' g x xs) => SubstRep' (f :*: g) x xs where
type SubstRep (f :*: g) x = SubstRep f x :*: SubstRep g x
substRep :: (:*:) f g (x ':&&: xs) -> SubstRep (f :*: g) x xs
substRep (f (x ':&&: xs)
x :*: g (x ':&&: xs)
y) = forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
f (x ':&&: xs) -> SubstRep f x xs
substRep f (x ':&&: xs)
x forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
f (x ':&&: xs) -> SubstRep f x xs
substRep g (x ':&&: xs)
y
unsubstRep :: SubstRep (f :*: g) x xs -> (:*:) f g (x ':&&: xs)
unsubstRep (SubstRep f x xs
x :*: SubstRep g x xs
y) = forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
SubstRep f x xs -> f (x ':&&: xs)
unsubstRep SubstRep f x xs
x forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
SubstRep f x xs -> f (x ':&&: xs)
unsubstRep SubstRep g x xs
y
instance SubstRep' f x xs => SubstRep' (M1 i c f) x xs where
type SubstRep (M1 i c f) x = M1 i c (SubstRep f x)
substRep :: M1 i c f (x ':&&: xs) -> SubstRep (M1 i c f) x xs
substRep (M1 f (x ':&&: xs)
x) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
f (x ':&&: xs) -> SubstRep f x xs
substRep f (x ':&&: xs)
x)
unsubstRep :: SubstRep (M1 i c f) x xs -> M1 i c f (x ':&&: xs)
unsubstRep (M1 SubstRep f x xs
x) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
SubstRep f x xs -> f (x ':&&: xs)
unsubstRep SubstRep f x xs
x)
instance ( Interpret (SubstAtom c x) xs => InterpretCons c x xs
, Interpret c (x ':&&: xs) => InterpretSubst c x xs
, SubstRep' f x xs )
=> SubstRep' (c :=>: f) x xs where
type SubstRep (c :=>: f) x = SubstAtom c x :=>: SubstRep f x
substRep :: (:=>:) c f (x ':&&: xs) -> SubstRep (c :=>: f) x xs
substRep (SuchThat f (x ':&&: xs)
x) = forall {d} (c :: Atom d Constraint) (x :: LoT d) (f :: LoT d -> *).
Interpret c x =>
f x -> (:=>:) c f x
SuchThat (forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
f (x ':&&: xs) -> SubstRep f x xs
substRep f (x ':&&: xs)
x) :: InterpretSubst c x xs => SubstRep (c :=>: f) x xs
unsubstRep :: SubstRep (c :=>: f) x xs -> (:=>:) c f (x ':&&: xs)
unsubstRep (SuchThat SubstRep f x xs
x) = forall {d} (c :: Atom d Constraint) (x :: LoT d) (f :: LoT d -> *).
Interpret c x =>
f x -> (:=>:) c f x
SuchThat (forall t k (f :: LoT (t -> k) -> *) (x :: t) (xs :: LoT k).
SubstRep' f x xs =>
SubstRep f x xs -> f (x ':&&: xs)
unsubstRep SubstRep f x xs
x) :: InterpretCons c x xs => (c :=>: f) (x ':&&: xs)
class Interpret c (x ':&&: xs) => InterpretCons c x xs
instance Interpret c (x ':&&: xs) => InterpretCons c x xs
class Interpret (SubstAtom c x) xs => InterpretSubst c x xs
instance Interpret (SubstAtom c x) xs => InterpretSubst c x xs
instance (Interpret (SubstAtom t x) xs ~ Interpret t (x ':&&: xs))
=> SubstRep' (Field t) x xs where
type SubstRep (Field t) x = Field (SubstAtom t x)
substRep :: Field t (x ':&&: xs) -> SubstRep (Field t) x xs
substRep (Field Interpret t (x ':&&: xs)
x) = forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field Interpret t (x ':&&: xs)
x
unsubstRep :: SubstRep (Field t) x xs -> Field t (x ':&&: xs)
unsubstRep (Field Interpret (SubstAtom t x) xs
x) = forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field Interpret (SubstAtom t x) xs
x
type family SubstAtom (f :: Atom (t -> k) d) (x :: t) :: Atom k d where
SubstAtom ('Var 'VZ) x = 'Kon x
SubstAtom ('Var ('VS v)) x = 'Var v
SubstAtom ('Kon t) x = 'Kon t
SubstAtom (t1 ':@: t2) x = SubstAtom t1 x ':@: SubstAtom t2 x
SubstAtom (t1 ':&: t2) x = SubstAtom t1 x ':&: SubstAtom t2 x
class Conv (gg :: Type -> Type) (kg :: LoT d -> Type) (tys :: LoT d) where
toGhcGenerics :: kg tys -> gg a
toKindGenerics :: gg a -> kg tys
instance Conv U1 U1 tys where
toGhcGenerics :: forall a. U1 tys -> U1 a
toGhcGenerics U1 tys
U1 = forall k (p :: k). U1 p
U1
toKindGenerics :: forall a. U1 a -> U1 tys
toKindGenerics U1 a
U1 = forall k (p :: k). U1 p
U1
instance (Conv f f' tys, Conv g g' tys) => Conv (f :+: g) (f' :+: g') tys where
toGhcGenerics :: forall a. (:+:) f' g' tys -> (:+:) f g a
toGhcGenerics (L1 f' tys
x) = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
kg tys -> gg a
toGhcGenerics f' tys
x)
toGhcGenerics (R1 g' tys
x) = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
kg tys -> gg a
toGhcGenerics g' tys
x)
toKindGenerics :: forall a. (:+:) f g a -> (:+:) f' g' tys
toKindGenerics (L1 f a
x) = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
gg a -> kg tys
toKindGenerics f a
x)
toKindGenerics (R1 g a
x) = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
gg a -> kg tys
toKindGenerics g a
x)
instance (Conv f f' tys, Conv g g' tys) => Conv (f :*: g) (f' :*: g') tys where
toGhcGenerics :: forall a. (:*:) f' g' tys -> (:*:) f g a
toGhcGenerics (f' tys
x :*: g' tys
y) = forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
kg tys -> gg a
toGhcGenerics f' tys
x forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
kg tys -> gg a
toGhcGenerics g' tys
y
toKindGenerics :: forall a. (:*:) f g a -> (:*:) f' g' tys
toKindGenerics (f a
x :*: g a
y) = forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
gg a -> kg tys
toKindGenerics f a
x forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
gg a -> kg tys
toKindGenerics g a
y
instance {-# OVERLAPPABLE #-} (Conv f f' tys) => Conv (M1 i c f) f' tys where
toGhcGenerics :: forall a. f' tys -> M1 i c f a
toGhcGenerics f' tys
x = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
kg tys -> gg a
toGhcGenerics f' tys
x)
toKindGenerics :: forall a. M1 i c f a -> f' tys
toKindGenerics (M1 f a
x) = forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
gg a -> kg tys
toKindGenerics f a
x
instance {-# OVERLAPS #-} (Conv f f' tys) => Conv (M1 i c f) (M1 i c f') tys where
toGhcGenerics :: forall a. M1 i c f' tys -> M1 i c f a
toGhcGenerics (M1 f' tys
x) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
kg tys -> gg a
toGhcGenerics f' tys
x)
toKindGenerics :: forall a. M1 i c f a -> M1 i c f' tys
toKindGenerics (M1 f a
x) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
gg a -> kg tys
toKindGenerics f a
x)
instance (k ~ Interpret t tys, Conv f f' tys)
=> Conv (k GG.:=>: f) (t :=>: f') tys where
toGhcGenerics :: forall a. (:=>:) t f' tys -> (:=>:) k f a
toGhcGenerics (SuchThat f' tys
x) = forall {k} (c :: Constraint) (f :: k -> *) (a :: k).
c =>
f a -> (:=>:) c f a
GG.SuchThat (forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
kg tys -> gg a
toGhcGenerics f' tys
x)
toKindGenerics :: forall a. (:=>:) k f a -> (:=>:) t f' tys
toKindGenerics (GG.SuchThat f a
x) = forall {d} (c :: Atom d Constraint) (x :: LoT d) (f :: LoT d -> *).
Interpret c x =>
f x -> (:=>:) c f x
SuchThat (forall d (gg :: * -> *) (kg :: LoT d -> *) (tys :: LoT d) a.
Conv gg kg tys =>
gg a -> kg tys
toKindGenerics f a
x)
instance (k ~ Interpret t tys) => Conv (K1 p k) (Field t) tys where
toGhcGenerics :: forall a. Field t tys -> K1 p k a
toGhcGenerics (Field Interpret t tys
x) = forall k i c (p :: k). c -> K1 i c p
K1 Interpret t tys
x
toKindGenerics :: forall a. K1 p k a -> Field t tys
toKindGenerics (K1 k
x) = forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field k
x