{-# Language CPP, DeriveDataTypeable, ScopedTypeVariables, TupleSections #-}

#if MIN_VERSION_base(4,4,0)
#define HAS_GENERICS
{-# Language DeriveGeneric #-}
#endif

#if MIN_VERSION_template_haskell(2,12,0)
{-# Language Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# Language Trustworthy #-}
#endif

{-|
Module      : Language.Haskell.TH.Datatype
Description : Backwards-compatible interface to reified information about datatypes.
Copyright   : Eric Mertens 2017-2020
License     : ISC
Maintainer  : emertens@gmail.com

This module provides a flattened view of information about data types
and newtypes that can be supported uniformly across multiple versions
of the @template-haskell@ package.

Sample output for @'reifyDatatype' ''Maybe@

@
'DatatypeInfo'
 { 'datatypeContext'   = []
 , 'datatypeName'      = GHC.Base.Maybe
 , 'datatypeVars'      = [ 'KindedTV' a_3530822107858468866 () 'StarT' ]
 , 'datatypeInstTypes' = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ]
 , 'datatypeVariant'   = 'Datatype'
 , 'datatypeReturnKind' = 'StarT'
 , 'datatypeCons'      =
     [ 'ConstructorInfo'
         { 'constructorName'       = GHC.Base.Nothing
         , 'constructorVars'       = []
         , 'constructorContext'    = []
         , 'constructorFields'     = []
         , 'constructorStrictness' = []
         , 'constructorVariant'    = 'NormalConstructor'
         }
     , 'ConstructorInfo'
         { 'constructorName'       = GHC.Base.Just
         , 'constructorVars'       = []
         , 'constructorContext'    = []
         , 'constructorFields'     = [ 'VarT' a_3530822107858468866 ]
         , 'constructorStrictness' = [ 'FieldStrictness'
                                         'UnspecifiedUnpackedness'
                                         'Lazy'
                                     ]
         , 'constructorVariant'    = 'NormalConstructor'
         }
     ]
 }
@

Datatypes declared with GADT syntax are normalized to constructors with existentially
quantified type variables and equality constraints.

-}
module Language.Haskell.TH.Datatype
  (
  -- * Types
    DatatypeInfo(..)
  , ConstructorInfo(..)
  , DatatypeVariant(..)
  , ConstructorVariant(..)
  , FieldStrictness(..)
  , Unpackedness(..)
  , Strictness(..)

  -- * Normalization functions
  , reifyDatatype
  , reifyConstructor
  , reifyRecord
  , normalizeInfo
  , normalizeDec
  , normalizeCon

  -- * 'DatatypeInfo' lookup functions
  , lookupByConstructorName
  , lookupByRecordName

  -- * Type variable manipulation
  , TypeSubstitution(..)
  , quantifyType
  , freeVariablesWellScoped
  , freshenFreeVariables

  -- * 'Pred' functions
  , equalPred
  , classPred
  , asEqualPred
  , asClassPred

  -- * Backward compatible data definitions
  , dataDCompat
  , newtypeDCompat
  , tySynInstDCompat
  , pragLineDCompat
  , arrowKCompat

  -- * Strictness annotations
  , isStrictAnnot
  , notStrictAnnot
  , unpackedAnnot

  -- * Type simplification
  , resolveTypeSynonyms
  , resolveKindSynonyms
  , resolvePredSynonyms
  , resolveInfixT

  -- * Fixities
  , reifyFixityCompat
  , showFixity
  , showFixityDirection

  -- * Convenience functions
  , unifyTypes
  , tvName
  , tvKind
  , datatypeType
  ) where

import           Data.Data (Typeable, Data)
import           Data.Foldable (foldMap, foldl')
import           Data.List (mapAccumL, nub, find, union, (\\))
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe
import qualified Data.Set as Set
import           Data.Set (Set)
import qualified Data.Traversable as T
import           Control.Monad
import           Language.Haskell.TH
#if MIN_VERSION_template_haskell(2,11,0)
                                     hiding (Extension(..))
#endif
import           Language.Haskell.TH.Datatype.Internal
import           Language.Haskell.TH.Datatype.TyVarBndr
import           Language.Haskell.TH.Lib (arrowK, starK) -- needed for th-2.4

#ifdef HAS_GENERICS
import           GHC.Generics (Generic)
#endif

#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative (Applicative(..), (<$>))
import           Data.Monoid (Monoid(..))
#endif

-- | Normalized information about newtypes and data types.
--
-- 'DatatypeInfo' contains two fields, 'datatypeVars' and 'datatypeInstTypes',
-- which encode information about the argument types. The simplest explanation
-- is that 'datatypeVars' contains all the type /variables/ bound by the data
-- type constructor, while 'datatypeInstTypes' contains the type /arguments/
-- to the data type constructor. To be more precise:
--
-- * For ADTs declared with @data@ and @newtype@, it will likely be the case
--   that 'datatypeVars' and 'datatypeInstTypes' coincide. For instance, given
--   @newtype Id a = MkId a@, in the 'DatatypeInfo' for @Id@ we would
--   have @'datatypeVars' = ['KindedTV' a () 'StarT']@ and
--   @'datatypeInstVars' = ['SigT' ('VarT' a) 'StarT']@.
--
--   ADTs that leverage @PolyKinds@ may have more 'datatypeVars' than
--   'datatypeInstTypes'. For instance, given @data Proxy (a :: k) = MkProxy@,
--   in the 'DatatypeInfo' for @Proxy@ we would have
--   @'datatypeVars' = ['KindedTV' k () 'StarT', 'KindedTV' a () ('VarT' k)]@
--   (since there are two variables, @k@ and @a@), whereas
--   @'datatypeInstTypes' = ['SigT' ('VarT' a) ('VarT' k)]@, since there is
--   only one explicit type argument to @Proxy@.
--
--   The same outcome would occur if @Proxy@ were declared using
--   @TypeAbstractions@, i.e., if it were declared as
--   @data Proxy \@k (a :: k) = MkProxy@. The 'datatypeInstTypes' would /not/
--   include a separate type for @\@k@.
--
-- * For @data instance@s and @newtype instance@s of data families,
--   'datatypeVars' and 'datatypeInstTypes' can be quite different. Here is
--   an example to illustrate the difference:
--
--   @
--   data family F a b
--   data instance F (Maybe c) (f x) = MkF c (f x)
--   @
--
--   Then in the 'DatatypeInfo' for @F@'s data instance, we would have:
--
--   @
--   'datatypeVars'      = [ 'KindedTV' c () 'StarT'
--                         , 'KindedTV' f () 'StarT'
--                         , 'KindedTV' x () 'StarT' ]
--   'datatypeInstTypes' = [ 'AppT' ('ConT' ''Maybe) ('VarT' c)
--                         , 'AppT' ('VarT' f) ('VarT' x) ]
--   @
data DatatypeInfo = DatatypeInfo
  { DatatypeInfo -> [Type]
datatypeContext   :: Cxt               -- ^ Data type context (deprecated)
  , DatatypeInfo -> Name
datatypeName      :: Name              -- ^ Type constructor
  , DatatypeInfo -> [TyVarBndrUnit]
datatypeVars      :: [TyVarBndrUnit]   -- ^ Type parameters
  , DatatypeInfo -> [Type]
datatypeInstTypes :: [Type]            -- ^ Argument types
  , DatatypeInfo -> DatatypeVariant
datatypeVariant   :: DatatypeVariant   -- ^ Extra information
  , DatatypeInfo -> Type
datatypeReturnKind:: Kind              -- ^ Return 'Kind' of the type.
                                           --
                                           -- If normalization is unable to determine the return kind,
                                           -- then this is conservatively set to @StarT@.
  , DatatypeInfo -> [ConstructorInfo]
datatypeCons      :: [ConstructorInfo] -- ^ Normalize constructor information
  }
  deriving (Int -> DatatypeInfo -> ShowS
[DatatypeInfo] -> ShowS
DatatypeInfo -> String
(Int -> DatatypeInfo -> ShowS)
-> (DatatypeInfo -> String)
-> ([DatatypeInfo] -> ShowS)
-> Show DatatypeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DatatypeInfo -> ShowS
showsPrec :: Int -> DatatypeInfo -> ShowS
$cshow :: DatatypeInfo -> String
show :: DatatypeInfo -> String
$cshowList :: [DatatypeInfo] -> ShowS
showList :: [DatatypeInfo] -> ShowS
Show, DatatypeInfo -> DatatypeInfo -> Bool
(DatatypeInfo -> DatatypeInfo -> Bool)
-> (DatatypeInfo -> DatatypeInfo -> Bool) -> Eq DatatypeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DatatypeInfo -> DatatypeInfo -> Bool
== :: DatatypeInfo -> DatatypeInfo -> Bool
$c/= :: DatatypeInfo -> DatatypeInfo -> Bool
/= :: DatatypeInfo -> DatatypeInfo -> Bool
Eq, Typeable, Typeable DatatypeInfo
Typeable DatatypeInfo =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DatatypeInfo -> c DatatypeInfo)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DatatypeInfo)
-> (DatatypeInfo -> Constr)
-> (DatatypeInfo -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DatatypeInfo))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DatatypeInfo))
-> ((forall b. Data b => b -> b) -> DatatypeInfo -> DatatypeInfo)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r)
-> (forall u. (forall d. Data d => d -> u) -> DatatypeInfo -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DatatypeInfo -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo)
-> Data DatatypeInfo
DatatypeInfo -> Constr
DatatypeInfo -> DataType
(forall b. Data b => b -> b) -> DatatypeInfo -> DatatypeInfo
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DatatypeInfo -> u
forall u. (forall d. Data d => d -> u) -> DatatypeInfo -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeInfo
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeInfo -> c DatatypeInfo
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeInfo)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeInfo)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeInfo -> c DatatypeInfo
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeInfo -> c DatatypeInfo
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeInfo
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeInfo
$ctoConstr :: DatatypeInfo -> Constr
toConstr :: DatatypeInfo -> Constr
$cdataTypeOf :: DatatypeInfo -> DataType
dataTypeOf :: DatatypeInfo -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeInfo)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeInfo)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeInfo)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeInfo)
$cgmapT :: (forall b. Data b => b -> b) -> DatatypeInfo -> DatatypeInfo
gmapT :: (forall b. Data b => b -> b) -> DatatypeInfo -> DatatypeInfo
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeInfo -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeInfo -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DatatypeInfo -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DatatypeInfo -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
Data
#ifdef HAS_GENERICS
           ,(forall x. DatatypeInfo -> Rep DatatypeInfo x)
-> (forall x. Rep DatatypeInfo x -> DatatypeInfo)
-> Generic DatatypeInfo
forall x. Rep DatatypeInfo x -> DatatypeInfo
forall x. DatatypeInfo -> Rep DatatypeInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DatatypeInfo -> Rep DatatypeInfo x
from :: forall x. DatatypeInfo -> Rep DatatypeInfo x
$cto :: forall x. Rep DatatypeInfo x -> DatatypeInfo
to :: forall x. Rep DatatypeInfo x -> DatatypeInfo
Generic
#endif
           )

-- | Possible variants of data type declarations.
data DatatypeVariant
  = Datatype        -- ^ Type declared with @data@ or a primitive datatype.
  | Newtype         -- ^ Type declared with @newtype@.
                    --
                    --   A 'DatatypeInfo' that uses 'Newtype' will uphold the
                    --   invariant that there will be exactly one
                    --   'ConstructorInfo' in the 'datatypeCons'.
  | DataInstance    -- ^ Type declared with @data instance@.
  | NewtypeInstance -- ^ Type declared with @newtype instance@.
                    --
                    --   A 'DatatypeInfo' that uses 'NewtypeInstance' will
                    --   uphold the invariant that there will be exactly one
                    --   'ConstructorInfo' in the 'datatypeCons'.
  | TypeData        -- ^ Type declared with @type data@.
                    --
                    --   A 'DatatypeInfo' that uses 'TypeData' will uphold the
                    --   following invariants:
                    --
                    --   * The 'datatypeContext' will be empty.
                    --
                    --   * None of the 'constructorVariant's in any of the
                    --     'datatypeCons' will be 'RecordConstructor'.
                    --
                    --   * Each of the 'constructorStrictness' values in each
                    --     of the 'datatypeCons' will be equal to
                    --     'notStrictAnnot'.
  deriving (Int -> DatatypeVariant -> ShowS
[DatatypeVariant] -> ShowS
DatatypeVariant -> String
(Int -> DatatypeVariant -> ShowS)
-> (DatatypeVariant -> String)
-> ([DatatypeVariant] -> ShowS)
-> Show DatatypeVariant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DatatypeVariant -> ShowS
showsPrec :: Int -> DatatypeVariant -> ShowS
$cshow :: DatatypeVariant -> String
show :: DatatypeVariant -> String
$cshowList :: [DatatypeVariant] -> ShowS
showList :: [DatatypeVariant] -> ShowS
Show, ReadPrec [DatatypeVariant]
ReadPrec DatatypeVariant
Int -> ReadS DatatypeVariant
ReadS [DatatypeVariant]
(Int -> ReadS DatatypeVariant)
-> ReadS [DatatypeVariant]
-> ReadPrec DatatypeVariant
-> ReadPrec [DatatypeVariant]
-> Read DatatypeVariant
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS DatatypeVariant
readsPrec :: Int -> ReadS DatatypeVariant
$creadList :: ReadS [DatatypeVariant]
readList :: ReadS [DatatypeVariant]
$creadPrec :: ReadPrec DatatypeVariant
readPrec :: ReadPrec DatatypeVariant
$creadListPrec :: ReadPrec [DatatypeVariant]
readListPrec :: ReadPrec [DatatypeVariant]
Read, DatatypeVariant -> DatatypeVariant -> Bool
(DatatypeVariant -> DatatypeVariant -> Bool)
-> (DatatypeVariant -> DatatypeVariant -> Bool)
-> Eq DatatypeVariant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DatatypeVariant -> DatatypeVariant -> Bool
== :: DatatypeVariant -> DatatypeVariant -> Bool
$c/= :: DatatypeVariant -> DatatypeVariant -> Bool
/= :: DatatypeVariant -> DatatypeVariant -> Bool
Eq, Eq DatatypeVariant
Eq DatatypeVariant =>
(DatatypeVariant -> DatatypeVariant -> Ordering)
-> (DatatypeVariant -> DatatypeVariant -> Bool)
-> (DatatypeVariant -> DatatypeVariant -> Bool)
-> (DatatypeVariant -> DatatypeVariant -> Bool)
-> (DatatypeVariant -> DatatypeVariant -> Bool)
-> (DatatypeVariant -> DatatypeVariant -> DatatypeVariant)
-> (DatatypeVariant -> DatatypeVariant -> DatatypeVariant)
-> Ord DatatypeVariant
DatatypeVariant -> DatatypeVariant -> Bool
DatatypeVariant -> DatatypeVariant -> Ordering
DatatypeVariant -> DatatypeVariant -> DatatypeVariant
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DatatypeVariant -> DatatypeVariant -> Ordering
compare :: DatatypeVariant -> DatatypeVariant -> Ordering
$c< :: DatatypeVariant -> DatatypeVariant -> Bool
< :: DatatypeVariant -> DatatypeVariant -> Bool
$c<= :: DatatypeVariant -> DatatypeVariant -> Bool
<= :: DatatypeVariant -> DatatypeVariant -> Bool
$c> :: DatatypeVariant -> DatatypeVariant -> Bool
> :: DatatypeVariant -> DatatypeVariant -> Bool
$c>= :: DatatypeVariant -> DatatypeVariant -> Bool
>= :: DatatypeVariant -> DatatypeVariant -> Bool
$cmax :: DatatypeVariant -> DatatypeVariant -> DatatypeVariant
max :: DatatypeVariant -> DatatypeVariant -> DatatypeVariant
$cmin :: DatatypeVariant -> DatatypeVariant -> DatatypeVariant
min :: DatatypeVariant -> DatatypeVariant -> DatatypeVariant
Ord, Typeable, Typeable DatatypeVariant
Typeable DatatypeVariant =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DatatypeVariant -> c DatatypeVariant)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DatatypeVariant)
-> (DatatypeVariant -> Constr)
-> (DatatypeVariant -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DatatypeVariant))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DatatypeVariant))
-> ((forall b. Data b => b -> b)
    -> DatatypeVariant -> DatatypeVariant)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> DatatypeVariant -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DatatypeVariant -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> DatatypeVariant -> m DatatypeVariant)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DatatypeVariant -> m DatatypeVariant)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DatatypeVariant -> m DatatypeVariant)
-> Data DatatypeVariant
DatatypeVariant -> Constr
DatatypeVariant -> DataType
(forall b. Data b => b -> b) -> DatatypeVariant -> DatatypeVariant
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> DatatypeVariant -> u
forall u. (forall d. Data d => d -> u) -> DatatypeVariant -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeVariant
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeVariant -> c DatatypeVariant
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeVariant)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeVariant)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeVariant -> c DatatypeVariant
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeVariant -> c DatatypeVariant
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeVariant
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeVariant
$ctoConstr :: DatatypeVariant -> Constr
toConstr :: DatatypeVariant -> Constr
$cdataTypeOf :: DatatypeVariant -> DataType
dataTypeOf :: DatatypeVariant -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeVariant)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeVariant)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeVariant)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeVariant)
$cgmapT :: (forall b. Data b => b -> b) -> DatatypeVariant -> DatatypeVariant
gmapT :: (forall b. Data b => b -> b) -> DatatypeVariant -> DatatypeVariant
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeVariant -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeVariant -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DatatypeVariant -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DatatypeVariant -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
Data
#ifdef HAS_GENERICS
           ,(forall x. DatatypeVariant -> Rep DatatypeVariant x)
-> (forall x. Rep DatatypeVariant x -> DatatypeVariant)
-> Generic DatatypeVariant
forall x. Rep DatatypeVariant x -> DatatypeVariant
forall x. DatatypeVariant -> Rep DatatypeVariant x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DatatypeVariant -> Rep DatatypeVariant x
from :: forall x. DatatypeVariant -> Rep DatatypeVariant x
$cto :: forall x. Rep DatatypeVariant x -> DatatypeVariant
to :: forall x. Rep DatatypeVariant x -> DatatypeVariant
Generic
#endif
           )

-- | Normalized information about constructors associated with newtypes and
-- data types.
data ConstructorInfo = ConstructorInfo
  { ConstructorInfo -> Name
constructorName       :: Name               -- ^ Constructor name
  , ConstructorInfo -> [TyVarBndrUnit]
constructorVars       :: [TyVarBndrUnit]    -- ^ Constructor type parameters
  , ConstructorInfo -> [Type]
constructorContext    :: Cxt                -- ^ Constructor constraints
  , ConstructorInfo -> [Type]
constructorFields     :: [Type]             -- ^ Constructor fields
  , ConstructorInfo -> [FieldStrictness]
constructorStrictness :: [FieldStrictness]  -- ^ Constructor fields' strictness
                                                --   (Invariant: has the same length
                                                --   as constructorFields)
  , ConstructorInfo -> ConstructorVariant
constructorVariant    :: ConstructorVariant -- ^ Extra information
  }
  deriving (Int -> ConstructorInfo -> ShowS
[ConstructorInfo] -> ShowS
ConstructorInfo -> String
(Int -> ConstructorInfo -> ShowS)
-> (ConstructorInfo -> String)
-> ([ConstructorInfo] -> ShowS)
-> Show ConstructorInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstructorInfo -> ShowS
showsPrec :: Int -> ConstructorInfo -> ShowS
$cshow :: ConstructorInfo -> String
show :: ConstructorInfo -> String
$cshowList :: [ConstructorInfo] -> ShowS
showList :: [ConstructorInfo] -> ShowS
Show, ConstructorInfo -> ConstructorInfo -> Bool
(ConstructorInfo -> ConstructorInfo -> Bool)
-> (ConstructorInfo -> ConstructorInfo -> Bool)
-> Eq ConstructorInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstructorInfo -> ConstructorInfo -> Bool
== :: ConstructorInfo -> ConstructorInfo -> Bool
$c/= :: ConstructorInfo -> ConstructorInfo -> Bool
/= :: ConstructorInfo -> ConstructorInfo -> Bool
Eq, Typeable, Typeable ConstructorInfo
Typeable ConstructorInfo =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> ConstructorInfo -> c ConstructorInfo)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ConstructorInfo)
-> (ConstructorInfo -> Constr)
-> (ConstructorInfo -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ConstructorInfo))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ConstructorInfo))
-> ((forall b. Data b => b -> b)
    -> ConstructorInfo -> ConstructorInfo)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> ConstructorInfo -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ConstructorInfo -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> ConstructorInfo -> m ConstructorInfo)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ConstructorInfo -> m ConstructorInfo)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ConstructorInfo -> m ConstructorInfo)
-> Data ConstructorInfo
ConstructorInfo -> Constr
ConstructorInfo -> DataType
(forall b. Data b => b -> b) -> ConstructorInfo -> ConstructorInfo
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorInfo -> u
forall u. (forall d. Data d => d -> u) -> ConstructorInfo -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorInfo
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConstructorInfo -> c ConstructorInfo
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorInfo)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorInfo)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConstructorInfo -> c ConstructorInfo
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConstructorInfo -> c ConstructorInfo
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorInfo
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorInfo
$ctoConstr :: ConstructorInfo -> Constr
toConstr :: ConstructorInfo -> Constr
$cdataTypeOf :: ConstructorInfo -> DataType
dataTypeOf :: ConstructorInfo -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorInfo)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorInfo)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorInfo)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorInfo)
$cgmapT :: (forall b. Data b => b -> b) -> ConstructorInfo -> ConstructorInfo
gmapT :: (forall b. Data b => b -> b) -> ConstructorInfo -> ConstructorInfo
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorInfo -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorInfo -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorInfo -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorInfo -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
Data
#ifdef HAS_GENERICS
           ,(forall x. ConstructorInfo -> Rep ConstructorInfo x)
-> (forall x. Rep ConstructorInfo x -> ConstructorInfo)
-> Generic ConstructorInfo
forall x. Rep ConstructorInfo x -> ConstructorInfo
forall x. ConstructorInfo -> Rep ConstructorInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ConstructorInfo -> Rep ConstructorInfo x
from :: forall x. ConstructorInfo -> Rep ConstructorInfo x
$cto :: forall x. Rep ConstructorInfo x -> ConstructorInfo
to :: forall x. Rep ConstructorInfo x -> ConstructorInfo
Generic
#endif
           )

-- | Possible variants of data constructors.
data ConstructorVariant
  = NormalConstructor        -- ^ Constructor without field names
  | InfixConstructor         -- ^ Constructor without field names that is
                             --   declared infix
  | RecordConstructor [Name] -- ^ Constructor with field names
  deriving (Int -> ConstructorVariant -> ShowS
[ConstructorVariant] -> ShowS
ConstructorVariant -> String
(Int -> ConstructorVariant -> ShowS)
-> (ConstructorVariant -> String)
-> ([ConstructorVariant] -> ShowS)
-> Show ConstructorVariant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstructorVariant -> ShowS
showsPrec :: Int -> ConstructorVariant -> ShowS
$cshow :: ConstructorVariant -> String
show :: ConstructorVariant -> String
$cshowList :: [ConstructorVariant] -> ShowS
showList :: [ConstructorVariant] -> ShowS
Show, ConstructorVariant -> ConstructorVariant -> Bool
(ConstructorVariant -> ConstructorVariant -> Bool)
-> (ConstructorVariant -> ConstructorVariant -> Bool)
-> Eq ConstructorVariant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstructorVariant -> ConstructorVariant -> Bool
== :: ConstructorVariant -> ConstructorVariant -> Bool
$c/= :: ConstructorVariant -> ConstructorVariant -> Bool
/= :: ConstructorVariant -> ConstructorVariant -> Bool
Eq, Eq ConstructorVariant
Eq ConstructorVariant =>
(ConstructorVariant -> ConstructorVariant -> Ordering)
-> (ConstructorVariant -> ConstructorVariant -> Bool)
-> (ConstructorVariant -> ConstructorVariant -> Bool)
-> (ConstructorVariant -> ConstructorVariant -> Bool)
-> (ConstructorVariant -> ConstructorVariant -> Bool)
-> (ConstructorVariant -> ConstructorVariant -> ConstructorVariant)
-> (ConstructorVariant -> ConstructorVariant -> ConstructorVariant)
-> Ord ConstructorVariant
ConstructorVariant -> ConstructorVariant -> Bool
ConstructorVariant -> ConstructorVariant -> Ordering
ConstructorVariant -> ConstructorVariant -> ConstructorVariant
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ConstructorVariant -> ConstructorVariant -> Ordering
compare :: ConstructorVariant -> ConstructorVariant -> Ordering
$c< :: ConstructorVariant -> ConstructorVariant -> Bool
< :: ConstructorVariant -> ConstructorVariant -> Bool
$c<= :: ConstructorVariant -> ConstructorVariant -> Bool
<= :: ConstructorVariant -> ConstructorVariant -> Bool
$c> :: ConstructorVariant -> ConstructorVariant -> Bool
> :: ConstructorVariant -> ConstructorVariant -> Bool
$c>= :: ConstructorVariant -> ConstructorVariant -> Bool
>= :: ConstructorVariant -> ConstructorVariant -> Bool
$cmax :: ConstructorVariant -> ConstructorVariant -> ConstructorVariant
max :: ConstructorVariant -> ConstructorVariant -> ConstructorVariant
$cmin :: ConstructorVariant -> ConstructorVariant -> ConstructorVariant
min :: ConstructorVariant -> ConstructorVariant -> ConstructorVariant
Ord, Typeable, Typeable ConstructorVariant
Typeable ConstructorVariant =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g)
 -> ConstructorVariant
 -> c ConstructorVariant)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ConstructorVariant)
-> (ConstructorVariant -> Constr)
-> (ConstructorVariant -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ConstructorVariant))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ConstructorVariant))
-> ((forall b. Data b => b -> b)
    -> ConstructorVariant -> ConstructorVariant)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> ConstructorVariant -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ConstructorVariant -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> ConstructorVariant -> m ConstructorVariant)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ConstructorVariant -> m ConstructorVariant)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ConstructorVariant -> m ConstructorVariant)
-> Data ConstructorVariant
ConstructorVariant -> Constr
ConstructorVariant -> DataType
(forall b. Data b => b -> b)
-> ConstructorVariant -> ConstructorVariant
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorVariant -> u
forall u. (forall d. Data d => d -> u) -> ConstructorVariant -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorVariant
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ConstructorVariant
-> c ConstructorVariant
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorVariant)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorVariant)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ConstructorVariant
-> c ConstructorVariant
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ConstructorVariant
-> c ConstructorVariant
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorVariant
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorVariant
$ctoConstr :: ConstructorVariant -> Constr
toConstr :: ConstructorVariant -> Constr
$cdataTypeOf :: ConstructorVariant -> DataType
dataTypeOf :: ConstructorVariant -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorVariant)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorVariant)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorVariant)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorVariant)
$cgmapT :: (forall b. Data b => b -> b)
-> ConstructorVariant -> ConstructorVariant
gmapT :: (forall b. Data b => b -> b)
-> ConstructorVariant -> ConstructorVariant
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorVariant -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorVariant -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorVariant -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorVariant -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
Data
#ifdef HAS_GENERICS
           ,(forall x. ConstructorVariant -> Rep ConstructorVariant x)
