{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}

{- |
Module      :  Generics.Linear.TH.Internal
Copyright   :  (c) 2008--2009 Universiteit Utrecht
License     :  BSD3

Maintainer  :  generics@haskell.org
Stability   :  experimental
Portability :  non-portable

Template Haskell-related utilities.
-}

module Generics.Linear.TH.Internal where

import           Control.Monad (unless)

import           Data.Foldable (foldr')
import qualified Data.List as List
import qualified Data.Set as Set
import           Data.Set (Set)

import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.Datatype.TyVarBndr
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Ppr (pprint)
import           Language.Haskell.TH.Syntax hiding (Extension (..))

-------------------------------------------------------------------------------
-- Assorted utilities
-------------------------------------------------------------------------------

-- Note: There are quite a few other utilities in
--
-- generic-deriving: Generics.Deriving.TH.Internal
--
-- Most of the ones that aren't used here have been stripped out.

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

-- | Turns
--
-- @
-- [a, b] c
-- @
--
-- into
--
-- @
-- a -> b -> c
-- @
makeFunType :: [Type] -> Type -> Type
makeFunType :: [Type] -> Type -> Type
makeFunType [Type]
argTys Type
resTy = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT) Type
resTy [Type]
argTys

-- | Turns
--
-- @
-- [k1, k2] k3
-- @
--
-- into
--
-- @
-- k1 -> k2 -> k3
-- @
makeFunKind :: [Kind] -> Kind -> Kind
makeFunKind :: [Type] -> Type -> Type
makeFunKind = [Type] -> Type -> Type
makeFunType

-- | Remove any outer `SigT` and `ParensT` constructors, and turn
-- an outermost `InfixT` constructor into plain applications.
dustOff :: Type -> Type
dustOff :: Type -> Type
dustOff (SigT Type
ty Type
_) = Type -> Type
dustOff Type
ty
dustOff (ParensT Type
ty) = Type -> Type
dustOff Type
ty
dustOff (InfixT Type
ty1 Name
n Type
ty2) = Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2
dustOff Type
ty = Type
ty

-- | Checks whether a type is an unsaturated type family
-- application.
isUnsaturatedType :: Type -> Q Bool
isUnsaturatedType :: Type -> Q Bool
isUnsaturatedType = Int -> Type -> Q Bool
go Int
0 (Type -> Q Bool) -> (Type -> Type) -> Type -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
dustOff
  where
    -- Expects its argument to be dusted
    go :: Int -> Type -> Q Bool
    go :: Int -> Type -> Q Bool
go Int
d Type
t = case Type
t of
      ConT Name
tcName -> Int -> Name -> Q Bool
check Int
d Name
tcName
      AppT Type
f Type
_ -> Int -> Type -> Q Bool
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Type -> Type
dustOff Type
f)
      Type
_ -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    check :: Int -> Name -> Q Bool
    check :: Int -> Name -> Q Bool
check Int
d Name
tcName = do
      Maybe [TyVarBndrVis]
mbinders <- Name -> Q (Maybe [TyVarBndrVis])
getTypeFamilyBinders Name
tcName
      Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ case Maybe [TyVarBndrVis]
mbinders of
        Just [TyVarBndrVis]
bndrs -> [TyVarBndrVis] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndrVis]
bndrs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
d
        Maybe [TyVarBndrVis]
Nothing -> Bool
False

-- | Given a name, check if that name is a type family. If
-- so, return a list of its binders.
getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndrVis])
getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndrVis])
getTypeFamilyBinders Name
tcName = do
      Info
info <- Name -> Q Info
reify Name
tcName
      Maybe [TyVarBndrVis] -> Q (Maybe [TyVarBndrVis])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [TyVarBndrVis] -> Q (Maybe [TyVarBndrVis]))
-> Maybe [TyVarBndrVis] -> Q (Maybe [TyVarBndrVis])
forall a b. (a -> b) -> a -> b
$ case Info
info of
        FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndrVis]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
          -> [TyVarBndrVis] -> Maybe [TyVarBndrVis]
forall a. a -> Maybe a
Just [TyVarBndrVis]
bndrs

        FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndrVis]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
          -> [TyVarBndrVis] -> Maybe [TyVarBndrVis]
forall a. a -> Maybe a
Just [TyVarBndrVis]
bndrs
        Info
