{-# Language CPP, DeriveDataTypeable #-}

#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'
 , '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@.
--
-- * 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 -> Cxt
datatypeContext   :: Cxt               -- ^ Data type context (deprecated)
  , DatatypeInfo -> Name
datatypeName      :: Name              -- ^ Type constructor
  , DatatypeInfo -> [TyVarBndrUnit]
datatypeVars      :: [TyVarBndrUnit]   -- ^ Type parameters
  , DatatypeInfo -> Cxt
datatypeInstTypes :: [Type]            -- ^ Argument types
  , DatatypeInfo -> DatatypeVariant
datatypeVariant   :: DatatypeVariant   -- ^ Extra information
  , 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
showList :: [DatatypeInfo] -> ShowS
$cshowList :: [DatatypeInfo] -> ShowS
show :: DatatypeInfo -> String
$cshow :: DatatypeInfo -> String
showsPrec :: Int -> DatatypeInfo -> ShowS
$cshowsPrec :: Int -> DatatypeInfo -> ShowS
Show, DatatypeInfo -> DatatypeInfo -> Bool
(DatatypeInfo -> DatatypeInfo -> Bool)
-> (DatatypeInfo -> DatatypeInfo -> Bool) -> Eq DatatypeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DatatypeInfo -> DatatypeInfo -> Bool
$c/= :: DatatypeInfo -> DatatypeInfo -> Bool
== :: DatatypeInfo -> DatatypeInfo -> Bool
$c== :: DatatypeInfo -> DatatypeInfo -> Bool
Eq, Typeable, Typeable DatatypeInfo
DataType
Constr
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 -> DataType
DatatypeInfo -> Constr
(forall b. Data b => b -> b) -> DatatypeInfo -> DatatypeInfo
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeInfo -> c DatatypeInfo
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cDatatypeInfo :: Constr
$tDatatypeInfo :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
gmapQi :: Int -> (forall d. Data d => d -> u) -> DatatypeInfo -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DatatypeInfo -> u
gmapQ :: (forall d. Data d => d -> u) -> DatatypeInfo -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeInfo -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
gmapT :: (forall b. Data b => b -> b) -> DatatypeInfo -> DatatypeInfo
$cgmapT :: (forall b. Data b => b -> b) -> DatatypeInfo -> DatatypeInfo
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeInfo)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeInfo)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DatatypeInfo)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeInfo)
dataTypeOf :: DatatypeInfo -> DataType
$cdataTypeOf :: DatatypeInfo -> DataType
toConstr :: DatatypeInfo -> Constr
$ctoConstr :: DatatypeInfo -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeInfo
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeInfo
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeInfo -> c DatatypeInfo
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeInfo -> c DatatypeInfo
$cp1Data :: Typeable 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
$cto :: forall x. Rep DatatypeInfo x -> DatatypeInfo
$cfrom :: forall x. DatatypeInfo -> Rep DatatypeInfo x
Generic
#endif
           )

-- | Possible variants of data type declarations.
data DatatypeVariant
  = Datatype        -- ^ Type declared with @data@
  | Newtype         -- ^ Type declared with @newtype@
  | DataInstance    -- ^ Type declared with @data instance@
  | NewtypeInstance -- ^ Type declared with @newtype instance@
  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
