{-# language CPP                   #-}
{-# language ExplicitNamespaces    #-}
{-# language MultiWayIf            #-}
{-# language TemplateHaskellQuotes #-}

-- | Main module of @kind-generics-th@.
-- Please refer to the @README@ file for documentation on how to use this package.
module Generics.Kind.TH
  ( deriveGenericK
  , deriveGenericKQuiet
  , preDeriveGenericK
  , postDeriveGenericK
  ) where

import           Control.Applicative
import           Control.Monad
import qualified Data.Kind                    as Kind
import           Data.List
import           Data.Maybe
import           Data.Type.Equality           (type (~~))
import           Fcf.Family.TH                (fcfify, isTypeFamilyOrSynonym, promoteNDFamily)
import           GHC.Generics                 as Generics hiding (conIsRecord, conName,
                                                           datatypeName)
import           Generics.Kind
import           Language.Haskell.TH          as TH
import           Language.Haskell.TH.Syntax   as TH
import           Language.Haskell.TH.Datatype as THAbs
import           Language.Haskell.TH.Datatype.TyVarBndr

#if MIN_VERSION_template_haskell(2,15,0)
import           GHC.Classes                  (IP)
#endif

-- | Given the 'Name' of a data type (or, the 'Name' of a constructor belonging
-- to a data type), generate 'GenericK' instances for that data type. You will
-- likely need to enable most of these language extensions in order for GHC to
-- accept the generated code:
--
-- * @DataKinds@
--
-- * @EmptyCase@ (if using an empty data type)
--
-- * @FlexibleInstances@
--
-- * @MultiParamTypeClasses@
--
-- * @PolyKinds@ (if using a poly-kinded data type)
--
-- * @TemplateHaskell@
--
-- * @TypeFamilies@
--
-- If the data type uses type families, 'deriveGenericK' warns that it
-- skips the 'GenericK' instances that require special support for it
--
-- - Use 'preDeriveGenericK' and 'postDeriveGenericK' to support type families.
-- - Use 'deriveGenericKQuiet' to silence the warnings.
deriveGenericK :: Name -> Q [Dec]
deriveGenericK :: Name -> Q [Dec]
deriveGenericK = Bool -> Name -> Q [Dec]
deriveGenericKWarnIf Bool
True

-- | Variant of 'deriveGenericK' that doesn't emit warnings.
deriveGenericKQuiet :: Name -> Q [Dec]
deriveGenericKQuiet :: Name -> Q [Dec]
deriveGenericKQuiet = Bool -> Name -> Q [Dec]
deriveGenericKWarnIf Bool
False

deriveGenericKWarnIf :: Bool -> Name -> Q [Dec]
deriveGenericKWarnIf :: Bool -> Name -> Q [Dec]
deriveGenericKWarnIf Bool
warn Name
name = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FamilyFriendliness -> Name -> Q ([Dec], [Dec])
deriveGenericK' (Bool -> FamilyFriendliness
NoFamilies Bool
warn) Name
name

-- | Generate 'GenericK' instances for data types that may mention
-- type families.
--
-- This 'preDeriveGenericK' is to be used in combination with
-- 'postDeriveGenericK'. These two functions let us stage the compilation of
-- the generated type instances, because GHC cannot compile them in a single
-- group.
--
-- - 'preDeriveGenericK' generates type instances to promote type families
--   that occur in the given data types (using 'fcfify'; see
--   <https://hackage.haskell.org/package/fcf-family fcf-family>).
--   The 'GenericK' instances are not produced at this stage,
--   they are accumulated in some internal global queue.
-- - 'postDeriveGenericK' produces all of the accumulated 'GenericK' instances.
--   It should be called in a slice separated from 'preDeriveGenericK'.
--   Multiple calls to `preDeriveGenericK` may precede 'postDeriveGenericK'.
--
-- @
-- 'preDeriveGenericK' ''MyT1
-- 'preDeriveGenericK' ''MyT2
-- 'preDeriveGenericK' ''MyT3
-- 'postDeriveGenericK'
-- @
--
-- You will need to enable the extensions @UndecidableInstances@ and @PolyKinds@
-- (even if your data types are not poly-kinded)
-- in addition to those mentioned in the documentation of 'deriveGenericK'.
preDeriveGenericK :: Name -> Q [Dec]
preDeriveGenericK :: Name -> Q [Dec]
preDeriveGenericK Name
n = do
  ([Dec]
pre, [Dec]
post) <- FamilyFriendliness -> Name -> Q ([Dec], [Dec])
deriveGenericK' FamilyFriendliness
YesFamilies Name
n
  [Dec] -> Q ()
pushGenericKQueue [Dec]
post
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
pre

-- | See 'preDeriveGenericK'.
postDeriveGenericK :: Q [Dec]
postDeriveGenericK :: Q [Dec]
postDeriveGenericK = Q [Dec]
takeGenericKQueue

-- | Flag to control support for type families, because that requires a
-- different API (preDeriveGenericK, postDeriveGenericK instead of
-- deriveGenericK).
data FamilyFriendliness
  = NoFamilies Bool -- ^ Whether to warn when a type family is detected.
  | YesFamilies

-- | Return a pair of:
--
-- - 'fcfify'-generated instances
-- - 'GenericK' instances
deriveGenericK' :: FamilyFriendliness -> Name -> Q ([Dec], [Dec])
deriveGenericK' :: FamilyFriendliness -> Name -> Q ([Dec], [Dec])
deriveGenericK' FamilyFriendliness
familyFriendliness Name
n = do
  DatatypeInfo{ datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
dataName
              , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
univVars
              , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
              , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
              } <- Name -> Q DatatypeInfo
reifyDatatype Name
n
  [ConstructorInfo]
cons' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConstructorInfo -> Q ConstructorInfo
resolveConSynonyms [ConstructorInfo]
cons
  let deriveInsts :: [Type] -> [Type] -> Q [Dec]
      deriveInsts :: [Type] -> [Type] -> Q [Dec]
deriveInsts [Type]
argsToKeep [Type]
argsToDrop = do
        Dec
inst <- [Type] -> [Type] -> Q Dec
deriveGenericKFor [Type]
argsToKeep [Type]
argsToDrop
        case [Type]
argsToKeep of
          [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
inst]
          (Type
argToDrop:[Type]
argsToKeep') -> do
            Type
argToDrop' <- Type -> Q Type
resolveTypeSynonyms Type
argToDrop
            if |  -- Can the argument to drop be eta-reduced?
                  Just Name
argNameToDrop <- [Name] -> Type -> Maybe Name
distinctTyVarType (forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
argsToKeep')
                                                          Type
argToDrop'
                  -- Check for dependent quantification, which we currently can't handle.
               ,  Name
argNameToDrop forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
                    forall a. TypeSubstitution a => a -> [Name]
freeVariables (forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
typeKind [Type]
argsToDrop
                                forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Type
tvKind ([ConstructorInfo] -> [TyVarBndrUnit]
gatherExistentials [ConstructorInfo]
cons'))
               -> do let allInnerTypes :: [Type]
allInnerTypes  = [ConstructorInfo] -> [Type]
gatherConstraints [ConstructorInfo]
cons' forall a. [a] -> [a] -> [a]
++ [ConstructorInfo] -> [Type]
gatherFields [ConstructorInfo]
cons'
                     -- Check if the argument appears in a type family application.
                     Bool
inTyFamApp <- forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name -> Type -> Q Bool
isInTypeFamilyApp Name
argNameToDrop)
                                                   [Type]
allInnerTypes
                     case FamilyFriendliness
familyFriendliness of
                       NoFamilies Bool
warn | Bool
inTyFamApp -> do
                         -- Found type family application when family suppport is disabled.
                         -- Emit a warning and don't generate GenericK instances for fewer argsToKeep.
                         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (String -> Q ()
reportWarning forall a b. (a -> b) -> a -> b
$ Name -> Name -> [Type] -> [Type] -> String
tyFamWarning Name
n Name
dataName [Type]
argsToKeep [Type]
argsToDrop)
                         forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
inst]
                       FamilyFriendliness
_ -> (Dec
instforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> [Type] -> Q [Dec]
deriveInsts [Type]
argsToKeep' (Type
argToDrop'forall a. a -> [a] -> [a]
:[Type]
argsToDrop)
               |  Bool
otherwise
               -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
inst]

      -- Generate a single GenericK instance for a given set of data type
      -- arguments and indexed arguments.
      deriveGenericKFor :: [Type] -> [Type] -> Q Dec
      deriveGenericKFor :: [Type] -> [Type] -> Q Dec
deriveGenericKFor [Type]
argsToKeep [Type]
argsToDrop = do
        let argNamesToDrop :: [Name]
argNamesToDrop = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName [Type]
argsToDrop
            kind :: Type
kind = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((\Type
x Type
y -> Type
ArrowT Type -> Type -> Type
`AppT` Type
x Type -> Type -> Type
`AppT` Type
y) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
typeKind)
                         (Name -> Type
ConT ''Kind.Type) [Type]
argsToDrop
            dataApp :: Q Type
dataApp = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
SigT (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
ConT Name
dataName) [Type]
argsToKeep) Type
kind
        forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
                  (forall (m :: * -> *). Quote m => Name -> m Type
conT ''GenericK forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
dataApp)
                  [ Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat ''RepK forall a. Maybe a
Nothing [Q Type
dataApp] forall a b. (a -> b) -> a -> b
$
                      Name -> [Name] -> DatatypeVariant -> [ConstructorInfo] -> Q Type
deriveRepK Name
dataName [Name]
argNamesToDrop DatatypeVariant
variant [ConstructorInfo]
cons'
                  , [ConstructorInfo] -> Q Dec
deriveFromK [ConstructorInfo]
cons'
                  , [ConstructorInfo] -> Q Dec
deriveToK [ConstructorInfo]
cons'
                  ]

  [Dec]
insts <- [Type] -> [Type] -> Q [Dec]
deriveInsts (forall a. [a] -> [a]
reverse [Type]
univVars) []
  [Dec]
fcfInsts <- Q [Dec]
takeFcfifyQueue
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
fcfInsts, [Dec]
insts)

-- | Warning to show when a type family is found by 'deriveGenericK'.
tyFamWarning :: Name -> Name -> [Type] -> [Type] -> String
tyFamWarning :: Name -> Name -> [Type] -> [Type] -> String
tyFamWarning Name
name Name
dataName [Type]
argsToKeep' [Type]
argsToDrop' =
  let argsToKeep :: [String]
argsToKeep = Type -> String
getVarTName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
reverse [Type]
argsToKeep'
      argsToDrop :: [String]
argsToDrop = Type -> String
getVarTName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
argsToDrop'
  in Name -> Name -> [String] -> [String] -> String
tyFamWarning' Name
name Name
dataName [String]
argsToKeep [String]
argsToDrop

-- | 'tyFamWarning' with variable names instead of Type, all in left-to-right order.
tyFamWarning' :: Name -> Name -> [String] -> [String] -> String
tyFamWarning' :: Name -> Name -> [String] -> [String] -> String
tyFamWarning' Name
name Name
dataName [String]
argsToKeep [String]
argsToDrop = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
  (String
"Found type family in definition of "
    forall a. [a] -> [a] -> [a]
++ Name -> String
quoteName Name
name forall a. [a] -> [a] -> [a]
++ String
". Some instances have been skipped.") forall a. a -> [a] -> [a]
:
  forall a b. (a -> b) -> [a] -> [b]
map (String
"    " forall a. [a] -> [a] -> [a]
++) (
    String
"Declared instances:" forall a. a -> [a] -> [a]
:
    Name -> [String] -> [String] -> [String]
showDeclaredInstances Name
dataName [String]
argsToKeep [String]
argsToDrop forall a. [a] -> [a] -> [a]
++
    String
"Skipped instances:" forall a. a -> [a] -> [a]
:
    Name -> [String] -> [String]
showSkippedInstances Name
dataName [String]
argsToKeep forall a. [a] -> [a] -> [a]
++
    String
"To enable type family support and obtain those skipped instances:" forall a. a -> [a] -> [a]
:
    (String
"\t$(preDeriveGenericK " forall a. [a] -> [a] -> [a]
++ Name -> String
quoteName Name
name forall a. [a] -> [a] -> [a]
++ String
")") forall a. a -> [a] -> [a]
:
    (String
"\t$(postDeriveGenericK " forall a. [a] -> [a] -> [a]
++ Name -> String
quoteName Name
name forall a. [a] -> [a] -> [a]
++ String
")") forall a. a -> [a] -> [a]
:
    String
"To silence this warning:" forall a. a -> [a] -> [a]
:
    (String
"\t$(deriveGenericKQuiet " forall a. [a] -> [a] -> [a]
++ Name -> String
quoteName Name
name forall a. [a] -> [a] -> [a]
++ String
")") forall a. a -> [a] -> [a]
:
    [])

-- | This assumes most uses are going to be unqualified names.
quoteName :: Name -> String
quoteName :: Name -> String
quoteName name :: Name
name@(Name OccName
_ (NameG NameSpace
DataName PkgName
_ ModName
_)) = String
"'" forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
quoteName Name
name = String
"''" forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name

showDeclaredInstances :: Name -> [String] -> [String] -> [String]
showDeclaredInstances :: Name -> [String] -> [String] -> [String]
showDeclaredInstances Name
name [String]
argsToKeep [String]
argsToDrop =
  (\[String]
args -> String
"\tinstance GenericK " forall a. [a] -> [a] -> [a]
++ Name -> [String] -> String
showConArgs Name
name ([String]
argsToKeep forall a. [a] -> [a] -> [a]
++ [String]
args)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [[a]]
inits [String]
argsToDrop

showSkippedInstances :: Name -> [String] -> [String]
showSkippedInstances :: Name -> [String] -> [String]
showSkippedInstances Name
name [String]
argsToKeep =
  (\[String]
args -> String
"\tinstance GenericK " forall a. [a] -> [a] -> [a]
++ Name -> [String] -> String
showConArgs Name
name [String]
args) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
init (forall a. [a] -> [[a]]
inits [String]
argsToKeep)

-- We manually pretty-print the types to drop module qualifiers.
showConArgs :: Name -> [String] -> String
showConArgs :: Name -> [String] -> String
showConArgs Name
name [] = Name -> String
nameBase Name
name
showConArgs Name
name [String]
args = String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
" " (Name -> String
nameBase Name
name forall a. a -> [a] -> [a]
: [String]
args) forall a. [a] -> [a] -> [a]
++ String
")"

-- | Find type variable stored in types coming from 'datatypeInstTypes'
-- (should be of the form (v :: k))
getVarTName :: Type -> String
getVarTName :: Type -> String
getVarTName (SigT Type
t Type
_) = Type -> String
getVarTName Type
t
getVarTName (VarT Name
name) = Name -> String
nameBase Name
name
getVarTName Type
_ = String
"_a"

-- | @'distinctTyVarType' tvSet ty@ returns @'Just' tvTy@ if @ty@:
--
-- a. Is a type variable named @tvTy@, and
-- b. @tvTy@ is not an element of @tvSet@.
--
-- Otherwise, returns 'Nothing'.
distinctTyVarType :: [Name] -> Type -> Maybe Name
distinctTyVarType :: [Name] -> Type -> Maybe Name
distinctTyVarType [Name]
tvSet Type
ty = do
  Name
tvTy <- Type -> Maybe Name
varTToName_maybe Type
ty
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Name
tvTy forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
tvSet
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
tvTy

deriveRepK :: Name -> [Name]
           -> DatatypeVariant -> [ConstructorInfo] -> Q Type
deriveRepK :: Name -> [Name] -> DatatypeVariant -> [ConstructorInfo] -> Q Type
deriveRepK Name
dataName [Name]
univVarNames DatatypeVariant
dataVariant [ConstructorInfo]
cons = do
  [Type]
cons' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConstructorInfo -> Q Type
constructor [ConstructorInfo]
cons
  Type -> Q Type
metaData forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Type
x Type
y -> Type -> Name -> Type -> Type
InfixT Type
x ''(:+:) Type
y) (Name -> Type
ConT ''V1) [Type]
cons'
  where
    metaData :: Type -> Q Type
    metaData :: Type -> Q Type
metaData Type
t = do
      String
m   <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot fetch module name!")  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe String
nameModule Name
dataName)
      String
pkg <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot fetch package name!") forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe String
namePackage Name
dataName)
      forall (m :: * -> *). Quote m => Name -> m Type
conT ''D1
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'MetaData forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
dataName)) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
m) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
pkg) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                Bool -> Q Type
promoteBool (DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
dataVariant))
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t

    constructor :: ConstructorInfo -> Q Type
    constructor :: ConstructorInfo -> Q Type
