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

-- | 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) 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 Generics.Kind
import GHC.Generics as Generics hiding (conIsRecord, conName, datatypeName)
import Language.Haskell.TH as TH
import Language.Haskell.TH.Datatype as THAbs

#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@
deriveGenericK :: Name -> Q [Dec]
deriveGenericK :: Name -> Q [Dec]
deriveGenericK 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' <- (ConstructorInfo -> Q ConstructorInfo)
-> [ConstructorInfo] -> Q [ConstructorInfo]
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
          [] -> [Dec] -> Q [Dec]
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 ([Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
argsToKeep')
                                                          Type
argToDrop'
                  -- Check for dependent quantification, which we currently can't handle.
               ,  Name
argNameToDrop Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
                    [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
typeKind [Type]
argsToDrop
                                [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
tvKind ([ConstructorInfo] -> [TyVarBndr]
gatherExistentials [ConstructorInfo]
cons'))
               -> do let allInnerTypes :: [Type]
allInnerTypes  = [ConstructorInfo] -> [Type]
gatherConstraints [ConstructorInfo]
cons' [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [ConstructorInfo] -> [Type]
gatherFields [ConstructorInfo]
cons'
                     -- Check if the argument appears in a type family application.
                     Bool
inTyFamApp <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Bool) -> [Type] -> Q [Bool]
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
                     if Bool
inTyFamApp
                        then [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
inst]
                        else (Dec
instDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:) ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> [Type] -> Q [Dec]
deriveInsts [Type]
argsToKeep' (Type
argToDrop'Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
argsToDrop)
               |  Bool
otherwise
               -> [Dec] -> Q [Dec]
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 = (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName [Type]
argsToDrop
            kind :: Type
kind = (Type -> Type -> Type) -> Type -> [Type] -> Type
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)
                         (Name -> Type
ConT ''Kind.Type) ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
typeKind [Type]
argsToDrop)
            dataApp :: Q Type
dataApp = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
SigT ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
ConT Name
dataName) [Type]
argsToKeep) Type
kind
        CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
                  (Name -> Q Type
conT ''GenericK Q Type -> Q Type -> Q Type
`appT` Q Type
dataApp)
                  [ Name -> Maybe [Q TyVarBndr] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat ''RepK Maybe [Q TyVarBndr]
forall a. Maybe a
Nothing [Q Type
dataApp] (Q Type -> Q Dec) -> Q Type -> Q Dec
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'
                  ]

  [Type] -> [Type] -> Q [Dec]
deriveInsts ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
univVars) []

-- | @'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
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Name
tvTy Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
tvSet
  Name -> Maybe Name
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' <- (ConstructorInfo -> Q Type) -> [ConstructorInfo] -> CxtQ
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 (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
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   <- Q String -> (String -> Q String) -> Maybe String -> Q String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot fetch module name!")  String -> Q String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe String
nameModule Name
dataName)
      String
pkg <- Q String -> (String -> Q String) -> Maybe String -> Q String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot fetch package name!") String -> Q String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe String
namePackage Name
dataName)
      Name -> Q Type
conT ''D1
        Q Type -> Q Type -> Q Type
`appT` (Name -> Q Type
promotedT 'MetaData Q Type -> Q Type -> Q Type
`appT`
                TyLitQ -> Q Type
litT (String -> TyLitQ
strTyLit (Name -> String
nameBase Name
dataName)) Q Type -> Q Type -> Q Type
`appT`
                TyLitQ -> Q Type
litT (String -> TyLitQ
strTyLit String
m) Q Type -> Q Type -> Q Type
`appT`
                TyLitQ -> Q Type
litT (String -> TyLitQ
strTyLit String
pkg) Q Type -> Q Type -> Q Type
`appT`
                Bool -> Q Type
promoteBool (DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
dataVariant))
        Q Type -> Q Type -> Q Type
`appT` Type -> Q Type
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 -> [TyVarBndr]
constructorVars       = [TyVarBndr]
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
      Name -> Q Type
conT ''C1
        Q Type -> Q Type -> Q Type
`appT` (Name -> Q Type
promotedT 'MetaCons Q Type -> Q Type -> Q Type
`appT`
                TyLitQ -> Q Type
litT (String -> TyLitQ
strTyLit (Name -> String
nameBase Name
conName)) Q Type -> Q Type -> Q Type
`appT`
                Maybe Fixity -> Bool -> Q Type
fixityIPromotedType Maybe Fixity
mbFi Bool
conIsInfix Q Type -> Q Type -> Q Type
`appT`
                Bool -> Q Type
promoteBool Bool
conIsRecord)
        Q Type -> Q Type -> Q Type