-> (forall x. Rep ConstructorVariant x -> ConstructorVariant)
-> Generic ConstructorVariant
forall x. Rep ConstructorVariant x -> ConstructorVariant
forall x. ConstructorVariant -> Rep ConstructorVariant x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ConstructorVariant -> Rep ConstructorVariant x
from :: forall x. ConstructorVariant -> Rep ConstructorVariant x
$cto :: forall x. Rep ConstructorVariant x -> ConstructorVariant
to :: forall x. Rep ConstructorVariant x -> ConstructorVariant
Generic
#endif
           )

-- | Normalized information about a constructor field's @UNPACK@ and
-- strictness annotations.
--
-- Note that the interface for reifying strictness in Template Haskell changed
-- considerably in GHC 8.0. The presentation in this library mirrors that which
-- can be found in GHC 8.0 or later, whereas previously, unpackedness and
-- strictness were represented with a single data type:
--
-- @
-- data Strict
--   = IsStrict
--   | NotStrict
--   | Unpacked -- On GHC 7.4 or later
-- @
--
-- For backwards compatibility, we retrofit these constructors onto the
-- following three values, respectively:
--
-- @
-- 'isStrictAnnot'  = 'FieldStrictness' 'UnspecifiedUnpackedness' 'Strict'
-- 'notStrictAnnot' = 'FieldStrictness' 'UnspecifiedUnpackedness' 'UnspecifiedStrictness'
-- 'unpackedAnnot'  = 'FieldStrictness' 'Unpack' 'Strict'
-- @
data FieldStrictness = FieldStrictness
  { FieldStrictness -> Unpackedness
fieldUnpackedness :: Unpackedness
  , FieldStrictness -> Strictness
fieldStrictness   :: Strictness
  }
  deriving (Int -> FieldStrictness -> ShowS
[FieldStrictness] -> ShowS
FieldStrictness -> String
(Int -> FieldStrictness -> ShowS)
-> (FieldStrictness -> String)
-> ([FieldStrictness] -> ShowS)
-> Show FieldStrictness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldStrictness -> ShowS
showsPrec :: Int -> FieldStrictness -> ShowS
$cshow :: FieldStrictness -> String
show :: FieldStrictness -> String
$cshowList :: [FieldStrictness] -> ShowS
showList :: [FieldStrictness] -> ShowS
Show, FieldStrictness -> FieldStrictness -> Bool
(FieldStrictness -> FieldStrictness -> Bool)
-> (FieldStrictness -> FieldStrictness -> Bool)
-> Eq FieldStrictness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldStrictness -> FieldStrictness -> Bool
== :: FieldStrictness -> FieldStrictness -> Bool
$c/= :: FieldStrictness -> FieldStrictness -> Bool
/= :: FieldStrictness -> FieldStrictness -> Bool
Eq, Eq FieldStrictness
Eq FieldStrictness =>
(FieldStrictness -> FieldStrictness -> Ordering)
-> (FieldStrictness -> FieldStrictness -> Bool)
-> (FieldStrictness -> FieldStrictness -> Bool)
-> (FieldStrictness -> FieldStrictness -> Bool)
-> (FieldStrictness -> FieldStrictness -> Bool)
-> (FieldStrictness -> FieldStrictness -> FieldStrictness)
-> (FieldStrictness -> FieldStrictness -> FieldStrictness)
-> Ord FieldStrictness
FieldStrictness -> FieldStrictness -> Bool
FieldStrictness -> FieldStrictness -> Ordering
FieldStrictness -> FieldStrictness -> FieldStrictness
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FieldStrictness -> FieldStrictness -> Ordering
compare :: FieldStrictness -> FieldStrictness -> Ordering
$c< :: FieldStrictness -> FieldStrictness -> Bool
< :: FieldStrictness -> FieldStrictness -> Bool
$c<= :: FieldStrictness -> FieldStrictness -> Bool
<= :: FieldStrictness -> FieldStrictness -> Bool
$c> :: FieldStrictness -> FieldStrictness -> Bool
> :: FieldStrictness -> FieldStrictness -> Bool
$c>= :: FieldStrictness -> FieldStrictness -> Bool
>= :: FieldStrictness -> FieldStrictness -> Bool
$cmax :: FieldStrictness -> FieldStrictness -> FieldStrictness
max :: FieldStrictness -> FieldStrictness -> FieldStrictness
$cmin :: FieldStrictness -> FieldStrictness -> FieldStrictness
min :: FieldStrictness -> FieldStrictness -> FieldStrictness
Ord, Typeable, Typeable FieldStrictness
Typeable FieldStrictness =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> FieldStrictness -> c FieldStrictness)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c FieldStrictness)
-> (FieldStrictness -> Constr)
-> (FieldStrictness -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c FieldStrictness))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c FieldStrictness))
-> ((forall b. Data b => b -> b)
    -> FieldStrictness -> FieldStrictness)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> FieldStrictness -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> FieldStrictness -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> FieldStrictness -> m FieldStrictness)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> FieldStrictness -> m FieldStrictness)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> FieldStrictness -> m FieldStrictness)
-> Data FieldStrictness
FieldStrictness -> Constr
FieldStrictness -> DataType
(forall b. Data b => b -> b) -> FieldStrictness -> FieldStrictness
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> FieldStrictness -> u
forall u. (forall d. Data d => d -> u) -> FieldStrictness -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FieldStrictness
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FieldStrictness -> c FieldStrictness
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FieldStrictness)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c FieldStrictness)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FieldStrictness -> c FieldStrictness
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FieldStrictness -> c FieldStrictness
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FieldStrictness
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FieldStrictness
$ctoConstr :: FieldStrictness -> Constr
toConstr :: FieldStrictness -> Constr
$cdataTypeOf :: FieldStrictness -> DataType
dataTypeOf :: FieldStrictness -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FieldStrictness)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FieldStrictness)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c FieldStrictness)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c FieldStrictness)
$cgmapT :: (forall b. Data b => b -> b) -> FieldStrictness -> FieldStrictness
gmapT :: (forall b. Data b => b -> b) -> FieldStrictness -> FieldStrictness
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> FieldStrictness -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> FieldStrictness -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> FieldStrictness -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> FieldStrictness -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
Data
#ifdef HAS_GENERICS
           ,(forall x. FieldStrictness -> Rep FieldStrictness x)
-> (forall x. Rep FieldStrictness x -> FieldStrictness)
-> Generic FieldStrictness
forall x. Rep FieldStrictness x -> FieldStrictness
forall x. FieldStrictness -> Rep FieldStrictness x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FieldStrictness -> Rep FieldStrictness x
from :: forall x. FieldStrictness -> Rep FieldStrictness x
$cto :: forall x. Rep FieldStrictness x -> FieldStrictness
to :: forall x. Rep FieldStrictness x -> FieldStrictness
Generic
#endif
           )

-- | Information about a constructor field's unpackedness annotation.
data Unpackedness
  = UnspecifiedUnpackedness -- ^ No annotation whatsoever
  | NoUnpack                -- ^ Annotated with @{\-\# NOUNPACK \#-\}@
  | Unpack                  -- ^ Annotated with @{\-\# UNPACK \#-\}@
  deriving (Int -> Unpackedness -> ShowS
[Unpackedness] -> ShowS
Unpackedness -> String
(Int -> Unpackedness -> ShowS)
-> (Unpackedness -> String)
-> ([Unpackedness] -> ShowS)
-> Show Unpackedness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Unpackedness -> ShowS
showsPrec :: Int -> Unpackedness -> ShowS
$cshow :: Unpackedness -> String
show :: Unpackedness -> String
$cshowList :: [Unpackedness] -> ShowS
showList :: [Unpackedness] -> ShowS
Show, Unpackedness -> Unpackedness -> Bool
(Unpackedness -> Unpackedness -> Bool)
-> (Unpackedness -> Unpackedness -> Bool) -> Eq Unpackedness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Unpackedness -> Unpackedness -> Bool
== :: Unpackedness -> Unpackedness -> Bool
$c/= :: Unpackedness -> Unpackedness -> Bool
/= :: Unpackedness -> Unpackedness -> Bool
Eq, Eq Unpackedness
Eq Unpackedness =>
(Unpackedness -> Unpackedness -> Ordering)
-> (Unpackedness -> Unpackedness -> Bool)
-> (Unpackedness -> Unpackedness -> Bool)
-> (Unpackedness -> Unpackedness -> Bool)
-> (Unpackedness -> Unpackedness -> Bool)
-> (Unpackedness -> Unpackedness -> Unpackedness)
-> (Unpackedness -> Unpackedness -> Unpackedness)
-> Ord Unpackedness
Unpackedness -> Unpackedness -> Bool
Unpackedness -> Unpackedness -> Ordering
Unpackedness -> Unpackedness -> Unpackedness
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Unpackedness -> Unpackedness -> Ordering
compare :: Unpackedness -> Unpackedness -> Ordering
$c< :: Unpackedness -> Unpackedness -> Bool
< :: Unpackedness -> Unpackedness -> Bool
$c<= :: Unpackedness -> Unpackedness -> Bool
<= :: Unpackedness -> Unpackedness -> Bool
$c> :: Unpackedness -> Unpackedness -> Bool
> :: Unpackedness -> Unpackedness -> Bool
$c>= :: Unpackedness -> Unpackedness -> Bool
>= :: Unpackedness -> Unpackedness -> Bool
$cmax :: Unpackedness -> Unpackedness -> Unpackedness
max :: Unpackedness -> Unpackedness -> Unpackedness
$cmin :: Unpackedness -> Unpackedness -> Unpackedness
min :: Unpackedness -> Unpackedness -> Unpackedness
Ord, Typeable, Typeable Unpackedness
Typeable Unpackedness =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Unpackedness -> c Unpackedness)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Unpackedness)
-> (Unpackedness -> Constr)
-> (Unpackedness -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Unpackedness))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c Unpackedness))
-> ((forall b. Data b => b -> b) -> Unpackedness -> Unpackedness)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Unpackedness -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Unpackedness -> r)
-> (forall u. (forall d. Data d => d -> u) -> Unpackedness -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Unpackedness -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness)
-> Data Unpackedness
Unpackedness -> Constr
Unpackedness -> DataType
(forall b. Data b => b -> b) -> Unpackedness -> Unpackedness
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Unpackedness -> u
forall u. (forall d. Data d => d -> u) -> Unpackedness -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Unpackedness
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Unpackedness -> c Unpackedness
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Unpackedness)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c Unpackedness)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Unpackedness -> c Unpackedness
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Unpackedness -> c Unpackedness
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Unpackedness
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Unpackedness
$ctoConstr :: Unpackedness -> Constr
toConstr :: Unpackedness -> Constr
$cdataTypeOf :: Unpackedness -> DataType
dataTypeOf :: Unpackedness -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Unpackedness)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Unpackedness)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c Unpackedness)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c Unpackedness)
$cgmapT :: (forall b. Data b => b -> b) -> Unpackedness -> Unpackedness
gmapT :: (forall b. Data b => b -> b) -> Unpackedness -> Unpackedness
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Unpackedness -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> Unpackedness -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Unpackedness -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Unpackedness -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
Data
#ifdef HAS_GENERICS
           ,(forall x. Unpackedness -> Rep Unpackedness x)
-> (forall x. Rep Unpackedness x -> Unpackedness)
-> Generic Unpackedness
forall x. Rep Unpackedness x -> Unpackedness
forall x. Unpackedness -> Rep Unpackedness x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Unpackedness -> Rep Unpackedness x
from :: forall x. Unpackedness -> Rep Unpackedness x
$cto :: forall x. Rep Unpackedness x -> Unpackedness
to :: forall x. Rep Unpackedness x -> Unpackedness
Generic
#endif
           )

-- | Information about a constructor field's strictness annotation.
data Strictness
  = UnspecifiedStrictness -- ^ No annotation whatsoever
  | Lazy                  -- ^ Annotated with @~@
  | Strict                -- ^ Annotated with @!@
  deriving (Int -> Strictness -> ShowS
[Strictness] -> ShowS
Strictness -> String
(Int -> Strictness -> ShowS)
-> (Strictness -> String)
-> ([Strictness] -> ShowS)
-> Show Strictness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Strictness -> ShowS
showsPrec :: Int -> Strictness -> ShowS
$cshow :: Strictness -> String
show :: Strictness -> String
$cshowList :: [Strictness] -> ShowS
showList :: [Strictness] -> ShowS
Show, Strictness -> Strictness -> Bool
(Strictness -> Strictness -> Bool)
-> (Strictness -> Strictness -> Bool) -> Eq Strictness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Strictness -> Strictness -> Bool
== :: Strictness -> Strictness -> Bool
$c/= :: Strictness -> Strictness -> Bool
/= :: Strictness -> Strictness -> Bool
Eq, Eq Strictness
Eq Strictness =>
(Strictness -> Strictness -> Ordering)
-> (Strictness -> Strictness -> Bool)
-> (Strictness -> Strictness -> Bool)
-> (Strictness -> Strictness -> Bool)
-> (Strictness -> Strictness -> Bool)
-> (Strictness -> Strictness -> Strictness)
-> (Strictness -> Strictness -> Strictness)
-> Ord Strictness
Strictness -> Strictness -> Bool
Strictness -> Strictness -> Ordering
Strictness -> Strictness -> Strictness
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Strictness -> Strictness -> Ordering
compare :: Strictness -> Strictness -> Ordering
$c< :: Strictness -> Strictness -> Bool
< :: Strictness -> Strictness -> Bool
$c<= :: Strictness -> Strictness -> Bool
<= :: Strictness -> Strictness -> Bool
$c> :: Strictness -> Strictness -> Bool
> :: Strictness -> Strictness -> Bool
$c>= :: Strictness -> Strictness -> Bool
>= :: Strictness -> Strictness -> Bool
$cmax :: Strictness -> Strictness -> Strictness
max :: Strictness -> Strictness -> Strictness
$cmin :: Strictness -> Strictness -> Strictness
min :: Strictness -> Strictness -> Strictness
Ord, Typeable, Typeable Strictness
Typeable Strictness =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Strictness -> c Strictness)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Strictness)
-> (Strictness -> Constr)
-> (Strictness -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Strictness))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c Strictness))
-> ((forall b. Data b => b -> b) -> Strictness -> Strictness)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Strictness -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Strictness -> r)
-> (forall u. (forall d. Data d => d -> u) -> Strictness -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Strictness -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Strictness -> m Strictness)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Strictness -> m Strictness)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Strictness -> m Strictness)
-> Data Strictness
Strictness -> Constr
Strictness -> DataType
(forall b. Data b => b -> b) -> Strictness -> Strictness
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Strictness -> u
forall u. (forall d. Data d => d -> u) -> Strictness -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Strictness
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Strictness -> c Strictness
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Strictness)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Strictness)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Strictness -> c Strictness
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Strictness -> c Strictness
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Strictness
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Strictness
$ctoConstr :: Strictness -> Constr
toConstr :: Strictness -> Constr
$cdataTypeOf :: Strictness -> DataType
dataTypeOf :: Strictness -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Strictness)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Strictness)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Strictness)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Strictness)
$cgmapT :: (forall b. Data b => b -> b) -> Strictness -> Strictness
gmapT :: (forall b. Data b => b -> b) -> Strictness -> Strictness
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Strictness -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> Strictness -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Strictness -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Strictness -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
Data
#ifdef HAS_GENERICS
           ,(forall x. Strictness -> Rep Strictness x)
-> (forall x. Rep Strictness x -> Strictness) -> Generic Strictness
forall x. Rep Strictness x -> Strictness
forall x. Strictness -> Rep Strictness x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Strictness -> Rep Strictness x
from :: forall x. Strictness -> Rep Strictness x
$cto :: forall x. Rep Strictness x -> Strictness
to :: forall x. Rep Strictness x -> Strictness
Generic
#endif
           )

isStrictAnnot, notStrictAnnot, unpackedAnnot :: FieldStrictness
isStrictAnnot :: FieldStrictness
isStrictAnnot  = Unpackedness -> Strictness -> FieldStrictness
FieldStrictness Unpackedness
UnspecifiedUnpackedness Strictness
Strict
notStrictAnnot :: FieldStrictness
notStrictAnnot = Unpackedness -> Strictness -> FieldStrictness
FieldStrictness Unpackedness
UnspecifiedUnpackedness Strictness
UnspecifiedStrictness
unpackedAnnot :: FieldStrictness
unpackedAnnot  = Unpackedness -> Strictness -> FieldStrictness
FieldStrictness Unpackedness
Unpack Strictness
Strict

-- | Construct a Type using the datatype's type constructor and type
-- parameters. Kind signatures are removed.
datatypeType :: DatatypeInfo -> Type
datatypeType :: DatatypeInfo -> Type
datatypeType DatatypeInfo
di
  = (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
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (DatatypeInfo -> Name
datatypeName DatatypeInfo
di))
  ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
stripSigT
  ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
di


-- | Compute a normalized view of the metadata about a data type or newtype
-- given a constructor.
--
-- This function will accept any constructor (value or type) for a type
-- declared with newtype or data. Value constructors must be used to
-- lookup datatype information about /data instances/ and /newtype instances/,
-- as giving the type constructor of a data family is often not enough to
-- determine a particular data family instance.
--
-- In addition, this function will also accept a record selector for a
-- data type with a constructor which uses that record.
--
-- GADT constructors are normalized into datatypes with explicit equality
-- constraints. Note that no effort is made to distinguish between equalities of
-- the same (homogeneous) kind and equalities between different (heterogeneous)
-- kinds. For instance, the following GADT's constructors:
--
-- @
-- data T (a :: k -> *) where
--   MkT1 :: T Proxy
--   MkT2 :: T Maybe
-- @
--
-- will be normalized to the following equality constraints:
--
-- @
-- AppT (AppT EqualityT (VarT a)) (ConT Proxy) -- MkT1
-- AppT (AppT EqualityT (VarT a)) (ConT Maybe) -- MkT2
-- @
--
-- But only the first equality constraint is well kinded, since in the second
-- constraint, the kinds of @(a :: k -> *)@ and @(Maybe :: * -> *)@ are different.
-- Trying to categorize which constraints need homogeneous or heterogeneous
-- equality is tricky, so we leave that task to users of this library.
--
-- Primitive types (other than unboxed sums and tuples) will have
-- no @datatypeCons@ in their normalization.
--
-- This function will apply various bug-fixes to the output of the underlying
-- @template-haskell@ library in order to provide a view of datatypes in
-- as uniform a way as possible.
reifyDatatype ::
  Name {- ^ data type or constructor name -} ->
  Q DatatypeInfo
reifyDatatype :: Name -> Q DatatypeInfo
reifyDatatype Name
n = String -> Bool -> Info -> Q DatatypeInfo
normalizeInfo' String
"reifyDatatype" Bool
isReified (Info -> Q DatatypeInfo) -> Q Info -> Q DatatypeInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q Info
reify Name
n

-- | Compute a normalized view of the metadata about a constructor given its
-- 'Name'. This is useful for scenarios when you don't care about the info for
-- the enclosing data type.
reifyConstructor ::
  Name {- ^ constructor name -} ->
  Q ConstructorInfo
reifyConstructor :: Name -> Q ConstructorInfo
reifyConstructor Name
conName = do
  DatatypeInfo
dataInfo <- Name -> Q DatatypeInfo
reifyDatatype Name
conName
  ConstructorInfo -> Q ConstructorInfo
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorInfo -> Q ConstructorInfo)
-> ConstructorInfo -> Q ConstructorInfo
forall a b. (a -> b) -> a -> b
$ Name -> DatatypeInfo -> ConstructorInfo
lookupByConstructorName Name
conName DatatypeInfo
dataInfo

-- | Compute a normalized view of the metadata about a constructor given the
-- 'Name' of one of its record selectors. This is useful for scenarios when you
-- don't care about the info for the enclosing data type.
reifyRecord ::
  Name {- ^ record name -} ->
  Q ConstructorInfo
reifyRecord :: Name -> Q ConstructorInfo
reifyRecord Name
recordName = do
  DatatypeInfo
dataInfo <- Name -> Q DatatypeInfo
reifyDatatype Name
recordName
  ConstructorInfo -> Q ConstructorInfo
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorInfo -> Q ConstructorInfo)
-> ConstructorInfo -> Q ConstructorInfo
forall a b. (a -> b) -> a -> b
$ Name -> DatatypeInfo -> ConstructorInfo
lookupByRecordName Name
recordName DatatypeInfo
dataInfo

-- | Given a 'DatatypeInfo', find the 'ConstructorInfo' corresponding to the
-- 'Name' of one of its constructors.
lookupByConstructorName ::
  Name {- ^ constructor name -} ->
  DatatypeInfo {- ^ info for the datatype which has that constructor -} ->
  ConstructorInfo
lookupByConstructorName :: Name -> DatatypeInfo -> ConstructorInfo
lookupByConstructorName Name
conName DatatypeInfo
dataInfo =
  case (ConstructorInfo -> Bool)
-> [ConstructorInfo] -> Maybe ConstructorInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
conName) (Name -> Bool)
-> (ConstructorInfo -> Name) -> ConstructorInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Name
constructorName) (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
dataInfo) of
    Just ConstructorInfo
conInfo -> ConstructorInfo
conInfo
    Maybe ConstructorInfo
Nothing      -> String -> ConstructorInfo
forall a. HasCallStack => String -> a
error (String -> ConstructorInfo) -> String -> ConstructorInfo
forall a b. (a -> b) -> a -> b
$ String
"Datatype " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (DatatypeInfo -> Name
datatypeName DatatypeInfo
dataInfo)
                         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not have a constructor named " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
conName
-- | Given a 'DatatypeInfo', find the 'ConstructorInfo' corresponding to the
-- 'Name' of one of its constructors.
lookupByRecordName ::
  Name {- ^ record name -} ->
  DatatypeInfo {- ^ info for the datatype which has that constructor -} ->
  ConstructorInfo
lookupByRecordName :: Name -> DatatypeInfo -> ConstructorInfo
lookupByRecordName Name
recordName DatatypeInfo
dataInfo =
  case (ConstructorInfo -> Bool)
-> [ConstructorInfo] -> Maybe ConstructorInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Name -> ConstructorInfo -> Bool
conHasRecord Name
recordName) (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
dataInfo) of
    Just ConstructorInfo
conInfo -> ConstructorInfo
conInfo
    Maybe ConstructorInfo
Nothing      -> String -> ConstructorInfo
forall a. HasCallStack => String -> a
error (String -> ConstructorInfo) -> String -> ConstructorInfo
forall a b. (a -> b) -> a -> b
$ String
"Datatype " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (DatatypeInfo -> Name
datatypeName DatatypeInfo
dataInfo)
                         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not have any constructors with a "
                         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"record selector named " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
recordName

-- | Normalize 'Info' for a newtype or datatype into a 'DatatypeInfo'.
-- Fail in 'Q' otherwise.
normalizeInfo :: Info -> Q DatatypeInfo
normalizeInfo :: Info -> Q DatatypeInfo
normalizeInfo = String -> Bool -> Info -> Q DatatypeInfo
normalizeInfo' String
"normalizeInfo" Bool
isn'tReified

normalizeInfo' :: String -> IsReifiedDec -> Info -> Q DatatypeInfo
normalizeInfo' :: String -> Bool -> Info -> Q DatatypeInfo
normalizeInfo' String
entry Bool
reifiedDec Info
i =
  case Info
i of
    (PrimTyConI Name
name Int
arity Bool
unlifted) -> do
#if MIN_VERSION_template_haskell(2,16,0)
      -- We provide a minimal @DataD@ because, since TH 2.16,
      -- we can rely on the call to @reifyType@ in
      -- @normalizeDecFor@ to fill in the missing details.
      Bool -> Dec -> Q DatatypeInfo
normalizeDecFor Bool
reifiedDec (Dec -> Q DatatypeInfo) -> Dec -> Q DatatypeInfo
forall a b. (a -> b) -> a -> b
$ [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [] Maybe Type
forall a. Maybe a
Nothing [] []
#else
      -- On older versions, we are very limited in what we can deduce.
      -- All we know is the appropriate amount of type constructors.
      -- Note that this will default all kinds to @Type@, which is all
      -- that is available anyway.
      args <- replicateM arity (newName "x")
      dec <- dataDCompat (return []) name (map plainTV args) [] []
      normalizeDecFor reifiedDec dec
#endif
    ClassI{}                          -> String -> Q DatatypeInfo
forall {m :: * -> *} {a}. MonadFail m => String -> m a
bad String
"Class not supported"
#if MIN_VERSION_template_haskell(2,11,0)
    FamilyI DataFamilyD{} [Dec]
_           ->
#elif MIN_VERSION_template_haskell(2,7,0)
    FamilyI (FamilyD DataFam _ _ _) _ ->
#else
    TyConI (FamilyD DataFam _ _ _)    ->
#endif
                                         String -> Q DatatypeInfo
forall {m :: * -> *} {a}. MonadFail m => String -> m a
bad String
"Use a value constructor to reify a data family instance"
#if MIN_VERSION_template_haskell(2,7,0)
    FamilyI Dec
_ [Dec]
_                       -> String -> Q DatatypeInfo
forall {m :: * -> *} {a}. MonadFail m => String -> m a
bad String
"Type families not supported"
#endif
    TyConI Dec
dec                        -> Bool -> Dec -> Q DatatypeInfo
normalizeDecFor Bool
reifiedDec Dec
dec
#if MIN_VERSION_template_haskell(2,11,0)
    DataConI Name
name Type
_ Name
parent            -> Name -> Name -> Q DatatypeInfo
reifyParent Name
name Name
parent
                                         -- NB: We do not pass the IsReifiedDec information here
                                         -- because there's no point. We have no choice but to
                                         -- call reify here, since we need to determine the
                                         -- parent data type/family.
#else
    DataConI name _ parent _          -> reifyParent name parent
#endif
#if MIN_VERSION_template_haskell(2,11,0)
    VarI Name
recName Type
recTy Maybe Dec
_              -> Name -> Type -> Q DatatypeInfo
reifyRecordType Name
recName Type
recTy
                                         -- NB: Similarly, we do not pass the IsReifiedDec
                                         -- information here.
#else
    VarI recName recTy _ _            -> reifyRecordType recName recTy
#endif
    Info
_                                 -> String -> Q DatatypeInfo
forall {m :: * -> *} {a}. MonadFail m => String -> m a
bad String
"Expected a type constructor"
  where
    bad :: String -> m a
bad String
msg = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
entry String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg)