constructor ConstructorInfo{ constructorName :: ConstructorInfo -> Name
constructorName       = Name
conName
                               , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars       = [TyVarBndrUnit]
exTvbs
                               , constructorContext :: ConstructorInfo -> [Type]
constructorContext    = [Type]
conCtxt
                               , constructorFields :: ConstructorInfo -> [Type]
constructorFields     = [Type]
fields
                               , constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
fieldStricts
                               , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant    = ConstructorVariant
conVariant
                               } = do
      Maybe Fixity
mbFi <- Name -> Q (Maybe Fixity)
reifyFixity Name
conName
      forall (m :: * -> *). Quote m => Name -> m Type
conT ''C1
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'MetaCons forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
conName)) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                Maybe Fixity -> Bool -> Q Type
fixityIPromotedType Maybe Fixity
mbFi Bool
conIsInfix forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                Bool -> Q Type
promoteBool Bool
conIsRecord)
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` do Type
prod <- forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Type
x Type
y -> Type -> Name -> Type -> Type
InfixT Type
x ''(:*:) Type
y) (Name -> Type
ConT ''U1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type]
selectors
                  Type
ctxtProd <- Type -> Q Type
context Type
prod
                  Type -> Q Type
existentials Type
ctxtProd
      where
        conIsRecord :: Bool
        conIsRecord :: Bool
conIsRecord =
          case ConstructorVariant
conVariant of
            ConstructorVariant
NormalConstructor   -> Bool
False
            ConstructorVariant
InfixConstructor    -> Bool
False
            RecordConstructor{} -> Bool
True

        conIsInfix :: Bool
        conIsInfix :: Bool
conIsInfix =
          case ConstructorVariant
conVariant of
            ConstructorVariant
NormalConstructor   -> Bool
False
            ConstructorVariant
InfixConstructor    -> Bool
True
            RecordConstructor{} -> Bool
False

        context :: Type -> Q Type
        context :: Type -> Q Type
context = Name -> [Name] -> [Type] -> Type -> Q Type
ntext ''(:=>:) [Name]
allTvbNames [Type]
conCtxt

        cocontext :: [Name] -> Cxt -> Type -> Q Type
        cocontext :: [Name] -> [Type] -> Type -> Q Type
cocontext = Name -> [Name] -> [Type] -> Type -> Q Type
ntext '(:=>>:)

        ntext :: Name -> [Name] -> Cxt -> Type -> Q Type
        ntext :: Name -> [Name] -> [Type] -> Type -> Q Type
ntext Name
(==>) [Name]
tvbNames [Type]
ctxt Type
ty =
          case [Type]
ctxt of
            [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty -- Don't use (:=>:) if there are no constraints
            [Type]
_  -> forall (m :: * -> *). Quote m => m Type -> Name -> m Type -> m Type
infixT ([Name] -> [Type] -> Q Type
atomizeContext [Name]
tvbNames [Type]
ctxt) Name
(==>) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty)

        existentials :: Type -> Q Type
        existentials :: Type -> Q Type
existentials Type
ty =
          forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Type
x TyVarBndrUnit
tvb -> forall (m :: * -> *). Quote m => Name -> m Type
conT ''Exists forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndrUnit
tvb) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
x)
                 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty) [TyVarBndrUnit]
exTvbs

        selectors :: Q [Type]
        selectors :: Q [Type]
selectors =
          case ConstructorVariant
conVariant of
            ConstructorVariant
NormalConstructor         -> Q [Type]
nonRecordCase
            ConstructorVariant
InfixConstructor          -> Q [Type]
nonRecordCase
            RecordConstructor [Name]
records -> [Name] -> Q [Type]
recordCase [Name]
records
          where
            nonRecordCase :: Q [Type]
            nonRecordCase :: Q [Type]
nonRecordCase = [Maybe Name] -> Q [Type]
mkCase (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) [Type]
fields)

            recordCase :: [Name] -> Q [Type]
            recordCase :: [Name] -> Q [Type]
recordCase [Name]
records = [Maybe Name] -> Q [Type]
mkCase (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [Name]
records)

            mkCase :: [Maybe Name] -> Q [Type]
            mkCase :: [Maybe Name] -> Q [Type]
mkCase [Maybe Name]
mbRecords = do
              [DecidedStrictness]
dcdStricts <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
conName
              forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M Maybe Name
-> FieldStrictness -> DecidedStrictness -> Type -> Q Type
selector [Maybe Name]
mbRecords [FieldStrictness]
fieldStricts [DecidedStrictness]
dcdStricts [Type]
fields

        selector :: Maybe Name -> FieldStrictness -> TH.DecidedStrictness -> Type -> Q Type
        selector :: Maybe Name
-> FieldStrictness -> DecidedStrictness -> Type -> Q Type
selector Maybe Name
mbRecord (FieldStrictness Unpackedness
fu Strictness
fs) DecidedStrictness
ds Type
field = do
          let mbSelNameT :: Q Type
mbSelNameT =
                case Maybe Name
mbRecord of
                  Just Name
record -> forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Just forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
record))
                  Maybe Name
Nothing     -> forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Nothing
          forall (m :: * -> *). Quote m => Name -> m Type
conT ''S1
            forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'MetaSel forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                    Q Type
mbSelNameT forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                    SourceUnpackedness -> Q Type
promoteSourceUnpackedness (Unpackedness -> SourceUnpackedness
generifyUnpackedness Unpackedness
fu) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                    SourceStrictness -> Q Type
promoteSourceStrictness (Strictness -> SourceStrictness
generifyStrictness Strictness
fs) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
                    DecidedStrictness -> Q Type
promoteDecidedStrictness (DecidedStrictness -> DecidedStrictness
generifyDecidedStrictness DecidedStrictness
ds))
            forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Field forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` [Name] -> Type -> Q Type