`appT` do Type
prod <- (Type -> Type -> Type) -> Type -> [Type] -> Type
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) ([Type] -> Type) -> CxtQ -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CxtQ
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 Type
ty =
          case [Type]
conCtxt of
            [] -> Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty -- Don't use (:=>:) if there are no constraints
            [Type]
_  -> Q Type -> Name -> Q Type -> Q Type
infixT ([Type] -> Q Type
atomizeContext [Type]
conCtxt) ''(:=>:) (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty)

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

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

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

            mkCase :: [Maybe Name] -> Q [Type]
            mkCase :: [Maybe Name] -> CxtQ
mkCase [Maybe Name]
mbRecords = do
              [DecidedStrictness]
dcdStricts <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
conName
              (Maybe Name
 -> FieldStrictness -> DecidedStrictness -> Type -> Q Type)
-> [Maybe Name]
-> [FieldStrictness]
-> [DecidedStrictness]
-> [Type]
-> CxtQ
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 -> Name -> Q Type
promotedT 'Just Q Type -> Q Type -> Q Type
`appT` TyLitQ -> Q Type
litT (String -> TyLitQ
strTyLit (Name -> String
nameBase Name
record))
                  Maybe Name
Nothing     -> Name -> Q Type
promotedT 'Nothing
          Name -> Q Type
conT ''S1
            Q Type -> Q Type -> Q Type
`appT` (Name -> Q Type
promotedT 'MetaSel Q Type -> Q Type -> Q Type
`appT`
                    Q Type
mbSelNameT Q Type -> Q Type -> Q Type
`appT`
                    SourceUnpackedness -> Q Type
promoteSourceUnpackedness (Unpackedness -> SourceUnpackedness
generifyUnpackedness Unpackedness
fu) Q Type -> Q Type -> Q Type
`appT`
                    SourceStrictness -> Q Type
promoteSourceStrictness (Strictness -> SourceStrictness
generifyStrictness Strictness
fs) Q Type -> Q Type -> Q Type
`appT`
                    DecidedStrictness -> Q Type
promoteDecidedStrictness (DecidedStrictness -> DecidedStrictness
generifyDecidedStrictness DecidedStrictness
ds))
            Q Type -> Q Type -> Q Type
`appT` (Name -> Q Type
conT ''Field Q Type -> Q Type -> Q Type
`appT` Type -> Q Type
atomize Type
field)

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

        atomize :: Type -> Q Type
        atomize :: Type -> Q Type
atomize = Type -> Q Type
go
          where
            go :: Type -> Q Type
            -- Var case
            go :: Type -> Q Type
go ty :: Type
ty@(VarT Name
n) =
              case Name -> [Name] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Name
n [Name]
allTvbNames of
                Just Int
idx -> Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
enumerateTyVar Int
idx
                Maybe Int
Nothing  -> Type -> Q Type
kon Type
ty

            -- Kon cases
            go ty :: Type
ty@ConT{}           = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@PromotedT{}      = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@TupleT{}         = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
ArrowT           = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
ListT            = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@PromotedTupleT{} = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
PromotedNilT     = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
PromotedConsT    = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
StarT            = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
ConstraintT      = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@LitT{}           = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@Type
WildCardT        = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@UnboxedTupleT{}  = Type -> Q Type
kon Type
ty
            go ty :: Type
ty@UnboxedSumT{}    = Type -> Q Type
kon Type
ty
            go Type
EqualityT           = 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.

            -- Recursive cases
            go (AppT Type
ty1 Type
ty2) = do Type
ty1' <- Type -> Q Type
go Type
ty1
                                   Type