reifyParent :: Name -> Name -> Q DatatypeInfo
reifyParent :: Name -> Name -> Q DatatypeInfo
reifyParent Name
con = String -> (DatatypeInfo -> Bool) -> Name -> Q DatatypeInfo
reifyParentWith String
"reifyParent" DatatypeInfo -> Bool
p
  where
    p :: DatatypeInfo -> Bool
    p :: DatatypeInfo -> Bool
p DatatypeInfo
info = Name
con Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ConstructorInfo -> Name) -> [ConstructorInfo] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Name
constructorName (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
info)

reifyRecordType :: Name -> Type -> Q DatatypeInfo
reifyRecordType :: Name -> Type -> Q DatatypeInfo
reifyRecordType Name
recName Type
recTy =
  let ([TyVarBndrSpec]
_, [Type]
_, [Type]
argTys :|- Type
_) = Type -> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
uncurryType Type
recTy
  in case [Type]
argTys of
       Type
dataTy:[Type]
_ -> Type -> Q DatatypeInfo
decomposeDataType Type
dataTy
       [Type]
_        -> Q DatatypeInfo
forall a. Q a
notRecSelFailure
  where
    decomposeDataType :: Type -> Q DatatypeInfo
    decomposeDataType :: Type -> Q DatatypeInfo
decomposeDataType Type
ty =
      do case Type -> NonEmpty Type
decomposeType Type
ty of
           ConT Name
parent :| [Type]
_ -> String -> (DatatypeInfo -> Bool) -> Name -> Q DatatypeInfo
reifyParentWith String
"reifyRecordType" DatatypeInfo -> Bool
p Name
parent
           NonEmpty Type
_                -> Q DatatypeInfo
forall a. Q a
notRecSelFailure

    notRecSelFailure :: Q a
    notRecSelFailure :: forall a. Q a
notRecSelFailure = 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
"reifyRecordType: Not a record selector type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
      Name -> String
nameBase Name
recName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
recTy

    p :: DatatypeInfo -> Bool
    p :: DatatypeInfo -> Bool
p DatatypeInfo
info = (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> ConstructorInfo -> Bool
conHasRecord Name
recName) (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
info)

reifyParentWith ::
  String                 {- ^ prefix for error messages -} ->
  (DatatypeInfo -> Bool) {- ^ predicate for finding the right
                              data family instance -}      ->
  Name                   {- ^ parent data type name -}     ->
  Q DatatypeInfo
reifyParentWith :: String -> (DatatypeInfo -> Bool) -> Name -> Q DatatypeInfo
reifyParentWith String
prefix DatatypeInfo -> Bool
p Name
n =
  do Info
info <- Name -> Q Info
reify Name
n
     case Info
info of
#if !(MIN_VERSION_template_haskell(2,11,0))
       -- This unusual combination of Info and Dec is only possible to reify on
       -- GHC 7.0 and 7.2, when you try to reify a data family. Because there's
       -- no way to reify the data family *instances* on these versions of GHC,
       -- we have no choice but to fail.
       TyConI FamilyD{} -> dataFamiliesOnOldGHCsError
#endif
       TyConI Dec
dec -> Bool -> Dec -> Q DatatypeInfo
normalizeDecFor Bool
isReified Dec
dec
#if MIN_VERSION_template_haskell(2,7,0)
       FamilyI Dec
dec [Dec]
instances ->
         do [Dec]
instances1 <- (Dec -> Q Dec) -> [Dec] -> Q [Dec]
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 (Dec -> Dec -> Q Dec
repairDataFam Dec
dec) [Dec]
instances
            [DatatypeInfo]
instances2 <- (Dec -> Q DatatypeInfo) -> [Dec] -> Q [DatatypeInfo]
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 (Bool -> Dec -> Q DatatypeInfo
normalizeDecFor Bool
isReified) [Dec]
instances1
            case (DatatypeInfo -> Bool) -> [DatatypeInfo] -> Maybe DatatypeInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find DatatypeInfo -> Bool
p [DatatypeInfo]
instances2 of
              Just DatatypeInfo
inst -> DatatypeInfo -> Q DatatypeInfo
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DatatypeInfo
inst
              Maybe DatatypeInfo
Nothing   -> String -> Q DatatypeInfo
forall a. String -> Q a
panic String
"lost the instance"
#endif
       Info
_ -> String -> Q DatatypeInfo
forall a. String -> Q a
panic String
"unexpected parent"
  where
    dataFamiliesOnOldGHCsError :: Q a
    dataFamiliesOnOldGHCsError :: forall a. Q a
dataFamiliesOnOldGHCsError = 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
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": Data family instances can only be reified with GHC 7.4 or later"

    panic :: String -> Q a
    panic :: forall a. String -> Q a
panic String
message = 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
"PANIC: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message

#if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0))

-- A GHC 7.6-specific bug requires us to replace all occurrences of
-- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.
-- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.
sanitizeStars :: Kind -> Kind
sanitizeStars = go
  where
    go :: Kind -> Kind
    go (AppT t1 t2)                 = AppT (go t1) (go t2)
    go (SigT t k)                   = SigT (go t) (go k)
    go (ConT n) | n == starKindName = StarT
    go t                            = t

