{-# LANGUAGE
  CPP,
  ConstraintKinds,
  ImplicitParams,
  TemplateHaskell #-}

-- | Template Haskell script to promote a type family to first class.
module Fcf.Family.TH
  ( -- * Generate boilerplate
    fcfify
  , fcfifySkip
  , fcfify'

    -- * Using promoted families
  , promoteFamily
  , promoteNDFamily
  , familyName
  , applyFamily
  , consTuple
  , paramsProxy

    -- * Predicates
  , isTypeFamily
  , isTypeSynonym
  , isTypeFamilyOrSynonym
  ) where

import Control.Applicative (liftA2)
import Control.Monad (when)
import Data.Function (on)
import Data.Functor (($>))
import Data.List (sort)
import Data.Maybe (fromMaybe)
import Data.Foldable (foldl')
import Data.Traversable (for)
import Data.Set (Set)
import qualified Data.Set as Set
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (getQ, putQ)

import Fcf.Core
import Fcf.Family hiding (Name)

-- | Generate the boilerplate needed to promote a type family to first class.
--
-- Required extensions:
--
-- - @DataKinds@
-- - @PolyKinds@
-- - @TypeFamilies@
--
-- If 'fcfify' is called more than once with the same 'Name' in the same module,
-- only the first invocation generates declarations; subsequent declarations
-- return the empty list, avoiding duplicate declarations in the current module.
--
-- For a stateless variant, use 'fcfify''.
--
-- See "Fcf.Family" for details on the encoding.
fcfify :: Name -> Q [Dec]
fcfify :: Name -> Q [Dec]
fcfify Name
name = do
  Bool
check <- Name -> Q Bool
checkFcfified Name
name
  if Bool
check then forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else Name -> Q [Dec]
fcfify' Name
name

-- | Mark a type family as already fcifified.
fcfifySkip :: Name -> Q [Dec]
fcfifySkip :: Name -> Q [Dec]
fcfifySkip Name
name = Name -> Q Bool
checkFcfified Name
name forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []

-- | Store invocations of 'fcfify' to avoid generating duplicate instances
-- in the current module (a minor performance optimization).
newtype Fcfified = Fcfified (Set Name)

-- | Check whether we've already seen this name.
-- Add the name to the registered set.
checkFcfified :: Name -> Q Bool
checkFcfified :: Name -> Q Bool
checkFcfified Name
name = do
  Fcfified Set Name
seen <- forall a. a -> Maybe a -> a
fromMaybe (Set Name -> Fcfified
Fcfified forall a. Set a
Set.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typeable a => Q (Maybe a)
getQ
  let check :: Bool
check = Name
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
seen
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
check) (forall a. Typeable a => a -> Q ()
putQ (Set Name -> Fcfified
Fcfified (forall a. Ord a => a -> Set a -> Set a
Set.insert Name
name Set Name
seen)))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
check


-- | Generate the boilerplate needed to promote a type family to first class.
--
-- Unlike 'fcfify', this always returns the same declarations for the same
-- named type.
fcfify' :: Name -> Q [Dec]
fcfify' :: Name -> Q [Dec]
fcfify' Name
name = (?funName::String) => Name -> Q TyInfo
reifyTyInfo Name
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrCtxt => TyInfo -> Q [Dec]
fcfifyInfo
  where
    ?funName = String
"fcfify"
    ?name = Name
name

-- | Get the quoted fcf 'Fcf.Core.Family.Name' of an existing type family.
familyName :: Name -> Type
familyName :: Name -> Type
familyName Name
name = Name -> Type
PromotedT 'MkName
  Type -> Type -> Type
`AppT` String -> Type
lit (forall a. a -> Maybe a -> a
fromMaybe String
"" (Name -> Maybe String
namePackage Name
name))
  Type -> Type -> Type
`AppT` String -> Type
lit (forall a. a -> Maybe a -> a
fromMaybe String
"" (Name -> Maybe String
nameModule Name
name))
  Type -> Type -> Type
`AppT` String -> Type
lit (Name -> String
nameBase Name
name)
  where lit :: String -> Type
lit = TyLit -> Type
LitT forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLit
StrTyLit

-- | Promote a fcfified family, returning its partially applied 'Family' and
-- its arity. The result can be applied to a 'consTuple' of the appropriate size,
promoteFamily :: Name -> Q (Type, Int)
promoteFamily :: Name -> Q (Type, Int)
promoteFamily = Name -> Name -> Q (Type, Int)
promoteFamily_ ''Family

-- | Promote a fcfified family, returning its partially applied 'Family' and
-- its arity. The result can be applied to a 'consTuple' of the appropriate size,
promoteNDFamily :: Name -> Q (Type, Int)
promoteNDFamily :: Name -> Q (Type, Int)
promoteNDFamily = Name -> Name -> Q (Type, Int)
promoteFamily_ ''NDFamily

promoteFamily_ :: Name -> Name -> Q (Type, Int)
promoteFamily_ :: Name -> Name -> Q (Type, Int)
promoteFamily_ Name
_Family Name
name = do
  TyInfo
info <- (?funName::String) => Name -> Q TyInfo
reifyTyInfo Name
name
  let arity :: Int
arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyInfo -> [(Name, Type)]
tiArgs TyInfo
info)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type
ConT Name
_Family Type -> Type -> Type
`AppT` TyInfo -> Type
tiNameT TyInfo
info Type -> Type -> Type
`AppT` TyInfo -> Type
paramsProxy' TyInfo
info, Int
arity)
  where
    ?funName = String