ty2' <- Type -> Q Type
go Type
ty2
                                   case (Type
ty1', Type
ty2') of
                                     (PromotedT Name
kon1 `AppT` Type
tyArg1,
                                      PromotedT Name
kon2 `AppT` Type
tyArg2)
                                            |  Name
kon1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Kon, Name
kon2 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Kon
                                            -> Type -> Q Type
kon (Type -> Type -> Type
AppT Type
tyArg1 Type
tyArg2)
                                     (Type
_, Type
_) -> Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Name -> Type -> Type
InfixT Type
ty1' '(:@:) Type
ty2'
            go (InfixT Type
ty1 Name
n Type
ty2)  = 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
go (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2)
            go (SigT Type
ty Type
_)         = Type -> Q Type
go Type
ty
            go (ParensT Type
ty)        = Type -> Type
ParensT (Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
go Type
ty
#if MIN_VERSION_template_haskell(2,15,0)
            go (AppKindT Type
ty Type
_)       = Type -> Q Type
go Type
ty
            go (ImplicitParamT String
n Type
ty) = 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 case
            go ty :: Type
ty@ForallT{}       = String -> Type -> Q Type
forall a. String -> Type -> Q a
can'tRepresent String
"rank-n type" Type
ty

            kon :: Type -> Q Type
            kon :: Type -> Q Type
kon Type
ty = Name -> Q Type
promotedT 'Kon Q Type -> Q Type -> Q Type
`appT` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty

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

        allTvbNames :: [Name]
        allTvbNames :: [Name]
allTvbNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tvName [TyVarBndr]
exTvbs [Name] -> [Name] -> [Name]
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 =
               Name -> Q Type
promotedT 'InfixI
        Q Type -> Q Type -> Q Type
`appT` Associativity -> Q Type
promoteAssociativity (FixityDirection -> Associativity
fdToAssociativity FixityDirection
fd)
        Q Type -> Q Type -> Q Type
`appT` TyLitQ -> Q Type
litT (Integer -> TyLitQ
numTyLit (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n))
      where
        Fixity Int
n FixityDirection
fd = Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
mbFi
    fixityIPromotedType Maybe Fixity
_ Bool
False = Name -> Q Type
promotedT 'PrefixI

deriveFromK :: [ConstructorInfo] -> Q Dec
deriveFromK :: [ConstructorInfo] -> Q Dec
deriveFromK [ConstructorInfo]
cons = do
  Name
x <- String -> Q Name
newName String
"x"
  Name -> [ClauseQ] -> Q Dec
funD 'fromK
       [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
x]
               (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE 'M1 ExpQ -> ExpQ -> ExpQ
`appE` ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [MatchQ]
cases)
               []]
  where
    cases :: [Q Match]
    cases :: [MatchQ]
cases = (Int -> ConstructorInfo -> MatchQ)
-> [Int] -> [ConstructorInfo] -> [MatchQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> ConstructorInfo -> MatchQ
fromCon ([ConstructorInfo] -> Int
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 -> MatchQ
fromCon Int
n Int
i (ConstructorInfo{ constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                                , constructorVars :: ConstructorInfo -> [TyVarBndr]
constructorVars    = [TyVarBndr]
exTvbs
                                , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
conCtxt
                                , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
fields
                                }) = do
      [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields
      PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
fNames))
            (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Int -> Int -> ExpQ -> ExpQ
lrE Int
i Int
n (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE 'M1 ExpQ -> ExpQ -> ExpQ
`appE`
              do Exp
prod <- (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\ExpQ
x ExpQ
y -> Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
x) (Name -> ExpQ
conE '(:*:)) (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
y))
                           (Name -> ExpQ
conE 'U1)
                           ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
fromField [Name]
fNames)
                 Exp
ctxtProd <- Exp -> ExpQ
context Exp
prod
                 Exp -> ExpQ
existentials Exp
ctxtProd)
            []
      where
        fromField :: Name -> Q Exp
        fromField :: Name -> ExpQ
fromField Name
fName = Name -> ExpQ
conE 'M1 ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
conE 'Field ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
fName)

        context :: Exp -> Q Exp
        context :: Exp -> ExpQ
context Exp
e =
          case [Type]
conCtxt of
            [] -> Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
            [Type]
_  -> Name -> ExpQ
conE 'SuchThat ExpQ -> ExpQ -> ExpQ
`appE` Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e

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

deriveToK :: [ConstructorInfo] -> Q Dec
deriveToK :: [ConstructorInfo] -> Q Dec
deriveToK [ConstructorInfo]
cons = do
  Name
x <- String -> Q Name
newName String
"x"
  Name -> [ClauseQ] -> Q Dec
funD 'toK
       [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP 'M1 [Name -> PatQ
varP Name
x]]
               (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [MatchQ]
cases)
               []]
  where
    cases :: [Q Match]
    cases :: [MatchQ]