prenex [Name]
allTvbNames Type
field)

        atomizeContext :: [Name] -> Cxt -> Q Type
        atomizeContext :: [Name] -> [Type] -> Q Type
atomizeContext [Name]
tvbNames =
          forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Q Type
x Q Type
y -> forall (m :: * -> *). Quote m => m Type -> Name -> m Type -> m Type
infixT Q Type
x '(:&:) Q Type
y)
                  (forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Kon forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
0)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Q Type
atomize [Name]
tvbNames)

#if MIN_VERSION_template_haskell(2,17,0)
        foralls :: [TyVarBndr Specificity] -> Q Type -> Q Type
#else
        foralls :: [TyVarBndr] -> Q Type -> Q Type
#endif
        foralls :: [TyVarBndr Specificity] -> Q Type -> Q Type
foralls [TyVarBndr Specificity]
vs Q Type
ty =
           forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TyVarBndr Specificity
_ Q Type
x -> forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'ForAll forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
x) Q Type
ty [TyVarBndr Specificity]
vs

        prenex :: [Name] -> Type -> Q Type
        prenex :: [Name] -> Type -> Q Type
prenex [Name]
tvbNames (ForallT [TyVarBndr Specificity]
vars [Type]
ctxt Type
ty) =
          let tvbNames' :: [Name]