"promoteFamily_"

-- | Apply a promoted family.
--
-- If there are more arguments than the arity of the family (as returned by 'promoteFamily'),
-- they are split and applied properly:
-- the family's main arguments are collected in a 'consTuple' and
-- the rest are applied with 'AppT'.
--
-- If there are fewer arguments than the arity, the result is nonsense.
applyFamily :: Name -> [Q Type] -> Q Type
applyFamily :: Name -> [Q Type] -> Q Type
applyFamily Name
name [Q Type]
argsQ = do
  (Type
fam, Int
arity) <- Name -> Q (Type, Int)
promoteFamily Name
name
  ([Type]
args1, [Type]
args2) <- forall a. Int -> [a] -> ([a], [a])
splitAt Int
arity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Q Type]
argsQ
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
fam Type -> Type -> Type
`AppT` [Type] -> Type
consTuple [Type]
args1 Type -> [Type] -> Type
`appsT` [Type]
args2)

paramsProxy :: Name -> Q Type
paramsProxy :: Name -> Q Type
paramsProxy Name
name = TyInfo -> Type
paramsProxy' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (?funName::String) => Name -> Q TyInfo
reifyTyInfo Name
name
  where
    ?funName = String
"paramsProxy"

paramsProxy' :: TyInfo -> Type
paramsProxy' :: TyInfo -> Type
paramsProxy' TyInfo
info = forall {t}. (Eq t, Num t) => t -> Type
go (forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyInfo -> [Name]
tiParams TyInfo
info))
  where
    go :: t -> Type
go t
0 = Name -> Type
ConT ''P0
    go t
n = Name -> Type
ConT ''PS Type -> Type -> Type
`AppT` t -> Type
go (t
nforall a. Num a => a -> a -> a
-t
1)

reifyTyInfo :: (?funName :: String) => Name -> Q TyInfo
reifyTyInfo :: (?funName::String) => Name -> Q TyInfo
reifyTyInfo Name
name = do
  let ?name = Name
name
  Info
info <- Name -> Q Info
reify Name
name
  case Info
info of
    FamilyI Dec
dec [Dec]
_ -> ErrCtxt => Dec -> Q TyInfo
reifyTyInfoDec Dec
dec
    TyConI Dec
dec -> ErrCtxt => Dec -> Q TyInfo
reifyTyInfoDec Dec
dec
    Info
_ -> forall a. ErrCtxt => Q a
errorNotType