_ -> Maybe [TyVarBndrVis]
forall a. Maybe a
Nothing

-- | True if the type does not mention the Name
ground :: Type -> Name -> Bool
ground :: Type -> Name -> Bool
ground Type
ty Name
name = Name
name 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
ty

-- | Construct a type via curried application.
applyTyToTys :: Type -> [Type] -> Type
applyTyToTys :: Type -> [Type] -> Type
applyTyToTys = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Type -> Type -> Type
AppT

-- | 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Q Name
forall (m :: * -> *). Quote m => String -> m 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]

-- | Checks to see if the last types in a data family instance can be safely eta-
-- reduced (i.e., dropped), given the other types. This checks for three conditions:
--
-- (1) All of the dropped types are type variables
-- (2) All of the dropped types are distinct
-- (3) None of the remaining types mention any of the dropped types
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce [Type]
remaining [Type]
dropped =
       (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVar [Type]
dropped
       -- Make sure not to pass something of type [Type], since Type
       -- didn't have an Ord instance until template-haskell-2.10.0.0
    Bool -> Bool -> Bool
&& [Name] -> Bool
forall a. Ord a => [a] -> Bool
allDistinct [Name]
droppedNames
    Bool -> Bool -> Bool
&& Bool -> Bool
not ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
droppedNames) [Type]
remaining)
  where
    droppedNames :: [Name]
    droppedNames :: [Name]
droppedNames = (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName [Type]
dropped

-- | 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 (VarT Name
n)   = Name
n
varTToName (SigT Type
t Type
_) = Type -> Name
varTToName Type
t
varTToName Type
_          = String -> Name
forall a. HasCallStack => String -> a
error String
"Not a type variable!"

-- | Is the given type a variable?
isTyVar :: Type -> Bool
isTyVar :: Type -> Bool
isTyVar VarT{}     = Bool
True
isTyVar (SigT Type
t Type
_) = Type -> Bool
isTyVar Type
t
isTyVar Type
_          = Bool
False

-- | Is the given kind a variable?
isKindVar :: Kind -> Bool
isKindVar :: Type -> Bool
isKindVar = Type -> Bool
isTyVar

-- | Does the given type mention any of the Names in the list?
mentionsName :: Type -> [Name] -> Bool
mentionsName :: Type -> [Name] -> Bool
mentionsName = Type -> [Name] -> Bool
go
  where
    go :: Type -> [Name] -> Bool
    go :: Type -> [Name] -> Bool
go (AppT Type
t1 Type
t2) [Name]
names = Type -> [Name] -> Bool
go Type
t1 [Name]
names Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
t2 [Name]
names
    go (SigT Type
t Type
k)  [Name]
names = Type -> [Name] -> Bool
go Type
t [Name]
names Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
k [Name]
names
    go (VarT Name
n)     [Name]
names = Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
    go Type
_            [Name]
_     = Bool
False

-- | Are all of the items in a list (which have an ordering) distinct?
--
-- This uses Set (as opposed to nub) for better asymptotic time complexity.
allDistinct :: Ord a => [a] -> Bool
allDistinct :: forall a. Ord a => [a] -> Bool
allDistinct = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' Set a
forall a. Set a
Set.empty
  where
    allDistinct' :: Ord a => Set a -> [a] -> Bool
    allDistinct' :: forall a. Ord a => Set a -> [a] -> Bool
allDistinct' Set a
uniqs (a
x:[a]
xs)
        | a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
uniqs = Bool
False
        | Bool
otherwise            = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
uniqs) [a]
xs
    allDistinct' Set a
_ [a]
_           = Bool
True

fst3 :: (a, b, c) -> a
fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a

snd3 :: (a, b, c) -> b
snd3 :: forall a b c. (a, b, c) -> b
snd3 (a
_, b
b, c
_) = b
b

trd3 :: (a, b, c) -> c
trd3 :: forall a b c. (a, b, c) -> c
trd3 (a
_, b
_, c
c) = c
c

foldBal :: (a -> a -> a) -> a -> [a] -> a
{-# INLINE foldBal #-} -- inlined to produce specialised code for each op
foldBal :: forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op0 a
x0 [a]
xs0 = (a -> a -> a) -> a -> Int -> [a] -> a
forall {t}. (t -> t -> t) -> t -> Int -> [t] -> t
fold_bal a -> a -> a
op0 a
x0 ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs0) [a]
xs0
  where
    fold_bal :: (t -> t -> t) -> t -> Int -> [t] -> t