tvbNames' = forall a. [a] -> [a]
reverse (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr Specificity]
vars) forall a. [a] -> [a] -> [a]
++ [Name]
tvbNames in
          ([TyVarBndr Specificity] -> Q Type -> Q Type
foralls [TyVarBndr Specificity]
vars forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name] -> [Type] -> Type -> Q Type
cocontext [Name]
tvbNames' [Type]
ctxt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Type -> Q Type
prenex [Name]
tvbNames') Type
ty
        prenex [Name]
tvbNames Type
ty = [Name] -> Type -> Q Type
atomize [Name]
tvbNames Type
ty

        atomize :: [Name] -> Type -> Q Type
        atomize :: [Name] -> Type -> Q Type
atomize [Name]
tvbNames = forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> [Q Type] -> Q Type
go []
          where
            -- Collect arguments in a list while descending to the left of AppT,
            -- in case this is a type family application.
            go :: Type -> [Q Type] -> Q Type
            -- Var case
            go :: Type -> [Q Type] -> Q Type
go ty :: Type
ty@(VarT Name
n) =
              case forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Name
n [Name]
tvbNames of
                Just Int
idx -> Type -> [Q Type] -> Q Type
appsT forall a b. (a -> b) -> a -> b
$ Int -> Type
enumerateTyVar Int
idx
                Maybe Int
Nothing  -> Type -> [Q Type] -> Q Type
kon Type
ty

            -- Either a type constructor or a type family
            go ty :: Type
ty@(ConT Name
n)         = \[Q Type]
args -> do
              Bool
isTFS <- Name -> Q Bool
isTypeFamilyOrSynonym Name
n
              if Bool
isTFS
              then do (Type
fam, Int
arity) <- Name -> Q (Type, Int)
promoteNDFamily Name
n
                      ([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 :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Type]
args
                      let saturated :: Bool
saturated = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isKonApp [Type]
args1
                      if Bool
saturated then Type -> [Q Type] -> Q Type
kon Type
ty [Q Type]
args
                      else do
                        Name -> Q [Dec]
fcfify Name
n forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dec] -> Q ()
pushFcfifyQueue
                        Name -> Type
PromotedT 'Eval
                          Type -> Type -> Type
`AppT` (Name -> Type
PromotedT 'Kon Type -> Type -> Type
`AppT` Type
fam Type -> Type -> Type
`appAtom` [Type] -> Type
consTupleAtom [Type]
args1)
                          Type -> [Q Type] -> Q Type
`appsT` (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
args2)
              else Type -> [Q Type] -> Q Type
kon Type
ty [Q Type]
args

            -- Kon cases
            go ty :: Type
ty@PromotedT{}      = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@TupleT{}         = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
ArrowT           = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
ListT            = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@PromotedTupleT{} = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
PromotedNilT     = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
PromotedConsT    = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
StarT            = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
ConstraintT      = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@LitT{}           = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
WildCardT        = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@UnboxedTupleT{}  = Type -> [Q Type] -> Q Type
kon Type
ty
            go ty :: Type
ty@UnboxedSumT{}    = Type -> [Q Type] -> Q Type
kon Type
ty
            go Type
EqualityT           = Type -> [Q Type] -> Q Type
kon (Name -> Type
ConT ''(~~))
                                       -- EqualityT can refer to both homogeneous
                                       -- and heterogeneous equality, but TH always
                                       -- splices EqualityT back in as if it were
                                       -- homogeneous. To be on the safe side, always
                                       -- conservatively assume that the equality it
                                       -- heterogeneous, since it is more permissive.
#if MIN_VERSION_template_haskell(2,17,0)
            go ty :: Type
ty@MulArrowT{}      = Type -> [Q Type] -> Q Type
kon Type
ty
#endif

            -- Recursive cases
            go (AppT Type
ty1 Type
ty2) = Type -> [Q Type] -> Q Type
go Type
ty1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [Q Type] -> Q Type
go Type
ty2 [] forall a. a -> [a] -> [a]
:)
            go (InfixT Type
ty1 Name
n Type
ty2)  = Type -> [Q Type] -> Q Type
go (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2)
            go (UInfixT Type
ty1 Name
n Type
ty2) = Type -> [Q Type] -> Q Type
go (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2)
#if MIN_VERSION_template_haskell(2,19,0)
            go (PromotedInfixT  ty1 n ty2) = go (ConT n `AppT` ty1 `AppT` ty2)
            go (PromotedUInfixT ty1 n ty2) = go (ConT n `AppT` ty1 `AppT` ty2)