-- | 'True' if it is a type family (open or closed).
isTypeFamily :: Name -> Q Bool
isTypeFamily :: Name -> Q Bool
isTypeFamily Name
name = Info -> Bool
isTypeFamilyInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
name

-- | 'True' if it is a type synonym.
isTypeSynonym :: Name -> Q Bool
isTypeSynonym :: Name -> Q Bool
isTypeSynonym Name
name = Info -> Bool
isTypeSynonymInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
name

-- | 'True' if it is a type family or synonym.
isTypeFamilyOrSynonym :: Name -> Q Bool
isTypeFamilyOrSynonym :: Name -> Q Bool
isTypeFamilyOrSynonym Name
name = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) Info -> Bool
isTypeFamilyInfo Info -> Bool
isTypeSynonymInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
name

isTypeFamilyInfo :: Info -> Bool
isTypeFamilyInfo :: Info -> Bool
isTypeFamilyInfo (FamilyI (OpenTypeFamilyD TypeFamilyHead
_) [Dec]
_) = Bool
True
isTypeFamilyInfo (FamilyI (ClosedTypeFamilyD TypeFamilyHead
_ [TySynEqn]
_) [Dec]
_) = Bool
True
isTypeFamilyInfo Info
_ = Bool
False

isTypeSynonymInfo :: Info -> Bool
isTypeSynonymInfo :: Info -> Bool
isTypeSynonymInfo (TyConI (TySynD Name
_ [TyVarBndr ()]
_ Type
_)) = Bool
True
isTypeSynonymInfo Info
_ = Bool
False

--

type ErrCtxt = (?funName :: String, ?name :: Name)

errorNotType :: ErrCtxt => Q a
errorNotType :: forall a. ErrCtxt => Q a
errorNotType = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (?funName::String
?funName forall a. [a] -> [a] -> [a]
++ String
": unexpected name, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ?name::Name
?name forall a. [a] -> [a] -> [a]
++ String
" is not a type family or type synonym.")

-- Example:
--
-- @
-- -- Input
-- type F a b c = (...)
--
-- -- Output
-- type instance Params F 
-- @

reifyTyInfoDec :: ErrCtxt => Dec -> Q TyInfo
reifyTyInfoDec :: ErrCtxt => Dec -> Q TyInfo
reifyTyInfoDec (TySynD Name
name [TyVarBndr ()]
args Type
_) = Name -> [TyVarBndr ()] -> Type -> Q TyInfo
mkInfoHead Name
name [TyVarBndr ()]
args Type
StarT -- TODO: don't assume result kind is Type
reifyTyInfoDec (OpenTypeFamilyD TypeFamilyHead
t) = ErrCtxt => TypeFamilyHead -> Q TyInfo
reifyTyInfoTFH TypeFamilyHead
t
reifyTyInfoDec (ClosedTypeFamilyD TypeFamilyHead
t [TySynEqn]
_) = ErrCtxt => TypeFamilyHead -> Q TyInfo
reifyTyInfoTFH TypeFamilyHead
t
reifyTyInfoDec Dec
_ = forall a. ErrCtxt => Q a
errorNotType

reifyTyInfoTFH :: ErrCtxt => TypeFamilyHead -> Q TyInfo
reifyTyInfoTFH :: ErrCtxt => TypeFamilyHead -> Q TyInfo
reifyTyInfoTFH (TypeFamilyHead Name
name [TyVarBndr ()]
args FamilyResultSig
resSig Maybe InjectivityAnn
_) = do
  Type
res <- ErrCtxt => FamilyResultSig -> Q Type
getRes FamilyResultSig
resSig
  Name -> [TyVarBndr ()] -> Type -> Q TyInfo
mkInfoHead Name
name [TyVarBndr ()]
args Type
res