showList :: [DatatypeVariant] -> ShowS
$cshowList :: [DatatypeVariant] -> ShowS
show :: DatatypeVariant -> String
$cshow :: DatatypeVariant -> String
showsPrec :: Int -> DatatypeVariant -> ShowS
$cshowsPrec :: Int -> 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
readListPrec :: ReadPrec [DatatypeVariant]
$creadListPrec :: ReadPrec [DatatypeVariant]
readPrec :: ReadPrec DatatypeVariant
$creadPrec :: ReadPrec DatatypeVariant
readList :: ReadS [DatatypeVariant]
$creadList :: ReadS [DatatypeVariant]
readsPrec :: Int -> ReadS DatatypeVariant
$creadsPrec :: Int -> ReadS DatatypeVariant
Read, DatatypeVariant -> DatatypeVariant -> Bool
(DatatypeVariant -> DatatypeVariant -> Bool)
-> (DatatypeVariant -> DatatypeVariant -> Bool)
-> Eq DatatypeVariant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DatatypeVariant -> DatatypeVariant -> Bool
$c/= :: DatatypeVariant -> DatatypeVariant -> Bool
== :: DatatypeVariant -> DatatypeVariant -> Bool
$c== :: 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
min :: DatatypeVariant -> DatatypeVariant -> DatatypeVariant
$cmin :: DatatypeVariant -> DatatypeVariant -> DatatypeVariant
max :: DatatypeVariant -> DatatypeVariant -> DatatypeVariant
$cmax :: DatatypeVariant -> DatatypeVariant -> DatatypeVariant
>= :: DatatypeVariant -> DatatypeVariant -> Bool
$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
compare :: DatatypeVariant -> DatatypeVariant -> Ordering
$ccompare :: DatatypeVariant -> DatatypeVariant -> Ordering
$cp1Ord :: Eq DatatypeVariant
Ord, Typeable, Typeable DatatypeVariant
DataType
Constr
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 -> DataType
DatatypeVariant -> Constr
(forall b. Data b => b -> b) -> DatatypeVariant -> DatatypeVariant
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeVariant -> c DatatypeVariant
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cNewtypeInstance :: Constr
$cDataInstance :: Constr
$cNewtype :: Constr
$cDatatype :: Constr
$tDatatypeVariant :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
gmapQi :: Int -> (forall d. Data d => d -> u) -> DatatypeVariant -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DatatypeVariant -> u
gmapQ :: (forall d. Data d => d -> u) -> DatatypeVariant -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeVariant -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
gmapT :: (forall b. Data b => b -> b) -> DatatypeVariant -> DatatypeVariant
$cgmapT :: (forall b. Data b => b -> b) -> DatatypeVariant -> DatatypeVariant
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeVariant)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeVariant)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DatatypeVariant)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeVariant)
dataTypeOf :: DatatypeVariant -> DataType
$cdataTypeOf :: DatatypeVariant -> DataType
toConstr :: DatatypeVariant -> Constr
$ctoConstr :: DatatypeVariant -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeVariant
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeVariant
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeVariant -> c DatatypeVariant
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeVariant -> c DatatypeVariant
$cp1Data :: Typeable 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
$cto :: forall x. Rep DatatypeVariant x -> DatatypeVariant
$cfrom :: forall x. DatatypeVariant -> Rep DatatypeVariant x
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 -> Cxt
constructorContext    :: Cxt                -- ^ Constructor constraints
  , ConstructorInfo -> Cxt
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
showList :: [ConstructorInfo] -> ShowS
$cshowList :: [ConstructorInfo] -> ShowS
show :: ConstructorInfo -> String
$cshow :: ConstructorInfo -> String
showsPrec :: Int -> ConstructorInfo -> ShowS
$cshowsPrec :: Int -> ConstructorInfo -> ShowS
Show, ConstructorInfo -> ConstructorInfo -> Bool
(ConstructorInfo -> ConstructorInfo -> Bool)
-> (ConstructorInfo -> ConstructorInfo -> Bool)
-> Eq ConstructorInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstructorInfo -> ConstructorInfo -> Bool
$c/= :: ConstructorInfo -> ConstructorInfo -> Bool
== :: ConstructorInfo -> ConstructorInfo -> Bool
$c== :: ConstructorInfo -> ConstructorInfo -> Bool
Eq, Typeable, Typeable ConstructorInfo
DataType
Constr
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 -> DataType
ConstructorInfo -> Constr
(forall b. Data b => b -> b) -> ConstructorInfo -> ConstructorInfo
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConstructorInfo -> c ConstructorInfo
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cConstructorInfo :: Constr
$tConstructorInfo :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
gmapQi :: Int -> (forall d. Data d => d -> u) -> ConstructorInfo -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorInfo -> u
gmapQ :: (forall d. Data d => d -> u) -> ConstructorInfo -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorInfo -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
gmapT :: (forall b. Data b => b -> b) -> ConstructorInfo -> ConstructorInfo
$cgmapT :: (forall b. Data b => b -> b) -> ConstructorInfo -> ConstructorInfo
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorInfo)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorInfo)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c ConstructorInfo)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorInfo)
dataTypeOf :: ConstructorInfo -> DataType
$cdataTypeOf :: ConstructorInfo -> DataType
toConstr :: ConstructorInfo -> Constr
$ctoConstr :: ConstructorInfo -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorInfo
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorInfo
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConstructorInfo -> c ConstructorInfo
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConstructorInfo -> c ConstructorInfo
$cp1Data :: Typeable 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
$cto :: forall x. Rep ConstructorInfo x -> ConstructorInfo
$cfrom :: forall x. ConstructorInfo -> Rep ConstructorInfo x
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
showList :: [ConstructorVariant] -> ShowS
$cshowList :: [ConstructorVariant] -> ShowS
show :: ConstructorVariant -> String
$cshow :: ConstructorVariant -> String
showsPrec :: Int -> ConstructorVariant -> ShowS
$cshowsPrec :: Int -> ConstructorVariant -> ShowS
Show, ConstructorVariant -> ConstructorVariant -> Bool
(ConstructorVariant -> ConstructorVariant -> Bool)
-> (ConstructorVariant -> ConstructorVariant -> Bool)
-> Eq ConstructorVariant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstructorVariant -> ConstructorVariant -> Bool
$c/= :: ConstructorVariant -> ConstructorVariant -> Bool
== :: ConstructorVariant -> ConstructorVariant -> Bool
$c== :: 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
min :: ConstructorVariant -> ConstructorVariant -> ConstructorVariant
$cmin :: ConstructorVariant -> ConstructorVariant -> ConstructorVariant
max :: ConstructorVariant -> ConstructorVariant -> ConstructorVariant
$cmax :: ConstructorVariant -> ConstructorVariant -> ConstructorVariant
>= :: ConstructorVariant -> ConstructorVariant -> Bool
$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
compare :: ConstructorVariant -> ConstructorVariant -> Ordering
$ccompare :: ConstructorVariant -> ConstructorVariant -> Ordering
$cp1Ord :: Eq ConstructorVariant
Ord, Typeable, Typeable ConstructorVariant
DataType
Constr
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 -> DataType
ConstructorVariant -> Constr
(forall b. Data b => b -> b)
-> ConstructorVariant -> ConstructorVariant
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ConstructorVariant
-> c ConstructorVariant
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cRecordConstructor :: Constr
$cInfixConstructor :: Constr
$cNormalConstructor :: Constr
$tConstructorVariant :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
gmapQi :: Int -> (forall d. Data d => d -> u) -> ConstructorVariant -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorVariant -> u
gmapQ :: (forall d. Data d => d -> u) -> ConstructorVariant -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorVariant -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
gmapT :: (forall b. Data b => b -> b)
-> ConstructorVariant -> ConstructorVariant
$cgmapT :: (forall b. Data b => b -> b)
-> ConstructorVariant -> ConstructorVariant
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorVariant)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorVariant)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c ConstructorVariant)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorVariant)
dataTypeOf :: ConstructorVariant -> DataType
$cdataTypeOf :: ConstructorVariant -> DataType
toConstr :: ConstructorVariant -> Constr
$ctoConstr :: ConstructorVariant -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorVariant
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorVariant
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ConstructorVariant
-> c ConstructorVariant
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ConstructorVariant
-> c ConstructorVariant
$cp1Data :: Typeable 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
$cto :: forall x. Rep ConstructorVariant x -> ConstructorVariant
$cfrom :: forall x. ConstructorVariant -> Rep ConstructorVariant x
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
showList :: [FieldStrictness] -> ShowS
$cshowList :: [FieldStrictness] -> ShowS
show :: FieldStrictness -> String
$cshow :: FieldStrictness -> String
showsPrec :: Int -> FieldStrictness -> ShowS
$cshowsPrec :: Int -> FieldStrictness -> ShowS
Show, FieldStrictness -> FieldStrictness -> Bool
(FieldStrictness -> FieldStrictness -> Bool)
-> (FieldStrictness -> FieldStrictness -> Bool)
-> Eq FieldStrictness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldStrictness -> FieldStrictness -> Bool
$c/= :: FieldStrictness -> FieldStrictness -> Bool
== :: FieldStrictness -> FieldStrictness -> Bool
$c== :: 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
min :: FieldStrictness -> FieldStrictness -> FieldStrictness
$cmin :: FieldStrictness -> FieldStrictness -> FieldStrictness
max :: FieldStrictness -> FieldStrictness -> FieldStrictness
$cmax :: FieldStrictness -> FieldStrictness -> FieldStrictness
>= :: FieldStrictness -> FieldStrictness -> Bool
$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
compare :: FieldStrictness -> FieldStrictness -> Ordering
$ccompare :: FieldStrictness -> FieldStrictness -> Ordering
$cp1Ord :: Eq FieldStrictness
Ord, Typeable, Typeable FieldStrictness
DataType
Constr
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 -> DataType
FieldStrictness -> Constr
(forall b. Data b => b -> b) -> FieldStrictness -> FieldStrictness
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FieldStrictness -> c FieldStrictness
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cFieldStrictness :: Constr
$tFieldStrictness :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
gmapQi :: Int -> (forall d. Data d => d -> u) -> FieldStrictness -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> FieldStrictness -> u
gmapQ :: (forall d. Data d => d -> u) -> FieldStrictness -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> FieldStrictness -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
gmapT :: (forall b. Data b => b -> b) -> FieldStrictness -> FieldStrictness
$cgmapT :: (forall b. Data b => b -> b) -> FieldStrictness -> FieldStrictness
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c FieldStrictness)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c FieldStrictness)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c FieldStrictness)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FieldStrictness)
dataTypeOf :: FieldStrictness -> DataType
$cdataTypeOf :: FieldStrictness -> DataType
toConstr :: FieldStrictness -> Constr
$ctoConstr :: FieldStrictness -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FieldStrictness
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FieldStrictness
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FieldStrictness -> c FieldStrictness
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FieldStrictness -> c FieldStrictness
$cp1Data :: Typeable 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
$cto :: forall x. Rep FieldStrictness x -> FieldStrictness
$cfrom :: forall x. FieldStrictness -> Rep FieldStrictness x
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
showList :: [Unpackedness] -> ShowS
$cshowList :: [Unpackedness] -> ShowS
show :: Unpackedness -> String
$cshow :: Unpackedness -> String
showsPrec :: Int -> Unpackedness -> ShowS
$cshowsPrec :: Int -> Unpackedness -> ShowS
Show, Unpackedness -> Unpackedness -> Bool
(Unpackedness -> Unpackedness -> Bool)
-> (Unpackedness -> Unpackedness -> Bool) -> Eq Unpackedness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Unpackedness -> Unpackedness -> Bool
$c/= :: Unpackedness -> Unpackedness -> Bool
== :: Unpackedness -> Unpackedness -> Bool
$c== :: 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
min :: Unpackedness -> Unpackedness -> Unpackedness
$cmin :: Unpackedness -> Unpackedness -> Unpackedness
max :: Unpackedness -> Unpackedness -> Unpackedness
$cmax :: Unpackedness -> Unpackedness -> Unpackedness
>= :: Unpackedness -> Unpackedness -> Bool
$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
compare :: Unpackedness -> Unpackedness -> Ordering
$ccompare :: Unpackedness -> Unpackedness -> Ordering
$cp1Ord :: Eq Unpackedness
Ord, Typeable, Typeable Unpackedness
DataType
Constr
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 -> DataType
Unpackedness -> Constr
(forall b. Data b => b -> b) -> Unpackedness -> Unpackedness
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Unpackedness -> c Unpackedness
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cUnpack :: Constr
$cNoUnpack :: Constr
$cUnspecifiedUnpackedness :: Constr
$tUnpackedness :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
gmapQi :: Int -> (forall d. Data d => d -> u) -> Unpackedness -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Unpackedness -> u
gmapQ :: (forall d. Data d => d -> u) -> Unpackedness -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Unpackedness -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
gmapT :: (forall b. Data b => b -> b) -> Unpackedness -> Unpackedness
$cgmapT :: (forall b. Data b => b -> b) -> Unpackedness -> Unpackedness
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c Unpackedness)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c Unpackedness)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Unpackedness)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Unpackedness)
dataTypeOf :: Unpackedness -> DataType
$cdataTypeOf :: Unpackedness -> DataType
toConstr :: Unpackedness -> Constr
$ctoConstr :: Unpackedness -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Unpackedness
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Unpackedness
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Unpackedness -> c Unpackedness
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Unpackedness -> c Unpackedness
$cp1Data :: Typeable 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
$cto :: forall x. Rep Unpackedness x -> Unpackedness
$cfrom :: forall x. Unpackedness -> Rep Unpackedness x
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
showList :: [Strictness] -> ShowS
$cshowList :: [Strictness] -> ShowS
show :: Strictness -> String
$cshow :: Strictness -> String
showsPrec :: Int -> Strictness -> ShowS
$cshowsPrec :: Int -> Strictness -> ShowS
Show, Strictness -> Strictness -> Bool
(Strictness -> Strictness -> Bool)
-> (Strictness -> Strictness -> Bool) -> Eq Strictness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Strictness -> Strictness -> Bool
$c/= :: Strictness -> Strictness -> Bool
== :: Strictness -> Strictness -> Bool
$c== :: 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
min :: Strictness -> Strictness -> Strictness
$cmin :: Strictness -> Strictness -> Strictness
max :: Strictness -> Strictness -> Strictness
$cmax :: Strictness -> Strictness -> Strictness
>= :: Strictness -> Strictness -> Bool
$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
compare :: Strictness -> Strictness -> Ordering
$ccompare :: Strictness -> Strictness -> Ordering
$cp1Ord :: Eq Strictness
Ord, Typeable, Typeable Strictness
DataType
Constr
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 -> DataType
Strictness -> Constr
(forall b. Data b => b -> b) -> Strictness -> Strictness
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Strictness -> c Strictness
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cStrict :: Constr
$cLazy :: Constr
$cUnspecifiedStrictness :: Constr
$tStrictness :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d) -> Strictness -> m Strictness
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
gmapQi :: Int -> (forall d. Data d => d -> u) -> Strictness -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Strictness -> u
gmapQ :: (forall d. Data d => d -> u) -> Strictness -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Strictness -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
gmapT :: (forall b. Data b => b -> b) -> Strictness -> Strictness
$cgmapT :: (forall b. Data b => b -> b) -> Strictness -> Strictness
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Strictness)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Strictness)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Strictness)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Strictness)
dataTypeOf :: Strictness -> DataType
$cdataTypeOf :: Strictness -> DataType
toConstr :: Strictness -> Constr
$ctoConstr :: Strictness -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Strictness
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Strictness
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Strictness -> c Strictness
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Strictness -> c Strictness
$cp1Data :: Typeable 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
$cto :: forall x. Rep Strictness x -> Strictness
$cfrom :: forall x. Strictness -> Rep Strictness x
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 -> Cxt -> Type
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))
  (Cxt -> Type) -> Cxt -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