fold_bal t -> t -> t
op t
x !Int
n [t]
xs = case [t]
xs of
      []  -> t
x
      [t
a] -> t
a
      [t]
_   -> let !nl :: Int
nl = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                 !nr :: Int
nr = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nl
                 ([t]
l,[t]
r) = Int -> [t] -> ([t], [t])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
nl [t]
xs
             in (t -> t -> t) -> t -> Int -> [t] -> t
fold_bal t -> t -> t
op t
x Int
nl [t]
l
                t -> t -> t
`op` (t -> t -> t) -> t -> Int -> [t] -> t
fold_bal t -> t -> t
op t
x Int
nr [t]
r

isNewtypeVariant :: DatatypeVariant_ -> Bool
isNewtypeVariant :: DatatypeVariant_ -> Bool
isNewtypeVariant DatatypeVariant_
Datatype_             = Bool
False
isNewtypeVariant DatatypeVariant_
Newtype_              = Bool
True
isNewtypeVariant (DataInstance_ {})    = Bool
False
isNewtypeVariant (NewtypeInstance_ {}) = Bool
True

-- | Indicates whether Generic or Generic1 is being derived.
data GenericClass = Generic | Generic1 deriving Int -> GenericClass
GenericClass -> Int
GenericClass -> [GenericClass]
GenericClass -> GenericClass
GenericClass -> GenericClass -> [GenericClass]
GenericClass -> GenericClass -> GenericClass -> [GenericClass]
(GenericClass -> GenericClass)
-> (GenericClass -> GenericClass)
-> (Int -> GenericClass)
-> (GenericClass -> Int)
-> (GenericClass -> [GenericClass])
-> (GenericClass -> GenericClass -> [GenericClass])
-> (GenericClass -> GenericClass -> [GenericClass])
-> (GenericClass -> GenericClass -> GenericClass -> [GenericClass])
-> Enum GenericClass
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: GenericClass -> GenericClass
succ :: GenericClass -> GenericClass
$cpred :: GenericClass -> GenericClass
pred :: GenericClass -> GenericClass
$ctoEnum :: Int -> GenericClass
toEnum :: Int -> GenericClass
$cfromEnum :: GenericClass -> Int
fromEnum :: GenericClass -> Int
$cenumFrom :: GenericClass -> [GenericClass]
enumFrom :: GenericClass -> [GenericClass]
$cenumFromThen :: GenericClass -> GenericClass -> [GenericClass]
enumFromThen :: GenericClass -> GenericClass -> [GenericClass]
$cenumFromTo :: GenericClass -> GenericClass -> [GenericClass]
enumFromTo :: GenericClass -> GenericClass -> [GenericClass]
$cenumFromThenTo :: GenericClass -> GenericClass -> GenericClass -> [GenericClass]
enumFromThenTo :: GenericClass -> GenericClass -> GenericClass -> [GenericClass]
Enum

-- | Records information about the type variables of a data type with a
-- 'Generic' or 'Generic1' instance.
data GenericTvbs
    -- | Information about a data type with a 'Generic' instance.
  = Gen0
      { GenericTvbs -> [TyVarBndrVis]
gen0Tvbs :: [TyVarBndrUnit]
        -- ^ All of the type variable arguments to the data type.
      }
    -- | Information about a data type with a 'Generic1' instance.
  | Gen1
      { GenericTvbs -> [TyVarBndrVis]
gen1InitTvbs :: [TyVarBndrUnit]
        -- ^ All of the type variable arguments to the data type except the
        --   last one. In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the
        --   'gen1InitTvbs' would be @[a_1, ..., a_(n-1)]@.
      , GenericTvbs -> Name
gen1LastTvbName :: Name
        -- ^ The name of the last type variable argument to the data type.
        --   In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the
        --   'gen1LastTvbName' name would be @a_n@.
      }

-- | Compute 'GenericTvbs' from a 'GenericClass' and the type variable
-- arguments to a data type.
mkGenericTvbs :: GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs :: GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
tySynVars =
  case GenericClass
gClass of
    GenericClass