-- A version of repairVarKindsWith that does much more extra work to
-- (1) eta-expand missing type patterns, and (2) ensure that the kind
-- signatures for these new type patterns match accordingly.
repairVarKindsWith' :: [TyVarBndrUnit] -> Maybe Kind -> [Type] -> Q [Type]
repairVarKindsWith' dvars dkind ts =
  let kindVars                = freeVariables . map kindPart
      kindPart (KindedTV _ k) = [k]
      kindPart (PlainTV  _  ) = []

      nparams             = length dvars
      kparams             = kindVars dvars
      (tsKinds,tsNoKinds) = splitAt (length kparams) ts
      tsKinds'            = map sanitizeStars tsKinds
      extraTys            = drop (length tsNoKinds) (bndrParams dvars)
      ts'                 = tsNoKinds ++ extraTys -- eta-expand
  in fmap (applySubstitution (Map.fromList (zip kparams tsKinds'))) $
     repairVarKindsWith dvars dkind ts'


-- Sadly, Template Haskell's treatment of data family instances leaves much
-- to be desired. Here are some problems that we have to work around:
--
-- 1. On all versions of GHC, TH leaves off the kind signatures on the
--    type patterns of data family instances where a kind signature isn't
--    specified explicitly. Here, we can use the parent data family's
--    type variable binders to reconstruct the kind signatures if they
--    are missing.
-- 2. On GHC 7.6 and 7.8, TH will eta-reduce data instances. We can find
--    the missing type variables on the data constructor.
--
-- We opt to avoid propagating these new type variables through to the
-- constructor now, but we will return to this task in normalizeCon.
repairDataFam ::
  Dec {- ^ family declaration   -} ->
  Dec {- ^ instance declaration -} ->
  Q Dec {- ^ instance declaration -}

repairDataFam
  (FamilyD _ _ dvars dk)
  (NewtypeInstD cx n ts con deriv) = do
    ts' <- repairVarKindsWith' dvars dk ts
    return $ NewtypeInstD cx n ts' con deriv
repairDataFam
  (FamilyD _ _ dvars dk)
  (DataInstD cx n ts cons deriv) = do
    ts' <- repairVarKindsWith' dvars dk ts
    return $ DataInstD cx n ts' cons deriv
#else
repairDataFam :: Dec -> Dec -> Q Dec
repairDataFam Dec
famD Dec
instD
# if MIN_VERSION_template_haskell(2,15,0)
      | DataFamilyD Name
_ [TyVarBndrUnit]
dvars Maybe Type
dk <- Dec
famD
      , NewtypeInstD [Type]
cx Maybe [TyVarBndrUnit]
mbInstVars Type
nts Maybe Type
k Con
c [DerivClause]
deriv <- Dec
instD
      , Type
con :| [Type]
ts <- Type -> NonEmpty Type
decomposeType Type
nts
      = do [Type]
ts' <- [TyVarBndrUnit] -> Maybe Type -> [Type] -> Q [Type]
repairVarKindsWith [TyVarBndrUnit]
dvars Maybe Type
dk [Type]
ts
           Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type]
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD [Type]
cx Maybe [TyVarBndrUnit]
mbInstVars ((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
foldl' Type -> Type -> Type
AppT Type
con [Type]
ts') Maybe Type
k Con
c [DerivClause]
deriv

      | DataFamilyD Name
_ [TyVarBndrUnit]
dvars Maybe Type
dk <- Dec
famD
      , DataInstD [Type]
cx Maybe [TyVarBndrUnit]
mbInstVars Type
nts Maybe Type
k [Con]
c [DerivClause]
deriv <- Dec
instD
      , Type
con :| [Type]
ts <- Type -> NonEmpty Type
decomposeType Type
nts
      = do [Type]
ts' <- [TyVarBndrUnit] -> Maybe Type -> [Type] -> Q [Type]
repairVarKindsWith [TyVarBndrUnit]
dvars Maybe Type
dk [Type]
ts
           Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type]
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [Type]
cx Maybe [TyVarBndrUnit]
mbInstVars ((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
foldl' Type -> Type -> Type
AppT Type
con [Type]
ts') Maybe Type
k [Con]
c [DerivClause]
deriv
# elif MIN_VERSION_template_haskell(2,11,0)
      | DataFamilyD _ dvars dk <- famD
      , NewtypeInstD cx n ts k c deriv <- instD
      = do ts' <- repairVarKindsWith dvars dk ts
           return $ NewtypeInstD cx n ts' k c deriv

      | DataFamilyD _ dvars dk <- famD
      , DataInstD cx n ts k c deriv <- instD
      = do ts' <- repairVarKindsWith dvars dk ts
           return $ DataInstD cx n ts' k c deriv
# else
      | FamilyD _ _ dvars dk <- famD
      , NewtypeInstD cx n ts c deriv <- instD
      = do ts' <- repairVarKindsWith dvars dk ts
           return $ NewtypeInstD cx n ts' c deriv

      | FamilyD _ _ dvars dk <- famD
      , DataInstD cx n ts c deriv <- instD
      = do ts' <- repairVarKindsWith dvars dk ts
           return $ DataInstD cx n ts' c deriv
# endif
#endif
repairDataFam Dec
_ Dec
instD = Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
instD

-- | @'repairVarKindsWith' tvbs mbKind ts@ returns @ts@, but where each element
-- has an explicit kind signature taken from a 'TyVarBndr' in the corresponding
-- position in @tvbs@, or from the corresponding kind argument in 'mbKind' if
-- there aren't enough 'TyVarBndr's available. An example where @tvbs@ can be
-- shorter than @ts@ can be found in this example from #95:
--
-- @
-- data family F :: Type -> Type
-- data instance F a = C
-- @
--
-- The @F@ has no type variable binders in its @data family@ declaration, and
-- it has a return kind of @Type -> Type@. As a result, we pair up @Type@ with
-- @VarT a@ to get @SigT a (ConT ''Type)@.
repairVarKindsWith :: [TyVarBndrVis] -> Maybe Kind -> [Type] -> Q [Type]
repairVarKindsWith :: [TyVarBndrUnit] -> Maybe Type -> [Type] -> Q [Type]
repairVarKindsWith [TyVarBndrUnit]
tvbs Maybe Type
mbKind [Type]
ts = do
  [TyVarBndrUnit]
extra_tvbs <- Type -> Q [TyVarBndrUnit]
mkExtraKindBinders (Type -> Q [TyVarBndrUnit]) -> Type -> Q [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
starK Maybe Type
mbKind
  -- This list should be the same length as @ts@. If it isn't, something has
  -- gone terribly wrong.
  let tvbs' :: [TyVarBndrUnit]
tvbs' = BndrVis -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags () [TyVarBndrUnit]
tvbs [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
extra_tvbs
  [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (TyVarBndrUnit -> Type -> Type)
-> [TyVarBndrUnit] -> [Type] -> [Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TyVarBndrUnit -> Type -> Type
forall flag. TyVarBndr_ flag -> Type -> Type
stealKindForType [TyVarBndrUnit]
tvbs' [Type]
ts

-- If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.
stealKindForType :: TyVarBndr_ flag -> Type -> Type
stealKindForType :: forall flag. TyVarBndr_ flag -> Type -> Type
stealKindForType TyVarBndr_ flag
tvb t :: Type
t@VarT{} = Type -> Type -> Type
SigT Type
t (TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr_ flag
tvb)
stealKindForType TyVarBndr_ flag
_   Type
t        = Type
t

-- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'.
-- Fail in 'Q' otherwise.
--
-- Beware: 'normalizeDec' can have surprising behavior when it comes to fixity.
-- For instance, if you have this quasiquoted data declaration:
--
-- @
-- [d| infix 5 :^^:
--     data Foo where
--       (:^^:) :: Int -> Int -> Foo |]
-- @
--
-- Then if you pass the 'Dec' for @Foo@ to 'normalizeDec' without splicing it
-- in a previous Template Haskell splice, then @(:^^:)@ will be labeled a 'NormalConstructor'
-- instead of an 'InfixConstructor'. This is because Template Haskell has no way to
-- reify the fixity declaration for @(:^^:)@, so it must assume there isn't one. To
-- work around this behavior, use 'reifyDatatype' instead.
normalizeDec :: Dec -> Q DatatypeInfo
normalizeDec :: Dec -> Q DatatypeInfo
normalizeDec = Bool -> Dec -> Q DatatypeInfo
normalizeDecFor Bool
isn'tReified

normalizeDecFor :: IsReifiedDec -> Dec -> Q DatatypeInfo
normalizeDecFor :: Bool -> Dec -> Q DatatypeInfo
normalizeDecFor Bool
isReified Dec
dec =
  case Dec
dec of
#if MIN_VERSION_template_haskell(2,20,0)
    TypeDataD Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons ->
      [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataD [] Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons DatatypeVariant
TypeData
#endif
#if MIN_VERSION_template_haskell(2,12,0)
    NewtypeD [Type]
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind Con
con [DerivClause]
_derives ->
      [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataD [Type]
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con
con] DatatypeVariant
Newtype
    DataD [Type]
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons [DerivClause]
_derives ->
      [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataD [Type]
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons DatatypeVariant
Datatype
# if MIN_VERSION_template_haskell(2,15,0)
    NewtypeInstD [Type]
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys Maybe Type
mbKind Con
con [DerivClause]
_derives ->
      String
-> [Type]
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPostTH2'15 String
"newtype" [Type]
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys
                                   Maybe Type
mbKind [Con
con] DatatypeVariant
NewtypeInstance
    DataInstD [Type]
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys Maybe Type
mbKind [Con]
cons [DerivClause]
_derives ->
      String
-> [Type]
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPostTH2'15 String
"data" [Type]
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys
                                   Maybe Type
mbKind [Con]
cons DatatypeVariant
DataInstance
# else
    NewtypeInstD context name instTys mbKind con _derives ->
      normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance
    DataInstD context name instTys mbKind cons _derives ->
      normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance
# endif
#elif MIN_VERSION_template_haskell(2,11,0)
    NewtypeD context name tyvars mbKind con _derives ->
      normalizeDataD context name tyvars mbKind [con] Newtype
    DataD context name tyvars mbKind cons _derives ->
      normalizeDataD context name tyvars mbKind cons Datatype
    NewtypeInstD context name instTys mbKind con _derives ->
      normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance
    DataInstD context name instTys mbKind cons _derives ->
      normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance
#else
    NewtypeD context name tyvars con _derives ->
      normalizeDataD context name tyvars Nothing [con] Newtype
    DataD context name tyvars cons _derives ->
      normalizeDataD context name tyvars Nothing cons Datatype
    NewtypeInstD context name instTys con _derives ->
      normalizeDataInstDPreTH2'15 context name instTys Nothing [con] NewtypeInstance
    DataInstD context name instTys cons _derives ->
      normalizeDataInstDPreTH2'15 context name instTys Nothing cons DataInstance
#endif
    Dec
_ -> String -> Q DatatypeInfo
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"normalizeDecFor: DataD or NewtypeD required"
  where
    -- We only need to repair reified declarations for data family instances.
    repair13618' :: DatatypeInfo -> Q DatatypeInfo
    repair13618' :: DatatypeInfo -> Q DatatypeInfo
repair13618' di :: DatatypeInfo
di@DatatypeInfo{datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant}
      | Bool
isReified Bool -> Bool -> Bool
&& DatatypeVariant -> Bool
isFamInstVariant DatatypeVariant
variant
      = DatatypeInfo -> Q DatatypeInfo
repair13618 DatatypeInfo
di
      | Bool
otherwise
      = DatatypeInfo -> Q DatatypeInfo
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DatatypeInfo
di

    -- If a data type lacks an explicit return kind, use `reifyType` to compute
    -- it, as described in step (1) of Note [Tricky result kinds].
    normalizeMbKind :: Name -> [Type] -> Maybe Kind -> Q (Maybe Kind)
    normalizeMbKind :: Name -> [Type] -> Maybe Type -> Q (Maybe Type)
normalizeMbKind Name
_name [Type]
_instTys mbKind :: Maybe Type
mbKind@(Just Type
_) = Maybe Type -> Q (Maybe Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
mbKind
    normalizeMbKind Name
name [Type]
instTys Maybe Type
Nothing = do
#if MIN_VERSION_template_haskell(2,16,0)
      Maybe Type
mbReifiedKind <- Maybe Type -> Q (Maybe Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing Q (Maybe Type) -> Q (Maybe Type) -> Q (Maybe Type)
forall a. Q a -> Q a -> Q a
`recover` (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Q Type
reifyType Name
name)
      (Type -> Q Type) -> Maybe Type -> Q (Maybe Type)
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) -> Maybe a -> m (Maybe b)
T.mapM Type -> Q Type
normalizeKind Maybe Type
mbReifiedKind
      where
        normalizeKind :: Kind -> Q Kind
        normalizeKind :: Type -> Q Type
normalizeKind Type
k = do
          Type
k' <- Type -> Q Type
resolveKindSynonyms Type
k
          -- Step (1) in Note [Tricky result kinds]
          -- (Wrinkle: normalizeMbKind argument unification).
          let ([(Type, VisFunArg)]
args, Type
res) = [Type] -> Type -> ([(Type, VisFunArg)], Type)
forall a. [a] -> Type -> ([(a, VisFunArg)], Type)
unravelKindUpTo [Type]
instTys Type
k'
              -- Step (2) in Note [Tricky result kinds]
              -- (Wrinkle: normalizeMbKind argument unification).
              ([Type]
instTys', [Type]
args') =
                [(Type, Type)] -> ([Type], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Type, Type)] -> ([Type], [Type]))
-> [(Type, Type)] -> ([Type], [Type])
forall a b. (a -> b) -> a -> b
$
                ((Type, VisFunArg) -> Maybe (Type, Type))
-> [(Type, VisFunArg)] -> [(Type, Type)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                  (\(Type
instTy, VisFunArg
arg) ->
                    case VisFunArg
arg of
                      VisFADep TyVarBndrUnit
tvb -> (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
instTy, TyVarBndrUnit -> Type
forall flag. TyVarBndr_ flag -> Type
bndrParam TyVarBndrUnit
tvb)
                      VisFAAnon Type
k  -> (, Type
k) (Type -> (Type, Type)) -> Maybe Type -> Maybe (Type, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Type
sigTMaybeKind Type
instTy)
                  [(Type, VisFunArg)]
args
              (Map Name Name
subst, [Type]
_) = [Type] -> [Type] -> (Map Name Name, [Type])
mergeArguments [Type]
args' [Type]
instTys'
          -- Step (3) in Note [Tricky result kinds]
          -- (Wrinkle: normalizeMbKind argument unification).
          Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution (Name -> Type
VarT (Name -> Type) -> Map Name Name -> Map Name Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Name
subst) Type
res
#else
      return Nothing
#endif

    -- Given a data type declaration's binders, as well as the arguments and
    -- result of its explicit return kind, compute the free type variables.
    -- For example, this:
    --
    -- @
    -- data T (a :: j) :: forall k. Maybe k -> Type
    -- @
    --
    -- Would yield:
    --
    -- @
    -- [j, (a :: j), k, (b :: k)]
    -- @
    --
    -- Where @b@ is a fresh name that is generated in 'mkExtraFunArgForalls'.
    datatypeFreeVars :: [TyVarBndr_ flag] -> FunArgs -> Kind -> [TyVarBndrUnit]
    datatypeFreeVars :: forall flag.
[TyVarBndr_ flag] -> FunArgs -> Type -> [TyVarBndrUnit]
datatypeFreeVars [TyVarBndr_ flag]
declBndrs FunArgs
kindArgs Type
kindRes =
      [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped ([Type] -> [TyVarBndrUnit]) -> [Type] -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ [TyVarBndr_ flag] -> [Type]
forall flag. [TyVarBndr_ flag] -> [Type]
bndrParams [TyVarBndr_ flag]
declBndrs [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++
#if MIN_VERSION_template_haskell(2,8,0)
        FunArgs -> [Type]
funArgTys FunArgs
kindArgs [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
kindRes]
#else
        [] -- No kind variables
#endif

    normalizeDataD :: Cxt -> Name -> [TyVarBndrVis] -> Maybe Kind
                   -> [Con] -> DatatypeVariant -> Q DatatypeInfo
    normalizeDataD :: [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataD [Type]
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons DatatypeVariant
variant = do
      -- NB: use `filter isRequiredTvb tyvars` here. It is possible for some of
      -- the `tyvars` to be `BndrInvis` if the data type is quoted, e.g.,
      --
      --   data D @k (a :: k)
      --
      -- th-abstraction adopts the convention that all binders in the
      -- 'datatypeInstTypes' are required, so we want to filter out the `@k`.
      let tys :: [Type]
tys = [TyVarBndrUnit] -> [Type]
forall flag. [TyVarBndr_ flag] -> [Type]
bndrParams ([TyVarBndrUnit] -> [Type]) -> [TyVarBndrUnit] -> [Type]
forall a b. (a -> b) -> a -> b
$ (TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. (a -> Bool) -> [a] -> [a]
filter TyVarBndrUnit -> Bool
isRequiredTvb [TyVarBndrUnit]
tyvars
      Maybe Type
mbKind' <- Name -> [Type] -> Maybe Type -> Q (Maybe Type)
normalizeMbKind Name
name [Type]
tys Maybe Type
mbKind
      [Type]
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
forall flag.
[Type]
-> Name
-> [TyVarBndr_ flag]
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' [Type]
context Name
name [TyVarBndrUnit]
tyvars [Type]
tys Maybe Type
mbKind' [Con]
cons DatatypeVariant
variant

    normalizeDataInstDPostTH2'15
      :: String -> Cxt -> Maybe [TyVarBndrUnit] -> Type -> Maybe Kind
      -> [Con] -> DatatypeVariant -> Q DatatypeInfo
    normalizeDataInstDPostTH2'15 :: String
-> [Type]
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPostTH2'15 String
what [Type]
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys
                                 Maybe Type
mbKind [Con]
cons DatatypeVariant
variant =
      case Type -> NonEmpty Type
decomposeType Type
nameInstTys of
        ConT Name
name :| [Type]
instTys -> do
          Maybe Type
mbKind' <- Name -> [Type] -> Maybe Type -> Q (Maybe Type)
normalizeMbKind Name
name [Type]
instTys Maybe Type
mbKind
          [Type]
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
forall flag.
[Type]
-> Name
-> [TyVarBndr_ flag]
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' [Type]
context Name
name
                     ([TyVarBndrUnit] -> Maybe [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. a -> Maybe a -> a
fromMaybe ([Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type]
instTys) Maybe [TyVarBndrUnit]
mbTyvars)
                     [Type]
instTys Maybe Type
mbKind' [Con]
cons DatatypeVariant
variant
        NonEmpty Type
_ -> String -> Q DatatypeInfo
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q DatatypeInfo) -> String -> Q DatatypeInfo
forall a b. (a -> b) -> a -> b
$ String
"Unexpected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" instance head: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
nameInstTys

    normalizeDataInstDPreTH2'15
      :: Cxt -> Name -> [Type] -> Maybe Kind
      -> [Con] -> DatatypeVariant -> Q DatatypeInfo
    normalizeDataInstDPreTH2'15 :: [Type]
-> Name
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPreTH2'15 [Type]
context Name
name [Type]
instTys Maybe Type
mbKind [Con]
cons DatatypeVariant
variant = do
      Maybe Type
mbKind' <- Name -> [Type] -> Maybe Type -> Q (Maybe Type)
normalizeMbKind Name
name [Type]
instTys Maybe Type
mbKind
      [Type]
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
forall flag.
[Type]
-> Name
-> [TyVarBndr_ flag]
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' [Type]
context Name
name ([Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type]
instTys)
                 [Type]
instTys Maybe Type
mbKind' [Con]
cons DatatypeVariant
variant

    -- The main worker of this function.
    normalize' :: Cxt -> Name -> [TyVarBndr_ flag] -> [Type] -> Maybe Kind
               -> [Con] -> DatatypeVariant -> Q DatatypeInfo
    normalize' :: forall flag.
[Type]
-> Name
-> [TyVarBndr_ flag]
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' [Type]
context Name
name [TyVarBndr_ flag]
tvbs [Type]
instTys Maybe Type
mbKind [Con]
cons DatatypeVariant
variant = do
      -- If `mbKind` is *still* Nothing after all of the work done in
      -- normalizeMbKind, then conservatively assume that the return kind is
      -- `Type`. See step (1) of Note [Tricky result kinds].
      let kind :: Type
kind = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
starK Maybe Type
mbKind
      Type
kind' <- Type -> Q Type
resolveKindSynonyms Type
kind
      let (FunArgs
kindArgs, Type
kindRes) = Type -> (FunArgs, Type)
unravelKind Type
kind'
      ([TyVarBndrUnit]
extra_vis_tvbs, FunArgs
kindArgs') <- FunArgs -> Q ([TyVarBndrUnit], FunArgs)
mkExtraFunArgForalls FunArgs
kindArgs
      let tvbs' :: [TyVarBndrUnit]
tvbs'    = [TyVarBndr_ flag] -> FunArgs -> Type -> [TyVarBndrUnit]
forall flag.
[TyVarBndr_ flag] -> FunArgs -> Type -> [TyVarBndrUnit]
datatypeFreeVars [TyVarBndr_ flag]
tvbs FunArgs
kindArgs' Type
kindRes
          instTys' :: [Type]
instTys' = [Type]
instTys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit] -> [Type]
forall flag. [TyVarBndr_ flag] -> [Type]
bndrParams [TyVarBndrUnit]
extra_vis_tvbs
      DatatypeInfo
dec <- Bool
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDec' Bool
isReified [Type]
context Name
name [TyVarBndrUnit]
tvbs' [Type]
instTys' Type
kindRes [Con]
cons DatatypeVariant
variant
      DatatypeInfo -> Q DatatypeInfo
repair13618' (DatatypeInfo -> Q DatatypeInfo) -> DatatypeInfo -> Q DatatypeInfo
forall a b. (a -> b) -> a -> b
$ Bool -> DatatypeInfo -> DatatypeInfo
giveDIVarsStarKinds Bool
isReified DatatypeInfo
dec

{-
Note [Tricky result kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this example, which uses UnliftedNewtypes:

  type T :: TYPE r
  newtype T where
    MkT :: forall r. Any @(TYPE r) -> T @r

This has one universally quantified type variable `r`, but making
`reifyDatatype ''T` realize this is surprisingly tricky. There root of the
trickiness is the fact that `Language.Haskell.TH.reify ''T` will yield this:

  newtype T where
    MkT :: forall r. (Any :: TYPE r) -> (T :: TYPE r)

In particular, note that:

1. `reify` does not give `T` an explicit return kind of `TYPE r`. This is bad,
   because without this, we cannot conclude that `r` is universally quantified.
2. The reified type of the `MkT` constructor uses explicit kind annotations
   instead of visible kind applications. That is, the return type is
   `T :: TYPE r` instead of `T @r`. This makes it even trickier to figure out
   that `r` is universally quantified, as `r` does not appear directly
   underneath an application of `T`.

We resolve each of these issues as follows:

1. In `normalizeDecFor.normalizeMbKind`, we attempt to use `reifyType` to look
   up the return kind of the data type. In the `T` example above, this suffices
   to conclude that `T :: TYPE r`. `reifyType` won't always work (e.g., when
   using `normalizeDec` on a data type without an explicit return kind), so for
   those situations, we conservatively assume that the data type has return kind
   `Type`.

   The implementation of `normalizeMbKind` is somewhat involved. See
   "Wrinkle: normalizeMbKind argument unification" below for more details.
2. After determining the result kind `K1`, we pass `K1` through to
   `normalizeGadtC`. In that function, we check if the return type of the data
   constructor is of the form `Ty :: K2`, and if so, we attempt to unify `K1`
   and `K2` by passing through to `mergeArguments`. In the example above, this
   lets us conclude that the `r` in the data type return kind is the same `r`
   as in the data constructor.

===================================================
== Wrinkle: normalizeMbKind argument unification ==
===================================================

Here is a slightly more involved example:

  type T2 :: TYPE r1 -> TYPE r1
  newtype T2 (a :: TYPE r2) = MkT2 a

Here, we must use `reifyType` in `normalizeMbKind` to determine that the return
kind is `TYPE r1`. But we must be careful here: `r1` is actually the same type
variable as `r2`! We don't want to accidentally end up quantifying over the two
variables separately in `datatypeInstVars`, since they're really one and the
same.

We accomplish this by doing the following:

1. After calling `reifyKind` in `normalizeMbKind`, split the result kind into
   as many arguments as there are visible binders in the data type declaration.
   In the `T2` example above, there is exactly one visible binder in
   `newtype T2 a`, so we split the kind `TYPE r1 -> TYPE r1` by one argument to
   get ([TYPE r1], TYPE r1). See `unravelKindUpTo` for how this splitting logic
   is implemented.
2. We then unify the argument kinds resuling from the splitting in the previous
   step with the corresponding kinds from the data type declaration. In the
   example above, the split argument kind is `TYPE r1`, and the binder in the
   declaration has kind `TYPE r2`, so we unify `TYPE r1` with `TYPE r2` using
   `mergeArgumentKinds` to get a substitution [r1 :-> r2].
3. We then apply the substitution from the previous step to the rest of the
   kind. In the example above, that means we apply the [r1 :-> r2] substitution
   to `TYPE r1` to obtain `TYPE r2`.

The payoff is that everything consistently refers to `r2`, rather than the mix
of `r1` and `r2` as before.
-}

-- | Create new kind variable binder names corresponding to the return kind of
-- a data type. This is useful when you have a data type like:
--
-- @
-- data Foo :: forall k. k -> Type -> Type where ...
-- @
--
-- But you want to be able to refer to the type @Foo a b@.
-- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@,
-- discover that is has two visible argument kinds, and return as a result
-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@
-- are fresh type variable names.
--
-- This expands kind synonyms if necessary.
mkExtraKindBinders :: Kind -> Q [TyVarBndrUnit]
mkExtraKindBinders :: Type -> Q [TyVarBndrUnit]
mkExtraKindBinders Type
kind = do
  Type
kind' <- Type -> Q Type
resolveKindSynonyms Type
kind
  let (FunArgs
args, Type
_) = Type -> (FunArgs, Type)
unravelKind Type
kind'
  ([TyVarBndrUnit]
extra_kvbs, FunArgs
_) <- FunArgs -> Q ([TyVarBndrUnit], FunArgs)
mkExtraFunArgForalls FunArgs
args
  [TyVarBndrUnit] -> Q [TyVarBndrUnit]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [TyVarBndrUnit]
extra_kvbs

-- | Take the supplied function kind arguments ('FunArgs') and do two things:
--
-- 1. For each 'FAAnon' with kind @k@, generate a fresh name @a@ and return
--    the 'TyVarBndr' @a :: k@. Also return each visible @forall@ in an
--    'FAForalls' as a 'TyVarBndr'. (This is what the list of 'TyVarBndrUnit's
--    in the return type consists of.)
--
-- 2. Return a new 'FunArgs' value where each 'FAAnon' has been replaced with
--    @'FAForalls' ('ForallVis' [a :: k])@, where @a :: k@ the corresponding
--    'TyVarBndr' computed in step (1).
--
-- As an example, consider this function kind:
--
-- @
-- forall k. k -> Type -> Type
-- @
--
-- After splitting this kind into its 'FunArgs':
--
-- @
-- ['FAForalls' ('ForallInvis' [k]), 'FAAnon' k, 'FAAnon' Type]
-- @
--
-- Calling 'mkExtraFunArgForalls' on this 'FunArgs' value would return:
--
-- @
-- ( [a :: k, b :: Type]
-- , [ 'FAForalls' ('ForallInvis' [k])
--   , 'FAForalls' ('ForallVis' [a :: k])
--   , 'FAForalls' ('ForallVis' [b :: Type])
--   ]
-- )
-- @
--
-- Where @a@ and @b@ are fresh.
--
-- This function is used in two places:
--
-- 1. As the workhorse for 'mkExtraKindBinders'.
--
-- 2. In 'normalizeDecFor', as part of computing the 'datatypeInstVars' and as
--    part of eta expanding the explicit return kind.
mkExtraFunArgForalls :: FunArgs -> Q ([TyVarBndrUnit], FunArgs)
mkExtraFunArgForalls :: FunArgs -> Q ([TyVarBndrUnit], FunArgs)
mkExtraFunArgForalls FunArgs
FANil =
  ([TyVarBndrUnit], FunArgs) -> Q ([TyVarBndrUnit], FunArgs)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FunArgs
FANil)
mkExtraFunArgForalls (FAForalls ForallTelescope
tele FunArgs
args) = do
  ([TyVarBndrUnit]
extra_vis_tvbs', FunArgs
args') <- FunArgs -> Q ([TyVarBndrUnit], FunArgs)
mkExtraFunArgForalls FunArgs
args
  case ForallTelescope
tele of
    ForallVis [TyVarBndrUnit]
tvbs ->
      ([TyVarBndrUnit], FunArgs) -> Q ([TyVarBndrUnit], FunArgs)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [TyVarBndrUnit]
tvbs [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
extra_vis_tvbs'
             , ForallTelescope -> FunArgs -> FunArgs
FAForalls ([TyVarBndrUnit] -> ForallTelescope
ForallVis [TyVarBndrUnit]
tvbs) FunArgs
args'
             )
    ForallInvis [TyVarBndrSpec]
tvbs ->
      ([TyVarBndrUnit], FunArgs) -> Q ([TyVarBndrUnit], FunArgs)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [TyVarBndrUnit]
extra_vis_tvbs'
             , ForallTelescope -> FunArgs -> FunArgs
FAForalls ([TyVarBndrSpec] -> ForallTelescope
ForallInvis [TyVarBndrSpec]
tvbs) FunArgs
args'
             )
mkExtraFunArgForalls (FACxt [Type]
ctxt FunArgs
args) = do
  ([TyVarBndrUnit]
extra_vis_tvbs', FunArgs
args') <- FunArgs -> Q ([TyVarBndrUnit], FunArgs)
mkExtraFunArgForalls FunArgs
args
  ([TyVarBndrUnit], FunArgs) -> Q ([TyVarBndrUnit], FunArgs)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndrUnit]
extra_vis_tvbs', [Type] -> FunArgs -> FunArgs
FACxt [Type]
ctxt FunArgs
args')
mkExtraFunArgForalls (FAAnon Type
anon FunArgs
args) = do
  Name
name <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  let tvb :: TyVarBndrUnit
tvb = Name -> Type -> TyVarBndrUnit
kindedTV Name
name Type
anon
  ([TyVarBndrUnit]
extra_vis_tvbs', FunArgs
args') <- FunArgs -> Q ([TyVarBndrUnit], FunArgs)
mkExtraFunArgForalls FunArgs
args
  ([TyVarBndrUnit], FunArgs) -> Q ([TyVarBndrUnit], FunArgs)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ( TyVarBndrUnit
tvb TyVarBndrUnit -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. a -> [a] -> [a]
: [TyVarBndrUnit]
extra_vis_tvbs'
         , ForallTelescope -> FunArgs -> FunArgs
FAForalls ([TyVarBndrUnit] -> ForallTelescope
ForallVis [TyVarBndrUnit
tvb]) FunArgs
args'
         )

-- | Is a declaration for a @data instance@ or @newtype instance@?
isFamInstVariant :: DatatypeVariant -> Bool
isFamInstVariant :: DatatypeVariant -> Bool
isFamInstVariant DatatypeVariant
dv =
  case DatatypeVariant
dv of
    DatatypeVariant
Datatype        -> Bool
False
    DatatypeVariant
Newtype         -> Bool
False
    DatatypeVariant
DataInstance    -> Bool
True
    DatatypeVariant
NewtypeInstance -> Bool
True
    DatatypeVariant
TypeData        -> Bool
False

bndrParams :: [TyVarBndr_ flag] -> [Type]
bndrParams :: forall flag. [TyVarBndr_ flag] -> [Type]
bndrParams = (TyVarBndr_ flag -> Type) -> [TyVarBndr_ flag] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
bndrParam

bndrParam :: TyVarBndr_ flag -> Type
bndrParam :: forall flag. TyVarBndr_ flag -> Type
bndrParam = (Name -> Type) -> (Name -> Type -> Type) -> TyVarBndr_ flag -> Type
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV Name -> Type
VarT (\Name
n Type
k -> Type -> Type -> Type
SigT (Name -> Type
VarT Name
n) Type
k)

-- | Returns 'True' if the flag of the supplied 'TyVarBndrVis' is 'BndrReq'.
isRequiredTvb :: TyVarBndrVis -> Bool
#if __GLASGOW_HASKELL__ >= 708
isRequiredTvb :: TyVarBndrUnit -> Bool
isRequiredTvb TyVarBndrUnit
tvb = TyVarBndrUnit -> BndrVis
forall flag. TyVarBndr_ flag -> flag
tvFlag TyVarBndrUnit
tvb BndrVis -> BndrVis -> Bool
forall a. Eq a => a -> a -> Bool
== BndrVis
BndrReq
#else
isRequiredTvb _ = True
#endif

-- | Remove the outermost 'SigT'.
stripSigT :: Type -> Type
stripSigT :: Type -> Type
stripSigT (SigT Type
t Type
_) = Type
t
stripSigT Type
t          = Type
t

-- | If the supplied 'Type' is a @'SigT' _ k@, return @'Just' k@. Otherwise,
-- return 'Nothing'.
sigTMaybeKind :: Type -> Maybe Kind
sigTMaybeKind :: Type -> Maybe Type
sigTMaybeKind (SigT Type
_ Type
k) = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
k
sigTMaybeKind Type
_          = Maybe Type
forall a. Maybe a
Nothing

normalizeDec' ::
  IsReifiedDec    {- ^ Is this a reified 'Dec'? -} ->
  Cxt             {- ^ Datatype context         -} ->
  Name            {- ^ Type constructor         -} ->
  [TyVarBndrUnit] {- ^ Type parameters          -} ->
  [Type]          {- ^ Argument types           -} ->
  Kind            {- ^ Result kind              -} ->
  [Con]           {- ^ Constructors             -} ->
  DatatypeVariant {- ^ Extra information        -} ->
  Q DatatypeInfo
normalizeDec' :: Bool
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDec' Bool
reifiedDec [Type]
context Name
name [TyVarBndrUnit]
params [Type]
instTys Type
resKind [Con]
cons DatatypeVariant
variant =
  do [ConstructorInfo]
cons' <- [[ConstructorInfo]] -> [ConstructorInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ConstructorInfo]] -> [ConstructorInfo])
-> Q [[ConstructorInfo]] -> Q [ConstructorInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q [ConstructorInfo]) -> [Con] -> Q [[ConstructorInfo]]
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 (Bool
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Type
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeConFor Bool
reifiedDec Name
name [TyVarBndrUnit]
params [Type]
instTys Type
resKind DatatypeVariant
variant) [Con]
cons
     DatatypeInfo -> Q DatatypeInfo
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DatatypeInfo
       { datatypeContext :: [Type]
datatypeContext   = [Type]
context
       , datatypeName :: Name
datatypeName      = Name
name
       , datatypeVars :: [TyVarBndrUnit]
datatypeVars      = [TyVarBndrUnit]
params
       , datatypeInstTypes :: [Type]
datatypeInstTypes = [Type]
instTys
       , datatypeCons :: [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons'
       , datatypeReturnKind :: Type
datatypeReturnKind = Type
resKind
       , datatypeVariant :: DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
       }

-- | Normalize a 'Con' into a 'ConstructorInfo'. This requires knowledge of
-- the type and parameters of the constructor, as well as whether the constructor
-- is for a data family instance, as extracted from the outer
-- 'Dec'.
normalizeCon ::
  Name            {- ^ Type constructor  -} ->
  [TyVarBndrUnit] {- ^ Type parameters   -} ->
  [Type]          {- ^ Argument types    -} ->
  Kind            {- ^ Result kind       -} ->
  DatatypeVariant {- ^ Extra information -} ->
  Con             {- ^ Constructor       -} ->
  Q [ConstructorInfo]
normalizeCon :: Name
-> [TyVarBndrUnit]
-> [Type]
-> Type
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeCon = Bool
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Type
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeConFor Bool
isn'tReified

normalizeConFor ::
  IsReifiedDec    {- ^ Is this a reified 'Dec'? -} ->
  Name            {- ^ Type constructor         -} ->
  [TyVarBndrUnit] {- ^ Type parameters          -} ->
  [Type]          {- ^ Argument types           -} ->
  Kind            {- ^ Result kind              -} ->
  DatatypeVariant {- ^ Extra information        -} ->
  Con             {- ^ Constructor              -} ->
  Q [ConstructorInfo]
normalizeConFor :: Bool
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Type
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeConFor Bool
reifiedDec Name
typename [TyVarBndrUnit]
params [Type]
instTys Type
resKind DatatypeVariant
variant =
  ([ConstructorInfo] -> [ConstructorInfo])
-> Q [ConstructorInfo] -> Q [ConstructorInfo]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ConstructorInfo -> ConstructorInfo)
-> [ConstructorInfo] -> [ConstructorInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> ConstructorInfo -> ConstructorInfo
giveCIVarsStarKinds Bool
reifiedDec)) (Q [ConstructorInfo] -> Q [ConstructorInfo])
-> (Con -> Q [ConstructorInfo]) -> Con -> Q [ConstructorInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Con -> Q [ConstructorInfo]
dispatch
  where
    -- A GADT constructor is declared infix when:
    --
    -- 1. Its name uses operator syntax (e.g., (:*:))
    -- 2. It has exactly two fields
    -- 3. It has a programmer-supplied fixity declaration
    checkGadtFixity :: [Type] -> Name -> Q ConstructorVariant
    checkGadtFixity :: [Type] -> Name -> Q ConstructorVariant
checkGadtFixity [Type]
ts Name
n = do
#if MIN_VERSION_template_haskell(2,11,0)
      -- Don't call reifyFixityCompat here! We need to be able to distinguish
      -- between a default fixity and an explicit @infixl 9@.
      Maybe Fixity
mbFi <- Maybe Fixity -> Q (Maybe Fixity)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Fixity
forall a. Maybe a
Nothing Q (Maybe Fixity) -> Q (Maybe Fixity) -> Q (Maybe Fixity)
forall a. Q a -> Q a -> Q a
`recover` Name -> Q (Maybe Fixity)
reifyFixity Name
n
      let userSuppliedFixity :: Bool
userSuppliedFixity = Maybe Fixity -> Bool
forall a. Maybe a -> Bool
isJust Maybe Fixity
mbFi
#else
      -- On old GHCs, there is a bug where infix GADT constructors will
      -- mistakenly be marked as (ForallC (NormalC ...)) instead of
      -- (ForallC (InfixC ...)). This is especially annoying since on these
      -- versions of GHC, Template Haskell doesn't grant the ability to query
      -- whether a constructor was given a user-supplied fixity declaration.
      -- Rather, you can only check the fixity that GHC ultimately decides on
      -- for a constructor, regardless of whether it was a default fixity or
      -- it was user-supplied.
      --
      -- We can approximate whether a fixity was user-supplied by checking if
      -- it is not equal to defaultFixity (infixl 9). Unfortunately,
      -- there is no way to distinguish between a user-supplied fixity of
      -- infixl 9 and the fixity that GHC defaults to, so we cannot properly
      -- handle that case.
      mbFi <- reifyFixityCompat n
      let userSuppliedFixity = isJust mbFi && mbFi /= Just defaultFixity
#endif
      ConstructorVariant -> Q ConstructorVariant
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorVariant -> Q ConstructorVariant)
-> ConstructorVariant -> Q ConstructorVariant
forall a b. (a -> b) -> a -> b
$ if String -> Bool
isInfixDataCon (Name -> String
nameBase Name
n)
                  Bool -> Bool -> Bool
&& [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
                  Bool -> Bool -> Bool
&& Bool
userSuppliedFixity
               then ConstructorVariant
InfixConstructor
               else ConstructorVariant
NormalConstructor

    -- Checks if a String names a valid Haskell infix data
    -- constructor (i.e., does it begin with a colon?).
    isInfixDataCon :: String -> Bool
    isInfixDataCon :: String -> Bool
isInfixDataCon (Char
':':String
_) = Bool
True
    isInfixDataCon String
_       = Bool
False

    dispatch :: Con -> Q [ConstructorInfo]
    dispatch :: Con -> Q [ConstructorInfo]
dispatch =
      let defaultCase :: Con -> Q [ConstructorInfo]
          defaultCase :: Con -> Q [ConstructorInfo]
defaultCase = [TyVarBndrUnit] -> [Type] -> Bool -> Con -> Q [ConstructorInfo]
go [] [] Bool
False
            where
              go :: [TyVarBndrUnit]
                 -> Cxt
                 -> Bool -- Is this a GADT? (see the documentation for
                         -- for checkGadtFixity)
                 -> Con
                 -> Q [ConstructorInfo]
              go :: [TyVarBndrUnit] -> [Type] -> Bool -> Con -> Q [ConstructorInfo]
go [TyVarBndrUnit]
tyvars [Type]
context Bool
gadt Con
c =
                case Con
c of
                  NormalC Name
n [BangType]
xs -> do
                    let ([Bang]
bangs, [Type]
ts) = [BangType] -> ([Bang], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip [BangType]
xs
                        stricts :: [FieldStrictness]
stricts     = (Bang -> FieldStrictness) -> [Bang] -> [FieldStrictness]
forall a b. (a -> b) -> [a] -> [b]
map Bang -> FieldStrictness
normalizeStrictness [Bang]
bangs
                    ConstructorVariant
fi <- if Bool
gadt
                             then [Type] -> Name -> Q ConstructorVariant
checkGadtFixity [Type]
ts Name
n
                             else ConstructorVariant -> Q ConstructorVariant
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ConstructorVariant
NormalConstructor
                    [ConstructorInfo] -> Q [ConstructorInfo]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
-> [TyVarBndrUnit]
-> [Type]
-> [Type]
-> [FieldStrictness]
-> ConstructorVariant
-> ConstructorInfo
ConstructorInfo Name
n [TyVarBndrUnit]
tyvars [Type]
context [Type]
ts [FieldStrictness]
stricts ConstructorVariant
fi]
                  InfixC BangType
l Name
n BangType
r ->
                    let ([Bang]
bangs, [Type]
ts) = [BangType] -> ([Bang], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip [BangType
l,BangType
r]
                        stricts :: [FieldStrictness]
stricts     = (Bang -> FieldStrictness) -> [Bang] -> [FieldStrictness]
forall a b. (a -> b) -> [a] -> [b]
map Bang -> FieldStrictness
normalizeStrictness [Bang]
bangs in
                    [ConstructorInfo] -> Q [ConstructorInfo]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
-> [TyVarBndrUnit]
-> [Type]
-> [Type]
-> [FieldStrictness]
-> ConstructorVariant
-> ConstructorInfo
ConstructorInfo Name
n [TyVarBndrUnit]
tyvars [Type]
context [Type]
ts [FieldStrictness]
stricts
                                            ConstructorVariant
InfixConstructor]
                  RecC Name
n [VarBangType]
xs ->
                    let fns :: [Name]
fns     = [VarBangType] -> [Name]
forall a b. [(Name, a, b)] -> [Name]
takeFieldNames [VarBangType]
xs
                        stricts :: [FieldStrictness]
stricts = [VarBangType] -> [FieldStrictness]
forall a b. [(a, Bang, b)] -> [FieldStrictness]
takeFieldStrictness [VarBangType]
xs in
                    [ConstructorInfo] -> Q [ConstructorInfo]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
-> [TyVarBndrUnit]
-> [Type]
-> [Type]
-> [FieldStrictness]
-> ConstructorVariant
-> ConstructorInfo
ConstructorInfo Name
n [TyVarBndrUnit]
tyvars [Type]
context
                              ([VarBangType] -> [Type]
forall a b. [(a, b, Type)] -> [Type]
takeFieldTypes [VarBangType]
xs) [FieldStrictness]
stricts ([Name] -> ConstructorVariant
RecordConstructor [Name]
fns)]
                  ForallC [TyVarBndrSpec]
tyvars' [Type]
context' Con
c' ->
                    [TyVarBndrUnit] -> [Type] -> Bool -> Con -> Q [ConstructorInfo]
go (BndrVis -> [TyVarBndrSpec] -> [TyVarBndrUnit]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags () [TyVarBndrSpec]
tyvars'[TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++[TyVarBndrUnit]
tyvars) ([Type]
context'[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++[Type]
context) Bool
True Con
c'
#if MIN_VERSION_template_haskell(2,11,0)
                  GadtC [Name]
ns [BangType]
xs Type
innerType ->
                    let ([Bang]
bangs, [Type]
ts) = [BangType] -> ([Bang], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip [BangType]
xs
                        stricts :: [FieldStrictness]
stricts     = (Bang -> FieldStrictness) -> [Bang] -> [FieldStrictness]
forall a b. (a -> b) -> [a] -> [b]
map Bang -> FieldStrictness
normalizeStrictness [Bang]
bangs in
                    [Name]
-> Type
-> [Type]
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
gadtCase [Name]
ns Type
innerType [Type]
ts [FieldStrictness]
stricts ([Type] -> Name -> Q ConstructorVariant
checkGadtFixity [Type]
ts)
                  RecGadtC [Name]
ns [VarBangType]
xs Type
innerType ->
                    let fns :: [Name]
fns     = [VarBangType] -> [Name]
forall a b. [(Name, a, b)] -> [Name]
takeFieldNames [VarBangType]
xs
                        stricts :: [FieldStrictness]
stricts = [VarBangType] -> [FieldStrictness]
forall a b. [(a, Bang, b)] -> [FieldStrictness]
takeFieldStrictness [VarBangType]
xs in
                    [Name]
-> Type
-> [Type]
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
gadtCase [Name]
ns Type
innerType ([VarBangType] -> [Type]
forall a b. [(a, b, Type)] -> [Type]
takeFieldTypes [VarBangType]
xs) [FieldStrictness]
stricts
                             (Q ConstructorVariant -> Name -> Q ConstructorVariant
forall a b. a -> b -> a
const (Q ConstructorVariant -> Name -> Q ConstructorVariant)
-> Q ConstructorVariant -> Name -> Q ConstructorVariant
forall a b. (a -> b) -> a -> b
$ ConstructorVariant -> Q ConstructorVariant
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorVariant -> Q ConstructorVariant)
-> ConstructorVariant -> Q ConstructorVariant
forall a b. (a -> b) -> a -> b
$ [Name] -> ConstructorVariant
RecordConstructor [Name]
fns)
                where
                  gadtCase :: [Name]
-> Type
-> [Type]
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
gadtCase = Name
-> [TyVarBndrUnit]
-> [Type]
-> Type
-> [TyVarBndrUnit]
-> [Type]
-> [Name]
-> Type
-> [Type]
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
normalizeGadtC Name
typename [TyVarBndrUnit]
params [Type]
instTys Type
resKind [TyVarBndrUnit]
tyvars [Type]
context
#endif
#if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0))
          dataFamCompatCase :: Con -> Q [ConstructorInfo]
          dataFamCompatCase = go []
            where
              go tyvars c =
                case c of
                  NormalC n xs ->
                    let stricts = map (normalizeStrictness . fst) xs in
                    dataFamCase' n stricts NormalConstructor
                  InfixC l n r ->
                    let stricts = map (normalizeStrictness . fst) [l,r] in
                    dataFamCase' n stricts InfixConstructor
                  RecC n xs ->
                    let stricts = takeFieldStrictness xs in
                    dataFamCase' n stricts
                                 (RecordConstructor (takeFieldNames xs))
                  ForallC tyvars' context' c' ->
                    go (tyvars'++tyvars) c'

          dataFamCase' :: Name -> [FieldStrictness]
                       -> ConstructorVariant
                       -> Q [ConstructorInfo]
          dataFamCase' n stricts variant = do
            mbInfo <- reifyMaybe n
            case mbInfo of
              Just (DataConI _ ty _ _) -> do
                let (tyvars, context, argTys :|- returnTy) = uncurryType ty
                returnTy' <- resolveTypeSynonyms returnTy
                -- Notice that we've ignored the TyVarBndrs, Cxt and argument
                -- Types from the Con argument above, as they might be scoped
                -- over eta-reduced variables. Instead of trying to figure out
                -- what the eta-reduced variables should be substituted with
                -- post facto, we opt for the simpler approach of using the
                -- context and argument types from the reified constructor
                -- Info, which will at least be correctly scoped. This will
                -- make the task of substituting those types with the variables
                -- we put in place of the eta-reduced variables
                -- (in normalizeDec) much easier.
                normalizeGadtC typename params instTys resKind tyvars context [n]
                               returnTy' argTys stricts (const $ return variant)
              _ -> fail $ unlines
                     [ "normalizeCon: Cannot reify constructor " ++ nameBase n
                     , "You are likely calling normalizeDec on GHC 7.6 or 7.8 on a data family"
                     , "whose type variables have been eta-reduced due to GHC Trac #9692."
                     , "Unfortunately, without being able to reify the constructor's type,"
                     , "there is no way to recover the eta-reduced type variables in general."
                     , "A recommended workaround is to use reifyDatatype instead."
                     ]

          -- A very ad hoc way of determining if we need to perform some extra passes
          -- to repair an eta-reduction bug for data family instances that only occurs
          -- with GHC 7.6 and 7.8. We want to avoid doing these passes if at all possible,
          -- since they require reifying extra information, and reifying during
          -- normalization can be problematic for locally declared Template Haskell
          -- splices (see ##22).
          mightHaveBeenEtaReduced :: [Type] -> Bool
          mightHaveBeenEtaReduced ts =
            case unsnoc ts of
              Nothing -> False
              Just (initTs :|- lastT) ->
                case varTName lastT of
                  Nothing -> False
                  Just n  -> not (n `elem` freeVariables initTs)

          -- If the list is empty returns 'Nothing', otherwise returns the
          -- 'init' and the 'last'.
          unsnoc :: [a] -> Maybe (NonEmptySnoc a)
          unsnoc [] = Nothing
          unsnoc (x:xs) = case unsnoc xs of
            Just (a :|- b) -> Just ((x:a) :|- b)
            Nothing        -> Just ([]    :|- x)

          -- If a Type is a VarT, find Just its Name. Otherwise, return Nothing.
          varTName :: Type -> Maybe Name
          varTName (SigT t _) = varTName t
          varTName (VarT n)   = Just n
          varTName _          = Nothing

      in case variant of
           -- On GHC 7.6 and 7.8, there's quite a bit of post-processing that
           -- needs to be performed to work around an old bug that eta-reduces the
           -- type patterns of data families (but only for reified data family instances).
           DataInstance
             | reifiedDec, mightHaveBeenEtaReduced instTys
             -> dataFamCompatCase
           NewtypeInstance
             | reifiedDec, mightHaveBeenEtaReduced instTys
             -> dataFamCompatCase
           _ -> defaultCase
#else
      in Con -> Q [ConstructorInfo]
defaultCase
#endif

#if MIN_VERSION_template_haskell(2,11,0)
normalizeStrictness :: Bang -> FieldStrictness
normalizeStrictness :: Bang -> FieldStrictness
normalizeStrictness (Bang SourceUnpackedness
upk SourceStrictness
str) =
  Unpackedness -> Strictness -> FieldStrictness
FieldStrictness (SourceUnpackedness -> Unpackedness
normalizeSourceUnpackedness SourceUnpackedness
upk)
                  (SourceStrictness -> Strictness
normalizeSourceStrictness SourceStrictness
str)
  where
    normalizeSourceUnpackedness :: SourceUnpackedness -> Unpackedness
    normalizeSourceUnpackedness :: SourceUnpackedness -> Unpackedness
normalizeSourceUnpackedness SourceUnpackedness
NoSourceUnpackedness = Unpackedness
UnspecifiedUnpackedness
    normalizeSourceUnpackedness SourceUnpackedness
SourceNoUnpack       = Unpackedness
NoUnpack
    normalizeSourceUnpackedness SourceUnpackedness
SourceUnpack         = Unpackedness
Unpack

    normalizeSourceStrictness :: SourceStrictness -> Strictness
    normalizeSourceStrictness :: SourceStrictness -> Strictness
normalizeSourceStrictness SourceStrictness
NoSourceStrictness = Strictness
UnspecifiedStrictness
    normalizeSourceStrictness SourceStrictness
SourceLazy         = Strictness
Lazy
    normalizeSourceStrictness SourceStrictness
SourceStrict       = Strictness
Strict
#else
normalizeStrictness :: Strict -> FieldStrictness
normalizeStrictness IsStrict  = isStrictAnnot
normalizeStrictness NotStrict = notStrictAnnot
# if MIN_VERSION_template_haskell(2,7,0)
normalizeStrictness Unpacked  = unpackedAnnot
# endif
#endif

normalizeGadtC ::
  Name              {- ^ Type constructor             -} ->
  [TyVarBndrUnit]   {- ^ Type parameters              -} ->
  [Type]            {- ^ Argument types               -} ->
  Kind              {- ^ Result kind                  -} ->
  [TyVarBndrUnit]   {- ^ Constructor parameters       -} ->
  Cxt               {- ^ Constructor context          -} ->
  [Name]            {- ^ Constructor names            -} ->
  Type              {- ^ Declared type of constructor -} ->
  [Type]            {- ^ Constructor field types      -} ->
  [FieldStrictness] {- ^ Constructor field strictness -} ->
  (Name -> Q ConstructorVariant)
                    {- ^ Determine a constructor variant
                         from its 'Name' -}              ->
  Q [ConstructorInfo]
normalizeGadtC :: Name
-> [TyVarBndrUnit]
-> [Type]
-> Type
-> [TyVarBndrUnit]
-> [Type]
-> [Name]
-> Type
-> [Type]
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
normalizeGadtC Name
typename [TyVarBndrUnit]
params [Type]
instTys Type
resKind [TyVarBndrUnit]
tyvars [Type]
context [Name]
names Type
innerType
               [Type]
fields [FieldStrictness]
stricts Name -> Q ConstructorVariant
getVariant =
  do -- It's possible that the constructor has implicitly quantified type
     -- variables, such as in the following example (from #58):
     --
     --   [d| data Foo where
     --         MkFoo :: a -> Foo |]
     --
     -- normalizeGadtC assumes that all type variables have binders, however,
     -- so we use freeVariablesWellScoped to obtain the implicit type
     -- variables' binders before proceeding.
     let implicitTyvars :: [TyVarBndrUnit]
implicitTyvars = [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped
                          [[TyVarBndrSpec] -> [Type] -> [Type] -> Type -> Type
curryType (Specificity -> [TyVarBndrUnit] -> [TyVarBndrSpec]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec [TyVarBndrUnit]
tyvars)
                                     [Type]
context [Type]
fields Type
innerType]
         allTyvars :: [TyVarBndrUnit]
allTyvars = [TyVarBndrUnit]
implicitTyvars [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
tyvars

     -- Due to GHC Trac #13885, it's possible that the type variables bound by
     -- a GADT constructor will shadow those that are bound by the data type.
     -- This function assumes this isn't the case in certain parts (e.g., when
     -- mergeArguments is invoked), so we do an alpha-renaming of the
     -- constructor-bound variables before proceeding. See #36 for an example
     -- of what can go wrong if this isn't done.
     let conBoundNames :: [Name]
conBoundNames =
           (TyVarBndrUnit -> [Name]) -> [TyVarBndrUnit] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\TyVarBndrUnit
tvb -> TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tvbName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (TyVarBndrUnit -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndrUnit
tvb)) [TyVarBndrUnit]
allTyvars
     Map Name Name
conSubst <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Map Name (m a) -> m (Map Name a)
T.sequence (Map Name (Q Name) -> Q (Map Name Name))
-> Map Name (Q Name) -> Q (Map Name Name)
forall a b. (a -> b) -> a -> b
$ [(Name, Q Name)] -> Map Name (Q Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Name
n, String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
n))
                                           | Name
n <- [Name]
conBoundNames ]
     let conSubst' :: Map Name Type
conSubst'     = (Name -> Type) -> Map Name Name -> Map Name Type
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT Map Name Name
conSubst
         renamedTyvars :: [TyVarBndrUnit]
renamedTyvars =
           (TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> TyVarBndrUnit)
-> (Name -> Type -> TyVarBndrUnit)
-> TyVarBndrUnit
-> TyVarBndrUnit
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
n   -> Name -> TyVarBndrUnit
plainTV  (Map Name Name
conSubst Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
n))
                       (\Name
n Type
k -> Name -> Type -> TyVarBndrUnit
kindedTV (Map Name Name
conSubst Map Name Name -> Name -> Name
forall k a. Ord k => Map k a -> k -> a
Map.! Name
n)
                                         (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' Type
k))) [TyVarBndrUnit]
allTyvars
         renamedContext :: [Type]
renamedContext   = Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' [Type]
context
         renamedInnerType :: Type
renamedInnerType = Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' Type
innerType
         renamedFields :: [Type]
renamedFields    = Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' [Type]
fields

     Type
innerType' <- Type -> Q Type
resolveTypeSynonyms Type
renamedInnerType

     -- If the return type in the data constructor is of the form `T :: K`, then
     -- return (T, Just K, Just resKind), where `resKind` is the result kind of
     -- the parent data type. Otherwise, return (T :: K, Nothing, Nothing). The
     -- two `Maybe` values are passed below to `mergeArgumentKinds` such that if
     -- they are both `Just`, then we will attempt to unify `K` and `resKind`.
     -- See step (2) of Note [Tricky result kinds].
     let (Type
innerType'', Maybe Type
mbInnerResKind, Maybe Type
mbResKind) =
           case Type
innerType' of
             SigT Type
t Type
innerResKind -> (Type
t, Type -> Maybe Type
forall a. a -> Maybe a
Just Type
innerResKind, Type -> Maybe Type
forall a. a -> Maybe a
Just Type
resKind)
             Type
_                   -> (Type
innerType', Maybe Type
forall a. Maybe a
Nothing, Maybe Type
forall a. Maybe a
Nothing)

     case Type -> NonEmpty Type
decomposeType Type
innerType'' of
       ConT Name
innerTyCon :| [Type]
ts | Name
typename Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
innerTyCon ->

         let -- See step (2) of Note [Tricky result kinds].
#if MIN_VERSION_template_haskell(2,8,0)
             instTys' :: [Type]
instTys' = Maybe Type -> [Type]
forall a. Maybe a -> [a]
maybeToList Maybe Type
mbResKind [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
instTys
             ts' :: [Type]
ts' = Maybe Type -> [Type]
forall a. Maybe a -> [a]
maybeToList Maybe Type
mbInnerResKind [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
ts
#else
             instTys' = instTys
             ts' = ts
#endif

             (Map Name Name
substName, [Type]
context1) =
               Map Name Type
-> Map Name Type
-> (Map Name Name, [Type])
-> (Map Name Name, [Type])
closeOverKinds ([TyVarBndrUnit] -> Map Name Type
forall flag. [TyVarBndr_ flag] -> Map Name Type
kindsOfFVsOfTvbs [TyVarBndrUnit]
renamedTyvars)
                              ([TyVarBndrUnit] -> Map Name Type
forall flag. [TyVarBndr_ flag] -> Map Name Type
kindsOfFVsOfTvbs [TyVarBndrUnit]
params)
                              ([Type] -> [Type] -> (Map Name Name, [Type])
mergeArguments [Type]
instTys' [Type]
ts')
             subst :: Map Name Type
subst    = Name -> Type
VarT (Name -> Type) -> Map Name Name -> Map Name Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Name
substName
             exTyvars :: [TyVarBndrUnit]
exTyvars = [ TyVarBndrUnit
tv | TyVarBndrUnit
tv <- [TyVarBndrUnit]
renamedTyvars, Name -> Map Name Type -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember (TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tv) Map Name Type
subst ]

             -- The use of substTyVarBndrKinds below will never capture, as the
             -- range of the substitution will always use distinct names from
             -- exTyvars due to the alpha-renaming pass above.
             exTyvars' :: [TyVarBndrUnit]
exTyvars' = Map Name Type -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall flag.
Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
substTyVarBndrKinds Map Name Type
subst [TyVarBndrUnit]
exTyvars
             context2 :: [Type]
context2  = Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution   Map Name Type
subst ([Type]
context1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
renamedContext)
             fields' :: [Type]
fields'   = Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution   Map Name Type
subst [Type]
renamedFields
         in [Q ConstructorInfo] -> Q [ConstructorInfo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name
-> [TyVarBndrUnit]
-> [Type]
-> [Type]
-> [FieldStrictness]
-> ConstructorVariant
-> ConstructorInfo
ConstructorInfo Name
name [TyVarBndrUnit]
exTyvars' [Type]
context2
                                       [Type]
fields' [FieldStrictness]
stricts (ConstructorVariant -> ConstructorInfo)
-> Q ConstructorVariant -> Q ConstructorInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q ConstructorVariant
variantQ
                     | Name
name <- [Name]
names
                     , let variantQ :: Q ConstructorVariant
variantQ = Name -> Q ConstructorVariant
getVariant Name
name
                     ]

       NonEmpty Type
_ -> String -> Q [ConstructorInfo]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"normalizeGadtC: Expected type constructor application"

{-
Extend a type variable renaming subtitution and a list of equality
predicates by looking into kind information as much as possible.

Why is this necessary? Consider the following example:

  data (a1 :: k1) :~: (b1 :: k1) where
    Refl :: forall k2 (a2 :: k2). a2 :~: a2

After an initial call to mergeArguments, we will have the following
substitution and context:

* Substitution: [a2 :-> a1]
* Context: (a2 ~ b1)

We shouldn't stop there, however! We determine the existentially quantified
type variables of a constructor by filtering out those constructor-bound
variables which do not appear in the substitution that mergeArguments
returns. In this example, Refl's bound variables are k2 and a2. a2 appears
in the returned substitution, but k2 does not, which means that we would
mistakenly conclude that k2 is existential!

Although we don't have the full power of kind inference to guide us here, we
can at least do the next best thing. Generally, the datatype-bound type
variables and the constructor type variable binders contain all of the kind
information we need, so we proceed as follows:

1. Construct a map from each constructor-bound variable to its kind. (Do the
   same for each datatype-bound variable). These maps are the first and second
   arguments to closeOverKinds, respectively.
2. Call mergeArguments once on the GADT return type and datatype-bound types,
   and pass that in as the third argument to closeOverKinds.
3. For each name-name pair in the supplied substitution, check if the first and
   second names map to kinds in the first and second kind maps in
   closeOverKinds, respectively. If so, associate the first kind with the
   second kind.
4. For each kind association discovered in part (3), call mergeArguments
   on the lists of kinds. This will yield a kind substitution and kind
   equality context.
5. If the kind substitution is non-empty, then go back to step (3) and repeat
   the process on the new kind substitution and context.

   Otherwise, if the kind substitution is empty, then we have reached a fixed-
   point (i.e., we have closed over the kinds), so proceed.
6. Union up all of the substitutions and contexts, and return those.

This algorithm is not perfect, as it will only catch everything if all of
the kinds are explicitly mentioned somewhere (and not left quantified
implicitly). Thankfully, reifying data types via Template Haskell tends to
yield a healthy amount of kind signatures, so this works quite well in
practice.
-}
closeOverKinds :: Map Name Kind
               -> Map Name Kind
               -> (Map Name Name, Cxt)
               -> (Map Name Name, Cxt)
closeOverKinds :: Map Name Type
-> Map Name Type
-> (Map Name Name, [Type])
-> (Map Name Name, [Type])
closeOverKinds Map Name Type
domainFVKinds Map Name Type
rangeFVKinds = (Map Name Name, [Type]) -> (Map Name Name, [Type])
go
  where
    go :: (Map Name Name, Cxt) -> (Map Name Name, Cxt)
    go :: (Map Name Name, [Type]) -> (Map Name Name, [Type])
go (Map Name Name
subst, [Type]
context) =
      let substList :: [(Name, Name)]
substList = Map Name Name -> [(Name, Name)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Name Name
subst
          ([Type]
kindsInner, [Type]
kindsOuter) =
            [(Type, Type)] -> ([Type], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Type, Type)] -> ([Type], [Type]))
-> [(Type, Type)] -> ([Type], [Type])
forall a b. (a -> b) -> a -> b
$
            ((Name, Name) -> Maybe (Type, Type))
-> [(Name, Name)] -> [(Type, Type)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Name
d, Name
r) -> do Type
d' <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
d Map Name Type
domainFVKinds
                                    Type
r' <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
r Map Name Type
rangeFVKinds
                                    (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
d', Type
r'))
                     [(Name, Name)]
substList
          (Map Name Name
kindSubst, [Type]
kindContext) = [Type] -> [Type] -> (Map Name Name, [Type])
mergeArgumentKinds [Type]
kindsOuter [Type]
kindsInner
          (Map Name Name
restSubst, [Type]
restContext)
            = if Map Name Name -> Bool
forall k a. Map k a -> Bool
Map.null Map Name Name
kindSubst -- Fixed-point calculation
                 then (Map Name Name
forall k a. Map k a
Map.empty, [])
                 else (Map Name Name, [Type]) -> (Map Name Name, [Type])
go (Map Name Name
kindSubst, [Type]
kindContext)
          finalSubst :: Map Name Name
finalSubst   = [Map Name Name] -> Map Name Name
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map Name Name
subst, Map Name Name
kindSubst, Map Name Name
restSubst]
          finalContext :: [Type]
finalContext = [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]
context, [Type]
kindContext, [Type]
restContext]
            -- Use `nub` here in an effort to minimize the number of
            -- redundant equality constraints in the returned context.
      in (Map Name Name
finalSubst, [Type]
finalContext)

-- Look into a list of types and map each free variable name to its kind.
kindsOfFVsOfTypes :: [Type] -> Map Name Kind
kindsOfFVsOfTypes :: [Type] -> Map Name Type
kindsOfFVsOfTypes = (Type -> Map Name Type) -> [Type] -> Map Name Type
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> Map Name Type
go
  where
    go :: Type -> Map Name Kind
    go :: Type -> Map Name Type
go (AppT Type
t1 Type
t2) = Type -> Map Name Type
go Type
t1 Map Name Type -> Map Name Type -> Map Name Type
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Type -> Map Name Type
go Type
t2
    go (SigT Type
t Type
k) =
      let kSigs :: Map Name Type
kSigs =
#if MIN_VERSION_template_haskell(2,8,0)
                  Type -> Map Name Type
go Type
k
#else
                  Map.empty
#endif
      in case Type
t of
           VarT Name
n -> Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n Type
k Map Name Type
kSigs
           Type
_      -> Type -> Map Name Type
go Type
t Map Name Type -> Map Name Type -> Map Name Type
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Name Type
kSigs

    go (ForallT {})    = Map Name Type
forall a. a
forallError
#if MIN_VERSION_template_haskell(2,16,0)
    go (ForallVisT {}) = Map Name Type
forall a. a
forallError
#endif

    go Type
_ = Map Name Type
forall k a. Map k a
Map.empty

    forallError :: a
    forallError :: forall a. a
forallError = String -> a
forall a. HasCallStack => String -> a
error String
"`forall` type used in data family pattern"

-- Look into a list of type variable binder and map each free variable name
-- to its kind (also map the names that KindedTVs bind to their respective
-- kinds). This function considers the kind of a PlainTV to be *.
kindsOfFVsOfTvbs :: [TyVarBndr_ flag] -> Map Name Kind
kindsOfFVsOfTvbs :: forall flag. [TyVarBndr_ flag] -> Map Name Type
kindsOfFVsOfTvbs = (TyVarBndr_ flag -> Map Name Type)
-> [TyVarBndr_ flag] -> Map Name Type
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TyVarBndr_ flag -> Map Name Type
forall flag. TyVarBndr_ flag -> Map Name Type
go
  where
    go :: TyVarBndr_ flag -> Map Name Kind
    go :: forall flag. TyVarBndr_ flag -> Map Name Type
go = (Name -> Map Name Type)
-> (Name -> Type -> Map Name Type)
-> TyVarBndr_ flag
-> Map Name Type
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
n -> Name -> Type -> Map Name Type
forall k a. k -> a -> Map k a
Map.singleton Name
n Type
starK)
                (\Name
n Type
k -> let kSigs :: Map Name Type
kSigs =
#if MIN_VERSION_template_haskell(2,8,0)
                                     [Type] -> Map Name Type
kindsOfFVsOfTypes [Type
k]
#else
                                     Map.empty
#endif
                         in Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n Type
k Map Name Type
kSigs)

mergeArguments ::
  [Type] {- ^ outer parameters                    -} ->
  [Type] {- ^ inner parameters (specializations ) -} ->
  (Map Name Name, Cxt)
mergeArguments :: [Type] -> [Type] -> (Map Name Name, [Type])
mergeArguments [Type]
ns [Type]
ts = ((Type, Type)
 -> (Map Name Name, [Type]) -> (Map Name Name, [Type]))
-> (Map Name Name, [Type])
-> [(Type, Type)]
-> (Map Name Name, [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) -> (Map Name Name, [Type]) -> (Map Name Name, [Type])
aux (Map Name Name
forall k a. Map k a
Map.empty, []) ([Type] -> [Type] -> [(Type, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
ns [Type]
ts)
  where

    aux :: (Type, Type) -> (Map Name Name, [Type]) -> (Map Name Name, [Type])
aux (Type
f `AppT` Type
x, Type
g `AppT` Type
y) (Map Name Name, [Type])
sc =
      (Type, Type) -> (Map Name Name, [Type]) -> (Map Name Name, [Type])
aux (Type
x,Type
y) ((Type, Type) -> (Map Name Name, [Type]) -> (Map Name Name, [Type])
aux (Type
f,Type
g) (Map Name Name, [Type])
sc)

    aux (VarT Name
n,Type
p) (Map Name Name
subst, [Type]
context) =
      case Type
p of
        VarT Name
m | Name
m Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n  -> (Map Name Name
subst, [Type]
context)
                   -- If the two variables are the same, don't bother extending
                   -- the substitution. (This is purely an optimization.)
               | Just Name
n' <- Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
m Map Name Name
subst
               , Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' -> (Map Name Name
subst, [Type]
context)
                   -- If a variable is already in a substitution and it maps
                   -- to the variable that we are trying to unify with, then
                   -- leave the context alone. (Not doing so caused #46.)
               | Name -> Map Name Name -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Name
m Map Name Name
subst -> (Name -> Name -> Map Name Name -> Map Name Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
m Name
n Map Name Name
subst, [Type]
context)
        Type
_ -> (Map Name Name
subst, Type -> Type -> Type
equalPred (Name -> Type
VarT Name
n) Type
p Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
context)

    aux (SigT Type
x Type
_, Type
y) (Map Name Name, [Type])
sc = (Type, Type) -> (Map Name Name, [Type]) -> (Map Name Name, [Type])
aux (Type
x,Type
y) (Map Name Name, [Type])
sc -- learn about kinds??
    -- This matches *after* VarT so that we can compute a substitution
    -- that includes the kind signature.
    aux (Type
x, SigT Type
y Type
_) (Map Name Name, [Type])
sc = (Type, Type) -> (Map Name Name, [Type]) -> (Map Name Name, [Type])
aux (Type
x,Type
y) (Map Name Name, [Type])
sc

    aux (Type, Type)
_ (Map Name Name, [Type])
sc = (Map Name Name, [Type])
sc

-- | A specialization of 'mergeArguments' to 'Kind'.
-- Needed only for backwards compatibility with older versions of
-- @template-haskell@.
mergeArgumentKinds ::
  [Kind] ->
  [Kind] ->
  (Map Name Name, Cxt)
#if MIN_VERSION_template_haskell(2,8,0)
mergeArgumentKinds :: [Type] -> [Type] -> (Map Name Name, [Type])
mergeArgumentKinds = [Type] -> [Type] -> (Map Name Name, [Type])
mergeArguments
#else
mergeArgumentKinds _ _ = (Map.empty, [])
#endif

-- | Expand all of the type synonyms in a type.
--
-- Note that this function will drop parentheses as a side effect.
resolveTypeSynonyms :: Type -> Q Type
resolveTypeSynonyms :: Type -> Q Type
resolveTypeSynonyms Type
t =
  let (Type
f, [TypeArg]
xs) = Type -> (Type, [TypeArg])
decomposeTypeArgs Type
t
      normal_xs :: [Type]
normal_xs = [TypeArg] -> [Type]
filterTANormals [TypeArg]
xs

      -- Either the type is not headed by a type synonym, or it is headed by a
      -- type synonym that is not applied to enough arguments. Leave the type
      -- alone and only expand its arguments.
      defaultCase :: Type -> Q Type
      defaultCase :: Type -> Q Type
defaultCase Type
ty = (Type -> TypeArg -> Type) -> Type -> [TypeArg] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> TypeArg -> Type
appTypeArg Type
ty ([TypeArg] -> Type) -> Q [TypeArg] -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeArg -> Q TypeArg) -> [TypeArg] -> Q [TypeArg]
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 TypeArg -> Q TypeArg
resolveTypeArgSynonyms [TypeArg]
xs

      expandCon :: Name -- The Name to check whether it is a type synonym or not
                -> Type -- The argument type to fall back on if the supplied
                        -- Name isn't a type synonym
                -> Q Type
      expandCon :: Name -> Type -> Q Type
expandCon Name
n Type
ty = do
        Maybe Info
mbInfo <- Name -> Q (Maybe Info)
reifyMaybe Name
n
        case Maybe Info
mbInfo of
          Just (TyConI (TySynD Name
_ [TyVarBndrUnit]
synvars Type
def))
            |  [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
normal_xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [TyVarBndrUnit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndrUnit]
synvars -- Don't expand undersaturated type synonyms (#88)
            -> Type -> Q Type
resolveTypeSynonyms (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ [TyVarBndrUnit] -> [Type] -> Type -> Type
forall flag. [TyVarBndr_ flag] -> [Type] -> Type -> Type
expandSynonymRHS [TyVarBndrUnit]
synvars [Type]
normal_xs Type
def
          Maybe Info
_ -> Type -> Q Type
defaultCase Type
ty

  in case Type
f of
       ForallT [TyVarBndrSpec]
tvbs [Type]
ctxt Type
body ->
         [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT ([TyVarBndrSpec] -> [Type] -> Type -> Type)
-> Q [TyVarBndrSpec] -> Q ([Type] -> Type -> Type)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (TyVarBndrSpec -> Q TyVarBndrSpec)
-> [TyVarBndrSpec] -> Q [TyVarBndrSpec]
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 TyVarBndrSpec -> Q TyVarBndrSpec
forall flag. TyVarBndr_ flag -> Q (TyVarBndr_ flag)
resolve_tvb_syns [TyVarBndrSpec]
tvbs
                   Q ([Type] -> Type -> Type) -> Q [Type] -> Q (Type -> Type)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Type -> Q Type) -> [Type] -> Q [Type]
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 Type -> Q Type
resolvePredSynonyms [Type]
ctxt
                   Q (Type -> Type) -> Q Type -> Q Type
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Type -> Q Type
resolveTypeSynonyms Type
body
       SigT Type
ty Type
ki -> do
         Type
ty' <- Type -> Q Type
resolveTypeSynonyms Type
ty
         Type
ki' <- Type -> Q Type
resolveKindSynonyms Type
ki
         Type -> Q Type
defaultCase (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
SigT Type
ty' Type
ki'
       ConT Name
n -> Name -> Type -> Q Type
expandCon Name
n Type
f
#if MIN_VERSION_template_haskell(2,11,0)
       InfixT Type
t1 Name
n Type
t2 -> do
         Type
t1' <- Type -> Q Type
resolveTypeSynonyms Type
t1
         Type
t2' <- Type -> Q Type
resolveTypeSynonyms Type
t2
         Name -> Type -> Q Type
expandCon Name
n (Type -> Name -> Type -> Type
InfixT Type
t1' Name
n Type
t2')
       UInfixT Type
t1 Name
n Type
t2 -> do
         Type
t1' <- Type -> Q Type
resolveTypeSynonyms Type
t1
         Type
t2' <- Type -> Q Type
resolveTypeSynonyms Type
t2
         Name -> Type -> Q Type
expandCon Name
n (Type -> Name -> Type -> Type
UInfixT Type
t1' Name
n Type
t2')
#endif
#if MIN_VERSION_template_haskell(2,15,0)
       ImplicitParamT String
n Type
t -> do
         String -> Type -> Type
ImplicitParamT String
n (Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveTypeSynonyms Type
t
#endif
#if MIN_VERSION_template_haskell(2,16,0)
       ForallVisT [TyVarBndrUnit]
tvbs Type
body ->
         [TyVarBndrUnit] -> Type -> Type
ForallVisT ([TyVarBndrUnit] -> Type -> Type)
-> Q [TyVarBndrUnit] -> Q (Type -> Type)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (TyVarBndrUnit -> Q TyVarBndrUnit)
-> [TyVarBndrUnit] -> Q [TyVarBndrUnit]
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 TyVarBndrUnit -> Q TyVarBndrUnit
forall flag. TyVarBndr_ flag -> Q (TyVarBndr_ flag)
resolve_tvb_syns [TyVarBndrUnit]
tvbs
                      Q (Type -> Type) -> Q Type -> Q Type
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Type -> Q Type
resolveTypeSynonyms Type
body
#endif
#if MIN_VERSION_template_haskell(2,19,0)
       PromotedInfixT Type
t1 Name
n Type
t2 -> do
         Type
t1' <- Type -> Q Type
resolveTypeSynonyms Type
t1
         Type
t2' <- Type -> Q Type
resolveTypeSynonyms Type
t2
         Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Name -> Type -> Type
PromotedInfixT Type
t1' Name
n Type
t2'
       PromotedUInfixT Type
t1 Name
n Type
t2 -> do
         Type
t1' <- Type -> Q Type
resolveTypeSynonyms Type
t1
         Type
t2' <- Type -> Q Type
resolveTypeSynonyms Type
t2
         Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Name -> Type -> Type
PromotedUInfixT Type
t1' Name
n Type
t2'
#endif
       Type
_ -> Type -> Q Type
defaultCase Type
f

-- | Expand all of the type synonyms in a 'TypeArg'.
resolveTypeArgSynonyms :: TypeArg -> Q TypeArg
resolveTypeArgSynonyms :: TypeArg -> Q TypeArg
resolveTypeArgSynonyms (TANormal Type
t) = Type -> TypeArg
TANormal (Type -> TypeArg) -> Q Type -> Q TypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveTypeSynonyms Type
t
resolveTypeArgSynonyms (TyArg Type
k)    = Type -> TypeArg
TyArg    (Type -> TypeArg) -> Q Type -> Q TypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveKindSynonyms Type
k

-- | Expand all of the type synonyms in a 'Kind'.
resolveKindSynonyms :: Kind -> Q Kind
#if MIN_VERSION_template_haskell(2,8,0)
resolveKindSynonyms :: Type -> Q Type
resolveKindSynonyms = Type -> Q Type
resolveTypeSynonyms
#else
resolveKindSynonyms = return -- One simply couldn't put type synonyms into
                             -- kinds on old versions of GHC.
#endif

-- | Expand all of the type synonyms in a the kind of a 'TyVarBndr'.
resolve_tvb_syns :: TyVarBndr_ flag -> Q (TyVarBndr_ flag)
resolve_tvb_syns :: forall flag. TyVarBndr_ flag -> Q (TyVarBndr_ flag)
resolve_tvb_syns = (Type -> Q Type) -> TyVarBndr_ flag -> Q (TyVarBndr_ flag)
forall (m :: * -> *) flag.
Monad m =>
(Type -> m Type) -> TyVarBndr_ flag -> m (TyVarBndr_ flag)
mapMTVKind Type -> Q Type
resolveKindSynonyms

expandSynonymRHS ::
  [TyVarBndr_ flag] {- ^ Substitute these variables... -} ->
  [Type]            {- ^ ...with these types... -} ->
  Type              {- ^ ...inside of this type. -} ->
  Type
expandSynonymRHS :: forall flag. [TyVarBndr_ flag] -> [Type] -> Type -> Type
expandSynonymRHS [TyVarBndr_ flag]
synvars [Type]
ts Type
def =
  let argNames :: [Name]
argNames    = (TyVarBndr_ flag -> Name) -> [TyVarBndr_ flag] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr_ flag]
synvars
      ([Type]
args,[Type]
rest) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames) [Type]
ts
      subst :: Map Name Type
subst       = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
argNames [Type]
args)
  in (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
foldl Type -> Type -> Type
AppT (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst Type
def) [Type]
rest

-- | Expand all of the type synonyms in a 'Pred'.
resolvePredSynonyms :: Pred -> Q Pred
#if MIN_VERSION_template_haskell(2,10,0)
resolvePredSynonyms :: Type -> Q Type
resolvePredSynonyms = Type -> Q Type
resolveTypeSynonyms
#else
resolvePredSynonyms (ClassP n ts) = do
  mbInfo <- reifyMaybe n
  case mbInfo of
    Just (TyConI (TySynD _ synvars def))
      |  length ts >= length synvars -- Don't expand undersaturated type synonyms (#88)
      -> resolvePredSynonyms $ typeToPred $ expandSynonymRHS synvars ts def
    _ -> ClassP n <$> mapM resolveTypeSynonyms ts
resolvePredSynonyms (EqualP t1 t2) = do
  t1' <- resolveTypeSynonyms t1
  t2' <- resolveTypeSynonyms t2
  return (EqualP t1' t2')

typeToPred :: Type -> Pred
typeToPred t =
  let f :| xs = decomposeType t in
  case f of
    ConT n
      | n == eqTypeName
# if __GLASGOW_HASKELL__ == 704
        -- There's an unfortunate bug in GHC 7.4 where the (~) type is reified
        -- with an explicit kind argument. To work around this, we ignore it.
      , [_,t1,t2] <- xs
# else
      , [t1,t2] <- xs
# endif
      -> EqualP t1 t2
      | otherwise
      -> ClassP n xs
    _ -> error $ "typeToPred: Can't handle type " ++ show t
#endif

-- | Decompose a type into a list of it's outermost applications. This process
-- forgets about infix application, explicit parentheses, and visible kind
-- applications.
--
-- This operation should be used after all 'UInfixT' cases have been resolved
-- by 'resolveFixities' if the argument is being user generated.
--
-- > t ~= foldl1 AppT (decomposeType t)
decomposeType :: Type -> NonEmpty Type
decomposeType :: Type -> NonEmpty Type
decomposeType Type
t =
  case Type -> (Type, [TypeArg])
decomposeTypeArgs Type
t of
    (Type
f, [TypeArg]
x) -> Type
f Type -> [Type] -> NonEmpty Type
forall a. a -> [a] -> NonEmpty a
:| [TypeArg] -> [Type]
filterTANormals [TypeArg]
x

-- | A variant of 'decomposeType' that preserves information about visible kind
-- applications by returning a 'NonEmpty' list of 'TypeArg's.
decomposeTypeArgs :: Type -> (Type, [TypeArg])
decomposeTypeArgs :: Type -> (Type, [TypeArg])
decomposeTypeArgs = [TypeArg] -> Type -> (Type, [TypeArg])
go []
  where
    go :: [TypeArg] -> Type -> (Type, [TypeArg])
    go :: [TypeArg] -> Type -> (Type, [TypeArg])
go [TypeArg]
args (AppT Type
f Type
x)     = [TypeArg] -> Type -> (Type, [TypeArg])
go (Type -> TypeArg
TANormal Type
xTypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
args) Type
f
#if MIN_VERSION_template_haskell(2,11,0)
    go [TypeArg]
args (ParensT Type
t)    = [TypeArg] -> Type -> (Type, [TypeArg])
go [TypeArg]
args Type
t
#endif
#if MIN_VERSION_template_haskell(2,15,0)
    go [TypeArg]
args (AppKindT Type
f Type
x) = [TypeArg] -> Type -> (Type, [TypeArg])
go (Type -> TypeArg
TyArg Type
xTypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
args) Type
f
#endif
    go [TypeArg]
args Type
t              = (Type
t, [TypeArg]
args)

-- | An argument to a type, either a normal type ('TANormal') or a visible
-- kind application ('TyArg').
data TypeArg
  = TANormal Type
  | TyArg Kind

-- | Apply a 'Type' to a 'TypeArg'.
appTypeArg :: Type -> TypeArg -> Type
appTypeArg :: Type -> TypeArg -> Type
appTypeArg Type
f (TANormal Type
x) = Type
f Type -> Type -> Type
`AppT` Type
x
appTypeArg Type
f (TyArg Type
_k) =
#if MIN_VERSION_template_haskell(2,15,0)
  Type
f Type -> Type -> Type
`AppKindT` Type
_k
#else
  f -- VKA isn't supported, so conservatively drop the argument
#endif

-- | Filter out all of the normal type arguments from a list of 'TypeArg's.
filterTANormals :: [TypeArg] -> [Type]
filterTANormals :: [TypeArg] -> [Type]
filterTANormals = (TypeArg -> Maybe Type) -> [TypeArg] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TypeArg -> Maybe Type
f
  where
    f :: TypeArg -> Maybe Type
    f :: TypeArg -> Maybe Type
f (TANormal Type
t) = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
    f (TyArg {})   = Maybe Type
forall a. Maybe a
Nothing

-- 'NonEmpty' didn't move into base until recently. Reimplementing it locally
-- saves dependencies for supporting older GHCs
data NonEmpty a = a :| [a]

data NonEmptySnoc a = [a] :|- a

-- Decompose a function type into its context, argument types,
-- and return type. For instance, this
--
--   forall a b. (Show a, b ~ Int) => (a -> b) -> Char -> Int
--
-- becomes
--
--   ([a, b], [Show a, b ~ Int], [a -> b, Char] :|- Int)
uncurryType :: Type -> ([TyVarBndrSpec], Cxt, NonEmptySnoc Type)
uncurryType :: Type -> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
uncurryType = [TyVarBndrSpec]
-> [Type]
-> [Type]
-> Type
-> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
go [] [] []
  where
    go :: [TyVarBndrSpec]
-> [Type]
-> [Type]
-> Type
-> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
go [TyVarBndrSpec]
tvbs [Type]
ctxt [Type]
args (AppT (AppT Type
ArrowT Type
t1) Type
t2) = [TyVarBndrSpec]
-> [Type]
-> [Type]
-> Type
-> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
go [TyVarBndrSpec]
tvbs [Type]
ctxt (Type
t1Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args) Type
t2
    go [TyVarBndrSpec]
tvbs [Type]
ctxt [Type]
args (ForallT [TyVarBndrSpec]
tvbs' [Type]
ctxt' Type
t)    = [TyVarBndrSpec]
-> [Type]
-> [Type]
-> Type
-> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
go ([TyVarBndrSpec]
tvbs[TyVarBndrSpec] -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++[TyVarBndrSpec]
tvbs') ([Type]
ctxt[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++[Type]
ctxt') [Type]
args Type
t
    go [TyVarBndrSpec]
tvbs [Type]
ctxt [Type]
args Type
t                          = ([TyVarBndrSpec]
tvbs, [Type]
ctxt, [Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
args [Type] -> Type -> NonEmptySnoc Type
forall a. [a] -> a -> NonEmptySnoc a
:|- Type
t)

-- Reconstruct a function type from its type variable binders, context,
-- argument types and return type.
curryType :: [TyVarBndrSpec] -> Cxt -> [Type] -> Type -> Type
curryType :: [TyVarBndrSpec] -> [Type] -> [Type] -> Type -> Type
curryType [TyVarBndrSpec]
tvbs [Type]
ctxt [Type]
args Type
res =
  [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
tvbs [Type]
ctxt (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ (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
arg Type
t -> Type
ArrowT Type -> Type -> Type
`AppT` Type
arg Type -> Type -> Type
`AppT` Type
t) Type
res [Type]
args

-- All of the code from @ForallTelescope@ through @unravelType@ is taken from
-- the @th-desugar@ library, which is licensed under a 3-Clause BSD license.

-- | The type variable binders in a @forall@. This is not used by the TH AST
-- itself, but this is used as an intermediate data type in 'FAForalls'.
data ForallTelescope
  = ForallVis [TyVarBndrUnit]
    -- ^ A visible @forall@ (e.g., @forall a -> {...}@).
    --   These do not have any notion of specificity, so we use
    --   '()' as a placeholder value in the 'TyVarBndr's.
  | ForallInvis [TyVarBndrSpec]
    -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),
    --   where each binder has a 'Specificity'.

-- | The list of arguments in a function 'Type'.
data FunArgs
  = FANil
    -- ^ No more arguments.
  | FAForalls ForallTelescope FunArgs
    -- ^ A series of @forall@ed type variables followed by a dot (if
    --   'ForallInvis') or an arrow (if 'ForallVis'). For example,
    --   the type variables @a1 ... an@ in @forall a1 ... an. r@.
  | FACxt Cxt FunArgs
    -- ^ A series of constraint arguments followed by @=>@. For example,
    --   the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.
  | FAAnon Kind FunArgs
    -- ^ An anonymous argument followed by an arrow. For example, the @a@
    --   in @a -> r@.

-- | A /visible/ function argument type (i.e., one that must be supplied
-- explicitly in the source code). This is in contrast to /invisible/
-- arguments (e.g., the @c@ in @c => r@), which are instantiated without
-- the need for explicit user input.
data VisFunArg
  = VisFADep TyVarBndrUnit
    -- ^ A visible @forall@ (e.g., @forall a -> a@).
  | VisFAAnon Kind
    -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).

#if MIN_VERSION_template_haskell(2,8,0)
-- | Decompose a function 'Type' into its arguments (the 'FunArgs') and its
-- result type (the 'Type).
unravelType :: Type -> (FunArgs, Type)
unravelType :: Type -> (FunArgs, Type)
unravelType (ForallT [TyVarBndrSpec]
tvbs [Type]
cxt Type
ty) =
  let (FunArgs
args, Type
res) = Type -> (FunArgs, Type)
unravelType Type
ty in
  (ForallTelescope -> FunArgs -> FunArgs
FAForalls ([TyVarBndrSpec] -> ForallTelescope
ForallInvis [TyVarBndrSpec]
tvbs) ([Type] -> FunArgs -> FunArgs
FACxt [Type]
cxt FunArgs
args), Type
res)
unravelType (AppT (AppT Type
ArrowT Type
t1) Type
t2) =
  let (FunArgs
args, Type
res) = Type -> (FunArgs, Type)
unravelType Type
t2 in
  (Type -> FunArgs -> FunArgs
FAAnon Type
t1 FunArgs
args, Type
res)
# if __GLASGOW_HASKELL__ >= 809
unravelType (ForallVisT [TyVarBndrUnit]
tvbs Type
ty) =
  let (FunArgs
args, Type
res) = Type -> (FunArgs, Type)
unravelType Type
ty in
  (ForallTelescope -> FunArgs -> FunArgs
FAForalls ([TyVarBndrUnit] -> ForallTelescope
ForallVis [TyVarBndrUnit]
tvbs) FunArgs
args, Type
res)
# endif
unravelType Type
t = (FunArgs
FANil, Type
t)

-- | Reconstruct an arrow 'Type' from its argument and result types.
ravelType :: FunArgs -> Type -> Type
ravelType :: FunArgs -> Type -> Type
ravelType FunArgs
FANil Type
res = Type
res
-- We need a special case for FAForalls ForallInvis followed by FACxt so that we may
-- collapse them into a single ForallT when raveling.
ravelType (FAForalls (ForallInvis [TyVarBndrSpec]
tvbs) (FACxt [Type]
p FunArgs
args)) Type
res =
  [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
tvbs [Type]
p (FunArgs -> Type -> Type
ravelType FunArgs
args Type
res)
ravelType (FAForalls (ForallInvis  [TyVarBndrSpec]
tvbs)  FunArgs
args)  Type
res = [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
tvbs [] (FunArgs -> Type -> Type
ravelType FunArgs
args Type
res)
ravelType (FAForalls (ForallVis   [TyVarBndrUnit]
_tvbs) FunArgs
_args) Type
_res =
#if __GLASGOW_HASKELL__ >= 809
      [TyVarBndrUnit] -> Type -> Type
ForallVisT [TyVarBndrUnit]
_tvbs (FunArgs -> Type -> Type
ravelType FunArgs
_args Type
_res)
#else
      error "Visible dependent quantification supported only on GHC 8.10+"
#endif
ravelType (FACxt [Type]
cxt FunArgs
args) Type
res = [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [] [Type]
cxt (FunArgs -> Type -> Type
ravelType FunArgs
args Type
res)
ravelType (FAAnon Type
t FunArgs
args)  Type
res = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
t) (FunArgs -> Type -> Type
ravelType FunArgs
args Type
res)

-- | Convert a 'FunArg's value into the list of 'Type's that it contains.
-- For example, given this function type:
--
-- @
-- forall k (a :: k). Proxy a -> forall b. Maybe b
-- @
--
-- Then calling @funArgTys@ on the arguments would yield:
--
-- @
-- [k, (a :: k), Proxy a, b, Maybe b]
-- @
--
-- This is primarily used for the purposes of computing all of the type
-- variables that appear in a 'FunArgs' value.
funArgTys :: FunArgs -> [Type]
funArgTys :: FunArgs -> [Type]
funArgTys FunArgs
FANil = []
funArgTys (FAForalls ForallTelescope
tele FunArgs
args) =
  ForallTelescope -> [Type]
forallTelescopeTys ForallTelescope
tele [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ FunArgs -> [Type]
funArgTys FunArgs
args
# if __GLASGOW_HASKELL__ >= 800
funArgTys (FACxt [Type]
ctxt FunArgs
args) =
  [Type]
ctxt [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ FunArgs -> [Type]
funArgTys FunArgs
args
# else
funArgTys (FACxt {}) =
  error "Constraints in kinds not supported prior to GHC 8.0"
# endif
funArgTys (FAAnon Type
anon FunArgs
args) =
  Type
anon Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: FunArgs -> [Type]
funArgTys FunArgs
args

-- | Convert a 'ForallTelescope' value into the list of 'Type's that it
-- contains. See the Haddocks for 'funArgTys' for an example of what this does.
forallTelescopeTys :: ForallTelescope -> [Type]
forallTelescopeTys :: ForallTelescope -> [Type]
forallTelescopeTys (ForallVis [TyVarBndrUnit]
tvbs)   = [TyVarBndrUnit] -> [Type]
forall flag. [TyVarBndr_ flag] -> [Type]
bndrParams [TyVarBndrUnit]
tvbs
forallTelescopeTys (ForallInvis [TyVarBndrSpec]
tvbs) = [TyVarBndrSpec] -> [Type]
forall flag. [TyVarBndr_ flag] -> [Type]
bndrParams [TyVarBndrSpec]
tvbs
#endif

-- | Reconstruct an arrow 'Kind' from its argument and result kinds.
ravelKind :: FunArgs -> Kind -> Kind
#if MIN_VERSION_template_haskell(2,8,0)
ravelKind :: FunArgs -> Type -> Type
ravelKind = FunArgs -> Type -> Type
ravelType
#else
ravelKind FANil res = res
ravelKind (FAAnon k args) res = ArrowK k (ravelKind args res)
ravelKind (FAForalls {}) _res =
  error "TH doesn't support `forall`s in kinds prior to template-haskell-2.8.0.0"
ravelKind (FACxt {}) _res =
  error "TH doesn't support contexts in kinds prior to template-haskell-2.8.0.0"
#endif

-- | Decompose a function 'Kind' into its arguments (the 'FunArgs') and its
-- result type (the 'Kind).
unravelKind :: Kind -> (FunArgs, Kind)
#if MIN_VERSION_template_haskell(2,8,0)
unravelKind :: Type -> (FunArgs, Type)
unravelKind = Type -> (FunArgs, Type)
unravelType
#else
unravelKind (ArrowK k1 k2) =
  let (args, res) = unravelKind k2 in
  (FAAnon k1 args, res)
unravelKind StarK =
  (FANil, StarK)
#endif

-- | @'filterVisFunArgsUpTo' xs args@ will split @args@ into 'VisFunArg's as
-- many times as there are elements in @xs@, pairing up each entry in @xs@ with
-- the corresponding 'VisFunArg' in the process. This will stop after the last
-- entry in @xs@ has been paired up.
--
-- For example, this:
--
-- @
-- 'filterVisFunArgsUpTo'
--   [Bool, True]
--   [ FAForalls (ForallVis [j])
--   , FAAnon j
--   , FAForalls (ForallInvis [k])
--   , FAAnon k
--   ]
-- @
--
-- Will yield:
--
-- @
-- ( [(Bool, VisFADep j), (True, VisFAAnon j)]
-- , [FAForalls (ForallInvis [k]), FAAnon k]
-- )
-- @
--
-- This function assumes the precondition that there are at least as many
-- visible function arguments in @args@ as there are elements in @xs@. If this
-- is not the case, this function will raise an error.
filterVisFunArgsUpTo :: forall a. [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
filterVisFunArgsUpTo :: forall a. [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
filterVisFunArgsUpTo = [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
go_fun_args
  where
    go_fun_args :: [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
    go_fun_args :: [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
go_fun_args [] FunArgs
args =
      ([], FunArgs
args)
    go_fun_args (a
_:[a]
_) FunArgs
FANil =
      String -> ([(a, VisFunArg)], FunArgs)
forall a. HasCallStack => String -> a
error String
"filterVisFunArgsUpTo.go_fun_args: Too few FunArgs"
    go_fun_args [a]
xs (FACxt [Type]
_ FunArgs
args) =
      [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
go_fun_args [a]
xs FunArgs
args
    go_fun_args (a
x:[a]
xs) (FAAnon Type
t FunArgs
args) =
      let ([(a, VisFunArg)]
xs', FunArgs
args') = [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
go_fun_args [a]
xs FunArgs
args in
      ((a
x, Type -> VisFunArg
VisFAAnon Type
t)(a, VisFunArg) -> [(a, VisFunArg)] -> [(a, VisFunArg)]
forall a. a -> [a] -> [a]
:[(a, VisFunArg)]
xs', FunArgs
args')
    go_fun_args [a]
xs (FAForalls ForallTelescope
tele FunArgs
args) =
      case ForallTelescope
tele of
        ForallVis [TyVarBndrUnit]
tvbs ->
          [TyVarBndrUnit] -> [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
go_vis_tvbs [TyVarBndrUnit]
tvbs [a]
xs FunArgs
args
        ForallInvis [TyVarBndrSpec]
_ ->
          [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
go_fun_args [a]
xs FunArgs
args

    go_vis_tvbs :: [TyVarBndrUnit] -> [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
    go_vis_tvbs :: [TyVarBndrUnit] -> [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
go_vis_tvbs [] [a]
xs FunArgs
args =
      [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
go_fun_args [a]
xs FunArgs
args
    go_vis_tvbs (TyVarBndrUnit
tvb:[TyVarBndrUnit]
tvbs) (a
x:[a]
xs) FunArgs
args =
      let ([(a, VisFunArg)]
xs', FunArgs
args') = [TyVarBndrUnit] -> [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
go_vis_tvbs [TyVarBndrUnit]
tvbs [a]
xs FunArgs
args in
      ((a
x, TyVarBndrUnit -> VisFunArg
VisFADep TyVarBndrUnit
tvb)(a, VisFunArg) -> [(a, VisFunArg)] -> [(a, VisFunArg)]
forall a. a -> [a] -> [a]
:[(a, VisFunArg)]
xs', FunArgs
args')
    go_vis_tvbs [TyVarBndrUnit]
tvbs [] FunArgs
args =
      ([], ForallTelescope -> FunArgs -> FunArgs
FAForalls ([TyVarBndrUnit] -> ForallTelescope
ForallVis [TyVarBndrUnit]
tvbs) FunArgs
args)

-- | @'unravelKindUpTo' xs k@ will split the function kind @k@ into its argument
-- kinds @args@ and result kind @res@, and then it will call
-- @'filterVisFunArgsUpTo' xs args@. The leftover arguments that were not split
-- apart by 'filterVisFunArgsUpTo' are then raveled back into @res@.
--
-- For example, this:
--
-- @
-- 'filterVisFunArgsUpTo'
--   [Bool, True]
--   (forall j -> j -> forall k. k -> Type)
-- @
--
-- Will yield:
--
-- @
-- ( [(Bool, VisFADep j), (True, VisFAAnon j)]
-- , forall k. k -> Type
-- )
-- @
--
-- This function assumes the precondition that there are at least as many
-- visible function arguments in @args@ as there are elements in @xs@. If this
-- is not the case, this function will raise an error.
unravelKindUpTo :: [a] -> Kind -> ([(a, VisFunArg)], Kind)
unravelKindUpTo :: forall a. [a] -> Type -> ([(a, VisFunArg)], Type)
unravelKindUpTo [a]
xs Type
k = ([(a, VisFunArg)]
xs', FunArgs -> Type -> Type
ravelKind FunArgs
args' Type
res)
  where
    (FunArgs
args, Type
res) = Type -> (FunArgs, Type)
unravelKind Type
k
    ([(a, VisFunArg)]
xs', FunArgs
args') = [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
forall a. [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)
filterVisFunArgsUpTo [a]
xs FunArgs
args

-- | Resolve any infix type application in a type using the fixities that
-- are currently available. Starting in `template-haskell-2.11` types could
-- contain unresolved infix applications.
resolveInfixT :: Type -> Q Type

#if MIN_VERSION_template_haskell(2,11,0)
resolveInfixT :: Type -> Q Type
resolveInfixT (ForallT [TyVarBndrSpec]
vs [Type]
cx Type
t) = [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT ([TyVarBndrSpec] -> [Type] -> Type -> Type)
-> Q [TyVarBndrSpec] -> Q ([Type] -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrSpec -> Q TyVarBndrSpec)
-> [TyVarBndrSpec] -> Q [TyVarBndrSpec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Type -> Q Type) -> TyVarBndrSpec -> Q TyVarBndrSpec
forall (f :: * -> *) flag.
Applicative f =>
(Type -> f Type) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
traverseTVKind Type -> Q Type
resolveInfixT) [TyVarBndrSpec]
vs
                                          Q ([Type] -> Type -> Type) -> Q [Type] -> Q (Type -> Type)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> Q Type) -> [Type] -> Q [Type]
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 Type -> Q Type
resolveInfixT [Type]
cx
                                          Q (Type -> Type) -> Q Type -> Q Type
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Q Type
resolveInfixT Type
t
resolveInfixT (Type
f `AppT` Type
x)      = Type -> Q Type
resolveInfixT Type
f Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
resolveInfixT Type
x
resolveInfixT (ParensT Type
t)       = Type -> Q Type
resolveInfixT Type
t
resolveInfixT (InfixT Type
l Name
o Type
r)    = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
o Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
resolveInfixT Type
l Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
resolveInfixT Type
r
resolveInfixT (SigT Type
t Type
k)        = Type -> Type -> Type
SigT (Type -> Type -> Type) -> Q Type -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveInfixT Type
t Q (Type -> Type) -> Q Type -> Q Type
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Q Type
resolveInfixT Type
k
resolveInfixT t :: Type
t@UInfixT{}       = Type -> Q Type
resolveInfixT (Type -> Q Type) -> Q Type -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InfixList -> Q Type
resolveInfixT1 (Type -> InfixList
gatherUInfixT Type
t)
# if MIN_VERSION_template_haskell(2,15,0)
resolveInfixT (Type
f `AppKindT` Type
x)  = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appKindT (Type -> Q Type
resolveInfixT Type
f) (Type -> Q Type
resolveInfixT Type
x)
resolveInfixT (ImplicitParamT String
n Type
t)
                                = String -> Q Type -> Q Type
forall (m :: * -> *). Quote m => String -> m Type -> m Type
implicitParamT String
n (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Q Type
resolveInfixT Type
t
# endif
# if MIN_VERSION_template_haskell(2,16,0)
resolveInfixT (ForallVisT [TyVarBndrUnit]
vs Type
t) = [TyVarBndrUnit] -> Type -> Type
ForallVisT ([TyVarBndrUnit] -> Type -> Type)
-> Q [TyVarBndrUnit] -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrUnit -> Q TyVarBndrUnit)
-> [TyVarBndrUnit] -> Q [TyVarBndrUnit]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Type -> Q Type) -> TyVarBndrUnit -> Q TyVarBndrUnit
forall (f :: * -> *) flag.
Applicative f =>
(Type -> f Type) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
traverseTVKind Type -> Q Type
resolveInfixT) [TyVarBndrUnit]
vs
                                             Q (Type -> Type) -> Q Type -> Q Type
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Q Type
resolveInfixT Type
t
# endif
# if MIN_VERSION_template_haskell(2,19,0)
resolveInfixT (PromotedInfixT Type
l Name
o Type
r)
                                = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
o Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
resolveInfixT Type
l Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
resolveInfixT Type
r
resolveInfixT t :: Type
t@PromotedUInfixT{}
                                = Type -> Q Type
resolveInfixT (Type -> Q Type) -> Q Type -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< InfixList -> Q Type
resolveInfixT1 (Type -> InfixList
gatherUInfixT Type
t)
# endif
resolveInfixT Type
t                 = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t

gatherUInfixT :: Type -> InfixList
gatherUInfixT :: Type -> InfixList
gatherUInfixT (UInfixT Type
l Name
o Type
r)         = InfixList -> Name -> Bool -> InfixList -> InfixList
ilAppend (Type -> InfixList
gatherUInfixT Type
l) Name
o Bool
False (Type -> InfixList
gatherUInfixT Type
r)
# if MIN_VERSION_template_haskell(2,19,0)
gatherUInfixT (PromotedUInfixT Type
l Name
o Type
r) = InfixList -> Name -> Bool -> InfixList -> InfixList
ilAppend (Type -> InfixList
gatherUInfixT Type
l) Name
o Bool
True  (Type -> InfixList
gatherUInfixT Type
r)
# endif
gatherUInfixT Type
t = Type -> InfixList
ILNil Type
t

-- This can fail due to incompatible fixities
resolveInfixT1 :: InfixList -> TypeQ
resolveInfixT1 :: InfixList -> Q Type
resolveInfixT1 = [(Type, Name, Bool, Fixity)] -> InfixList -> Q Type
go []
  where
    go :: [(Type,Name,Bool,Fixity)] -> InfixList -> TypeQ
    go :: [(Type, Name, Bool, Fixity)] -> InfixList -> Q Type
go [(Type, Name, Bool, Fixity)]
ts (ILNil Type
u) = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> (Type, Name, Bool, Fixity) -> Type)
-> Type -> [(Type, Name, Bool, Fixity)] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
acc (Type
l,Name
o,Bool
p,Fixity
_) -> Bool -> Name -> Type
mkConT Bool
p Name
o Type -> Type -> Type
`AppT` Type
l Type -> Type -> Type
`AppT` Type
acc) Type
u [(Type, Name, Bool, Fixity)]
ts)
    go [(Type, Name, Bool, Fixity)]
ts (ILCons Type
l Name
o Bool
p InfixList
r) =
      do Fixity
ofx <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q (Maybe Fixity)
reifyFixityCompat Name
o
         let push :: Q Type
push = [(Type, Name, Bool, Fixity)] -> InfixList -> Q Type
go ((Type
l,Name
o,Bool
p,Fixity
ofx)(Type, Name, Bool, Fixity)
-> [(Type, Name, Bool, Fixity)] -> [(Type, Name, Bool, Fixity)]
forall a. a -> [a] -> [a]
:[(Type, Name, Bool, Fixity)]
ts) InfixList
r
         case [(Type, Name, Bool, Fixity)]
ts of
           (Type
l1,Name
o1,Bool
p1,Fixity
o1fx):[(Type, Name, Bool, Fixity)]
ts' ->
             case Fixity -> Fixity -> Maybe Bool
compareFixity Fixity
o1fx Fixity
ofx of
               Just Bool
True  -> [(Type, Name, Bool, Fixity)] -> InfixList -> Q Type
go ((Bool -> Name -> Type
mkConT Bool
p1 Name
o1 Type -> Type -> Type
`AppT` Type
l1 Type -> Type -> Type
`AppT` Type
l, Name
o, Bool
p, Fixity
ofx)(Type, Name, Bool, Fixity)
-> [(Type, Name, Bool, Fixity)] -> [(Type, Name, Bool, Fixity)]
forall a. a -> [a] -> [a]
:[(Type, Name, Bool, Fixity)]
ts') InfixList
r
               Just Bool
False -> Q Type
push
               Maybe Bool
Nothing    -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Name -> Fixity -> Name -> Fixity -> String
precedenceError Name
o1 Fixity
o1fx Name
o Fixity
ofx)
           [(Type, Name, Bool, Fixity)]
_ -> Q Type
push

    mkConT :: Bool -> Name -> Type
    mkConT :: Bool -> Name -> Type
mkConT Bool
promoted = if Bool
promoted then Name -> Type
PromotedT else Name -> Type
ConT

    compareFixity :: Fixity -> Fixity -> Maybe Bool
    compareFixity :: Fixity -> Fixity -> Maybe Bool
compareFixity (Fixity Int
n1 FixityDirection
InfixL) (Fixity Int
n2 FixityDirection
InfixL) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n2)
    compareFixity (Fixity Int
n1 FixityDirection
InfixR) (Fixity Int
n2 FixityDirection
InfixR) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
n2)
    compareFixity (Fixity Int
n1 FixityDirection
_     ) (Fixity Int
n2 FixityDirection
_     ) =
      case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n1 Int
n2 of
        Ordering
GT -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
        Ordering
LT -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        Ordering
EQ -> Maybe Bool
forall a. Maybe a
Nothing

    precedenceError :: Name -> Fixity -> Name -> Fixity -> String
    precedenceError :: Name -> Fixity -> Name -> Fixity -> String
precedenceError Name
o1 Fixity
ofx1 Name
o2 Fixity
ofx2 =
      String
"Precedence parsing error: cannot mix ‘" String -> ShowS
forall a. [a] -> [a] -> [a]
++
      Name -> String
nameBase Name
o1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"’ [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Fixity -> String
showFixity Fixity
ofx1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] and ‘" String -> ShowS
forall a. [a] -> [a] -> [a]
++
      Name -> String
nameBase Name
o2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"’ [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Fixity -> String
showFixity Fixity
ofx2 String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String
"] in the same infix type expression"

data InfixList
  = ILCons Type      -- The first argument to the type operator
           Name      -- The name of the infix type operator
           Bool      -- 'True' if this is a promoted infix data constructor,
                     -- 'False' otherwise
           InfixList -- The rest of the infix applications to resolve
  | ILNil Type

ilAppend :: InfixList -> Name -> Bool -> InfixList -> InfixList
ilAppend :: InfixList -> Name -> Bool -> InfixList -> InfixList
ilAppend (ILNil Type
l)            Name
o Bool
p InfixList
r = Type -> Name -> Bool -> InfixList -> InfixList
ILCons Type
l Name
o Bool
p InfixList
r
ilAppend (ILCons Type
l1 Name
o1 Bool
p1 InfixList
r1) Name
o Bool
p InfixList
r = Type -> Name -> Bool -> InfixList -> InfixList
ILCons Type
l1 Name
o1 Bool
p1 (InfixList -> Name -> Bool -> InfixList -> InfixList
ilAppend InfixList
r1 Name
o Bool
p InfixList
r)

#else
-- older template-haskell packages don't have UInfixT
resolveInfixT = return
#endif


-- | Render a 'Fixity' as it would appear in Haskell source.
--
-- Example: @infixl 5@
showFixity :: Fixity -> String
showFixity :: Fixity -> String
showFixity (Fixity Int
n FixityDirection
d) = FixityDirection -> String
showFixityDirection FixityDirection
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n


-- | Render a 'FixityDirection' like it would appear in Haskell source.
--
-- Examples: @infixl@ @infixr@ @infix@
showFixityDirection :: FixityDirection -> String
showFixityDirection :: FixityDirection -> String
showFixityDirection FixityDirection
InfixL = String
"infixl"
showFixityDirection FixityDirection
InfixR = String
"infixr"
showFixityDirection FixityDirection
InfixN = String
"infix"

takeFieldNames :: [(Name,a,b)] -> [Name]
takeFieldNames :: forall a b. [(Name, a, b)] -> [Name]
takeFieldNames [(Name, a, b)]
xs = [Name
a | (Name
a,a
_,b
_) <- [(Name, a, b)]
xs]

#if MIN_VERSION_template_haskell(2,11,0)
takeFieldStrictness :: [(a,Bang,b)]   -> [FieldStrictness]
#else
takeFieldStrictness :: [(a,Strict,b)] -> [FieldStrictness]
#endif
takeFieldStrictness :: forall a b. [(a, Bang, b)] -> [FieldStrictness]
takeFieldStrictness [(a, Bang, b)]
xs = [Bang -> FieldStrictness
normalizeStrictness Bang
a | (a
_,Bang
a,b
_) <- [(a, Bang, b)]
xs]

takeFieldTypes :: [(a,b,Type)] -> [Type]
takeFieldTypes :: forall a b. [(a, b, Type)] -> [Type]
takeFieldTypes [(a, b, Type)]
xs = [Type
a | (a
_,b
_,Type
a) <- [(a, b, Type)]
xs]

conHasRecord :: Name -> ConstructorInfo -> Bool
conHasRecord :: Name -> ConstructorInfo -> Bool
conHasRecord Name
recName ConstructorInfo
info =
  case ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
info of
    ConstructorVariant
NormalConstructor        -> Bool
False
    ConstructorVariant
InfixConstructor         -> Bool
False
    RecordConstructor [Name]
fields -> Name
recName Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
fields

------------------------------------------------------------------------

-- | Add universal quantifier for all free variables in the type. This is
-- useful when constructing a type signature for a declaration.
-- This code is careful to ensure that the order of the variables quantified
-- is determined by their order of appearance in the type signature. (In
-- contrast with being dependent upon the Ord instance for 'Name')
quantifyType :: Type -> Type
quantifyType :: Type -> Type
quantifyType Type
t
  | [TyVarBndrSpec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrSpec]
tvbs
  = Type
t
  | ForallT [TyVarBndrSpec]
tvbs' [Type]
ctxt' Type
t' <- Type
t -- Collapse two consecutive foralls (#63)
  = [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT ([TyVarBndrSpec]
tvbs [TyVarBndrSpec] -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrSpec]
tvbs') [Type]
ctxt' Type
t'
  | Bool
otherwise
  = [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
tvbs [] Type
t
  where
    tvbs :: [TyVarBndrSpec]
tvbs = Specificity -> [TyVarBndrUnit] -> [TyVarBndrSpec]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec ([TyVarBndrUnit] -> [TyVarBndrSpec])
-> [TyVarBndrUnit] -> [TyVarBndrSpec]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
t]

-- | Take a list of 'Type's, find their free variables, and sort them
-- according to dependency order.
--
-- As an example of how this function works, consider the following type:
--
-- @
-- Proxy (a :: k)
-- @
--
-- Calling 'freeVariables' on this type would yield @[a, k]@, since that is
-- the order in which those variables appear in a left-to-right fashion. But
-- this order does not preserve the fact that @k@ is the kind of @a@. Moreover,
-- if you tried writing the type @forall a k. Proxy (a :: k)@, GHC would reject
-- this, since GHC would demand that @k@ come before @a@.
--
-- 'freeVariablesWellScoped' orders the free variables of a type in a way that
-- preserves this dependency ordering. If one were to call
-- 'freeVariablesWellScoped' on the type above, it would return
-- @[k, (a :: k)]@. (This is why 'freeVariablesWellScoped' returns a list of
-- 'TyVarBndr's instead of 'Name's, since it must make it explicit that @k@
-- is the kind of @a@.)
--
-- 'freeVariablesWellScoped' guarantees the free variables returned will be
-- ordered such that:
--
-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is
--    encountered, the free variables of @K@ will always appear to the left of
--    the free variables of @A@ in the returned result.
--
-- 2. The constraint in (1) notwithstanding, free variables will appear in
--    left-to-right order of their original appearance.
--
-- On older GHCs, this takes measures to avoid returning explicitly bound
-- kind variables, which was not possible before @TypeInType@.
freeVariablesWellScoped :: [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped :: [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type]
tys =
  let fvs :: [Name]
      fvs :: [Name]
fvs = [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
tys

      varKindSigs :: Map Name Kind
      varKindSigs :: Map Name Type
varKindSigs = (Type -> Map Name Type) -> [Type] -> Map Name Type
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> Map Name Type
go_ty [Type]
tys
        where
          go_ty :: Type -> Map Name Kind
          go_ty :: Type -> Map Name Type
go_ty (ForallT [TyVarBndrSpec]
tvbs [Type]
ctxt Type
t) =
            (TyVarBndrSpec -> Map Name Type -> Map Name Type)
-> Map Name Type -> [TyVarBndrSpec] -> Map Name Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TyVarBndrSpec
tvb -> Name -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (TyVarBndrSpec -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrSpec
tvb))
                  ((Type -> Map Name Type) -> [Type] -> Map Name Type
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> Map Name Type
go_pred [Type]
ctxt Map Name Type -> Map Name Type -> Map Name Type
forall a. Monoid a => a -> a -> a
`mappend` Type -> Map Name Type
go_ty Type
t) [TyVarBndrSpec]
tvbs
          go_ty (AppT Type
t1 Type
t2) = Type -> Map Name Type
go_ty Type
t1 Map Name Type -> Map Name Type -> Map Name Type
forall a. Monoid a => a -> a -> a
`mappend` Type -> Map Name Type
go_ty Type
t2
          go_ty (SigT Type
t Type
k) =
            let kSigs :: Map Name Type
kSigs =
#if MIN_VERSION_template_haskell(2,8,0)
                  Type -> Map Name Type
go_ty Type
k
#else
                  mempty
#endif
            in case Type
t of
                 VarT Name
n -> Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n Type
k Map Name Type
kSigs
                 Type
_      -> Type -> Map Name Type
go_ty Type
t Map Name Type -> Map Name Type -> Map Name Type
forall a. Monoid a => a -> a -> a
`mappend` Map Name Type
kSigs
#if MIN_VERSION_template_haskell(2,15,0)
          go_ty (AppKindT Type
t Type
k) = Type -> Map Name Type
go_ty Type
t Map Name Type -> Map Name Type -> Map Name Type
forall a. Monoid a => a -> a -> a
`mappend` Type -> Map Name Type
go_ty Type
k
          go_ty (ImplicitParamT String
_ Type
t) = Type -> Map Name Type
go_ty Type
t
#endif
#if MIN_VERSION_template_haskell(2,16,0)
          go_ty (ForallVisT [TyVarBndrUnit]
tvbs Type
t) =
            (TyVarBndrUnit -> Map Name Type -> Map Name Type)
-> Map Name Type -> [TyVarBndrUnit] -> Map Name Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TyVarBndrUnit
tvb -> Name -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tvb)) (Type -> Map Name Type
go_ty Type
t) [TyVarBndrUnit]
tvbs
#endif
          go_ty Type
_ = Map Name Type
forall a. Monoid a => a
mempty

          go_pred :: Pred -> Map Name Kind
#if MIN_VERSION_template_haskell(2,10,0)
          go_pred :: Type -> Map Name Type
go_pred = Type -> Map Name Type
go_ty
#else
          go_pred (ClassP _ ts)  = foldMap go_ty ts
          go_pred (EqualP t1 t2) = go_ty t1 `mappend` go_ty t2
#endif

      -- | Do a topological sort on a list of tyvars,
      --   so that binders occur before occurrences
      -- E.g. given  [ a::k, k::*, b::k ]
      -- it'll return a well-scoped list [ k::*, a::k, b::k ]
      --
      -- This is a deterministic sorting operation
      -- (that is, doesn't depend on Uniques).
      --
      -- It is also meant to be stable: that is, variables should not
      -- be reordered unnecessarily.
      scopedSort :: [Name] -> [Name]
      scopedSort :: [Name] -> [Name]
scopedSort = [Name] -> [Set Name] -> [Name] -> [Name]
go [] []

      go :: [Name]     -- already sorted, in reverse order
         -> [Set Name] -- each set contains all the variables which must be placed
                       -- before the tv corresponding to the set; they are accumulations
                       -- of the fvs in the sorted tvs' kinds

                       -- This list is in 1-to-1 correspondence with the sorted tyvars
                       -- INVARIANT:
                       --   all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list)
                       -- That is, each set in the list is a superset of all later sets.
         -> [Name]     -- yet to be sorted
         -> [Name]
      go :: [Name] -> [Set Name] -> [Name] -> [Name]
go [Name]
acc [Set Name]
_fv_list [] = [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
acc
      go [Name]
acc  [Set Name]
fv_list (Name
tv:[Name]
tvs)
        = [Name] -> [Set Name] -> [Name] -> [Name]
go [Name]
acc' [Set Name]
fv_list' [Name]
tvs
        where
          ([Name]
acc', [Set Name]
fv_list') = Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv [Name]
acc [Set Name]
fv_list

      insert :: Name       -- var to insert
             -> [Name]     -- sorted list, in reverse order
             -> [Set Name] -- list of fvs, as above
             -> ([Name], [Set Name])   -- augmented lists
      insert :: Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv []     []         = ([Name
tv], [Name -> Set Name
kindFVSet Name
tv])
      insert Name
tv (Name
a:[Name]
as) (Set Name
fvs:[Set Name]
fvss)
        | Name
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
fvs
        , ([Name]
as', [Set Name]
fvss') <- Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv [Name]
as [Set Name]
fvss
        = (Name
aName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
as', Set Name
fvs Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
fv_tv Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: [Set Name]
fvss')

        | Bool
otherwise
        = (Name
tvName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
aName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
as, Set Name
fvs Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
fv_tv Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: Set Name
fvs Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: [Set Name]
fvss)
        where
          fv_tv :: Set Name
fv_tv = Name -> Set Name
kindFVSet Name
tv

         -- lists not in correspondence
      insert Name
_ [Name]
_ [Set Name]
_ = String -> ([Name], [Set Name])
forall a. HasCallStack => String -> a
error String
"scopedSort"

      kindFVSet :: Name -> Set Name
kindFVSet Name
n =
        Set Name -> (Type -> Set Name) -> Maybe Type -> Set Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Name
forall a. Set a
Set.empty ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> (Type -> [Name]) -> Type -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables) (Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Type
varKindSigs)
      ascribeWithKind :: Name -> TyVarBndrUnit
ascribeWithKind Name
n =
        TyVarBndrUnit
-> (Type -> TyVarBndrUnit) -> Maybe Type -> TyVarBndrUnit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> TyVarBndrUnit
plainTV Name
n) (Name -> Type -> TyVarBndrUnit
kindedTV Name
n) (Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Type
varKindSigs)

      -- An annoying wrinkle: GHCs before 8.0 don't support explicitly
      -- quantifying kinds, so something like @forall k (a :: k)@ would be
      -- rejected. To work around this, we filter out any binders whose names
      -- also appear in a kind on old GHCs.
      isKindBinderOnOldGHCs :: b -> Bool
isKindBinderOnOldGHCs
#if __GLASGOW_HASKELL__ >= 800
        = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False
#else
        = (`elem` kindVars)
          where
            kindVars = freeVariables $ Map.elems varKindSigs
#endif

  in (Name -> TyVarBndrUnit) -> [Name] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndrUnit
ascribeWithKind ([Name] -> [TyVarBndrUnit]) -> [Name] -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$
     (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
forall {b}. b -> Bool
isKindBinderOnOldGHCs) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$
     [Name] -> [Name]
scopedSort [Name]
fvs

-- | Substitute all of the free variables in a type with fresh ones
freshenFreeVariables :: Type -> Q Type
freshenFreeVariables :: Type -> Q Type
freshenFreeVariables Type
t =
  do let xs :: [(Name, Q Type)]
xs = [ (Name
n, Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
n)) | Name
n <- Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t]
     Map Name Type
subst <- Map Name (Q Type) -> Q (Map Name Type)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Map Name (m a) -> m (Map Name a)
T.sequence ([(Name, Q Type)] -> Map Name (Q Type)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, Q Type)]
xs)
     Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst Type
t)


-- | Class for types that support type variable substitution.
class TypeSubstitution a where
  -- | Apply a type variable substitution.
  applySubstitution :: Map Name Type -> a -> a
  -- | Compute the free type variables
  freeVariables     :: a -> [Name]

instance TypeSubstitution a => TypeSubstitution [a] where
  freeVariables :: [a] -> [Name]
freeVariables     = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name] -> [Name]) -> ([a] -> [Name]) -> [a] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name]) -> ([a] -> [[Name]]) -> [a] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [Name]) -> [a] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables
  applySubstitution :: Map Name Type -> [a] -> [a]
applySubstitution = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> [a] -> [a])
-> (Map Name Type -> a -> a) -> Map Name Type -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name Type -> a -> a
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution

instance TypeSubstitution Type where
  applySubstitution :: Map Name Type -> Type -> Type
applySubstitution Map Name Type
subst = Type -> Type
go
    where
      go :: Type -> Type
go (ForallT [TyVarBndrSpec]
tvs [Type]
context Type
t) =
        let (Map Name Type
subst', [TyVarBndrSpec]
tvs') = Map Name Type
-> [TyVarBndrSpec] -> (Map Name Type, [TyVarBndrSpec])
forall flag.
Map Name Type
-> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag])
substTyVarBndrs Map Name Type
subst [TyVarBndrSpec]
tvs in
        [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
tvs'
                (Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst' [Type]
context)
                (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst' Type
t)
      go (AppT Type
f Type
x)      = Type -> Type -> Type
AppT (Type -> Type
go Type
f) (Type -> Type
go Type
x)
      go (SigT Type
t Type
k)      = Type -> Type -> Type
SigT (Type -> Type
go Type
t) (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst Type
k) -- k could be Kind
      go (VarT Name
v)        = Type -> Name -> Map Name Type -> Type
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Name -> Type
VarT Name
v) Name
v Map Name Type
subst
#if MIN_VERSION_template_haskell(2,11,0)
      go (InfixT Type
l Name
c Type
r)  = Type -> Name -> Type -> Type
InfixT (Type -> Type
go Type
l) Name
c (Type -> Type
go Type
r)
      go (UInfixT Type
l Name
c Type
r) = Type -> Name -> Type -> Type
UInfixT (Type -> Type
go Type
l) Name
c (Type -> Type
go Type
r)
      go (ParensT Type
t)     = Type -> Type
ParensT (Type -> Type
go Type
t)
#endif
#if MIN_VERSION_template_haskell(2,15,0)
      go (AppKindT Type
t Type
k)  = Type -> Type -> Type
AppKindT (Type -> Type
go Type
t) (Type -> Type
go Type
k)
      go (ImplicitParamT String
n Type
t)
                         = String -> Type -> Type
ImplicitParamT String
n (Type -> Type
go Type
t)
#endif
#if MIN_VERSION_template_haskell(2,16,0)
      go (ForallVisT [TyVarBndrUnit]
tvs Type
t) =
        let (Map Name Type
subst', [TyVarBndrUnit]
tvs') = Map Name Type
-> [TyVarBndrUnit] -> (Map Name Type, [TyVarBndrUnit])
forall flag.
Map Name Type
-> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag])
substTyVarBndrs Map Name Type
subst [TyVarBndrUnit]
tvs in
        [TyVarBndrUnit] -> Type -> Type
ForallVisT [TyVarBndrUnit]
tvs'
                   (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst' Type
t)
#endif
#if MIN_VERSION_template_haskell(2,19,0)
      go (PromotedInfixT Type
l Name
c Type
r)
                         = Type -> Name -> Type -> Type
PromotedInfixT (Type -> Type
go Type
l) Name
c (Type -> Type
go Type
r)
      go (PromotedUInfixT Type
l Name
c Type
r)
                         = Type -> Name -> Type -> Type
PromotedUInfixT (Type -> Type
go Type
l) Name
c (Type -> Type
go Type
r)
#endif
      go Type
t               = Type
t

      subst_tvbs :: [TyVarBndr_ flag] -> (Map Name Type -> a) -> a
      subst_tvbs :: forall flag a. [TyVarBndr_ flag] -> (Map Name Type -> a) -> a
subst_tvbs [TyVarBndr_ flag]
tvs Map Name Type -> a
k = Map Name Type -> a
k (Map Name Type -> a) -> Map Name Type -> a
forall a b. (a -> b) -> a -> b
$ (Map Name Type -> Name -> Map Name Type)
-> Map Name Type -> [Name] -> Map Name Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Name -> Map Name Type -> Map Name Type)
-> Map Name Type -> Name -> Map Name Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) Map Name Type
subst ((TyVarBndr_ flag -> Name) -> [TyVarBndr_ flag] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr_ flag]
tvs)

  freeVariables :: Type -> [Name]
freeVariables Type
t =
    case Type
t of
      ForallT [TyVarBndrSpec]
tvs [Type]
context Type
t' ->
          [TyVarBndrSpec] -> [Name] -> [Name]
forall flag. [TyVarBndr_ flag] -> [Name] -> [Name]
fvs_under_forall [TyVarBndrSpec]
tvs ([Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
context [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t')
      AppT Type
f Type
x      -> Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
f [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
x
      SigT Type
t' Type
k     -> Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t' [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
k
      VarT Name
v        -> [Name
v]
#if MIN_VERSION_template_haskell(2,11,0)
      InfixT Type
l Name
_ Type
r  -> Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
l [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
r
      UInfixT Type
l Name
_ Type
r -> Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
l [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
r
      ParensT Type
t'    -> Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t'
#endif
#if MIN_VERSION_template_haskell(2,15,0)
      AppKindT Type
t Type
k  -> Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
k
      ImplicitParamT String
_ Type
t
                    -> Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t
#endif
#if MIN_VERSION_template_haskell(2,16,0)
      ForallVisT [TyVarBndrUnit]
tvs Type
t'
                    -> [TyVarBndrUnit] -> [Name] -> [Name]
forall flag. [TyVarBndr_ flag] -> [Name] -> [Name]
fvs_under_forall [TyVarBndrUnit]
tvs (Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t')
#endif
#if MIN_VERSION_template_haskell(2,19,0)
      PromotedInfixT Type
l Name
_ Type
r
                    -> Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
l [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
r
      PromotedUInfixT Type
l Name
_ Type
r
                    -> Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
l [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
r
#endif
      Type
_             -> []
    where
      fvs_under_forall :: [TyVarBndr_ flag] -> [Name] -> [Name]
      fvs_under_forall :: forall flag. [TyVarBndr_ flag] -> [Name] -> [Name]
fvs_under_forall [TyVarBndr_ flag]
tvs [Name]
fvs =
        ([Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables ((TyVarBndr_ flag -> Type) -> [TyVarBndr_ flag] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind [TyVarBndr_ flag]
tvs) [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Name]
fvs)
        [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ (TyVarBndr_ flag -> Name) -> [TyVarBndr_ flag] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr_ flag]
tvs

instance TypeSubstitution ConstructorInfo where
  freeVariables :: ConstructorInfo -> [Name]
freeVariables ConstructorInfo
ci =
      ([Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables ((TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind (ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
ci))
          [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (ConstructorInfo -> [Type]
constructorContext ConstructorInfo
ci)
          [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
ci))
      [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ (TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
ci)

  applySubstitution :: Map Name Type -> ConstructorInfo -> ConstructorInfo
applySubstitution Map Name Type
subst ConstructorInfo
ci =
    let subst' :: Map Name Type
subst' = (Map Name Type -> Name -> Map Name Type)
-> Map Name Type -> [Name] -> Map Name Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Name -> Map Name Type -> Map Name Type)
-> Map Name Type -> Name -> Map Name Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) Map Name Type
subst ((TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
ci)) in
    ConstructorInfo
ci { constructorVars    = map (mapTVKind (applySubstitution subst'))
                                  (constructorVars ci)
       , constructorContext = applySubstitution subst' (constructorContext ci)
       , constructorFields  = applySubstitution subst' (constructorFields ci)
       }

-- 'Pred' became a type synonym for 'Type'
#if !MIN_VERSION_template_haskell(2,10,0)
instance TypeSubstitution Pred where
  freeVariables (ClassP _ xs) = freeVariables xs
  freeVariables (EqualP x y) = freeVariables x `union` freeVariables y

  applySubstitution p (ClassP n xs) = ClassP n (applySubstitution p xs)
  applySubstitution p (EqualP x y) = EqualP (applySubstitution p x)
                                            (applySubstitution p y)
#endif

-- 'Kind' became a type synonym for 'Type'. Previously there were no kind variables
#if !MIN_VERSION_template_haskell(2,8,0)
instance TypeSubstitution Kind where
  freeVariables _ = []
  applySubstitution _ k = k
#endif

-- | Substitutes into the kinds of type variable binders. This makes an effort
-- to avoid capturing the 'TyVarBndr' names during substitution by
-- alpha-renaming names if absolutely necessary. For a version of this function
-- which does /not/ avoid capture, see 'substTyVarBndrKinds'.
substTyVarBndrs :: Map Name Type -> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag])
substTyVarBndrs :: forall flag.
Map Name Type
-> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag])
substTyVarBndrs = (Map Name Type
 -> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag))
-> Map Name Type
-> [TyVarBndr_ flag]
-> (Map Name Type, [TyVarBndr_ flag])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Map Name Type
-> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag)
forall flag.
Map Name Type
-> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag)
substTyVarBndr

-- | The workhorse for 'substTyVarBndrs'.
substTyVarBndr :: Map Name Type -> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag)
substTyVarBndr :: forall flag.
Map Name Type
-> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag)
substTyVarBndr Map Name Type
subst TyVarBndr_ flag
tvb
  | Name
tvbName Name -> Map Name Type -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Name Type
subst
  = (Name -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Name
tvbName Map Name Type
subst, (Type -> Type) -> TyVarBndr_ flag -> TyVarBndr_ flag
forall flag. (Type -> Type) -> TyVarBndr_ flag -> TyVarBndr_ flag
mapTVKind (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst) TyVarBndr_ flag
tvb)
  | Name
tvbName Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Name
substRangeFVs
  = (Map Name Type
subst, (Type -> Type) -> TyVarBndr_ flag -> TyVarBndr_ flag
forall flag. (Type -> Type) -> TyVarBndr_ flag -> TyVarBndr_ flag
mapTVKind (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst) TyVarBndr_ flag
tvb)
  | Bool
otherwise
  = let tvbName' :: Name
tvbName' = Name -> Name
evade Name
tvbName in
    ( Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
tvbName (Name -> Type
VarT Name
tvbName') Map Name Type
subst
    , (Name -> Name)
-> (flag -> flag)
-> (Type -> Type)
-> TyVarBndr_ flag
-> TyVarBndr_ flag
forall flag flag'.
(Name -> Name)
-> (flag -> flag')
-> (Type -> Type)
-> TyVarBndr_ flag
-> TyVarBndr_ flag'
mapTV (\Name
_ -> Name
tvbName') flag -> flag
forall a. a -> a
id (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst) TyVarBndr_ flag
tvb
    )
  where
    tvbName :: Name
    tvbName :: Name
tvbName = TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
tvb

    substRangeFVs :: Set Name
    substRangeFVs :: Set Name
substRangeFVs = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables ([Type] -> [Name]) -> [Type] -> [Name]
forall a b. (a -> b) -> a -> b
$ Map Name Type -> [Type]
forall k a. Map k a -> [a]
Map.elems Map Name Type
subst

    evade :: Name -> Name
    evade :: Name -> Name
evade Name
n | Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
substRangeFVs
            = Name -> Name
evade (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
bump Name
n
            | Bool
otherwise
            = Name
n

    -- An improvement would be to try a variety of different characters instead
    -- of prepending the same character repeatedly. Let's wait to see if
    -- someone complains about this before making this more complicated,
    -- however.
    bump :: Name -> Name
    bump :: Name -> Name
bump Name
n = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'f'Char -> ShowS
forall a. a -> [a] -> [a]
:Name -> String
nameBase Name
n

-- | Substitutes into the kinds of type variable binders. This is slightly more
-- efficient than 'substTyVarBndrs', but at the expense of not avoiding
-- capture. Only use this function in situations where you know that none of
-- the 'TyVarBndr' names are contained in the range of the substitution.
substTyVarBndrKinds :: Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
substTyVarBndrKinds :: forall flag.
Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
substTyVarBndrKinds Map Name Type
subst = (TyVarBndr_ flag -> TyVarBndr_ flag)
-> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
forall a b. (a -> b) -> [a] -> [b]
map (Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag
forall flag. Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag
substTyVarBndrKind Map Name Type
subst)

-- | The workhorse for 'substTyVarBndrKinds'.
substTyVarBndrKind :: Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag
substTyVarBndrKind :: forall flag. Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag
substTyVarBndrKind Map Name Type
subst = (Type -> Type) -> TyVarBndr_ flag -> TyVarBndr_ flag
forall flag. (Type -> Type) -> TyVarBndr_ flag -> TyVarBndr_ flag
mapTVKind (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst)

------------------------------------------------------------------------

combineSubstitutions :: Map Name Type -> Map Name Type -> Map Name Type
combineSubstitutions :: Map Name Type -> Map Name Type -> Map Name Type
combineSubstitutions Map Name Type
x Map Name Type
y = Map Name Type -> Map Name Type -> Map Name Type
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ((Type -> Type) -> Map Name Type -> Map Name Type
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
y) Map Name Type
x) Map Name Type
y

-- | Compute the type variable substitution that unifies a list of types,
-- or fail in 'Q'.
--
-- All infix issue should be resolved before using 'unifyTypes'
--
-- Alpha equivalent quantified types are not unified.
unifyTypes :: [Type] -> Q (Map Name Type)
unifyTypes :: [Type] -> Q (Map Name Type)
unifyTypes [] = Map Name Type -> Q (Map Name Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Name Type
forall k a. Map k a
Map.empty
unifyTypes (Type
t:[Type]
ts) =
  do Type
t':[Type]
ts' <- (Type -> Q Type) -> [Type] -> Q [Type]
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 Type -> Q Type
resolveTypeSynonyms (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
ts)
     let aux :: Map Name Type -> Type -> Either (Type, Type) (Map Name Type)
aux Map Name Type
sub Type
u =
           do Map Name Type
sub' <- Type -> Type -> Either (Type, Type) (Map Name Type)
unify' (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
sub Type
t')
                             (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
sub Type
u)
              Map Name Type -> Either (Type, Type) (Map Name Type)
forall a. a -> Either (Type, Type) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type -> Map Name Type -> Map Name Type
combineSubstitutions Map Name Type
sub Map Name Type
sub')

     case (Map Name Type -> Type -> Either (Type, Type) (Map Name Type))
-> Map Name Type -> [Type] -> Either (Type, Type) (Map Name Type)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map Name Type -> Type -> Either (Type, Type) (Map Name Type)
aux Map Name Type
forall k a. Map k a
Map.empty [Type]
ts' of
       Right Map Name Type
m -> Map Name Type -> Q (Map Name Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Name Type
m
       Left (Type
x,Type
y) ->
         String -> Q (Map Name Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Map Name Type)) -> String -> Q (Map Name Type)
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Unable to unify types "
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Type
x
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" and "
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Type
y
              ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
""

unify' :: Type -> Type -> Either (Type,Type) (Map Name Type)

unify' :: Type -> Type -> Either (Type, Type) (Map Name Type)
unify' (VarT Name
n) (VarT Name
m) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m = Map Name Type -> Either (Type, Type) (Map Name Type)
forall a. a -> Either (Type, Type) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Name Type
forall k a. Map k a
Map.empty
unify' (VarT Name
n) Type
t | Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t = (Type, Type) -> Either (Type, Type) (Map Name Type)
forall a b. a -> Either a b
Left (Name -> Type
VarT Name
n, Type
t)
                  | Bool
otherwise                = Map Name Type -> Either (Type, Type) (Map Name Type)
forall a b. b -> Either a b
Right (Name -> Type -> Map Name Type
forall k a. k -> a -> Map k a
Map.singleton Name
n Type
t)
unify' Type
t (VarT Name
n) | Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t = (Type, Type) -> Either (Type, Type) (Map Name Type)
forall a b. a -> Either a b
Left (Name -> Type
VarT Name
n, Type
t)
                  | Bool
otherwise                = Map Name Type -> Either (Type, Type) (Map Name Type)
forall a b. b -> Either a b
Right (Name -> Type -> Map Name Type
forall k a. k -> a -> Map k a
Map.singleton Name
n Type
t)

unify' (AppT Type
f1 Type
x1) (AppT Type
f2 Type
x2) =
  do Map Name Type
sub1 <- Type -> Type -> Either (Type, Type) (Map Name Type)
unify' Type
f1 Type
f2
     Map Name Type
sub2 <- Type -> Type -> Either (Type, Type) (Map Name Type)
unify' (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
sub1 Type
x1) (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
sub1 Type
x2)
     Map Name Type -> Either (Type, Type) (Map Name Type)
forall a b. b -> Either a b
Right (Map Name Type -> Map Name Type -> Map Name Type
combineSubstitutions Map Name Type
sub1 Map Name Type
sub2)

-- Doesn't unify kind signatures
unify' (SigT Type
t Type
_) Type
u = Type -> Type -> Either (Type, Type) (Map Name Type)
unify' Type
t Type
u
unify' Type
t (SigT Type
u Type
_) = Type -> Type -> Either (Type, Type) (Map Name Type)
unify' Type
t Type
u

-- only non-recursive cases should remain at this point
unify' Type
t Type
u
  | Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
u    = Map Name Type -> Either (Type, Type) (Map Name Type)
forall a b. b -> Either a b
Right Map Name Type
forall k a. Map k a
Map.empty
  | Bool
otherwise = (Type, Type) -> Either (Type, Type) (Map Name Type)
forall a b. a -> Either a b
Left (Type
t,Type
u)


-- | Construct an equality constraint. The implementation of 'Pred' varies
-- across versions of Template Haskell.
equalPred :: Type -> Type -> Pred
equalPred :: Type -> Type -> Type
equalPred Type
x Type
y =
#if MIN_VERSION_template_haskell(2,10,0)
  Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
EqualityT Type
x) Type
y
#else
  EqualP x y
#endif

-- | Construct a typeclass constraint. The implementation of 'Pred' varies
-- across versions of Template Haskell.
classPred :: Name {- ^ class -} -> [Type] {- ^ parameters -} -> Pred
classPred :: Name -> [Type] -> Type
classPred =
#if MIN_VERSION_template_haskell(2,10,0)
  (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
foldl Type -> Type -> Type
AppT (Type -> [Type] -> Type)
-> (Name -> Type) -> Name -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
ConT
#else
  ClassP
#endif

-- | Match a 'Pred' representing an equality constraint. Returns
-- arguments to the equality constraint if successful.
asEqualPred :: Pred -> Maybe (Type,Type)
#if MIN_VERSION_template_haskell(2,10,0)
asEqualPred :: Type -> Maybe (Type, Type)
asEqualPred (Type
EqualityT `AppT` Type
x `AppT` Type
y)                    = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
x,Type
y)
asEqualPred (ConT Name
eq   `AppT` Type
x `AppT` Type
y) | Name
eq Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
eqTypeName = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
x,Type
y)
#else
asEqualPred (EqualP            x        y)                   = Just (x,y)
#endif
asEqualPred Type
_                                                = Maybe (Type, Type)
forall a. Maybe a
Nothing

-- | Match a 'Pred' representing a class constraint.
-- Returns the classname and parameters if successful.
asClassPred :: Pred -> Maybe (Name, [Type])
#if MIN_VERSION_template_haskell(2,10,0)
asClassPred :: Type -> Maybe (Name, [Type])
asClassPred Type
t =
  case Type -> NonEmpty Type
decomposeType Type
t of
    ConT Name
f :| [Type]
xs | Name
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
eqTypeName -> (Name, [Type]) -> Maybe (Name, [Type])
forall a. a -> Maybe a
Just (Name
f,[Type]
xs)
    NonEmpty Type
_                              -> Maybe (Name, [Type])
forall a. Maybe a
Nothing
#else
asClassPred (ClassP f xs) = Just (f,xs)
asClassPred _             = Nothing
#endif

------------------------------------------------------------------------

-- | If we are working with a 'Dec' obtained via 'reify' (as opposed to one
-- created from, say, [d| ... |] quotes), then we need to apply more hacks than
-- we otherwise would to sanitize the 'Dec'. See #28.
type IsReifiedDec = Bool

isReified, isn'tReified :: IsReifiedDec
isReified :: Bool
isReified    = Bool
True
isn'tReified :: Bool
isn'tReified = Bool
False

-- On old versions of GHC, reify would not give you kind signatures for
-- GADT type variables of kind *. To work around this, we insert the kinds
-- manually on any reified type variable binders without a signature. However,
-- don't do this for quoted type variable binders (#84).

giveDIVarsStarKinds :: IsReifiedDec -> DatatypeInfo -> DatatypeInfo
giveDIVarsStarKinds :: Bool -> DatatypeInfo -> DatatypeInfo
giveDIVarsStarKinds Bool
isReified DatatypeInfo
info =
  DatatypeInfo
info { datatypeVars      = map (giveTyVarBndrStarKind isReified) (datatypeVars info)
       , datatypeInstTypes = map (giveTypeStarKind isReified) (datatypeInstTypes info) }

giveCIVarsStarKinds :: IsReifiedDec -> ConstructorInfo -> ConstructorInfo
giveCIVarsStarKinds :: Bool -> ConstructorInfo -> ConstructorInfo
giveCIVarsStarKinds Bool
isReified ConstructorInfo
info =
  ConstructorInfo
info { constructorVars = map (giveTyVarBndrStarKind isReified) (constructorVars info) }

giveTyVarBndrStarKind :: IsReifiedDec ->  TyVarBndrUnit -> TyVarBndrUnit
giveTyVarBndrStarKind :: Bool -> TyVarBndrUnit -> TyVarBndrUnit
giveTyVarBndrStarKind Bool
isReified TyVarBndrUnit
tvb
  | Bool
isReified
  = (Name -> TyVarBndrUnit)
-> (Name -> Type -> TyVarBndrUnit)
-> TyVarBndrUnit
-> TyVarBndrUnit
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
n -> Name -> Type -> TyVarBndrUnit
kindedTV Name
n Type
starK) (\Name
_ Type
_ -> TyVarBndrUnit
tvb) TyVarBndrUnit
tvb
  | Bool
otherwise
  = TyVarBndrUnit
tvb

giveTypeStarKind :: IsReifiedDec -> Type -> Type
giveTypeStarKind :: Bool -> Type -> Type
giveTypeStarKind Bool
isReified Type
t
  | Bool
isReified
  = case Type
t of
      VarT Name
n -> Type -> Type -> Type
SigT Type
t Type
starK
      Type
_      -> Type
t
  | Bool
otherwise
  = Type
t

-- | Prior to GHC 8.2.1, reify was broken for data instances and newtype
-- instances. This code attempts to detect the problem and repair it if
-- possible.
--
-- The particular problem is that the type variables used in the patterns
-- while defining a data family instance do not completely match those
-- used when defining the fields of the value constructors beyond the
-- base names. This code attempts to recover the relationship between the
-- type variables.
--
-- It is possible, however, to generate these kinds of declarations by
-- means other than reify. In these cases the name bases might not be
-- unique and the declarations might be well formed. In such a case this
-- code attempts to avoid altering the declaration.
--
-- https://ghc.haskell.org/trac/ghc/ticket/13618
repair13618 :: DatatypeInfo -> Q DatatypeInfo
repair13618 :: DatatypeInfo -> Q DatatypeInfo
repair13618 DatatypeInfo
info =
  do Map Name Type
s <- Map Name (Q Type) -> Q (Map Name Type)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Map Name (m a) -> m (Map Name a)
T.sequence ([(Name, Q Type)] -> Map Name (Q Type)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, Q Type)]
substList)
     DatatypeInfo -> Q DatatypeInfo
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DatatypeInfo
info { datatypeCons = applySubstitution s (datatypeCons info) }

  where
    used :: [Name]
used  = [ConstructorInfo] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
info)
    bound :: [Name]
bound = (TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (DatatypeInfo -> [TyVarBndrUnit]
datatypeVars DatatypeInfo
info)
    free :: [Name]
free  = [Name]
used [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
bound

    substList :: [(Name, Q Type)]
substList =
      [ (Name
u, Name -> [Name] -> Q Type
forall {m :: * -> *} {a}.
(Quote m, MonadFail m, Show a) =>
a -> [Name] -> m Type
substEntry Name
u [Name]
vs)
      | Name
u <- [Name]
free
      , let vs :: [Name]
vs = [Name
v | Name
v <- [Name]
bound, Name -> String
nameBase Name
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
nameBase Name
u]
      ]

    substEntry :: a -> [Name] -> m Type
substEntry a
_ [Name
v] = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
v
    substEntry a
u []  = String -> m Type
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Impossible free variable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
u)
    substEntry a
u [Name]
_   = String -> m Type
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Ambiguous free variable: "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
u)

------------------------------------------------------------------------

-- | Backward compatible version of 'dataD'
dataDCompat ::
  CxtQ           {- ^ context                 -} ->
  Name           {- ^ type constructor        -} ->
  [TyVarBndrVis] {- ^ type parameters         -} ->
  [ConQ]         {- ^ constructor definitions -} ->
  [Name]         {- ^ derived class names     -} ->
  DecQ
#if MIN_VERSION_template_haskell(2,12,0)
dataDCompat :: Q [Type] -> Name -> [TyVarBndrUnit] -> [ConQ] -> [Name] -> Q Dec
dataDCompat Q [Type]
c Name
n [TyVarBndrUnit]
ts [ConQ]
cs [Name]
ds =
  Q [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [ConQ]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD Q [Type]
c Name
n [TyVarBndrUnit]
ts Maybe Type
forall a. Maybe a
Nothing [ConQ]
cs
    (if [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
ds then [] else [Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT [Name]
ds)])
#elif MIN_VERSION_template_haskell(2,11,0)
dataDCompat c n ts cs ds =
  dataD c n ts Nothing cs
    (return (map ConT ds))
#else
dataDCompat = dataD
#endif

-- | Backward compatible version of 'newtypeD'
newtypeDCompat ::
  CxtQ           {- ^ context                 -} ->
  Name           {- ^ type constructor        -} ->
  [TyVarBndrVis] {- ^ type parameters         -} ->
  ConQ           {- ^ constructor definition  -} ->
  [Name]         {- ^ derived class names     -} ->
  DecQ
#if MIN_VERSION_template_haskell(2,12,0)
newtypeDCompat :: Q [Type] -> Name -> [TyVarBndrUnit] -> ConQ -> [Name] -> Q Dec
newtypeDCompat Q [Type]
c Name
n [TyVarBndrUnit]
ts ConQ
cs [Name]
ds =
  Q [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> ConQ
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD Q [Type]
c Name
n [TyVarBndrUnit]
ts Maybe Type
forall a. Maybe a
Nothing ConQ
cs
    (if [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
ds then [] else [Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT [Name]
ds)])
#elif MIN_VERSION_template_haskell(2,11,0)
newtypeDCompat c n ts cs ds =
  newtypeD c n ts Nothing cs
    (return (map ConT ds))
#else
newtypeDCompat = newtypeD
#endif

-- | Backward compatible version of 'tySynInstD'
tySynInstDCompat ::
  Name                    {- ^ type family name    -}   ->
  Maybe [Q TyVarBndrUnit] {- ^ type variable binders -} ->
  [TypeQ]                 {- ^ instance parameters -}   ->
  TypeQ                   {- ^ instance result     -}   ->
  DecQ
#if MIN_VERSION_template_haskell(2,15,0)
tySynInstDCompat :: Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat Name
n Maybe [Q TyVarBndrUnit]
mtvbs [Q Type]
ps Q Type
r = TySynEqn -> Dec
TySynInstD (TySynEqn -> Dec) -> Q TySynEqn -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe [TyVarBndrUnit] -> Type -> Type -> TySynEqn
TySynEqn (Maybe [TyVarBndrUnit] -> Type -> Type -> TySynEqn)
-> Q (Maybe [TyVarBndrUnit]) -> Q (Type -> Type -> TySynEqn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Q TyVarBndrUnit] -> Q [TyVarBndrUnit])
-> Maybe [Q TyVarBndrUnit] -> Q (Maybe [TyVarBndrUnit])
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) -> Maybe a -> m (Maybe b)
mapM [Q TyVarBndrUnit] -> Q [TyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence Maybe [Q TyVarBndrUnit]
mtvbs
                                                         Q (Type -> Type -> TySynEqn) -> Q Type -> Q (Type -> TySynEqn)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
n) [Q Type]
ps
                                                         Q (Type -> TySynEqn) -> Q Type -> Q TySynEqn
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Type
r)
#elif MIN_VERSION_template_haskell(2,9,0)
tySynInstDCompat n _ ps r     = TySynInstD n <$> (TySynEqn <$> sequence ps <*> r)
#else
tySynInstDCompat n _          = tySynInstD n
#endif

-- | Backward compatible version of 'pragLineD'. Returns
-- 'Nothing' if line pragmas are not suported.
pragLineDCompat ::
  Int     {- ^ line number -} ->
  String  {- ^ file name   -} ->
  Maybe DecQ
#if MIN_VERSION_template_haskell(2,10,0)
pragLineDCompat :: Int -> String -> Maybe (Q Dec)
pragLineDCompat Int
ln String
fn = Q Dec -> Maybe (Q Dec)
forall a. a -> Maybe a
Just (Int -> String -> Q Dec
forall (m :: * -> *). Quote m => Int -> String -> m Dec
pragLineD Int
ln String
fn)
#else
pragLineDCompat _  _  = Nothing
#endif

arrowKCompat :: Kind -> Kind -> Kind
#if MIN_VERSION_template_haskell(2,8,0)
arrowKCompat :: Type -> Type -> Type
arrowKCompat Type
x Type
y = Type
arrowK Type -> Type -> Type
`appK` Type
x Type -> Type -> Type
`appK` Type
y
#else
arrowKCompat = arrowK
#endif

------------------------------------------------------------------------

-- | Backwards compatibility wrapper for 'Fixity' lookup.
--
-- In @template-haskell-2.11.0.0@ and later, the answer will always
-- be 'Just' of a fixity.
--
-- Before @template-haskell-2.11.0.0@ it was only possible to determine
-- fixity information for variables, class methods, and data constructors.
-- In this case for type operators the answer could be 'Nothing', which
-- indicates that the answer is unavailable.
reifyFixityCompat :: Name -> Q (Maybe Fixity)
#if MIN_VERSION_template_haskell(2,11,0)
reifyFixityCompat :: Name -> Q (Maybe Fixity)
reifyFixityCompat Name
n = Q (Maybe Fixity) -> Q (Maybe Fixity) -> Q (Maybe Fixity)
forall a. Q a -> Q a -> Q a
recover (Maybe Fixity -> Q (Maybe Fixity)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Fixity
forall a. Maybe a
Nothing) ((Maybe Fixity -> Maybe Fixity -> Maybe Fixity
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
defaultFixity) (Maybe Fixity -> Maybe Fixity)
-> Q (Maybe Fixity) -> Q (Maybe Fixity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q (Maybe Fixity)
reifyFixity Name
n)
#else
reifyFixityCompat n = recover (return Nothing) $
  do info <- reify n
     return $! case info of
       ClassOpI _ _ _ fixity -> Just fixity
       DataConI _ _ _ fixity -> Just fixity
       VarI     _ _ _ fixity -> Just fixity
       _                     -> Nothing
#endif

-- | Call 'reify' and return @'Just' info@ if successful or 'Nothing' if
-- reification failed.
reifyMaybe :: Name -> Q (Maybe Info)
reifyMaybe :: Name -> Q (Maybe Info)
reifyMaybe Name
n = Maybe Info -> Q (Maybe Info)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Info
forall a. Maybe a
Nothing Q (Maybe Info) -> Q (Maybe Info) -> Q (Maybe Info)
forall a. Q a -> Q a -> Q a
`recover` (Info -> Maybe Info) -> Q Info -> Q (Maybe Info)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Info -> Maybe Info
forall a. a -> Maybe a
Just (Name -> Q Info
reify Name
n)