stripSigT
  (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Cxt
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.
--
-- 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 (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 (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{}                      -> String -> Q DatatypeInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
bad String
"Primitive type not supported"
    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 (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 (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 ([TyVarBndrUnit]
_, Cxt
_, Cxt
argTys :|- Type
_) = Type -> ([TyVarBndrUnit], Cxt, NonEmptySnoc Type)
uncurryType Type
recTy
  in case Cxt
argTys of
       Type
dataTy:Cxt
_ -> Type -> Q DatatypeInfo
decomposeDataType Type
dataTy
       Cxt
_        -> 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 :| Cxt
_ -> 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 :: Q a
notRecSelFailure = 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)
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)
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 (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 :: Q a
dataFamiliesOnOldGHCsError = 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 :: String -> Q a
panic String
message = 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 Cxt
cx Maybe [TyVarBndrUnit]
mbInstVars Type
nts Maybe Type
k Con
c [DerivClause]
deriv <- Dec
instD
      , Type
con :| Cxt
ts <- Type -> NonEmpty Type
decomposeType Type
nts
      = do Cxt
ts' <- [TyVarBndrUnit] -> Maybe Type -> Cxt -> Q Cxt
repairVarKindsWith [TyVarBndrUnit]
dvars Maybe Type
dk Cxt
ts
           Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Cxt
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD Cxt
cx Maybe [TyVarBndrUnit]
mbInstVars ((Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT Type
con Cxt
ts') Maybe Type
k Con
c [DerivClause]
deriv

      | DataFamilyD Name
_ [TyVarBndrUnit]
dvars Maybe Type
dk <- Dec
famD
      , DataInstD Cxt
cx Maybe [TyVarBndrUnit]
mbInstVars Type
nts Maybe Type
k [Con]
c [DerivClause]
deriv <- Dec
instD
      , Type
con :| Cxt
ts <- Type -> NonEmpty Type
decomposeType Type
nts
      = do Cxt
ts' <- [TyVarBndrUnit] -> Maybe Type -> Cxt -> Q Cxt
repairVarKindsWith [TyVarBndrUnit]
dvars Maybe Type
dk Cxt
ts
           Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Cxt
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD Cxt
cx Maybe [TyVarBndrUnit]
mbInstVars ((Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT Type
con Cxt
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 (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 :: [TyVarBndrUnit] -> Maybe Kind -> [Type] -> Q [Type]
repairVarKindsWith :: [TyVarBndrUnit] -> Maybe Type -> Cxt -> Q Cxt
repairVarKindsWith [TyVarBndrUnit]
tvbs Maybe Type
mbKind Cxt
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' = [TyVarBndrUnit]
tvbs [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
extra_tvbs
  Cxt -> Q Cxt
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt -> Q Cxt) -> Cxt -> Q Cxt
forall a b. (a -> b) -> a -> b
$ (TyVarBndrUnit -> Type -> Type) -> [TyVarBndrUnit] -> Cxt -> Cxt
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TyVarBndrUnit -> Type -> Type
forall flag. TyVarBndrUnit -> Type -> Type
stealKindForType [TyVarBndrUnit]
tvbs' Cxt
ts

-- If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.
stealKindForType :: TyVarBndr_ flag -> Type -> Type
stealKindForType :: TyVarBndrUnit -> Type -> Type
stealKindForType TyVarBndrUnit
tvb t :: Type
t@VarT{} = Type -> Type -> Type
SigT Type
t (TyVarBndrUnit -> Type
forall flag. TyVarBndrUnit -> Type
tvKind TyVarBndrUnit
tvb)
stealKindForType TyVarBndrUnit
_   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,12,0)
    NewtypeD Cxt
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind Con
con [DerivClause]
_derives ->
      Cxt
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataD Cxt
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con
con] DatatypeVariant
Newtype
    DataD Cxt
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons [DerivClause]
_derives ->
      Cxt
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataD Cxt
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons DatatypeVariant
Datatype
# if MIN_VERSION_template_haskell(2,15,0)
    NewtypeInstD Cxt
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys Maybe Type
mbKind Con
con [DerivClause]
_derives ->
      String
-> Cxt
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPostTH2'15 String
"newtype" Cxt
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys
                                   Maybe Type
mbKind [Con
con] DatatypeVariant
NewtypeInstance
    DataInstD Cxt
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys Maybe Type
mbKind [Con]
cons [DerivClause]
_derives ->
      String
-> Cxt
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPostTH2'15 String
"data" Cxt
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 (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 (m :: * -> *) a. Monad m => a -> m a
return DatatypeInfo
di

    -- Given a data type's instance types and kind, compute its free variables.
    datatypeFreeVars :: [Type] -> Maybe Kind -> [TyVarBndrUnit]
    datatypeFreeVars :: Cxt -> Maybe Type -> [TyVarBndrUnit]
datatypeFreeVars Cxt
instTys Maybe Type
mbKind =
      Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped (Cxt -> [TyVarBndrUnit]) -> Cxt -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ Cxt
instTys Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++
#if MIN_VERSION_template_haskell(2,8,0)
                                           Maybe Type -> Cxt
forall a. Maybe a -> [a]
maybeToList Maybe Type
mbKind
#else
                                           [] -- No kind variables
#endif

    normalizeDataD :: Cxt -> Name -> [TyVarBndrUnit] -> Maybe Kind
                   -> [Con] -> DatatypeVariant -> Q DatatypeInfo
    normalizeDataD :: Cxt
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataD Cxt
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons DatatypeVariant
variant =
      let params :: Cxt
params = [TyVarBndrUnit] -> Cxt
forall flag. [TyVarBndrUnit] -> Cxt
bndrParams [TyVarBndrUnit]
tyvars in
      Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' Cxt
context Name
name (Cxt -> Maybe Type -> [TyVarBndrUnit]
datatypeFreeVars Cxt
params Maybe Type
mbKind)
                 Cxt
params Maybe Type
mbKind [Con]
cons DatatypeVariant
variant

    normalizeDataInstDPostTH2'15
      :: String -> Cxt -> Maybe [TyVarBndrUnit] -> Type -> Maybe Kind
      -> [Con] -> DatatypeVariant -> Q DatatypeInfo
    normalizeDataInstDPostTH2'15 :: String
-> Cxt
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPostTH2'15 String
what Cxt
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys
                                 Maybe Type
mbKind [Con]
cons DatatypeVariant
variant =
      case Type -> NonEmpty Type
decomposeType Type
nameInstTys of
        ConT Name
name :| Cxt
instTys ->
          Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' Cxt
context Name
name
                     ([TyVarBndrUnit] -> Maybe [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. a -> Maybe a -> a
fromMaybe (Cxt -> Maybe Type -> [TyVarBndrUnit]
datatypeFreeVars Cxt
instTys Maybe Type
mbKind) Maybe [TyVarBndrUnit]
mbTyvars)
                     Cxt
instTys Maybe Type
mbKind [Con]
cons DatatypeVariant
variant
        NonEmpty Type
_ -> String -> Q DatatypeInfo
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 :: Cxt
-> Name
-> Cxt
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPreTH2'15 Cxt
context Name
name Cxt
instTys Maybe Type
mbKind [Con]
cons DatatypeVariant
variant =
      Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' Cxt
context Name
name (Cxt -> Maybe Type -> [TyVarBndrUnit]
datatypeFreeVars Cxt
instTys Maybe Type
mbKind)
                 Cxt
instTys Maybe Type
mbKind [Con]
cons DatatypeVariant
variant

    -- The main worker of this function.
    normalize' :: Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> Maybe Kind
               -> [Con] -> DatatypeVariant -> Q DatatypeInfo
    normalize' :: Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' Cxt
context Name
name [TyVarBndrUnit]
tvbs Cxt
instTys Maybe Type
mbKind [Con]
cons DatatypeVariant
variant = 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
      let tvbs' :: [TyVarBndrUnit]
tvbs'    = [TyVarBndrUnit]
tvbs [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
extra_tvbs
          instTys' :: Cxt
instTys' = Cxt
instTys Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit] -> Cxt
forall flag. [TyVarBndrUnit] -> Cxt
bndrParams [TyVarBndrUnit]
extra_tvbs
      DatatypeInfo
dec <- Bool
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDec' Bool
isReified Cxt
context Name
name [TyVarBndrUnit]
tvbs' Cxt
instTys' [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

-- | 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 ([TyVarBndrUnit]
_, Cxt
_, Cxt
args :|- Type
_) = Type -> ([TyVarBndrUnit], Cxt, NonEmptySnoc Type)
uncurryKind Type
kind'
  [Name]
names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
args) (String -> Q Name
newName String
"x")
  [TyVarBndrUnit] -> Q [TyVarBndrUnit]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndrUnit] -> Q [TyVarBndrUnit])
-> [TyVarBndrUnit] -> Q [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ (Name -> Type -> TyVarBndrUnit) -> [Name] -> Cxt -> [TyVarBndrUnit]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Type -> TyVarBndrUnit
kindedTV [Name]
names Cxt
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

bndrParams :: [TyVarBndr_ flag] -> [Type]
bndrParams :: [TyVarBndrUnit] -> Cxt
bndrParams = (TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ((TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> Cxt)
-> (TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> a -> b
$ (Name -> Type) -> (Name -> Type -> Type) -> TyVarBndrUnit -> Type
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndrUnit -> r
elimTV Name -> Type
VarT (\Name
n Type
k -> Type -> Type -> Type
SigT (Name -> Type
VarT Name
n) Type
k)

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


normalizeDec' ::
  IsReifiedDec    {- ^ Is this a reified 'Dec'? -} ->
  Cxt             {- ^ Datatype context         -} ->
  Name            {- ^ Type constructor         -} ->
  [TyVarBndrUnit] {- ^ Type parameters          -} ->
  [Type]          {- ^ Argument types           -} ->
  [Con]           {- ^ Constructors             -} ->
  DatatypeVariant {- ^ Extra information        -} ->
  Q DatatypeInfo
normalizeDec' :: Bool
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDec' Bool
reifiedDec Cxt
context Name
name [TyVarBndrUnit]
params Cxt
instTys [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)
mapM (Bool
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeConFor Bool
reifiedDec Name
name [TyVarBndrUnit]
params Cxt
instTys DatatypeVariant
variant) [Con]
cons
     DatatypeInfo -> Q DatatypeInfo
forall (m :: * -> *) a. Monad m => a -> m a
return DatatypeInfo :: Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> DatatypeVariant
-> [ConstructorInfo]
-> DatatypeInfo
DatatypeInfo
       { datatypeContext :: Cxt
datatypeContext   = Cxt
context
       , datatypeName :: Name
datatypeName      = Name
name
       , datatypeVars :: [TyVarBndrUnit]
datatypeVars      = [TyVarBndrUnit]
params
       , datatypeInstTypes :: Cxt
datatypeInstTypes = Cxt
instTys
       , datatypeCons :: [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons'
       , 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    -} ->
  DatatypeVariant {- ^ Extra information -} ->
  Con             {- ^ Constructor       -} ->
  Q [ConstructorInfo]
normalizeCon :: Name
-> [TyVarBndrUnit]
-> Cxt
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeCon = Bool
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeConFor Bool
isn'tReified

normalizeConFor ::
  IsReifiedDec    {- ^ Is this a reified 'Dec'? -} ->
  Name            {- ^ Type constructor         -} ->
  [TyVarBndrUnit] {- ^ Type parameters          -} ->
  [Type]          {- ^ Argument types           -} ->
  DatatypeVariant {- ^ Extra information        -} ->
  Con             {- ^ Constructor              -} ->
  Q [ConstructorInfo]
normalizeConFor :: Bool
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeConFor Bool
reifiedDec Name
typename [TyVarBndrUnit]
params Cxt
instTys DatatypeVariant
variant =
  ([ConstructorInfo] -> [ConstructorInfo])
-> Q [ConstructorInfo] -> Q [ConstructorInfo]
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 :: Cxt -> Name -> Q ConstructorVariant
checkGadtFixity Cxt
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 (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 (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
&& Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
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] -> Cxt -> 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] -> Cxt -> Bool -> Con -> Q [ConstructorInfo]
go [TyVarBndrUnit]
tyvars Cxt
context Bool
gadt Con
c =
                case Con
c of
                  NormalC Name
n [BangType]
xs -> do
                    let ([Bang]
bangs, Cxt
ts) = [BangType] -> ([Bang], Cxt)
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 Cxt -> Name -> Q ConstructorVariant
checkGadtFixity Cxt
ts Name
n
                             else ConstructorVariant -> Q ConstructorVariant
forall (m :: * -> *) a. Monad m => a -> m a
return ConstructorVariant
NormalConstructor
                    [ConstructorInfo] -> Q [ConstructorInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
-> [TyVarBndrUnit]
-> Cxt
-> Cxt
-> [FieldStrictness]
-> ConstructorVariant
-> ConstructorInfo
ConstructorInfo Name
n [TyVarBndrUnit]
tyvars Cxt
context Cxt
ts [FieldStrictness]
stricts ConstructorVariant
fi]
                  InfixC BangType
l Name
n BangType
r ->
                    let ([Bang]
bangs, Cxt
ts) = [BangType] -> ([Bang], Cxt)
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 (m :: * -> *) a. Monad m => a -> m a
return [Name
-> [TyVarBndrUnit]
-> Cxt
-> Cxt
-> [FieldStrictness]
-> ConstructorVariant
-> ConstructorInfo
ConstructorInfo Name
n [TyVarBndrUnit]
tyvars Cxt
context Cxt
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 (m :: * -> *) a. Monad m => a -> m a
return [Name
-> [TyVarBndrUnit]
-> Cxt
-> Cxt
-> [FieldStrictness]
-> ConstructorVariant
-> ConstructorInfo
ConstructorInfo Name
n [TyVarBndrUnit]
tyvars Cxt
context
                              ([VarBangType] -> Cxt
forall a b. [(a, b, Type)] -> Cxt
takeFieldTypes [VarBangType]
xs) [FieldStrictness]
stricts ([Name] -> ConstructorVariant
RecordConstructor [Name]
fns)]
                  ForallC [TyVarBndrUnit]
tyvars' Cxt
context' Con
c' ->
                    [TyVarBndrUnit] -> Cxt -> Bool -> Con -> Q [ConstructorInfo]
go (() -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall newFlag oldFlag.
newFlag -> [TyVarBndrUnit] -> [TyVarBndrUnit]
changeTVFlags () [TyVarBndrUnit]
tyvars'[TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++[TyVarBndrUnit]
tyvars) (Cxt
context'Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++Cxt
context) Bool
True Con
c'
#if MIN_VERSION_template_haskell(2,11,0)
                  GadtC [Name]
ns [BangType]
xs Type
innerType ->
                    let ([Bang]
bangs, Cxt
ts) = [BangType] -> ([Bang], Cxt)
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
-> Cxt
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
gadtCase [Name]
ns Type
innerType Cxt
ts [FieldStrictness]
stricts (Cxt -> Name -> Q ConstructorVariant
checkGadtFixity Cxt
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
-> Cxt
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
gadtCase [Name]
ns Type
innerType ([VarBangType] -> Cxt
forall a b. [(a, b, Type)] -> Cxt
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 (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
-> Cxt
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
gadtCase = Name
-> [TyVarBndrUnit]
-> Cxt
-> [TyVarBndrUnit]
-> Cxt
-> [Name]
-> Type
-> Cxt
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
normalizeGadtC Name
typename [TyVarBndrUnit]
params Cxt
instTys [TyVarBndrUnit]
tyvars Cxt
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 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               -} ->
  [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]
-> Cxt
-> [TyVarBndrUnit]
-> Cxt
-> [Name]
-> Type
-> Cxt
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
normalizeGadtC Name
typename [TyVarBndrUnit]
params Cxt
instTys [TyVarBndrUnit]
tyvars Cxt
context [Name]
names Type
innerType
               Cxt
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 = Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped
                          [[TyVarBndrUnit] -> Cxt -> Cxt -> Type -> Type
curryType (Specificity -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall newFlag oldFlag.
newFlag -> [TyVarBndrUnit] -> [TyVarBndrUnit]
changeTVFlags Specificity
SpecifiedSpec [TyVarBndrUnit]
tyvars)
                                     Cxt
context Cxt
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. TyVarBndrUnit -> Name
tvName TyVarBndrUnit
tvbName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (TyVarBndrUnit -> Type
forall flag. TyVarBndrUnit -> 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)
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
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 (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) -> TyVarBndrUnit -> 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 :: Cxt
renamedContext   = Map Name Type -> Cxt -> Cxt
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' Cxt
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 :: Cxt
renamedFields    = Map Name Type -> Cxt -> Cxt
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' Cxt
fields

     Type
innerType' <- Type -> Q Type
resolveTypeSynonyms Type
renamedInnerType
     case Type -> NonEmpty Type
decomposeType Type
innerType' of
       ConT Name
innerTyCon :| Cxt
ts | Name
typename Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
innerTyCon ->

         let (Map Name Name
substName, Cxt
context1) =
               Map Name Type
-> Map Name Type -> (Map Name Name, Cxt) -> (Map Name Name, Cxt)
closeOverKinds ([TyVarBndrUnit] -> Map Name Type
forall flag. [TyVarBndrUnit] -> Map Name Type
kindsOfFVsOfTvbs [TyVarBndrUnit]
renamedTyvars)
                              ([TyVarBndrUnit] -> Map Name Type
forall flag. [TyVarBndrUnit] -> Map Name Type
kindsOfFVsOfTvbs [TyVarBndrUnit]
params)
                              (Cxt -> Cxt -> (Map Name Name, Cxt)
mergeArguments Cxt
instTys Cxt
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. TyVarBndrUnit -> 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 -> [TyVarBndrUnit] -> [TyVarBndrUnit]
substTyVarBndrKinds Map Name Type
subst [TyVarBndrUnit]
exTyvars
             context2 :: Cxt
context2  = Map Name Type -> Cxt -> Cxt
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution   Map Name Type
subst (Cxt
context1 Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
renamedContext)
             fields' :: Cxt
fields'   = Map Name Type -> Cxt -> Cxt
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution   Map Name Type
subst Cxt
renamedFields
         in [Q ConstructorInfo] -> Q [ConstructorInfo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name
-> [TyVarBndrUnit]
-> Cxt
-> Cxt
-> [FieldStrictness]
-> ConstructorVariant
-> ConstructorInfo
ConstructorInfo Name
name [TyVarBndrUnit]
forall flag. [TyVarBndrUnit]
exTyvars' Cxt
context2
                                       Cxt
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 (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, Cxt) -> (Map Name Name, Cxt)
closeOverKinds Map Name Type
domainFVKinds Map Name Type
rangeFVKinds = (Map Name Name, Cxt) -> (Map Name Name, Cxt)
go
  where
    go :: (Map Name Name, Cxt) -> (Map Name Name, Cxt)
    go :: (Map Name Name, Cxt) -> (Map Name Name, Cxt)
go (Map Name Name
subst, Cxt
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
          (Cxt
kindsInner, Cxt
kindsOuter) =
            [(Type, Type)] -> (Cxt, Cxt)
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Type, Type)] -> (Cxt, Cxt)) -> [(Type, Type)] -> (Cxt, Cxt)
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 (m :: * -> *) a. Monad m => a -> m a
return (Type
d', Type
r'))
                     [(Name, Name)]
substList
          (Map Name Name
kindSubst, Cxt
kindContext) = Cxt -> Cxt -> (Map Name Name, Cxt)
mergeArgumentKinds Cxt
kindsOuter Cxt
kindsInner
          (Map Name Name
restSubst, Cxt
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, Cxt) -> (Map Name Name, Cxt)
go (Map Name Name
kindSubst, Cxt
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 :: Cxt
finalContext = Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ [Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Cxt
context, Cxt
kindContext, Cxt
restContext]
            -- Use `nub` here in an effort to minimize the number of
            -- redundant equality constraints in the returned context.
      in (Map Name Name
finalSubst, Cxt
finalContext)

-- Look into a list of types and map each free variable name to its kind.
kindsOfFVsOfTypes :: [Type] -> Map Name Kind
kindsOfFVsOfTypes :: Cxt -> Map Name Type
kindsOfFVsOfTypes = (Type -> Map Name Type) -> Cxt -> Map Name Type
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 :: 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 :: [TyVarBndrUnit] -> Map Name Type
kindsOfFVsOfTvbs = (TyVarBndrUnit -> Map Name Type)
-> [TyVarBndrUnit] -> Map Name Type
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TyVarBndrUnit -> Map Name Type
forall flag. TyVarBndrUnit -> Map Name Type
go
  where
    go :: TyVarBndr_ flag -> Map Name Kind
    go :: TyVarBndrUnit -> Map Name Type
go = (Name -> Map Name Type)
-> (Name -> Type -> Map Name Type)
-> TyVarBndrUnit
-> Map Name Type
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndrUnit -> 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)
                                     Cxt -> 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 :: Cxt -> Cxt -> (Map Name Name, Cxt)
mergeArguments Cxt
ns Cxt
ts = ((Type, Type) -> (Map Name Name, Cxt) -> (Map Name Name, Cxt))
-> (Map Name Name, Cxt) -> [(Type, Type)] -> (Map Name Name, Cxt)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type, Type) -> (Map Name Name, Cxt) -> (Map Name Name, Cxt)
aux (Map Name Name
forall k a. Map k a
Map.empty, []) (Cxt -> Cxt -> [(Type, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
ns Cxt
ts)
  where

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

    aux (VarT Name
n,Type
p) (Map Name Name
subst, Cxt
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, Cxt
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, Cxt
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, Cxt
context)
        Type
_ -> (Map Name Name
subst, Type -> Type -> Type
equalPred (Name -> Type
VarT Name
n) Type
p Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
context)

    aux (SigT Type
x Type
_, Type
y) (Map Name Name, Cxt)
sc = (Type, Type) -> (Map Name Name, Cxt) -> (Map Name Name, Cxt)
aux (Type
x,Type
y) (Map Name Name, Cxt)
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, Cxt)
sc = (Type, Type) -> (Map Name Name, Cxt) -> (Map Name Name, Cxt)
aux (Type
x,Type
y) (Map Name Name, Cxt)
sc

    aux (Type, Type)
_ (Map Name Name, Cxt)
sc = (Map Name Name, Cxt)
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 :: Cxt -> Cxt -> (Map Name Name, Cxt)
mergeArgumentKinds = Cxt -> Cxt -> (Map Name Name, Cxt)
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 :: Cxt
normal_xs = [TypeArg] -> Cxt
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 (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)
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))
            |  Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
normal_xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [TyVarBndrUnit] -> 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] -> Cxt -> Type -> Type
forall flag. [TyVarBndrUnit] -> Cxt -> Type -> Type
expandSynonymRHS [TyVarBndrUnit]
synvars Cxt
normal_xs Type
def
          Maybe Info
_ -> Type -> Q Type
defaultCase Type
ty

  in case Type
f of
       ForallT [TyVarBndrUnit]
tvbs Cxt
ctxt Type
body ->
         [TyVarBndrUnit] -> Cxt -> Type -> Type
ForallT ([TyVarBndrUnit] -> Cxt -> Type -> Type)
-> Q [TyVarBndrUnit] -> Q (Cxt -> Type -> Type)
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)
mapM TyVarBndrUnit -> Q TyVarBndrUnit
forall flag. TyVarBndrUnit -> Q TyVarBndrUnit
resolve_tvb_syns [TyVarBndrUnit]
tvbs
                   Q (Cxt -> Type -> Type) -> Q Cxt -> Q (Type -> Type)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolvePredSynonyms Cxt
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 (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)
mapM TyVarBndrUnit -> Q TyVarBndrUnit
forall flag. TyVarBndrUnit -> Q TyVarBndrUnit
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 t1 n t2 -> do
         t1' <- resolveTypeSynonyms t1
         t2' <- resolveTypeSynonyms t2
         return $ PromotedInfixT t1' n t2'
       PromotedUInfixT t1 n t2 -> do
         t1' <- resolveTypeSynonyms t1
         t2' <- resolveTypeSynonyms t2
         return $ PromotedUInfixT t1' n 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 :: TyVarBndrUnit -> Q TyVarBndrUnit
resolve_tvb_syns = (Type -> Q Type) -> TyVarBndrUnit -> Q TyVarBndrUnit
forall (m :: * -> *) flag.
Monad m =>
(Type -> m Type) -> TyVarBndrUnit -> m TyVarBndrUnit
mapMTVKind Type -> Q Type
resolveKindSynonyms

expandSynonymRHS ::
  [TyVarBndr_ flag] {- ^ Substitute these variables... -} ->
  [Type]            {- ^ ...with these types... -} ->
  Type              {- ^ ...inside of this type. -} ->
  Type
expandSynonymRHS :: [TyVarBndrUnit] -> Cxt -> Type -> Type
expandSynonymRHS [TyVarBndrUnit]
synvars Cxt
ts Type
def =
  let argNames :: [Name]
argNames    = (TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
tvName [TyVarBndrUnit]
synvars
      (Cxt
args,Cxt
rest) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames) Cxt
ts
      subst :: Map Name Type
subst       = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Name] -> Cxt -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
argNames Cxt
args)
  in (Type -> Type -> Type) -> Type -> Cxt -> Type
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) Cxt
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 -> Cxt -> NonEmpty Type
forall a. a -> [a] -> NonEmpty a
:| [TypeArg] -> Cxt
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] -> Cxt
filterTANormals = (TypeArg -> Maybe Type) -> [TypeArg] -> Cxt
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 -> ([TyVarBndrUnit], Cxt, NonEmptySnoc Type)
uncurryType = [TyVarBndrUnit]
-> Cxt -> Cxt -> Type -> ([TyVarBndrUnit], Cxt, NonEmptySnoc Type)
go [] [] []
  where
    go :: [TyVarBndrUnit]
-> Cxt -> Cxt -> Type -> ([TyVarBndrUnit], Cxt, NonEmptySnoc Type)
go [TyVarBndrUnit]
tvbs Cxt
ctxt Cxt
args (AppT (AppT Type
ArrowT Type
t1) Type
t2) = [TyVarBndrUnit]
-> Cxt -> Cxt -> Type -> ([TyVarBndrUnit], Cxt, NonEmptySnoc Type)
go [TyVarBndrUnit]
tvbs Cxt
ctxt (Type
t1Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:Cxt
args) Type
t2
    go [TyVarBndrUnit]
tvbs Cxt
ctxt Cxt
args (ForallT [TyVarBndrUnit]
tvbs' Cxt
ctxt' Type
t)    = [TyVarBndrUnit]
-> Cxt -> Cxt -> Type -> ([TyVarBndrUnit], Cxt, NonEmptySnoc Type)
go ([TyVarBndrUnit]
tvbs[TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++[TyVarBndrUnit]
tvbs') (Cxt
ctxtCxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++Cxt
ctxt') Cxt
args Type
t
    go [TyVarBndrUnit]
tvbs Cxt
ctxt Cxt
args Type
t                          = ([TyVarBndrUnit]
tvbs, Cxt
ctxt, Cxt -> Cxt
forall a. [a] -> [a]
reverse Cxt
args Cxt -> Type -> NonEmptySnoc Type
forall a. [a] -> a -> NonEmptySnoc a
:|- Type
t)

-- | Decompose a function kind into its context, argument kinds,
-- and return kind. For instance, this
--
--  forall a b. Maybe a -> Maybe b -> Type
--
-- becomes
--
--   ([a, b], [], [Maybe a, Maybe b] :|- Type)
uncurryKind :: Kind -> ([TyVarBndrSpec], Cxt, NonEmptySnoc Kind)
#if MIN_VERSION_template_haskell(2,8,0)
uncurryKind :: Type -> ([TyVarBndrUnit], Cxt, NonEmptySnoc Type)
uncurryKind = Type -> ([TyVarBndrUnit], Cxt, NonEmptySnoc Type)
uncurryType
#else
uncurryKind = go []
  where
    go args (ArrowK k1 k2) = go (k1:args) k2
    go args StarK          = ([], [], reverse args :|- StarK)
#endif

-- Reconstruct a function type from its type variable binders, context,
-- argument types and return type.
curryType :: [TyVarBndrSpec] -> Cxt -> [Type] -> Type -> Type
curryType :: [TyVarBndrUnit] -> Cxt -> Cxt -> Type -> Type
curryType [TyVarBndrUnit]
tvbs Cxt
ctxt Cxt
args Type
res =
  [TyVarBndrUnit] -> Cxt -> Type -> Type
ForallT [TyVarBndrUnit]
tvbs Cxt
ctxt (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> Cxt -> Type
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 Cxt
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 [TyVarBndrUnit]
vs Cxt
cx Type
t) = [TyVarBndrUnit] -> Cxt -> Type -> Type
ForallT ([TyVarBndrUnit] -> Cxt -> Type -> Type)
-> Q [TyVarBndrUnit] -> Q (Cxt -> 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)
traverse ((Type -> Q Type) -> TyVarBndrUnit -> Q TyVarBndrUnit
forall (f :: * -> *) flag.
Applicative f =>
(Type -> f Type) -> TyVarBndrUnit -> f TyVarBndrUnit
traverseTVKind Type -> Q Type
resolveInfixT) [TyVarBndrUnit]
vs
                                          Q (Cxt -> Type -> Type) -> Q Cxt -> Q (Type -> Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveInfixT Cxt
cx
                                          Q (Type -> Type) -> Q Type -> Q Type
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
`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
conT Name
o Q Type -> Q Type -> Q Type
`appT` Type -> Q Type
resolveInfixT Type
l Q Type -> Q Type -> Q 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 (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
appKindT (Type -> Q Type
resolveInfixT Type
f) (Type -> Q Type
resolveInfixT Type
x)
resolveInfixT (ImplicitParamT String
n Type
t)
                                = String -> Q Type -> Q 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)
traverse ((Type -> Q Type) -> TyVarBndrUnit -> Q TyVarBndrUnit
forall (f :: * -> *) flag.
Applicative f =>
(Type -> f Type) -> TyVarBndrUnit -> f TyVarBndrUnit
traverseTVKind Type -> Q Type
resolveInfixT) [TyVarBndrUnit]
vs
                                             Q (Type -> Type) -> Q Type -> Q Type
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 l o r)
                                = promotedT o `appT` resolveInfixT l `appT` resolveInfixT r
resolveInfixT t@PromotedUInfixT{}
                                = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t)
# endif
resolveInfixT Type
t                 = Type -> Q Type
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 l o r) = ilAppend (gatherUInfixT l) o True  (gatherUInfixT 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 (m :: * -> *) a. Monad m => a -> m a
return ((Type -> (Type, Name, Bool, Fixity) -> Type)
-> Type -> [(Type, Name, Bool, Fixity)] -> Type
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 (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 :: [(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 :: [(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 :: [(a, b, Type)] -> Cxt
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 (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
  | [TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
tvbs
  = Type
t
  | ForallT [TyVarBndrUnit]
tvbs' Cxt
ctxt' Type
t' <- Type
t -- Collapse two consecutive foralls (#63)
  = [TyVarBndrUnit] -> Cxt -> Type -> Type
ForallT ([TyVarBndrUnit]
tvbs [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
tvbs') Cxt
ctxt' Type
t'
  | Bool
otherwise
  = [TyVarBndrUnit] -> Cxt -> Type -> Type
ForallT [TyVarBndrUnit]
tvbs [] Type
t
  where
    tvbs :: [TyVarBndrUnit]
tvbs = Specificity -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall newFlag oldFlag.
newFlag -> [TyVarBndrUnit] -> [TyVarBndrUnit]
changeTVFlags Specificity
SpecifiedSpec ([TyVarBndrUnit] -> [TyVarBndrUnit])
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ Cxt -> [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 :: Cxt -> [TyVarBndrUnit]
freeVariablesWellScoped Cxt
tys =
  let fvs :: [Name]
      fvs :: [Name]
fvs = Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
tys

      varKindSigs :: Map Name Kind
      varKindSigs :: Map Name Type
varKindSigs = (Type -> Map Name Type) -> Cxt -> Map Name Type
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> Map Name Type
go_ty Cxt
tys
        where
          go_ty :: Type -> Map Name Kind
          go_ty :: Type -> Map Name Type
go_ty (ForallT [TyVarBndrUnit]
tvbs Cxt
ctxt Type
t) =
            (TyVarBndrUnit -> Map Name Type -> Map Name Type)
-> Map Name Type -> [TyVarBndrUnit] -> Map Name Type
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. TyVarBndrUnit -> Name
tvName TyVarBndrUnit
tvb))
                  ((Type -> Map Name Type) -> Cxt -> Map Name Type
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> Map Name Type
go_pred Cxt
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) [TyVarBndrUnit]
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 (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. TyVarBndrUnit -> 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
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)
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 (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 (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 [TyVarBndrUnit]
tvs Cxt
context Type
t) =
        let (Map Name Type
subst', [TyVarBndrUnit]
tvs') = Map Name Type
-> [TyVarBndrUnit] -> (Map Name Type, [TyVarBndrUnit])
forall flag.
Map Name Type
-> [TyVarBndrUnit] -> (Map Name Type, [TyVarBndrUnit])
substTyVarBndrs Map Name Type
subst [TyVarBndrUnit]
tvs in
        [TyVarBndrUnit] -> Cxt -> Type -> Type
ForallT [TyVarBndrUnit]
forall flag. [TyVarBndrUnit]
tvs'
                (Map Name Type -> Cxt -> Cxt
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst' Cxt
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
-> [TyVarBndrUnit] -> (Map Name Type, [TyVarBndrUnit])
substTyVarBndrs Map Name Type
subst [TyVarBndrUnit]
tvs in
        [TyVarBndrUnit] -> Type -> Type
ForallVisT [TyVarBndrUnit]
forall flag. [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 l c r)
                         = PromotedInfixT (go l) c (go r)
      go (PromotedUInfixT l c r)
                         = PromotedUInfixT (go l) c (go r)
#endif
      go Type
t               = Type
t

      subst_tvbs :: [TyVarBndr_ flag] -> (Map Name Type -> a) -> a
      subst_tvbs :: [TyVarBndrUnit] -> (Map Name Type -> a) -> a
subst_tvbs [TyVarBndrUnit]
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 (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. TyVarBndrUnit -> Name
tvName [TyVarBndrUnit]
tvs)

  freeVariables :: Type -> [Name]
freeVariables Type
t =
    case Type
t of
      ForallT [TyVarBndrUnit]
tvs Cxt
context Type
t' ->
          [TyVarBndrUnit] -> [Name] -> [Name]
forall flag. [TyVarBndrUnit] -> [Name] -> [Name]
fvs_under_forall [TyVarBndrUnit]
tvs (Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
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. [TyVarBndrUnit] -> [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 l _ r
                    -> freeVariables l `union` freeVariables r
      PromotedUInfixT l _ r
                    -> freeVariables l `union` freeVariables r
#endif
      Type
_             -> []
    where
      fvs_under_forall :: [TyVarBndr_ flag] -> [Name] -> [Name]
      fvs_under_forall :: [TyVarBndrUnit] -> [Name] -> [Name]
fvs_under_forall [TyVarBndrUnit]
tvs [Name]
fvs =
        (Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables ((TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Type
forall flag. TyVarBndrUnit -> Type
tvKind [TyVarBndrUnit]
tvs) [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Name]
fvs)
        [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ (TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
tvName [TyVarBndrUnit]
tvs

instance TypeSubstitution ConstructorInfo where
  freeVariables :: ConstructorInfo -> [Name]
freeVariables ConstructorInfo
ci =
      (Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables ((TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Type
forall flag. TyVarBndrUnit -> Type
tvKind (ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
ci))
          [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (ConstructorInfo -> Cxt
constructorContext ConstructorInfo
ci)
          [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (ConstructorInfo -> Cxt
constructorFields ConstructorInfo
ci))
      [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ (TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> 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 (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. TyVarBndrUnit -> Name
tvName (ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
ci)) in
    ConstructorInfo
ci { constructorVars :: [TyVarBndrUnit]
constructorVars    = (TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Type) -> TyVarBndrUnit -> TyVarBndrUnit
forall flag. (Type -> Type) -> TyVarBndrUnit -> TyVarBndrUnit
mapTVKind (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst'))
                                  (ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
ci)
       , constructorContext :: Cxt
constructorContext = Map Name Type -> Cxt -> Cxt
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst' (ConstructorInfo -> Cxt
constructorContext ConstructorInfo
ci)
       , constructorFields :: Cxt
constructorFields  = Map Name Type -> Cxt -> Cxt
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst' (ConstructorInfo -> Cxt
constructorFields ConstructorInfo
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 :: Map Name Type
-> [TyVarBndrUnit] -> (Map Name Type, [TyVarBndrUnit])
substTyVarBndrs = (Map Name Type -> TyVarBndrUnit -> (Map Name Type, TyVarBndrUnit))
-> Map Name Type
-> [TyVarBndrUnit]
-> (Map Name Type, [TyVarBndrUnit])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Map Name Type -> TyVarBndrUnit -> (Map Name Type, TyVarBndrUnit)
forall flag.
Map Name Type -> TyVarBndrUnit -> (Map Name Type, TyVarBndrUnit)
substTyVarBndr

-- | The workhorse for 'substTyVarBndrs'.
substTyVarBndr :: Map Name Type -> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag)
substTyVarBndr :: Map Name Type -> TyVarBndrUnit -> (Map Name Type, TyVarBndrUnit)
substTyVarBndr Map Name Type
subst TyVarBndrUnit
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) -> TyVarBndrUnit -> TyVarBndrUnit
forall flag. (Type -> Type) -> TyVarBndrUnit -> TyVarBndrUnit
mapTVKind (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst) TyVarBndrUnit
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) -> TyVarBndrUnit -> TyVarBndrUnit
forall flag. (Type -> Type) -> TyVarBndrUnit -> TyVarBndrUnit
mapTVKind (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst) TyVarBndrUnit
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)
-> (Any -> Any) -> (Type -> Type) -> TyVarBndrUnit -> TyVarBndrUnit
forall flag flag'.
(Name -> Name)
-> (flag -> flag')
-> (Type -> Type)
-> TyVarBndrUnit
-> TyVarBndrUnit
mapTV (\Name
_ -> Name
tvbName') Any -> Any
forall a. a -> a
id (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst) TyVarBndrUnit
tvb
    )
  where
    tvbName :: Name
    tvbName :: Name
tvbName = TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
tvName TyVarBndrUnit
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
$ Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Map Name Type -> Cxt
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 :: Map Name Type -> [TyVarBndrUnit] -> [TyVarBndrUnit]
substTyVarBndrKinds Map Name Type
subst = (TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map (Map Name Type -> TyVarBndrUnit -> TyVarBndrUnit
forall flag. Map Name Type -> TyVarBndrUnit -> TyVarBndrUnit
substTyVarBndrKind Map Name Type
subst)

-- | The workhorse for 'substTyVarBndrKinds'.
substTyVarBndrKind :: Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag
substTyVarBndrKind :: Map Name Type -> TyVarBndrUnit -> TyVarBndrUnit
substTyVarBndrKind Map Name Type
subst = (Type -> Type) -> TyVarBndrUnit -> TyVarBndrUnit
forall flag. (Type -> Type) -> TyVarBndrUnit -> TyVarBndrUnit
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 (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 :: Cxt -> Q (Map Name Type)
unifyTypes [] = Map Name Type -> Q (Map Name Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Name Type
forall k a. Map k a
Map.empty
unifyTypes (Type
t:Cxt
ts) =
  do Type
t':Cxt
ts' <- (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms (Type
tType -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:Cxt
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 (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 -> Cxt -> 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 Cxt
ts' of
       Right Map Name Type
m -> Map Name Type -> Q (Map Name Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Name Type
m
       Left (Type
x,Type
y) ->
         String -> Q (Map Name Type)
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 (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 (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 (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 -> Cxt -> Type
classPred =
#if MIN_VERSION_template_haskell(2,10,0)
  (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Type -> Cxt -> Type) -> (Name -> Type) -> Name -> Cxt -> 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, Cxt)
asClassPred Type
t =
  case Type -> NonEmpty Type
decomposeType Type
t of
    ConT Name
f :| Cxt
xs | Name
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
eqTypeName -> (Name, Cxt) -> Maybe (Name, Cxt)
forall a. a -> Maybe a
Just (Name
f,Cxt
xs)
    NonEmpty Type
_                              -> Maybe (Name, Cxt)
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 :: [TyVarBndrUnit]
datatypeVars      = (TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> TyVarBndrUnit -> TyVarBndrUnit
giveTyVarBndrStarKind Bool
isReified) (DatatypeInfo -> [TyVarBndrUnit]
datatypeVars DatatypeInfo
info)
       , datatypeInstTypes :: Cxt
datatypeInstTypes = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Type -> Type
giveTypeStarKind Bool
isReified) (DatatypeInfo -> Cxt
datatypeInstTypes DatatypeInfo
info) }

giveCIVarsStarKinds :: IsReifiedDec -> ConstructorInfo -> ConstructorInfo
giveCIVarsStarKinds :: Bool -> ConstructorInfo -> ConstructorInfo
giveCIVarsStarKinds Bool
isReified ConstructorInfo
info =
  ConstructorInfo
info { constructorVars :: [TyVarBndrUnit]
constructorVars = (TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> TyVarBndrUnit -> TyVarBndrUnit
giveTyVarBndrStarKind Bool
isReified) (ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
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) -> TyVarBndrUnit -> 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)
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 (m :: * -> *) a. Monad m => a -> m a
return DatatypeInfo
info { datatypeCons :: [ConstructorInfo]
datatypeCons = Map Name Type -> [ConstructorInfo] -> [ConstructorInfo]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
s (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
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. TyVarBndrUnit -> 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 a. Show a => a -> [Name] -> Q 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] -> Q Type
substEntry a
_ [Name
v] = Name -> Q Type
varT Name
v
    substEntry a
u []  = String -> Q Type
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 -> Q Type
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        -} ->
  [TyVarBndrUnit] {- ^ type parameters         -} ->
  [ConQ]          {- ^ constructor definitions -} ->
  [Name]          {- ^ derived class names     -} ->
  DecQ
#if MIN_VERSION_template_haskell(2,12,0)
dataDCompat :: Q Cxt -> Name -> [TyVarBndrUnit] -> [ConQ] -> [Name] -> Q Dec
dataDCompat Q Cxt
c Name
n [TyVarBndrUnit]
ts [ConQ]
cs [Name]
ds =
  Q Cxt
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> Q Dec
dataD Q Cxt
c Name
n [TyVarBndrUnit]
ts Maybe Type
forall a. Maybe a
Nothing [ConQ]
cs
    (if [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
ds then [] else [Maybe DerivStrategy -> [Q Type] -> DerivClauseQ
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
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        -} ->
  [TyVarBndrUnit] {- ^ type parameters         -} ->
  ConQ            {- ^ constructor definition  -} ->
  [Name]          {- ^ derived class names     -} ->
  DecQ
#if MIN_VERSION_template_haskell(2,12,0)
newtypeDCompat :: Q Cxt -> Name -> [TyVarBndrUnit] -> ConQ -> [Name] -> Q Dec
newtypeDCompat Q Cxt
c Name
n [TyVarBndrUnit]
ts ConQ
cs [Name]
ds =
  Q Cxt
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> ConQ
-> [DerivClauseQ]
-> Q Dec
newtypeD Q Cxt
c Name
n [TyVarBndrUnit]
ts Maybe Type
forall a. Maybe a
Nothing ConQ
cs
    (if [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
ds then [] else [Maybe DerivStrategy -> [Q Type] -> DerivClauseQ
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
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)
mapM [Q TyVarBndrUnit] -> Q [TyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Maybe [Q TyVarBndrUnit]
mtvbs
                                                         Q (Type -> Type -> TySynEqn) -> Q Type -> Q (Type -> TySynEqn)
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT Name
n) [Q Type]
ps
                                                         Q (Type -> TySynEqn) -> Q Type -> Q TySynEqn
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
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Fixity
forall a. Maybe a
Nothing) ((Maybe Fixity -> Maybe Fixity -> Maybe Fixity
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 (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 (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)