getRes :: ErrCtxt => FamilyResultSig -> Q Type
getRes :: ErrCtxt => FamilyResultSig -> Q Type
getRes FamilyResultSig
NoSig = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (?funName::String
?funName forall a. [a] -> [a] -> [a]
++ String
": implicit result type not supported")
getRes (KindSig Type
k) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
k
getRes (TyVarSig (KindedTV Name
_ ()
_ Type
k)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
k
getRes (TyVarSig PlainTV{}) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (?funName::String
?funName forall a. [a] -> [a] -> [a]
++ String
": implicit result type not supported")

--

mkInfoHead :: Name -> [TyVarBndr ()] -> Type -> Q TyInfo
mkInfoHead :: Name -> [TyVarBndr ()] -> Type -> Q TyInfo
mkInfoHead Name
name [TyVarBndr ()]
args Type
res = do
  [(Name, Type)]
args' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [TyVarBndr ()]
args (\TyVarBndr ()
arg -> case TyVarBndr ()
arg of
    PlainTV Name
_ ()
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected unnanotated arguments"  -- as far as I understand, the binders given by reify are always annotated so this shouldn't happen
    KindedTV Name
v ()
_ Type
k -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
v, Type
k))
  let params :: [Name]
params = [(Name, Type)] -> Type -> [Name]
collectParams [(Name, Type)]
args' Type
res
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Name] -> [(Name, Type)] -> Type -> TyInfo
mkTyInfo Name
name [Name]
params [(Name, Type)]
args' Type
res)

collectParams :: [(Name, Type)] -> Type -> [Name]
collectParams :: [(Name, Type)] -> Type -> [Name]
collectParams [(Name, Type)]
args Type
res = Set Name -> [(Name, Type)] -> [Name]
collect forall a. Set a
Set.empty [(Name, Type)]
args where

  collect :: Set Name -> [(Name, Type)] -> [Name]
collect Set Name
bound [] = forall a b. (a, b) -> b
snd (forall {a}. Ord a => Set a -> [a] -> [a] -> (Set a, [a])
addVars Set Name
bound [] (Type -> [Name]
getVars Type
res))  -- collect parameters from the result type
  collect Set Name
bound ((Name
v, Type
k) : [(Name, Type)]
vs) =
    let (Set Name
bound', [Name]
ws) = forall {a}. Ord a => Set a -> [a] -> [a] -> (Set a, [a])
addVars Set Name
bound [] (Type -> [Name]
getVars Type
k) in
    [Name]
ws forall a. [a] -> [a] -> [a]
++ Set Name -> [(Name, Type)] -> [Name]
collect (forall a. Ord a => a -> Set a -> Set a
Set.insert Name
v Set Name
bound') [(Name, Type)]
vs

  addVars :: Set a -> [a] -> [a] -> (Set a, [a])
addVars Set a
bound [a]
ws [] = (Set a
bound, forall a. [a] -> [a]
reverse [a]
ws)
  addVars Set a
bound [a]
ws (a
x : [a]
xs)
    | forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
bound = Set a -> [a] -> [a] -> (Set a, [a])
addVars Set a
bound [a]
ws [a]
xs
    | Bool
otherwise = Set a -> [a] -> [a] -> (Set a, [a])
addVars (forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
bound) (a
x forall a. a -> [a] -> [a]
: [a]
ws) [a]
xs

data TyInfo = TyInfo
  { TyInfo -> Name
tiName :: Name
  , TyInfo -> Type
tiNameT :: Type     -- ^ Encoding of name as a 'Name'
  , TyInfo -> [Name]
tiParams :: [Name]
  , TyInfo -> Type
tiParamsT :: Type   -- ^ Params as a tuple
  , TyInfo -> [(Name, Type)]
tiArgs :: [(Name, Type)]
  , TyInfo -> Type
tiArgsT :: Type
  , TyInfo -> Type
tiRes :: Type
  }

appsT :: Type -> [Type] -> Type
appsT :: Type -> [Type] -> Type
appsT = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT

mkTyInfo :: Name -> [Name] -> [(Name, Type)] -> Type -> TyInfo
mkTyInfo :: Name -> [Name] -> [(Name, Type)] -> Type -> TyInfo
mkTyInfo Name
name [Name]
params [(Name, Type)]
args Type
res = TyInfo
  { tiName :: Name
tiName = Name
name
  , tiNameT :: Type
tiNameT = Name -> Type
familyName Name
name
  , tiParams :: [Name]
tiParams = [Name]
params
  , tiParamsT :: Type
tiParamsT = [Type] -> Type
consTuple (Name -> Type
VarT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
params)
  , tiArgs :: [(Name, Type)]
tiArgs = [(Name, Type)]
args
  , tiArgsT :: Type
tiArgsT = [Type] -> Type
consTuple (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Type -> Type -> Type
SigT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
VarT) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Type)]
args)
  , tiRes :: Type