Generic  -> Gen0{gen0Tvbs :: [TyVarBndrVis]
gen0Tvbs = [Type] -> [TyVarBndrVis]
freeVariablesWellScoped [Type]
tySynVars}
    GenericClass
Generic1 -> Gen1{ gen1InitTvbs :: [TyVarBndrVis]
gen1InitTvbs    = [Type] -> [TyVarBndrVis]
freeVariablesWellScoped [Type]
initArgs
                    , gen1LastTvbName :: Name
gen1LastTvbName = Type -> Name
varTToName Type
lastArg
                    }
  where
    -- Everything below is only used for Generic1.
    initArgs :: [Type]
    initArgs :: [Type]
initArgs = [Type] -> [Type]
forall a. HasCallStack => [a] -> [a]
init [Type]
tySynVars

    lastArg :: Type
    lastArg :: Type
lastArg = [Type] -> Type
forall a. HasCallStack => [a] -> a
last [Type]
tySynVars

-- | Return the type variable arguments to a data type that appear in a
-- 'Generic' or 'Generic1' instance. For a 'Generic' instance, this consists of
-- all the type variable arguments. For a 'Generic1' instance, this consists of
-- all the type variable arguments except for the last one.
genericInitTvbs :: GenericTvbs -> [TyVarBndrUnit]
genericInitTvbs :: GenericTvbs -> [TyVarBndrVis]
genericInitTvbs (Gen0{gen0Tvbs :: GenericTvbs -> [TyVarBndrVis]
gen0Tvbs = [TyVarBndrVis]
tvbs})     = [TyVarBndrVis]
tvbs
genericInitTvbs (Gen1{gen1InitTvbs :: GenericTvbs -> [TyVarBndrVis]
gen1InitTvbs = [TyVarBndrVis]
tvbs}) = [TyVarBndrVis]
tvbs

-- | A version of 'DatatypeVariant' in which the data family instance
-- constructors come equipped with the 'ConstructorInfo' of the first
-- constructor in the family instance (for 'Name' generation purposes).
data DatatypeVariant_
  = Datatype_
  | Newtype_
  | DataInstance_    ConstructorInfo
  | NewtypeInstance_ ConstructorInfo

-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
-- function for the criteria it would have to meet).
etaReductionError :: Type -> Q a
etaReductionError :: forall a. Type -> Q a
etaReductionError Type
instanceType = String -> Q a
forall a. 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
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceType

-- | Either the given data type doesn't have enough type variables, or one of
-- the type variables to be eta-reduced cannot realize kind *.
derivingKindError :: Name -> Q a
derivingKindError :: forall a. Name -> Q a
derivingKindError Name
tyConName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> (String -> String) -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Cannot derive well-kinded instance of form ‘Generic1 "
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> (String -> String) -> String -> String
showParen Bool
True
    ( String -> String -> String
showString (Name -> String
nameBase Name
tyConName)
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" ..."
    )
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘\n\tClass Generic1 expects an argument of kind k -> Type"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type mentions the last type variable in a place other
-- than the last position of a data type in a constructor's field.
outOfPlaceTyVarError :: Q a
outOfPlaceTyVarError :: forall a. Q a
outOfPlaceTyVarError = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> (String -> String) -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Constructor must only use its last type variable as"
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" the last argument of a data type"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type mentions the last type variable in a type family
-- application.
typeFamilyApplicationError :: Q a
typeFamilyApplicationError :: forall a. Q a
typeFamilyApplicationError = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  (String -> Q a) -> (String -> String) -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Constructor must not apply its last type variable"
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" to an unsaturated type family"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | Cannot have a constructor argument of form (forall a1 ... an. <type>)
-- when deriving Generic(1)
rankNError :: Q a
rankNError :: forall a. Q a
rankNError = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot have polymorphic arguments"

-- | Boilerplate for top level splices.
--
-- The given Name must meet one of two criteria:
--
-- 1. It must be the name of a type constructor of a plain data type or newtype.
-- 2. It must be the name of a data family instance or newtype instance constructor.
--
-- Any other value will result in an exception.
reifyDataInfo :: Name
              -> Q (Name, [Type], [ConstructorInfo], DatatypeVariant_)