#endif
            go (SigT Type
ty Type
_)         = Type -> [Q Type] -> Q Type
go Type
ty
            go (ParensT Type
ty)        = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
ParensT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Q Type] -> Q Type
go Type
ty
#if MIN_VERSION_template_haskell(2,15,0)
            go (AppKindT Type
ty Type
_)       = Type -> [Q Type] -> Q Type
go Type
ty
            go (ImplicitParamT String
n Type
ty) = Type -> [Q Type] -> Q Type
go (Name -> Type
ConT ''IP Type -> Type -> Type
`AppT` TyLit -> Type
LitT (String -> TyLit
StrTyLit String
n) Type -> Type -> Type
`AppT` Type
ty)
                                         -- Desugar (?n :: T) into (IP "n" T)
#endif

            -- Failure cases
            go ty :: Type
ty@ForallT{}       = \[Q Type]
_ -> forall a. String -> Type -> Q a
can'tRepresent String
"rank-n type" Type
ty
#if MIN_VERSION_template_haskell(2,16,0)
            go ty :: Type
ty@ForallVisT{}    = \[Q Type]
_ -> forall a. String -> Type -> Q a
can'tRepresent String
"rank-n type" Type
ty
#endif

            kon :: Type -> [Q Type] -> Q Type
            kon :: Type -> [Q Type] -> Q Type
kon Type
ty [Q Type]
tys = do Type
ty' <- forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Kon forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
                            Type -> [Q Type] -> Q Type
appsT Type
ty' [Q Type]
tys

            appsT :: Type -> [Q Type] -> Q Type
            appsT :: Type -> [Q Type] -> Q Type
appsT Type
ty1 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty1
            appsT Type
ty1 (Q Type
ty2' : [Q Type]
tys) = do Type
ty2 <- Q Type
ty2'
                                        case (Type
ty1, Type
ty2) of
                                          (PromotedT Name
kon1 `AppT` Type
tyArg1,
                                           PromotedT Name
kon2 `AppT` Type
tyArg2)
                                                 |  Name
kon1 forall a. Eq a => a -> a -> Bool
== 'Kon, Name
kon2 forall a. Eq a => a -> a -> Bool
== 'Kon
                                                 -> Type -> [Q Type] -> Q Type
kon (Type -> Type -> Type
AppT Type
tyArg1 Type
tyArg2) [Q Type]
tys
                                          (Type
_, Type
_) -> Type -> [Q Type] -> Q Type
appsT (Type
ty1 Type -> Type -> Type
`appAtom` Type
ty2) [Q Type]
tys

            can'tRepresent :: String -> Type -> Q a
            can'tRepresent :: forall a. String -> Type -> Q a
can'tRepresent String
thing Type
ty = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unsupported " forall a. [a] -> [a] -> [a]
++ String
thing forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
ty

        allTvbNames :: [Name]
        allTvbNames :: [Name]
allTvbNames = forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndrUnit]
exTvbs forall a. [a] -> [a] -> [a]
++ [Name]
univVarNames

    fixityIPromotedType :: Maybe TH.Fixity -> Bool -> Q Type
    fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type
fixityIPromotedType Maybe Fixity
mbFi Bool
True =
               forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'InfixI
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Associativity -> Q Type
promoteAssociativity (FixityDirection -> Associativity
fdToAssociativity FixityDirection
fd)
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => Integer -> m TyLit
numTyLit (forall a. Integral a => a -> Integer
toInteger Int
n))
      where
        Fixity Int
n FixityDirection
fd = forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
mbFi
    fixityIPromotedType Maybe Fixity
_ Bool
False = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'PrefixI

isKonApp :: Type -> Bool
isKonApp :: Type -> Bool
isKonApp (PromotedT Name
kon `AppT` Type
_) = Name
kon forall a. Eq a => a -> a -> Bool
== 'Kon
isKonApp Type
_ = Bool
False

appAtom :: Type -> Type -> Type
appAtom :: Type -> Type -> Type
appAtom Type
t Type
t' = Type -> Name -> Type -> Type
InfixT Type
t '(:@:) Type
t'

consTupleAtom :: [Type] -> Type
consTupleAtom :: [Type] -> Type
consTupleAtom [] = Name -> Type
PromotedT 'Kon Type -> Type -> Type
`AppT` Name -> Type
PromotedT '()
consTupleAtom (Type
t : [Type]
ts) =
  (Name -> Type
PromotedT 'Kon Type -> Type -> Type
`AppT` Name -> Type
PromotedT '(,)) Type -> Type -> Type
`appAtom` Type
t Type -> Type -> Type
`appAtom` [Type] -> Type
consTupleAtom [Type]
ts

deriveFromK :: [ConstructorInfo] -> Q Dec
deriveFromK :: [ConstructorInfo] -> Q Dec
deriveFromK [ConstructorInfo]
cons = do
  Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'fromK
       [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]
               (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) [Q Match]
cases)
               []]
  where
    cases :: [Q Match]
    cases :: [Q Match]
cases = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> ConstructorInfo -> Q Match
fromCon (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons)) [Int
1..] [ConstructorInfo]
cons

    fromCon :: Int -- Total number of constructors
            -> Int -- Constructor index
            -> ConstructorInfo -> Q Match
    fromCon :: Int -> Int -> ConstructorInfo -> Q Match
fromCon Int
n Int
i ConstructorInfo{ constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                               , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars    = [TyVarBndrUnit]
exTvbs
                               , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
conCtxt
                               , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
fields
                               } = do
      [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields
      forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fNames))
            (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
n forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
              do Exp
prod <- forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Q Exp
x Q Exp
y -> forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just Q Exp
x) (forall (m :: * -> *). Quote m => Name -> m Exp
conE '(:*:)) (forall a. a -> Maybe a
Just Q Exp
y))
                           (forall (m :: * -> *). Quote m => Name -> m Exp
conE 'U1)
                           (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Type -> Q Exp
fromField [Name]
fNames [Type]
fields)
                 Exp
ctxtProd <- Exp -> Q Exp
context Exp
prod
                 Exp -> Q Exp
existentials Exp
ctxtProd)
            []
      where
        fromField :: Name -> Type -> Q Exp
        fromField :: Name -> Type -> Q Exp
fromField Name
fName Type
fty = forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Field forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Type -> Q Exp -> Q Exp
prenex Type
fty (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName))

        prenex :: Type -> Q Exp -> Q Exp
        prenex :: Type -> Q Exp -> Q Exp
prenex (ForallT [TyVarBndr Specificity]
vars [Type]
ctxt Type
ty) Q Exp
e =
          forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TyVarBndr Specificity
_ -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE 'ForAllI)) ([Type] -> Exp -> Q Exp
cocontext [Type]
ctxt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Exp -> Q Exp
prenex Type
ty Q Exp
e) [TyVarBndr Specificity]
vars
        prenex Type
_ Q Exp
e = Q Exp
e

        context :: Exp -> Q Exp
        context :: Exp -> Q Exp