cases = (Int -> ConstructorInfo -> MatchQ)
-> [Int] -> [ConstructorInfo] -> [MatchQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> ConstructorInfo -> MatchQ
toCon ([ConstructorInfo] -> Int
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 -> MatchQ
toCon Int
n Int
i (ConstructorInfo{ constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                              , constructorVars :: ConstructorInfo -> [TyVarBndr]
constructorVars    = [TyVarBndr]
exTvbs
                              , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
conCtxt
                              , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
fields
                              }) = do
      [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields
      PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Int -> Int -> PatQ -> PatQ
lrP Int
i Int
n (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> [PatQ] -> PatQ
conP 'M1
              [ do Pat
prod <- (PatQ -> PatQ -> PatQ) -> PatQ -> [PatQ] -> PatQ
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal (\PatQ
x PatQ
y -> PatQ -> Name -> PatQ -> PatQ
infixP PatQ
x '(:*:) PatQ
y)
                                  (Name -> [PatQ] -> PatQ
conP 'U1 [])
                                  ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
toField [Name]
fNames)
                   Pat
ctxtProd <- Pat -> PatQ
context Pat
prod
                   Pat -> PatQ
existentials Pat
ctxtProd
              ] )
            (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
conName) ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
fNames))
            []
        where
          toField :: Name -> Q Pat
          toField :: Name -> PatQ
toField Name
fName = Name -> [PatQ] -> PatQ
conP 'M1 [Name -> [PatQ] -> PatQ
conP 'Field [Name -> PatQ
varP Name
fName]]

          context :: Pat -> Q Pat
          context :: Pat -> PatQ
context Pat
p =
            case [Type]
conCtxt of
              [] -> Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
p
              [Type]
_  -> Name -> [PatQ] -> PatQ
conP 'SuchThat [Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
p]

          existentials :: Pat -> Q Pat
          existentials :: Pat -> PatQ
existentials Pat
p = (PatQ -> TyVarBndr -> PatQ) -> PatQ -> [TyVarBndr] -> PatQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\PatQ
x TyVarBndr
_ -> Name -> [PatQ] -> PatQ
conP 'Exists [PatQ
x]) (Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
p) [TyVarBndr]
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 = Name -> Q Type
promotedT 'Generics.NoSourceUnpackedness
promoteSourceUnpackedness SourceUnpackedness
Generics.SourceNoUnpack       = Name -> Q Type
promotedT 'Generics.SourceNoUnpack
promoteSourceUnpackedness SourceUnpackedness
Generics.SourceUnpack         = Name -> Q Type
promotedT 'Generics.SourceUnpack

promoteSourceStrictness :: Generics.SourceStrictness -> Q Type
promoteSourceStrictness :: SourceStrictness -> Q Type
promoteSourceStrictness SourceStrictness
Generics.NoSourceStrictness = Name -> Q Type
promotedT 'Generics.NoSourceStrictness
promoteSourceStrictness SourceStrictness
Generics.SourceLazy         = Name -> Q Type
promotedT 'Generics.SourceLazy
promoteSourceStrictness SourceStrictness
Generics.SourceStrict       = Name -> Q Type
promotedT 'Generics.SourceStrict

promoteDecidedStrictness :: Generics.DecidedStrictness -> Q Type
promoteDecidedStrictness :: DecidedStrictness -> Q Type
promoteDecidedStrictness DecidedStrictness
Generics.DecidedLazy   = Name -> Q Type
promotedT 'Generics.DecidedLazy
promoteDecidedStrictness DecidedStrictness
Generics.DecidedStrict = Name -> Q Type
promotedT 'Generics.DecidedStrict
promoteDecidedStrictness DecidedStrictness
Generics.DecidedUnpack = Name -> Q Type
promotedT 'Generics.DecidedUnpack

promoteAssociativity :: Associativity -> Q Type
promoteAssociativity :: Associativity -> Q Type
promoteAssociativity Associativity
LeftAssociative  = Name -> Q Type
promotedT 'LeftAssociative
promoteAssociativity Associativity
RightAssociative = Name -> Q Type
promotedT 'RightAssociative
promoteAssociativity Associativity
NotAssociative   = Name -> Q Type
promotedT 'NotAssociative