tiRes = Type
res
  }

-- | Construct a tuple suitable for a 'Family' argument.
consTuple :: [Type] -> Type
consTuple :: [Type] -> Type
consTuple = Type -> Type -> [Type] -> Type
consTuple_ (Int -> Type
PromotedTupleT Int
2) (Int -> Type
PromotedTupleT Int
0)

consTupleT :: [Type] -> Type
consTupleT :: [Type] -> Type
consTupleT = Type -> Type -> [Type] -> Type
consTuple_ (Int -> Type
TupleT Int
2) (Int -> Type
TupleT Int
0)

consTuple_ :: Type -> Type -> [Type] -> Type
consTuple_ :: Type -> Type -> [Type] -> Type
consTuple_ Type
_ Type
unit [] = Type
unit
consTuple_ Type
tup Type
unit (Type
t : [Type]
ts) = Type
tup Type -> Type -> Type
`AppT` Type
t Type -> Type -> Type
`AppT` Type -> Type -> [Type] -> Type
consTuple_ Type
tup Type
unit [Type]
ts

-- 

fcfifyInfo :: ErrCtxt => TyInfo -> Q [Dec]
fcfifyInfo :: ErrCtxt => TyInfo -> Q [Dec]
fcfifyInfo TyInfo
info = do
  Dec
paramsD <- TyInfo -> Q Dec
declareParams TyInfo
info
  Dec
argsD <- TyInfo -> Q Dec
declareArgs TyInfo
info
  Dec
resD <- TyInfo -> Q Dec
declareRes TyInfo
info
  Dec
familyD <- TyInfo -> Q Dec
declareFamily TyInfo
info
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
paramsD, Dec
argsD, Dec
resD, Dec
familyD]

getVars :: Type -> [Name]
getVars :: Type -> [Name]
getVars (VarT Name
v) = [Name
v]
getVars (AppT Type
t Type
t') = Type -> [Name]
getVars Type
t forall a. [a] -> [a] -> [a]
++ Type -> [Name]
getVars Type
t'
getVars (AppKindT Type
t Type
t') = Type -> [Name]
getVars Type
t forall a. [a] -> [a] -> [a]
++ Type -> [Name]
getVars Type
t'
getVars (SigT Type
t Type
k) = Type -> [Name]
getVars Type
t forall a. [a] -> [a] -> [a]
++ Type -> [Name]
getVars Type
k
getVars (InfixT Type
t Name
_ Type
t') = Type -> [Name]
getVars Type
t forall a. [a] -> [a] -> [a]
++ Type -> [Name]
getVars Type
t'
getVars (UInfixT Type
t Name
_ Type
t') = Type -> [Name]
getVars Type
t forall a. [a] -> [a] -> [a]
++ Type -> [Name]
getVars Type
t'
getVars (ParensT Type
t) = Type -> [Name]
getVars Type
t
#if MIN_VERSION_template_haskell(2,19,0)
getVars (PromotedInfixT t _ t') = getVars t ++ getVars t'
getVars (PromotedUInfixT t _ t') = getVars t ++ getVars t'
#endif
getVars Type
_ = []

declareParams :: TyInfo -> Q Dec
declareParams :: TyInfo -> Q Dec
declareParams TyInfo
info = do
  let nParams :: Int
nParams = forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyInfo -> [Name]
tiParams TyInfo
info)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn forall a. Maybe a
Nothing (Name -> Type
ConT ''Params Type -> Type -> Type
`AppT` TyInfo -> Type
tiNameT TyInfo
info) ([Type] -> Type
consTupleT (forall a. Int -> a -> [a]
replicate Int
nParams Type
StarT))))  -- TODO: don't guess Type for all params

declareArgs :: TyInfo -> Q Dec
declareArgs :: TyInfo -> Q Dec
declareArgs TyInfo
info = do
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn forall a. Maybe a
Nothing
    (Name -> Type
ConT ''Args_ Type -> Type -> Type
`AppT` TyInfo -> Type
tiNameT TyInfo
info Type -> Type -> Type
`AppT` TyInfo -> Type
tiParamsT TyInfo
info)
    ([Type] -> Type
consTupleT (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyInfo -> [(Name, Type)]
tiArgs TyInfo
info))))
    
declareRes :: TyInfo -> Q Dec
declareRes :: TyInfo -> Q Dec
declareRes TyInfo
info = do
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn forall a. Maybe a
Nothing
    (Name -> Type
ConT ''Res_ Type -> Type -> Type
`AppT` TyInfo -> Type
tiNameT TyInfo
info Type -> Type -> Type
`AppT` TyInfo -> Type
tiParamsT TyInfo
info Type -> Type -> Type
`AppT` if TyInfo -> Bool
isDT TyInfo
info then TyInfo -> Type
tiArgsT TyInfo
info else Type
WildCardT)
    (TyInfo -> Type
tiRes TyInfo
info)))