context = Name -> [Type] -> Exp -> Q Exp
ntext 'SuchThat [Type]
conCtxt

        cocontext :: Cxt -> Exp -> Q Exp
        cocontext :: [Type] -> Exp -> Q Exp
cocontext = Name -> [Type] -> Exp -> Q Exp
ntext 'SuchThatI

        ntext :: Name -> Cxt -> Exp -> Q Exp
        ntext :: Name -> [Type] -> Exp -> Q Exp
ntext Name
suchThat [Type]
ctxt Exp
e =
          case [Type]
ctxt of
            [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
            [Type]
_  -> forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
suchThat forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e

        existentials :: Exp -> Q Exp
        existentials :: Exp -> Q Exp
existentials Exp
e = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Exp
x TyVarBndrUnit
_ -> forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Exists forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e) [TyVarBndrUnit]
exTvbs

deriveToK :: [ConstructorInfo] -> Q Dec
deriveToK :: [ConstructorInfo] -> Q Dec
deriveToK [ConstructorInfo]
cons = do
  Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'toK
       [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'M1 [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]]
               (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) [Q Match]
cases)
               []]
  where
    cases :: [Q Match]
    cases :: [Q Match]
cases = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> ConstructorInfo -> Q Match
toCon (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons)) [Int
1..] [ConstructorInfo]
cons

    toCon :: Int -- Total number of constructors
          -> Int -- Constructor index
          -> ConstructorInfo -> Q Match
    toCon :: Int -> Int -> ConstructorInfo -> Q Match
toCon Int
n Int
i ConstructorInfo{ constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                             , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars    = [TyVarBndrUnit]
exTvbs
                             , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
conCtxt
                             , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
fields
                             } = do
      [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields
      forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
n forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'M1
              [ do Pat
prod <- forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\Q Pat
x Q Pat
y -> forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP Q Pat
x '(:*:) Q Pat
y)
                                  (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'U1 [])
                                  (forall a b. (a -> b) -> [a] -> [b]
map (\Name
x -> forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'M1 [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Field [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]]) [Name]
fNames)
                   Pat
ctxtProd <- Pat -> Q Pat
context Pat
prod
                   Pat -> Q Pat
existentials Pat
ctxtProd
              ] )
            (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Type -> Q Exp
toField [Name]
fNames [Type]
fields))
            []
        where
          toField :: Name -> Type -> Q Exp
          toField :: Name -> Type -> Q Exp
toField Name
fName Type
ty = Type -> Q Exp -> Q Exp
prenex Type
ty (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName)

          prenex :: Type -> Q Exp -> Q Exp
          prenex :: Type -> Q Exp -> Q Exp
prenex (ForallT [TyVarBndr Specificity]
vars [Type]
ctxt Type
ty) Q Exp
e =
            Type -> Q Exp -> Q Exp
prenex Type
ty ([Type] -> Exp -> Q Exp
cocontext [Type]
ctxt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x TyVarBndr Specificity
_ -> forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unwrapI forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toWrappedI forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x)) Q Exp
e [TyVarBndr Specificity]
vars)
          prenex Type
_ Q Exp
e = Q Exp
e

          context :: Pat -> Q Pat
          context :: Pat -> Q Pat
