{-# LANGUAGE KindSignatures
, TypeOperators
, DataKinds
, PolyKinds
, TypeFamilies
, UndecidableInstances
#-}
module Data.Generics.ClassyPlate.TypePrune (ClassIgnoresSubtree, AppSelector, AppPruning, IgnoredFields) where
import GHC.Exts (Constraint)
import GHC.Generics
import Data.Type.Bool
import GHC.TypeLits (Symbol, Nat)
type family Union xs ys where
Union '[] ys = ys
Union (x ': xs) ys = Insert x (Union xs ys)
type family Find x ys where
Find x '[] = 'False
Find x (x ': ys) = 'True
Find x (y ': ys) = Find x ys
type family Insert a xs where
Insert a '[] = (a ': '[])
Insert a (a ': xs) = (a ': xs)
Insert a (x ': xs) = x ': (Insert a xs)
type family ClassIgnoresSubtree (cls :: * -> Constraint) (typ :: *) :: Bool where
ClassIgnoresSubtree cls typ = Not (AnySelected cls (MemberTypes typ))
type family AppSelector (c :: * -> Constraint) (a :: *) :: Bool
type family AppPruning (c :: * -> Constraint) (a :: *) :: Bool
type family IgnoredFields (t :: *) :: [Either (Symbol, Nat) Symbol]
type family AnySelected (c :: * -> Constraint) (ls :: [*]) :: Bool where
AnySelected c (fst ': rest) = AppSelector c fst || AnySelected c rest
AnySelected c '[] = False
type family MemberTypes (typ :: *) :: [*] where
MemberTypes t = GetMemberTypes '[] t
type family GetMemberTypes (checked :: [*]) (typ :: *) :: [*] where
GetMemberTypes checked t = GetElementTypes t checked (Rep t)
type family GetElementTypes (t :: *) (checked :: [*]) (typ :: * -> *) :: [*] where
GetElementTypes t checked (D1 md cons) = GetElementTypesCons t checked cons
type family GetElementTypesCons (t :: *) (checked :: [*]) (typ :: * -> *) where
GetElementTypesCons t checked (C1 (MetaCons consName pref flag) flds) = GetElementTypesFields consName 0 t checked flds
GetElementTypesCons t checked (c1 :+: c2) = GetElementTypesCons t checked c1 `Union` GetElementTypesCons t checked c2
type family GetElementTypesFields (cons :: Symbol) (n :: Nat) (t :: *) (checked :: [*]) (typ :: * -> *) where
GetElementTypesFields cons n t checked (fld1 :*: fld2)
=
GetElementTypesFields cons n t checked fld1 `Union` GetElementTypesFields cons n t checked fld2
GetElementTypesFields cons n t checked (S1 (MetaSel fld unp str laz) (Rec0 innerT))
= If (IsIgnoredField cons n fld (IgnoredFields t)) '[] (GetElementTypesField checked (Find innerT checked) innerT)
GetElementTypesFields cons n t checked U1 = '[]
type family IsIgnoredField (cons :: Symbol) (fldNum :: Nat) (fldSelector :: Maybe Symbol)
(ignored :: [Either (Symbol, Nat) Symbol]) :: Bool where
IsIgnoredField cons fldNum (Just sel) ignored = Find (Right sel) ignored || Find (Left '(cons, fldNum)) ignored
IsIgnoredField cons fldNum Nothing ignored = Find (Left '(cons, fldNum)) ignored
type family GetElementTypesField (checked :: [*]) (inChecked :: Bool) (typ :: *) where
GetElementTypesField checked True typ = '[]
GetElementTypesField checked False typ = Insert typ (GetMemberTypes (typ ': checked) typ)