isDT :: TyInfo -> Bool
isDT :: TyInfo -> Bool
isDT TyInfo
info = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Ord a => [a] -> [a] -> [a]
intersection (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyInfo -> [(Name, Type)]
tiArgs TyInfo
info) (Type -> [Name]
getVars (TyInfo -> Type
tiRes TyInfo
info))))

intersection :: Ord a => [a] -> [a] -> [a]
intersection :: forall a. Ord a => [a] -> [a] -> [a]
intersection = forall a. Ord a => [a] -> [a] -> [a]
intersectionSorted forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. Ord a => [a] -> [a]
sort

intersectionSorted :: Ord a => [a] -> [a] -> [a]
intersectionSorted :: forall a. Ord a => [a] -> [a] -> [a]
intersectionSorted [] [a]
_  = []
intersectionSorted [a]
_  [] = []
intersectionSorted xxs :: [a]
xxs@(a
x : [a]
xs) yys :: [a]
yys@(a
y : [a]
ys) = case forall a. Ord a => a -> a -> Ordering
compare a
x a
y of
  Ordering
EQ -> a
x forall a. a -> [a] -> [a]
: forall a. Ord a => [a] -> [a] -> [a]
intersectionSorted [a]
xs [a]
ys
  Ordering
LT -> forall a. Ord a => [a] -> [a] -> [a]
intersectionSorted [a]
xs [a]
yys
  Ordering
GT -> forall a. Ord a => [a] -> [a] -> [a]
intersectionSorted [a]
xxs [a]
ys

declareFamily :: TyInfo -> Q Dec
declareFamily :: TyInfo -> Q Dec
declareFamily TyInfo
info = do
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn forall a. Maybe a
Nothing
    (Name -> Type
ConT ''Eval Type -> Type -> Type
`AppT` (Name -> Type
ConT ''Family_ Type -> Type -> Type
`AppT` TyInfo -> Type
tiNameT TyInfo
info Type -> Type -> Type
`AppT` Type -> Type -> Type
SigT Type
WildCardT (Type
WildCardT Type -> Type -> Type
`AppT` TyInfo -> Type
tiParamsT TyInfo
info) Type -> Type -> Type
`AppT` TyInfo -> Type
tiArgsT TyInfo
info))
    (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Name -> Type
ConT (TyInfo -> Name
tiName TyInfo
info)) (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyInfo -> [(Name, Type)]
tiArgs TyInfo
info))))