context = forall a. (Q a -> Q a) -> [Type] -> a -> Q a
ntext (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'SuchThat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])) [Type]
conCtxt

          cocontext :: Cxt -> Exp -> Q Exp
          cocontext :: [Type] -> Exp -> Q Exp
cocontext = forall a. (Q a -> Q a) -> [Type] -> a -> Q a
ntext (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unSuchThatI forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`)

          ntext :: (Q a -> Q a) -> Cxt -> a -> Q a
          ntext :: forall a. (Q a -> Q a) -> [Type] -> a -> Q a
ntext Q a -> Q a
suchThat [Type]
ctxt a
p =
            case [Type]
ctxt of
              [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
p
              [Type]
_  -> Q a -> Q a
suchThat (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
p)

          existentials :: Pat -> Q Pat
          existentials :: Pat -> Q Pat
existentials Pat
p = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Pat
x TyVarBndrUnit
_ -> forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Exists [Q Pat
x]) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
p) [TyVarBndrUnit]
exTvbs

-- | If a Type is a SigT, returns its kind signature. Otherwise, return Type.
typeKind :: Type -> Kind
typeKind :: Type -> Type
typeKind (SigT Type
_ Type
k) = Type
k
typeKind Type
_          = Name -> Type
ConT ''Kind.Type

fdToAssociativity :: FixityDirection -> Associativity
fdToAssociativity :: FixityDirection -> Associativity
fdToAssociativity FixityDirection
InfixL = Associativity
LeftAssociative
fdToAssociativity FixityDirection
InfixR = Associativity
RightAssociative
fdToAssociativity FixityDirection
InfixN = Associativity
NotAssociative

generifyUnpackedness :: Unpackedness -> Generics.SourceUnpackedness
generifyUnpackedness :: Unpackedness -> SourceUnpackedness
generifyUnpackedness Unpackedness
UnspecifiedUnpackedness = SourceUnpackedness
Generics.NoSourceUnpackedness
generifyUnpackedness Unpackedness
NoUnpack                = SourceUnpackedness
Generics.SourceNoUnpack
generifyUnpackedness Unpackedness
Unpack                  = SourceUnpackedness
Generics.SourceUnpack

generifyStrictness :: Strictness -> Generics.SourceStrictness
generifyStrictness :: Strictness -> SourceStrictness
generifyStrictness Strictness
UnspecifiedStrictness = SourceStrictness
Generics.NoSourceStrictness
generifyStrictness Strictness
Lazy                  = SourceStrictness
Generics.SourceLazy
generifyStrictness Strictness
THAbs.Strict          = SourceStrictness
Generics.SourceStrict

generifyDecidedStrictness :: TH.DecidedStrictness -> Generics.DecidedStrictness
generifyDecidedStrictness :: DecidedStrictness -> DecidedStrictness
generifyDecidedStrictness DecidedStrictness
TH.DecidedLazy   = DecidedStrictness
Generics.DecidedLazy
generifyDecidedStrictness DecidedStrictness
TH.DecidedStrict = DecidedStrictness
Generics.DecidedStrict
generifyDecidedStrictness DecidedStrictness
TH.DecidedUnpack = DecidedStrictness
Generics.DecidedUnpack

promoteSourceUnpackedness :: Generics.SourceUnpackedness -> Q Type
promoteSourceUnpackedness :: SourceUnpackedness -> Q Type
promoteSourceUnpackedness SourceUnpackedness
Generics.NoSourceUnpackedness = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.NoSourceUnpackedness
promoteSourceUnpackedness SourceUnpackedness
Generics.SourceNoUnpack       = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.SourceNoUnpack
promoteSourceUnpackedness SourceUnpackedness
Generics.SourceUnpack         = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.SourceUnpack

promoteSourceStrictness :: Generics.SourceStrictness -> Q Type
promoteSourceStrictness :: SourceStrictness -> Q Type
promoteSourceStrictness SourceStrictness
Generics.NoSourceStrictness = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.NoSourceStrictness
promoteSourceStrictness SourceStrictness
Generics.SourceLazy         = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.SourceLazy
promoteSourceStrictness SourceStrictness
Generics.SourceStrict       = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.SourceStrict

promoteDecidedStrictness :: Generics.DecidedStrictness -> Q Type
promoteDecidedStrictness :: DecidedStrictness -> Q Type
promoteDecidedStrictness DecidedStrictness
Generics.DecidedLazy   = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.DecidedLazy
promoteDecidedStrictness DecidedStrictness
Generics.DecidedStrict = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.DecidedStrict
promoteDecidedStrictness DecidedStrictness
Generics.DecidedUnpack = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'Generics.DecidedUnpack

promoteAssociativity :: Associativity -> Q Type
promoteAssociativity :: Associativity -> Q Type
promoteAssociativity Associativity
LeftAssociative  = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'LeftAssociative
promoteAssociativity Associativity
RightAssociative = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'RightAssociative
promoteAssociativity Associativity
NotAssociative   = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'NotAssociative

promoteBool :: Bool -> Q Type
promoteBool :: Bool -> Q Type
promoteBool Bool
True  = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'True
promoteBool Bool
False = forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'False

enumerateTyVar :: Int -> Type
-- Special-case the first 10, if only to generate more compact code
enumerateTyVar :: Int -> Type
enumerateTyVar Int
0 = Name -> Type
ConT ''Var0
enumerateTyVar Int
1 = Name -> Type
ConT ''Var1
enumerateTyVar Int
2 = Name -> Type
ConT ''Var2
enumerateTyVar Int
3 = Name -> Type
ConT ''Var3
enumerateTyVar Int
4 = Name -> Type
ConT ''Var4
enumerateTyVar Int
5 = Name -> Type
ConT ''Var5
enumerateTyVar Int
6 = Name -> Type
ConT ''Var6
enumerateTyVar Int
7 = Name -> Type
ConT ''Var7
enumerateTyVar Int
8 = Name -> Type
ConT ''Var8
enumerateTyVar Int
9 = Name -> Type
ConT ''Var9
enumerateTyVar Int
n = Name -> Type
PromotedT 'Var Type -> Type -> Type
`AppT` forall a. Int -> (a -> a) -> a -> a
nTimes Int
n (Type -> Type -> Type
AppT (Name -> Type
PromotedT 'VS)) (Name -> Type
PromotedT 'VZ)

-- | Variant of foldr for producing balanced lists
foldBal :: (a -> a -> a) -> a -> [a] -> a
foldBal :: forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
_  a
x []  = a
x
foldBal a -> a -> a
_  a
_ [a
y] = a
y
foldBal a -> a -> a
op a
x [a]
l   = let ([a]
a,[a]
b) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l forall a. Integral a => a -> a -> a
`div` Int
2) [a]
l
                   in forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op a
x [a]
a a -> a -> a
`op` forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op a
x [a]
b

lrP :: Int -- Constructor index
    -> Int -- Total number of constructors
    -> Q Pat -> Q Pat
lrP :: Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
n Q Pat
p
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
0       = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrP: impossible"
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
1       = Q Pat
p
  | Int
i forall a. Ord a => a -> a -> Bool
<= forall a. Integral a => a -> a -> a
div Int
n Int
2 = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'L1 [Int -> Int -> Q Pat -> Q Pat
lrP Int
i     (forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Pat
p]
  | Bool
otherwise    = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'R1 [Int -> Int -> Q Pat -> Q Pat
lrP (Int
iforall a. Num a => a -> a -> a
-Int
m) (Int
nforall a. Num a => a -> a -> a
-Int
m)     Q Pat
p]
                     where m :: Int
m = forall a. Integral a => a -> a -> a
div Int
n Int
2

lrE :: Int -- Constructor index
    -> Int -- Total number of constructors
    -> Q Exp -> Q Exp
lrE :: Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
n Q Exp
e
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
0       = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrE: impossible"
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
1       = Q Exp
e
  | Int
i forall a. Ord a => a -> a -> Bool
<= forall a. Integral a => a -> a -> a
div Int
n Int
2 = forall (m :: * -> *). Quote m => Name -> m Exp
conE 'L1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE Int
i     (forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Exp
e
  | Bool
otherwise    = forall (m :: * -> *). Quote m => Name -> m Exp
conE 'R1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE (Int
iforall a. Num a => a -> a -> a
-Int
m) (Int
nforall a. Num a => a -> a -> a
-Int
m)     Q Exp
e
                     where m :: Int
m = forall a. Integral a => a -> a -> a
div Int
n Int
2

isNewtypeVariant :: DatatypeVariant -> Bool
isNewtypeVariant :: DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
Datatype        = Bool
False
isNewtypeVariant DatatypeVariant
Newtype         = Bool
True
isNewtypeVariant DatatypeVariant
DataInstance    = Bool
False
isNewtypeVariant DatatypeVariant
NewtypeInstance = Bool
True
#if MIN_VERSION_th_abstraction(0,5,0)
isNewtypeVariant DatatypeVariant
THAbs.TypeData  = Bool
False
#endif

-- | Extract 'Just' the 'Name' from a type variable. If the argument 'Type' is
-- not a type variable, return 'Nothing'.
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe (VarT Name
n)   = forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT Type
t Type
_) = Type -> Maybe Name
varTToName_maybe Type
t
varTToName_maybe Type
_          = forall a. Maybe a
Nothing

-- | Extract the 'Name' from a type variable. If the argument 'Type' is not a
-- type variable, throw an error.
varTToName :: Type -> Name
varTToName :: Type -> Name
varTToName = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Not a type variable!") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Name
varTToName_maybe

zipWith4M :: Monad m => (a -> b -> c -> d -> m e)
          -> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M :: forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M a -> b -> c -> d -> m e
_ []     [b]
_      [c]
_      [d]
_      = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
_ [a]
_      []     [c]
_      [d]
_      = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
_ [a]
_      [b]
_      []     [d]
_      = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
_ [a]
_      [b]
_      [c]
_      []     = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
f (a
x:[a]
xs) (b
y:[b]
ys) (c
z:[c]
zs) (d
a:[d]
as)
  = do e
r  <- a -> b -> c -> d -> m e
f a
x b
y c
z d
a
       [e]
rs <- forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M a -> b -> c -> d -> m e
f [a]
xs [b]
ys [c]
zs [d]
as
       forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ e
rforall a. a -> [a] -> [a]
:[e]
rs

-- | Compose a function with itself n times.  (nth rather than twice)
nTimes :: Int -> (a -> a) -> (a -> a)
nTimes :: forall a. Int -> (a -> a) -> a -> a
nTimes Int
0 a -> a
_ = forall a. a -> a
id
nTimes Int
1 a -> a
f = a -> a
f
nTimes Int
n a -> a
f = a -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> (a -> a) -> a -> a
nTimes (Int
nforall a. Num a => a -> a -> a
-Int
1) a -> a
f

-- | Generate a list of fresh names with a common prefix, and numbered suffixes.
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList String
prefix Int
n = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
n]

gatherExistentials :: [ConstructorInfo] -> [TyVarBndrUnit]
gatherExistentials :: [ConstructorInfo] -> [TyVarBndrUnit]
gatherExistentials = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [TyVarBndrUnit]
constructorVars

gatherConstraints :: [ConstructorInfo] -> [Pred]
gatherConstraints :: [ConstructorInfo] -> [Type]
gatherConstraints = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [Type]
constructorContext

gatherFields :: [ConstructorInfo] -> [Type]
gatherFields :: [ConstructorInfo] -> [Type]
gatherFields = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [Type]
constructorFields

-- | Detect if a name occurs as an argument to some type family.
isInTypeFamilyApp :: Name -> Type -> Q Bool
isInTypeFamilyApp :: Name -> Type -> Q Bool
isInTypeFamilyApp Name
name = Type -> Q Bool
go
  where
    go :: Type -> Q Bool
    go :: Type -> Q Bool
go ty :: Type
ty@AppT{}          = case Type -> (Type, [Type])
splitAppTs Type
ty of
                              (Type
tyFun, [Type]
tyArgs)
                                |  ConT Name
tcName <- Type
tyFun
                                -> Name -> [Type] -> Q Bool
goTyConApp Name
tcName [Type]
tyArgs
                                |  Bool
otherwise
                                -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Bool
go (Type
tyFunforall a. a -> [a] -> [a]
:[Type]
tyArgs)
    go (InfixT Type
ty1 Name
n Type
ty2) = Type -> Q Bool
go (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2)
    go (SigT Type
ty Type
ki)       = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) (Type -> Q Bool
go Type
ty) (Type -> Q Bool
go Type
ki)
    go (ParensT Type
ty)       = Type -> Q Bool
go Type
ty
    go Type
_                  = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

    goTyConApp :: Name -> [Type] -> Q Bool
    goTyConApp :: Name -> [Type] -> Q Bool
goTyConApp Name
tcName [Type]
tcArgs = do
      Info
info <- Name -> Q Info
reify Name
tcName
      case Info
info of
        FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndrUnit]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
          -> forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndrUnit]
bndrs
        FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndrUnit]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
          -> forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndrUnit]
bndrs
        Info
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      where
        withinFirstArgs :: [a] -> Q Bool
        withinFirstArgs :: forall a. [a] -> Q Bool
withinFirstArgs [a]
bndrs =
          let firstArgs :: [Type]
firstArgs = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) [Type]
tcArgs
          in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
firstArgs

-- | Split a chain of 'AppT's to a linear chain of arguments.
splitAppTs :: Type -> (Type, [Type])
splitAppTs :: Type -> (Type, [Type])
splitAppTs Type
ty = Type -> Type -> [Type] -> (Type, [Type])
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [Type] -> (Type, [Type])
    split :: Type -> Type -> [Type] -> (Type, [Type])
split Type
_      (AppT Type
ty1 Type
ty2)     [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
ty1 Type
ty1 (Type
ty2forall a. a -> [a] -> [a]
:[Type]
args)
    split Type
origTy (InfixT Type
ty1 Name
n Type
ty2) [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
origTy (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2) [Type]
args
    split Type
origTy (SigT Type
ty' Type
_)       [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
origTy Type
ty' [Type]
args
    split Type
origTy (ParensT Type
ty')      [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
origTy Type
ty' [Type]
args
    split Type
origTy Type
_                  [Type]
args = (Type
origTy, [Type]
args)

-- | Resolve all of the type synonyms in a 'ConstructorInfo'.
resolveConSynonyms :: ConstructorInfo -> Q ConstructorInfo
resolveConSynonyms :: ConstructorInfo -> Q ConstructorInfo
resolveConSynonyms con :: ConstructorInfo
con@ConstructorInfo{ constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars    = [TyVarBndrUnit]
vars
                                      , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
context
                                      , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
fields
                                      } = do
  [TyVarBndrUnit]
vars'    <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\TyVarBndrUnit
tvb ->
                         forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
_n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TyVarBndrUnit
tvb)
                                (\Name
n Type
k -> Name -> Type -> TyVarBndrUnit
kindedTV Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveTypeSynonyms Type
k) TyVarBndrUnit
tvb) [TyVarBndrUnit]
vars
  [Type]
context' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Type
resolveTypeSynonyms [Type]
context
  [Type]
fields'  <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Type
resolveTypeSynonyms [Type]
fields
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ConstructorInfo
con{ constructorVars :: [TyVarBndrUnit]
constructorVars = [TyVarBndrUnit]
vars'
            , constructorContext :: [Type]
constructorContext = [Type]
context'
            , constructorFields :: [Type]
constructorFields  = [Type]
fields'
            }

-- | Store 'GenericK' instances to be produced after having typechecked
-- 'fcfify'-generated instances.
newtype GenericKQueue = GenericKQueue [Dec]

pushGenericKQueue :: [Dec] -> Q ()
pushGenericKQueue :: [Dec] -> Q ()
pushGenericKQueue [Dec]
d = do
  GenericKQueue [Dec]
decs <- forall a. a -> Maybe a -> a
fromMaybe ([Dec] -> GenericKQueue
GenericKQueue []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typeable a => Q (Maybe a)
TH.getQ
  forall a. Typeable a => a -> Q ()
TH.putQ ([Dec] -> GenericKQueue
GenericKQueue ([Dec]
d forall a. [a] -> [a] -> [a]
++ [Dec]
decs))

takeGenericKQueue :: Q [Dec]
takeGenericKQueue :: Q [Dec]
takeGenericKQueue = do
  GenericKQueue [Dec]
decs <- forall a. a -> Maybe a -> a
fromMaybe ([Dec] -> GenericKQueue
GenericKQueue []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typeable a => Q (Maybe a)
TH.getQ
  forall a. Typeable a => a -> Q ()
TH.putQ ([Dec] -> GenericKQueue
GenericKQueue [])
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
decs

-- | Store 'fcfify'-generated instances for the current data type.
-- This could also be done with StateT in deriveRepK but that's
-- a more invasive change.
newtype FcfifyQueue = FcfifyQueue [Dec]

pushFcfifyQueue :: [Dec] -> Q ()
pushFcfifyQueue :: [Dec] -> Q ()
pushFcfifyQueue [Dec]
d = do
  FcfifyQueue [Dec]
decs <- forall a. a -> Maybe a -> a
fromMaybe ([Dec] -> FcfifyQueue
FcfifyQueue []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typeable a => Q (Maybe a)
TH.getQ
  forall a. Typeable a => a -> Q ()
TH.putQ ([Dec] -> FcfifyQueue
FcfifyQueue ([Dec]
d forall a. [a] -> [a] -> [a]
++ [Dec]
decs))

takeFcfifyQueue :: Q [Dec]
takeFcfifyQueue :: Q [Dec]
takeFcfifyQueue = do
  FcfifyQueue [Dec]
decs <- forall a. a -> Maybe a -> a
fromMaybe ([Dec] -> FcfifyQueue
FcfifyQueue []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typeable a => Q (Maybe a)
TH.getQ
  forall a. Typeable a => a -> Q ()
TH.putQ ([Dec] -> FcfifyQueue
FcfifyQueue [])
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
decs