promoteBool :: Bool -> Q Type
promoteBool :: Bool -> Q Type
promoteBool Bool
True  = Name -> Q Type
promotedT 'True
promoteBool Bool
False = Name -> Q 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` Int -> (Type -> Type) -> Type -> Type
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 :: (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) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [a]
l
                   in (a -> a -> a) -> a -> [a] -> a
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op a
x [a]
a a -> a -> a
`op` (a -> a -> a) -> a -> [a] -> a
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 -> PatQ -> PatQ
lrP Int
i Int
n PatQ
p
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0       = String -> PatQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrP: impossible"
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1       = PatQ
p
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> [PatQ] -> PatQ
conP 'L1 [Int -> Int -> PatQ -> PatQ
lrP Int
i     (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) PatQ
p]
  | Bool
otherwise    = Name -> [PatQ] -> PatQ
conP 'R1 [Int -> Int -> PatQ -> PatQ
lrP (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m)     PatQ
p]
                     where m :: Int
m = Int -> Int -> Int
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 -> ExpQ -> ExpQ
lrE Int
i Int
n ExpQ
e
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0       = String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrE: impossible"
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1       = ExpQ
e
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> ExpQ
conE 'L1 ExpQ -> ExpQ -> ExpQ
`appE` Int -> Int -> ExpQ -> ExpQ
lrE Int
i     (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) ExpQ
e
  | Bool
otherwise    = Name -> ExpQ
conE 'R1 ExpQ -> ExpQ -> ExpQ
`appE` Int -> Int -> ExpQ -> ExpQ
lrE (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m)     ExpQ
e
                     where m :: Int
m = Int -> Int -> Int
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

-- | 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)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT Type
t Type
_) = Type -> Maybe Name
varTToName_maybe Type
t
varTToName_maybe Type
_          = Maybe Name
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 = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (String -> Name
forall a. HasCallStack => String -> a
error String
"Not a type variable!") (Maybe Name -> Name) -> (Type -> Maybe Name) -> Type -> Name
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 :: (a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M a -> b -> c -> d -> m e
_ []     [b]
_      [c]
_      [d]
_      = [e] -> m [e]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
_ [a]
_      []     [c]
_      [d]
_      = [e] -> m [e]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
_ [a]
_      [b]
_      []     [d]
_      = [e] -> m [e]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
zipWith4M a -> b -> c -> d -> m e
_ [a]
_      [b]
_      [c]
_      []     = [e] -> m [e]
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 <- (a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e]
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
       [e] -> m [e]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([e] -> m [e]) -> [e] -> m [e]
forall a b. (a -> b) -> a -> b
$ e
re -> [e] -> [e]
forall a. a -> [a] -> [a]
:[e]
rs

-- | Compose a function with itself n times.  (nth rather than twice)
nTimes :: Int -> (a -> a) -> (a -> a)
nTimes :: Int -> (a -> a) -> a -> a
nTimes Int
0 a -> a
_ = 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 (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (a -> a) -> a -> a
forall a. Int -> (a -> a) -> a -> a
nTimes (Int
nInt -> Int -> Int
forall 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 = (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
n]

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

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

gatherFields :: [ConstructorInfo] -> [Type]
gatherFields :: [ConstructorInfo] -> [Type]
gatherFields = (ConstructorInfo -> [Type]) -> [ConstructorInfo] -> [Type]
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
                                -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Bool) -> [Type] -> Q [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Bool
go (Type
tyFunType -> [Type] -> [Type]
forall 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)       = (Bool -> Bool -> Bool) -> Q Bool -> Q Bool -> Q Bool
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
_                  = Bool -> Q Bool
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
_ [TyVarBndr]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
          -> [TyVarBndr] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr]
bndrs
        FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
          -> [TyVarBndr] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr]
bndrs
        Info
_ -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      where
        withinFirstArgs :: [a] -> Q Bool
        withinFirstArgs :: [a] -> Q Bool
withinFirstArgs [a]
bndrs =
          let firstArgs :: [Type]
firstArgs = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) [Type]
tcArgs
          in Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Type] -> [Name]
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
ty2Type -> [Type] -> [Type]
forall 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 -> [TyVarBndr]
constructorVars    = [TyVarBndr]
vars
                                       , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
context
                                       , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
fields
                                       }) = do
  [TyVarBndr]
vars'    <- (TyVarBndr -> Q TyVarBndr) -> [TyVarBndr] -> Q [TyVarBndr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\TyVarBndr
tvb ->
                         case TyVarBndr
tvb of
                           PlainTV{} -> TyVarBndr -> Q TyVarBndr
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyVarBndr
tvb
                           KindedTV Name
n Type
k -> Name -> Type -> TyVarBndr
KindedTV Name
n (Type -> TyVarBndr) -> Q Type -> Q TyVarBndr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveTypeSynonyms Type
k) [TyVarBndr]
vars
  [Type]
context' <- (Type -> Q Type) -> [Type] -> CxtQ
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'  <- (Type -> Q Type) -> [Type] -> CxtQ
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Type
resolveTypeSynonyms [Type]
fields
  ConstructorInfo -> Q ConstructorInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorInfo -> Q ConstructorInfo)
-> ConstructorInfo -> Q ConstructorInfo
forall a b. (a -> b) -> a -> b
$ ConstructorInfo
con{ constructorVars :: [TyVarBndr]
constructorVars = [TyVarBndr]
vars'
            , constructorContext :: [Type]
constructorContext = [Type]
context'
            , constructorFields :: [Type]
constructorFields  = [Type]
fields'
            }