reifyDataInfo :: Name -> Q (Name, [Type], [ConstructorInfo], DatatypeVariant_)
reifyDataInfo Name
name = do
  do
    DatatypeInfo { datatypeContext :: DatatypeInfo -> [Type]
datatypeContext   = [Type]
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
                 , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
tys
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } <-
                     String -> Q DatatypeInfo
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Could not reify " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name)
                     Q DatatypeInfo -> Q DatatypeInfo -> Q DatatypeInfo
forall a. Q a -> Q a -> Q a
`recover`
                     Name -> Q DatatypeInfo
reifyDatatype Name
name
    DatatypeVariant_
variant_ <-
      case DatatypeVariant
variant of
        DatatypeVariant
Datatype          -> DatatypeVariant_ -> Q DatatypeVariant_
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DatatypeVariant_
Datatype_
        DatatypeVariant
Newtype           -> DatatypeVariant_ -> Q DatatypeVariant_
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DatatypeVariant_
Newtype_
        DatatypeVariant
DataInstance      -> DatatypeVariant_ -> Q DatatypeVariant_
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DatatypeVariant_ -> Q DatatypeVariant_)
-> DatatypeVariant_ -> Q DatatypeVariant_
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> DatatypeVariant_
DataInstance_    (ConstructorInfo -> DatatypeVariant_)
-> ConstructorInfo -> DatatypeVariant_
forall a b. (a -> b) -> a -> b
$ Name -> [ConstructorInfo] -> ConstructorInfo
headDataFamInstCon Name
parentName [ConstructorInfo]
cons
        DatatypeVariant
NewtypeInstance   -> DatatypeVariant_ -> Q DatatypeVariant_
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DatatypeVariant_ -> Q DatatypeVariant_)
-> DatatypeVariant_ -> Q DatatypeVariant_
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> DatatypeVariant_
NewtypeInstance_ (ConstructorInfo -> DatatypeVariant_)
-> ConstructorInfo -> DatatypeVariant_
forall a b. (a -> b) -> a -> b
$ Name -> [ConstructorInfo] -> ConstructorInfo
headDataFamInstCon Name
parentName [ConstructorInfo]
cons
        DatatypeVariant
TypeData -> String -> Q DatatypeVariant_
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q DatatypeVariant_) -> String -> Q DatatypeVariant_
forall a b. (a -> b) -> a -> b
$ String
"Cannot derive Generic instances for TypeData " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
    Name -> [Type] -> Q ()
checkDataContext Name
parentName [Type]
ctxt
    (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> Q (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
parentName, [Type]
tys, [ConstructorInfo]
cons, DatatypeVariant_
variant_)
  where
    ns :: String
    ns :: String
ns = String
"Generics.Linear.TH.reifyDataInfo: "

    -- This isn't total, but the API requires that the data family instance have
    -- at least one constructor anyways, so this will always succeed.
    headDataFamInstCon :: Name -> [ConstructorInfo] -> ConstructorInfo
    headDataFamInstCon :: Name -> [ConstructorInfo] -> ConstructorInfo
headDataFamInstCon Name
dataFamName [ConstructorInfo]
cons =
      case [ConstructorInfo]
cons of
        ConstructorInfo
con:[ConstructorInfo]
_ -> ConstructorInfo
con
        [] -> String -> ConstructorInfo
forall a. HasCallStack => String -> a
error (String -> ConstructorInfo) -> String -> ConstructorInfo
forall a b. (a -> b) -> a -> b
$ String
"reified data family instance without a data constructor: "
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
dataFamName

-- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts,
-- so check to make sure the Cxt field of a datatype is null.
checkDataContext :: Name -> Cxt -> Q ()
checkDataContext :: Name -> [Type] -> Q ()
checkDataContext Name
_        [] = () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkDataContext Name
dataName [Type]
_ = String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
  Name -> String
nameBase Name
dataName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must not have a datatype context"

-- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs.
checkExistentialContext :: Name -> [TyVarBndrUnit] -> Cxt -> Q ()
checkExistentialContext :: Name -> [TyVarBndrVis] -> [Type] -> Q ()
checkExistentialContext Name
conName [TyVarBndrVis]
vars [Type]
ctxt =
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TyVarBndrVis] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrVis]
vars Bool -> Bool -> Bool
&& [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
    Name -> String
nameBase Name
conName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be a vanilla data constructor"

#if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0))
type TyVarBndrVis = TyVarBndrUnit

bndrReq :: ()
bndrReq = ()
#endif