{-# 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@.
--
--   The same outcome would occur if @Proxy@ were declared using
--   @TypeAbstractions@, i.e., if it were declared as
--   @data Proxy \@k (a :: k) = MkProxy@. The 'datatypeInstTypes' would /not/
--   include a separate type for @\@k@.
--
-- * For @data instance@s and @newtype instance@s of data families,
--   'datatypeVars' and 'datatypeInstTypes' can be quite different. Here is
--   an example to illustrate the difference:
--
--   @
--   data family F a b
--   data instance F (Maybe c) (f x) = MkF c (f x)
--   @
--
--   Then in the 'DatatypeInfo' for @F@'s data instance, we would have:
--
--   @
--   'datatypeVars'      = [ 'KindedTV' c () 'StarT'
--                         , 'KindedTV' f () 'StarT'
--                         , 'KindedTV' x () 'StarT' ]
--   'datatypeInstTypes' = [ 'AppT' ('ConT' ''Maybe) ('VarT' c)
--                         , 'AppT' ('VarT' f) ('VarT' x) ]
--   @
data DatatypeInfo = DatatypeInfo
  { DatatypeInfo -> [Type]
datatypeContext   :: Cxt               -- ^ Data type context (deprecated)
  , DatatypeInfo -> Name
datatypeName      :: Name              -- ^ Type constructor
  , DatatypeInfo -> [TyVarBndrUnit]
datatypeVars      :: [TyVarBndrUnit]   -- ^ Type parameters
  , DatatypeInfo -> [Type]
datatypeInstTypes :: [Type]            -- ^ Argument types
  , DatatypeInfo -> DatatypeVariant
datatypeVariant   :: DatatypeVariant   -- ^ Extra information
  , DatatypeInfo -> [ConstructorInfo]
datatypeCons      :: [ConstructorInfo] -- ^ Normalize constructor information
  }
  deriving (Int -> DatatypeInfo -> ShowS
[DatatypeInfo] -> ShowS
DatatypeInfo -> String
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
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
DatatypeInfo -> DataType
DatatypeInfo -> Constr
(forall b. Data b => b -> b) -> DatatypeInfo -> DatatypeInfo
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DatatypeInfo -> u
forall u. (forall d. Data d => d -> u) -> DatatypeInfo -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeInfo
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeInfo -> c DatatypeInfo
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeInfo)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeInfo)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DatatypeInfo -> m DatatypeInfo
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u. Int -> (forall d. Data d => d -> u) -> DatatypeInfo -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DatatypeInfo -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeInfo -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeInfo -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeInfo -> r
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data
#ifdef HAS_GENERICS
           ,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@.
                    --
                    --   A 'DatatypeInfo' that uses 'Newtype' will uphold the
                    --   invariant that there will be exactly one
                    --   'ConstructorInfo' in the 'datatypeCons'.
  | DataInstance    -- ^ Type declared with @data instance@.
  | NewtypeInstance -- ^ Type declared with @newtype instance@.
                    --
                    --   A 'DatatypeInfo' that uses 'NewtypeInstance' will
                    --   uphold the invariant that there will be exactly one
                    --   'ConstructorInfo' in the 'datatypeCons'.
  | TypeData        -- ^ Type declared with @type data@.
                    --
                    --   A 'DatatypeInfo' that uses 'TypeData' will uphold the
                    --   following invariants:
                    --
                    --   * The 'datatypeContext' will be empty.
                    --
                    --   * None of the 'constructorVariant's in any of the
                    --     'datatypeCons' will be 'RecordConstructor'.
                    --
                    --   * Each of the 'constructorStrictness' values in each
                    --     of the 'datatypeCons' will be equal to
                    --     'notStrictAnnot'.
  deriving (Int -> DatatypeVariant -> ShowS
[DatatypeVariant] -> ShowS
DatatypeVariant -> String
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]
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
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
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
Ord, Typeable, Typeable DatatypeVariant
DatatypeVariant -> DataType
DatatypeVariant -> Constr
(forall b. Data b => b -> b) -> DatatypeVariant -> DatatypeVariant
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> DatatypeVariant -> u
forall u. (forall d. Data d => d -> u) -> DatatypeVariant -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DatatypeVariant
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DatatypeVariant -> c DatatypeVariant
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DatatypeVariant)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DatatypeVariant)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DatatypeVariant -> m DatatypeVariant
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u.
Int -> (forall d. Data d => d -> u) -> DatatypeVariant -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DatatypeVariant -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeVariant -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DatatypeVariant -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DatatypeVariant -> r
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data
#ifdef HAS_GENERICS
           ,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 -> [Type]
constructorContext    :: Cxt                -- ^ Constructor constraints
  , ConstructorInfo -> [Type]
constructorFields     :: [Type]             -- ^ Constructor fields
  , ConstructorInfo -> [FieldStrictness]
constructorStrictness :: [FieldStrictness]  -- ^ Constructor fields' strictness
                                                --   (Invariant: has the same length
                                                --   as constructorFields)
  , ConstructorInfo -> ConstructorVariant
constructorVariant    :: ConstructorVariant -- ^ Extra information
  }
  deriving (Int -> ConstructorInfo -> ShowS
[ConstructorInfo] -> ShowS
ConstructorInfo -> String
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
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
ConstructorInfo -> DataType
ConstructorInfo -> Constr
(forall b. Data b => b -> b) -> ConstructorInfo -> ConstructorInfo
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorInfo -> u
forall u. (forall d. Data d => d -> u) -> ConstructorInfo -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorInfo
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConstructorInfo -> c ConstructorInfo
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorInfo)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorInfo)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorInfo -> m ConstructorInfo
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorInfo -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorInfo -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorInfo -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorInfo -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorInfo -> r
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data
#ifdef HAS_GENERICS
           ,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
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
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
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
Ord, Typeable, Typeable ConstructorVariant
ConstructorVariant -> DataType
ConstructorVariant -> Constr
(forall b. Data b => b -> b)
-> ConstructorVariant -> ConstructorVariant
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorVariant -> u
forall u. (forall d. Data d => d -> u) -> ConstructorVariant -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConstructorVariant
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> ConstructorVariant
-> c ConstructorVariant
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConstructorVariant)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConstructorVariant)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ConstructorVariant -> m ConstructorVariant
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorVariant -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ConstructorVariant -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorVariant -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ConstructorVariant -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConstructorVariant -> r
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data
#ifdef HAS_GENERICS
           ,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
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
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
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
Ord, Typeable, Typeable FieldStrictness
FieldStrictness -> DataType
FieldStrictness -> Constr
(forall b. Data b => b -> b) -> FieldStrictness -> FieldStrictness
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> FieldStrictness -> u
forall u. (forall d. Data d => d -> u) -> FieldStrictness -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FieldStrictness
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FieldStrictness -> c FieldStrictness
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FieldStrictness)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c FieldStrictness)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> FieldStrictness -> m FieldStrictness
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u.
Int -> (forall d. Data d => d -> u) -> FieldStrictness -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> FieldStrictness -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> FieldStrictness -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> FieldStrictness -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FieldStrictness -> r
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data
#ifdef HAS_GENERICS
           ,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
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
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
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
Ord, Typeable, Typeable Unpackedness
Unpackedness -> DataType
Unpackedness -> Constr
(forall b. Data b => b -> b) -> Unpackedness -> Unpackedness
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Unpackedness -> u
forall u. (forall d. Data d => d -> u) -> Unpackedness -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Unpackedness
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Unpackedness -> c Unpackedness
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Unpackedness)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c Unpackedness)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Unpackedness -> m Unpackedness
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u. Int -> (forall d. Data d => d -> u) -> Unpackedness -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Unpackedness -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Unpackedness -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Unpackedness -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Unpackedness -> r
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data
#ifdef HAS_GENERICS
           ,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
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
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
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
Ord, Typeable, Typeable Strictness
Strictness -> DataType
Strictness -> Constr
(forall b. Data b => b -> b) -> Strictness -> Strictness
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Strictness -> u
forall u. (forall d. Data d => d -> u) -> Strictness -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Strictness
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Strictness -> c Strictness
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Strictness)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Strictness)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Strictness -> m Strictness
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u. Int -> (forall d. Data d => d -> u) -> Strictness -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Strictness -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Strictness -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Strictness -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Strictness -> r
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data
#ifdef HAS_GENERICS
           ,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
  = 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))
  forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
stripSigT
  forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
di


-- | Compute a normalized view of the metadata about a data type or newtype
-- given a constructor.
--
-- This function will accept any constructor (value or type) for a type
-- declared with newtype or data. Value constructors must be used to
-- lookup datatype information about /data instances/ and /newtype instances/,
-- as giving the type constructor of a data family is often not enough to
-- determine a particular data family instance.
--
-- In addition, this function will also accept a record selector for a
-- data type with a constructor which uses that record.
--
-- GADT constructors are normalized into datatypes with explicit equality
-- constraints. Note that no effort is made to distinguish between equalities of
-- the same (homogeneous) kind and equalities between different (heterogeneous)
-- kinds. For instance, the following GADT's constructors:
--
-- @
-- data T (a :: k -> *) where
--   MkT1 :: T Proxy
--   MkT2 :: T Maybe
-- @
--
-- will be normalized to the following equality constraints:
--
-- @
-- AppT (AppT EqualityT (VarT a)) (ConT Proxy) -- MkT1
-- AppT (AppT EqualityT (VarT a)) (ConT Maybe) -- MkT2
-- @
--
-- But only the first equality constraint is well kinded, since in the second
-- constraint, the kinds of @(a :: k -> *)@ and @(Maybe :: * -> *)@ are different.
-- Trying to categorize which constraints need homogeneous or heterogeneous
-- equality is tricky, so we leave that task to users of this library.
--
-- 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 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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Name
conName) 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      -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Datatype " forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (DatatypeInfo -> Name
datatypeName DatatypeInfo
dataInfo)
                         forall a. [a] -> [a] -> [a]
++ String
" does not have a constructor named " 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 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      -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Datatype " forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (DatatypeInfo -> Name
datatypeName DatatypeInfo
dataInfo)
                         forall a. [a] -> [a] -> [a]
++ String
" does not have any constructors with a "
                         forall a. [a] -> [a] -> [a]
++ String
"record selector named " 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{}                      -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
bad String
"Primitive type not supported"
    ClassI{}                          -> 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
                                         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]
_                       -> 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
_                                 -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
bad String
"Expected a type constructor"
  where
    bad :: String -> m a
bad String
msg = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
entry forall a. [a] -> [a] -> [a]
++ String
": " 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Name
constructorName (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
info)

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

    notRecSelFailure :: Q a
    notRecSelFailure :: forall a. Q a
notRecSelFailure = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
      String
"reifyRecordType: Not a record selector type: " forall a. [a] -> [a] -> [a]
++
      Name -> String
nameBase Name
recName forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
recTy

    p :: DatatypeInfo -> Bool
    p :: DatatypeInfo -> Bool
p DatatypeInfo
info = 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 <- 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 <- 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find DatatypeInfo -> Bool
p [DatatypeInfo]
instances2 of
              Just DatatypeInfo
inst -> forall (m :: * -> *) a. Monad m => a -> m a
return DatatypeInfo
inst
              Maybe DatatypeInfo
Nothing   -> forall a. String -> Q a
panic String
"lost the instance"
#endif
       Info
_ -> forall a. String -> Q a
panic String
"unexpected parent"
  where
    dataFamiliesOnOldGHCsError :: Q a
    dataFamiliesOnOldGHCsError :: forall a. Q a
dataFamiliesOnOldGHCsError = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
      String
prefix forall a. [a] -> [a] -> [a]
++ String
": Data family instances can only be reified with GHC 7.4 or later"

    panic :: String -> Q a
    panic :: forall a. String -> Q a
panic String
message = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"PANIC: " forall a. [a] -> [a] -> [a]
++ String
prefix forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
message

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

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

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

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


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

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

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

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

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

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

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

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

normalizeDecFor :: IsReifiedDec -> Dec -> Q DatatypeInfo
normalizeDecFor :: Bool -> Dec -> Q DatatypeInfo
normalizeDecFor Bool
isReified Dec
dec =
  case Dec
dec of
#if MIN_VERSION_template_haskell(2,20,0)
    TypeDataD name tyvars mbKind cons ->
      normalizeDataD [] name tyvars mbKind cons TypeData
#endif
#if MIN_VERSION_template_haskell(2,12,0)
    NewtypeD [Type]
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind Con
con [DerivClause]
_derives ->
      [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataD [Type]
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con
con] DatatypeVariant
Newtype
    DataD [Type]
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons [DerivClause]
_derives ->
      [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataD [Type]
context Name
name [TyVarBndrUnit]
tyvars Maybe Type
mbKind [Con]
cons DatatypeVariant
Datatype
# if MIN_VERSION_template_haskell(2,15,0)
    NewtypeInstD [Type]
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys Maybe Type
mbKind Con
con [DerivClause]
_derives ->
      String
-> [Type]
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPostTH2'15 String
"newtype" [Type]
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys
                                   Maybe Type
mbKind [Con
con] DatatypeVariant
NewtypeInstance
    DataInstD [Type]
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys Maybe Type
mbKind [Con]
cons [DerivClause]
_derives ->
      String
-> [Type]
-> Maybe [TyVarBndrUnit]
-> Type
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPostTH2'15 String
"data" [Type]
context Maybe [TyVarBndrUnit]
mbTyvars Type
nameInstTys
                                   Maybe Type
mbKind [Con]
cons DatatypeVariant
DataInstance
# else
    NewtypeInstD context name instTys mbKind con _derives ->
      normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance
    DataInstD context name instTys mbKind cons _derives ->
      normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance
# endif
#elif MIN_VERSION_template_haskell(2,11,0)
    NewtypeD context name tyvars mbKind con _derives ->
      normalizeDataD context name tyvars mbKind [con] Newtype
    DataD context name tyvars mbKind cons _derives ->
      normalizeDataD context name tyvars mbKind cons Datatype
    NewtypeInstD context name instTys mbKind con _derives ->
      normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance
    DataInstD context name instTys mbKind cons _derives ->
      normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance
#else
    NewtypeD context name tyvars con _derives ->
      normalizeDataD context name tyvars Nothing [con] Newtype
    DataD context name tyvars cons _derives ->
      normalizeDataD context name tyvars Nothing cons Datatype
    NewtypeInstD context name instTys con _derives ->
      normalizeDataInstDPreTH2'15 context name instTys Nothing [con] NewtypeInstance
    DataInstD context name instTys cons _derives ->
      normalizeDataInstDPreTH2'15 context name instTys Nothing cons DataInstance
#endif
    Dec
_ -> 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
      = 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 :: [Type] -> Maybe Type -> [TyVarBndrUnit]
datatypeFreeVars [Type]
instTys Maybe Type
mbKind =
      [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped forall a b. (a -> b) -> a -> b
$ [Type]
instTys forall a. [a] -> [a] -> [a]
++
#if MIN_VERSION_template_haskell(2,8,0)
                                           forall a. Maybe a -> [a]
maybeToList Maybe Type
mbKind
#else
                                           [] -- No kind variables
#endif

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

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

    normalizeDataInstDPreTH2'15
      :: Cxt -> Name -> [Type] -> Maybe Kind
      -> [Con] -> DatatypeVariant -> Q DatatypeInfo
    normalizeDataInstDPreTH2'15 :: [Type]
-> Name
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDataInstDPreTH2'15 [Type]
context Name
name [Type]
instTys Maybe Type
mbKind [Con]
cons DatatypeVariant
variant =
      [Type]
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' [Type]
context Name
name ([Type] -> Maybe Type -> [TyVarBndrUnit]
datatypeFreeVars [Type]
instTys Maybe Type
mbKind)
                 [Type]
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' :: [Type]
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> Maybe Type
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalize' [Type]
context Name
name [TyVarBndrUnit]
tvbs [Type]
instTys Maybe Type
mbKind [Con]
cons DatatypeVariant
variant = do
      [TyVarBndrUnit]
extra_tvbs <- Type -> Q [TyVarBndrUnit]
mkExtraKindBinders forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Type
starK Maybe Type
mbKind
      let tvbs' :: [TyVarBndrUnit]
tvbs'    = [TyVarBndrUnit]
tvbs forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
extra_tvbs
          instTys' :: [Type]
instTys' = [Type]
instTys forall a. [a] -> [a] -> [a]
++ forall flag. [TyVarBndr_ flag] -> [Type]
bndrParams [TyVarBndrUnit]
extra_tvbs
      DatatypeInfo
dec <- Bool
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDec' Bool
isReified [Type]
context Name
name [TyVarBndrUnit]
tvbs' [Type]
instTys' [Con]
cons DatatypeVariant
variant
      DatatypeInfo -> Q DatatypeInfo
repair13618' 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 ([TyVarBndrSpec]
_, [Type]
_, [Type]
args :|- Type
_) = Type -> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
uncurryKind Type
kind'
  [Name]
names <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Type -> TyVarBndrUnit
kindedTV [Name]
names [Type]
args

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

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

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

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


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
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> [Con]
-> DatatypeVariant
-> Q DatatypeInfo
normalizeDec' Bool
reifiedDec [Type]
context Name
name [TyVarBndrUnit]
params [Type]
instTys [Con]
cons DatatypeVariant
variant =
  do [ConstructorInfo]
cons' <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeConFor Bool
reifiedDec Name
name [TyVarBndrUnit]
params [Type]
instTys DatatypeVariant
variant) [Con]
cons
     forall (m :: * -> *) a. Monad m => a -> m a
return DatatypeInfo
       { datatypeContext :: [Type]
datatypeContext   = [Type]
context
       , datatypeName :: Name
datatypeName      = Name
name
       , datatypeVars :: [TyVarBndrUnit]
datatypeVars      = [TyVarBndrUnit]
params
       , datatypeInstTypes :: [Type]
datatypeInstTypes = [Type]
instTys
       , datatypeCons :: [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons'
       , 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]
-> [Type]
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeCon = Bool
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeConFor Bool
isn'tReified

normalizeConFor ::
  IsReifiedDec    {- ^ Is this a reified 'Dec'? -} ->
  Name            {- ^ Type constructor         -} ->
  [TyVarBndrUnit] {- ^ Type parameters          -} ->
  [Type]          {- ^ Argument types           -} ->
  DatatypeVariant {- ^ Extra information        -} ->
  Con             {- ^ Constructor              -} ->
  Q [ConstructorInfo]
normalizeConFor :: Bool
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> DatatypeVariant
-> Con
-> Q [ConstructorInfo]
normalizeConFor Bool
reifiedDec Name
typename [TyVarBndrUnit]
params [Type]
instTys DatatypeVariant
variant =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (Bool -> ConstructorInfo -> ConstructorInfo
giveCIVarsStarKinds Bool
reifiedDec)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Con -> Q [ConstructorInfo]
dispatch
  where
    -- A GADT constructor is declared infix when:
    --
    -- 1. Its name uses operator syntax (e.g., (:*:))
    -- 2. It has exactly two fields
    -- 3. It has a programmer-supplied fixity declaration
    checkGadtFixity :: [Type] -> Name -> Q ConstructorVariant
    checkGadtFixity :: [Type] -> Name -> Q ConstructorVariant
checkGadtFixity [Type]
ts Name
n = do
#if MIN_VERSION_template_haskell(2,11,0)
      -- Don't call reifyFixityCompat here! We need to be able to distinguish
      -- between a default fixity and an explicit @infixl 9@.
      Maybe Fixity
mbFi <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing forall a. Q a -> Q a -> Q a
`recover` Name -> Q (Maybe Fixity)
reifyFixity Name
n
      let userSuppliedFixity :: Bool
userSuppliedFixity = 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
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if String -> Bool
isInfixDataCon (Name -> String
nameBase Name
n)
                  Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts forall a. Eq a => a -> a -> Bool
== Int
2
                  Bool -> Bool -> Bool
&& Bool
userSuppliedFixity
               then ConstructorVariant
InfixConstructor
               else ConstructorVariant
NormalConstructor

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

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

          dataFamCase' :: Name -> [FieldStrictness]
                       -> ConstructorVariant
                       -> Q [ConstructorInfo]
          dataFamCase' n stricts variant = do
            mbInfo <- reifyMaybe n
            case mbInfo of
              Just (DataConI _ ty _ _) -> do
                let (tyvars, context, argTys :|- returnTy) = uncurryType ty
                returnTy' <- resolveTypeSynonyms returnTy
                -- Notice that we've ignored the TyVarBndrs, Cxt and argument
                -- Types from the Con argument above, as they might be scoped
                -- over eta-reduced variables. Instead of trying to figure out
                -- what the eta-reduced variables should be substituted with
                -- post facto, we opt for the simpler approach of using the
                -- context and argument types from the reified constructor
                -- Info, which will at least be correctly scoped. This will
                -- make the task of substituting those types with the variables
                -- we put in place of the eta-reduced variables
                -- (in normalizeDec) much easier.
                normalizeGadtC typename params instTys 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]
-> [Type]
-> [TyVarBndrUnit]
-> [Type]
-> [Name]
-> Type
-> [Type]
-> [FieldStrictness]
-> (Name -> Q ConstructorVariant)
-> Q [ConstructorInfo]
normalizeGadtC Name
typename [TyVarBndrUnit]
params [Type]
instTys [TyVarBndrUnit]
tyvars [Type]
context [Name]
names Type
innerType
               [Type]
fields [FieldStrictness]
stricts Name -> Q ConstructorVariant
getVariant =
  do -- It's possible that the constructor has implicitly quantified type
     -- variables, such as in the following example (from #58):
     --
     --   [d| data Foo where
     --         MkFoo :: a -> Foo |]
     --
     -- normalizeGadtC assumes that all type variables have binders, however,
     -- so we use freeVariablesWellScoped to obtain the implicit type
     -- variables' binders before proceeding.
     let implicitTyvars :: [TyVarBndrUnit]
implicitTyvars = [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped
                          [[TyVarBndrSpec] -> [Type] -> [Type] -> Type -> Type
curryType (forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec [TyVarBndrUnit]
tyvars)
                                     [Type]
context [Type]
fields Type
innerType]
         allTyvars :: [TyVarBndrUnit]
allTyvars = [TyVarBndrUnit]
implicitTyvars 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 =
           forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\TyVarBndrUnit
tvb -> forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tvbforall a. a -> [a] -> [a]
:forall a. TypeSubstitution a => a -> [Name]
freeVariables (forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndrUnit
tvb)) [TyVarBndrUnit]
allTyvars
     Map Name Name
conSubst <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
T.sequence forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Name
n, forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
n))
                                           | Name
n <- [Name]
conBoundNames ]
     let conSubst' :: Map Name Type
conSubst'     = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT Map Name Name
conSubst
         renamedTyvars :: [TyVarBndrUnit]
renamedTyvars =
           forall a b. (a -> b) -> [a] -> [b]
map (forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
n   -> Name -> TyVarBndrUnit
plainTV  (Map Name Name
conSubst 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 forall k a. Ord k => Map k a -> k -> a
Map.! Name
n)
                                         (forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' Type
k))) [TyVarBndrUnit]
allTyvars
         renamedContext :: [Type]
renamedContext   = forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' [Type]
context
         renamedInnerType :: Type
renamedInnerType = forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' Type
innerType
         renamedFields :: [Type]
renamedFields    = forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
conSubst' [Type]
fields

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

         let (Map Name Name
substName, [Type]
context1) =
               Map Name Type
-> Map Name Type
-> (Map Name Name, [Type])
-> (Map Name Name, [Type])
closeOverKinds (forall flag. [TyVarBndr_ flag] -> Map Name Type
kindsOfFVsOfTvbs [TyVarBndrUnit]
renamedTyvars)
                              (forall flag. [TyVarBndr_ flag] -> Map Name Type
kindsOfFVsOfTvbs [TyVarBndrUnit]
params)
                              ([Type] -> [Type] -> (Map Name Name, [Type])
mergeArguments [Type]
instTys [Type]
ts)
             subst :: Map Name Type
subst    = Name -> Type
VarT 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, forall k a. Ord k => k -> Map k a -> Bool
Map.notMember (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tv) Map Name Type
subst ]

             -- The use of substTyVarBndrKinds below will never capture, as the
             -- range of the substitution will always use distinct names from
             -- exTyvars due to the alpha-renaming pass above.
             exTyvars' :: [TyVarBndrUnit]
exTyvars' = forall flag.
Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
substTyVarBndrKinds Map Name Type
subst [TyVarBndrUnit]
exTyvars
             context2 :: [Type]
context2  = forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution   Map Name Type
subst ([Type]
context1 forall a. [a] -> [a] -> [a]
++ [Type]
renamedContext)
             fields' :: [Type]
fields'   = forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution   Map Name Type
subst [Type]
renamedFields
         in forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name
-> [TyVarBndrUnit]
-> [Type]
-> [Type]
-> [FieldStrictness]
-> ConstructorVariant
-> ConstructorInfo
ConstructorInfo Name
name [TyVarBndrUnit]
exTyvars' [Type]
context2
                                       [Type]
fields' [FieldStrictness]
stricts 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
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"normalizeGadtC: Expected type constructor application"

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

Why is this necessary? Consider the following example:

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

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

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

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

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

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

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

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

-- Look into a list of types and map each free variable name to its kind.
kindsOfFVsOfTypes :: [Type] -> Map Name Kind
kindsOfFVsOfTypes :: [Type] -> Map Name Type
kindsOfFVsOfTypes = 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 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 -> 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 forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Name Type
kSigs

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

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

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

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

mergeArguments ::
  [Type] {- ^ outer parameters                    -} ->
  [Type] {- ^ inner parameters (specializations ) -} ->
  (Map Name Name, Cxt)
mergeArguments :: [Type] -> [Type] -> (Map Name Name, [Type])
mergeArguments [Type]
ns [Type]
ts = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type, Type) -> (Map Name Name, [Type]) -> (Map Name Name, [Type])
aux (forall k a. Map k a
Map.empty, []) (forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
ns [Type]
ts)
  where

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

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

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

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

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

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

      -- Either the type is not headed by a type synonym, or it is headed by a
      -- type synonym that is not applied to enough arguments. Leave the type
      -- alone and only expand its arguments.
      defaultCase :: Type -> Q Type
      defaultCase :: Type -> Q Type
defaultCase Type
ty = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> TypeArg -> Type
appTypeArg Type
ty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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))
            |  forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
normal_xs forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndrUnit]
synvars -- Don't expand undersaturated type synonyms (#88)
            -> Type -> Q Type
resolveTypeSynonyms forall a b. (a -> b) -> a -> b
$ forall flag. [TyVarBndr_ flag] -> [Type] -> Type -> Type
expandSynonymRHS [TyVarBndrUnit]
synvars [Type]
normal_xs Type
def
          Maybe Info
_ -> Type -> Q Type
defaultCase Type
ty

  in case Type
f of
       ForallT [TyVarBndrSpec]
tvbs [Type]
ctxt Type
body ->
         [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall flag. TyVarBndr_ flag -> Q (TyVarBndr_ flag)
resolve_tvb_syns [TyVarBndrSpec]
tvbs
                   forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolvePredSynonyms [Type]
ctxt
                   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 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall flag. TyVarBndr_ flag -> Q (TyVarBndr_ flag)
resolve_tvb_syns [TyVarBndrUnit]
tvbs
                      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 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    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveKindSynonyms Type
k

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

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

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

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

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

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

-- | A variant of 'decomposeType' that preserves information about visible kind
-- applications by returning a 'NonEmpty' list of 'TypeArg's.
decomposeTypeArgs :: Type -> (Type, [TypeArg])
decomposeTypeArgs :: Type -> (Type, [TypeArg])
decomposeTypeArgs = [TypeArg] -> Type -> (Type, [TypeArg])
go []
  where
    go :: [TypeArg] -> Type -> (Type, [TypeArg])
    go :: [TypeArg] -> Type -> (Type, [TypeArg])
go [TypeArg]
args (AppT Type
f Type
x)     = [TypeArg] -> Type -> (Type, [TypeArg])
go (Type -> TypeArg
TANormal Type
xforall 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
xforall a. a -> [a] -> [a]
:[TypeArg]
args) Type
f
#endif
    go [TypeArg]
args Type
t              = (Type
t, [TypeArg]
args)

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

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

-- | Filter out all of the normal type arguments from a list of 'TypeArg's.
filterTANormals :: [TypeArg] -> [Type]
filterTANormals :: [TypeArg] -> [Type]
filterTANormals = 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) = forall a. a -> Maybe a
Just Type
t
    f (TyArg {})   = forall a. Maybe a
Nothing

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

data NonEmptySnoc a = [a] :|- a

-- Decompose a function type into its context, argument types,
-- and return type. For instance, this
--
--   forall a b. (Show a, b ~ Int) => (a -> b) -> Char -> Int
--
-- becomes
--
--   ([a, b], [Show a, b ~ Int], [a -> b, Char] :|- Int)
uncurryType :: Type -> ([TyVarBndrSpec], Cxt, NonEmptySnoc Type)
uncurryType :: Type -> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
uncurryType = [TyVarBndrSpec]
-> [Type]
-> [Type]
-> Type
-> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
go [] [] []
  where
    go :: [TyVarBndrSpec]
-> [Type]
-> [Type]
-> Type
-> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
go [TyVarBndrSpec]
tvbs [Type]
ctxt [Type]
args (AppT (AppT Type
ArrowT Type
t1) Type
t2) = [TyVarBndrSpec]
-> [Type]
-> [Type]
-> Type
-> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
go [TyVarBndrSpec]
tvbs [Type]
ctxt (Type
t1forall a. a -> [a] -> [a]
:[Type]
args) Type
t2
    go [TyVarBndrSpec]
tvbs [Type]
ctxt [Type]
args (ForallT [TyVarBndrSpec]
tvbs' [Type]
ctxt' Type
t)    = [TyVarBndrSpec]
-> [Type]
-> [Type]
-> Type
-> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
go ([TyVarBndrSpec]
tvbsforall a. [a] -> [a] -> [a]
++[TyVarBndrSpec]
tvbs') ([Type]
ctxtforall a. [a] -> [a] -> [a]
++[Type]
ctxt') [Type]
args Type
t
    go [TyVarBndrSpec]
tvbs [Type]
ctxt [Type]
args Type
t                          = ([TyVarBndrSpec]
tvbs, [Type]
ctxt, forall a. [a] -> [a]
reverse [Type]
args 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 -> ([TyVarBndrSpec], [Type], NonEmptySnoc Type)
uncurryKind = Type -> ([TyVarBndrSpec], [Type], 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 :: [TyVarBndrSpec] -> [Type] -> [Type] -> Type -> Type
curryType [TyVarBndrSpec]
tvbs [Type]
ctxt [Type]
args Type
res =
  [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
tvbs [Type]
ctxt forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Type
arg Type
t -> Type
ArrowT Type -> Type -> Type
`AppT` Type
arg Type -> Type -> Type
`AppT` Type
t) Type
res [Type]
args

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

#if MIN_VERSION_template_haskell(2,11,0)
resolveInfixT :: Type -> Q Type
resolveInfixT (ForallT [TyVarBndrSpec]
vs [Type]
cx Type
t) = [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) flag.
Applicative f =>
(Type -> f Type) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
traverseTVKind Type -> Q Type
resolveInfixT) [TyVarBndrSpec]
vs
                                          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveInfixT [Type]
cx
                                          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 forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
resolveInfixT Type
x
resolveInfixT (ParensT Type
t)       = Type -> Q Type
resolveInfixT Type
t
resolveInfixT (InfixT Type
l Name
o Type
r)    = forall (m :: * -> *). Quote m => Name -> m Type
conT Name
o forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
resolveInfixT Type
l forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
resolveInfixT Type
r
resolveInfixT (SigT Type
t Type
k)        = Type -> Type -> Type
SigT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveInfixT Type
t 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 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)  = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appKindT (Type -> Q Type
resolveInfixT Type
f) (Type -> Q Type
resolveInfixT Type
x)
resolveInfixT (ImplicitParamT String
n Type
t)
                                = forall (m :: * -> *). Quote m => String -> m Type -> m Type
implicitParamT String
n 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) flag.
Applicative f =>
(Type -> f Type) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
traverseTVKind Type -> Q Type
resolveInfixT) [TyVarBndrUnit]
vs
                                             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                 = 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) = forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity 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)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)forall a. a -> [a] -> [a]
:[(Type, Name, Bool, Fixity)]
ts') InfixList
r
               Just Bool
False -> Q Type
push
               Maybe Bool
Nothing    -> 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) = forall a. a -> Maybe a
Just (Int
n1 forall a. Ord a => a -> a -> Bool
>= Int
n2)
    compareFixity (Fixity Int
n1 FixityDirection
InfixR) (Fixity Int
n2 FixityDirection
InfixR) = forall a. a -> Maybe a
Just (Int
n1 forall a. Ord a => a -> a -> Bool
>  Int
n2)
    compareFixity (Fixity Int
n1 FixityDirection
_     ) (Fixity Int
n2 FixityDirection
_     ) =
      case forall a. Ord a => a -> a -> Ordering
compare Int
n1 Int
n2 of
        Ordering
GT -> forall a. a -> Maybe a
Just Bool
True
        Ordering
LT -> forall a. a -> Maybe a
Just Bool
False
        Ordering
EQ -> 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 ‘" forall a. [a] -> [a] -> [a]
++
      Name -> String
nameBase Name
o1 forall a. [a] -> [a] -> [a]
++ String
"’ [" forall a. [a] -> [a] -> [a]
++ Fixity -> String
showFixity Fixity
ofx1 forall a. [a] -> [a] -> [a]
++ String
"] and ‘" forall a. [a] -> [a] -> [a]
++
      Name -> String
nameBase Name
o2 forall a. [a] -> [a] -> [a]
++ String
"’ [" forall a. [a] -> [a] -> [a]
++ Fixity -> String
showFixity Fixity
ofx2 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 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n


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

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

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

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

conHasRecord :: Name -> ConstructorInfo -> Bool
conHasRecord :: Name -> ConstructorInfo -> Bool
conHasRecord Name
recName ConstructorInfo
info =
  case ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
info of
    ConstructorVariant
NormalConstructor        -> Bool
False
    ConstructorVariant
InfixConstructor         -> Bool
False
    RecordConstructor [Name]
fields -> Name
recName 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
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrSpec]
tvbs
  = Type
t
  | ForallT [TyVarBndrSpec]
tvbs' [Type]
ctxt' Type
t' <- Type
t -- Collapse two consecutive foralls (#63)
  = [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT ([TyVarBndrSpec]
tvbs forall a. [a] -> [a] -> [a]
++ [TyVarBndrSpec]
tvbs') [Type]
ctxt' Type
t'
  | Bool
otherwise
  = [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
tvbs [] Type
t
  where
    tvbs :: [TyVarBndrSpec]
tvbs = forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags Specificity
SpecifiedSpec forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
t]

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

      varKindSigs :: Map Name Kind
      varKindSigs :: Map Name Type
varKindSigs = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> Map Name Type
go_ty [Type]
tys
        where
          go_ty :: Type -> Map Name Kind
          go_ty :: Type -> Map Name Type
go_ty (ForallT [TyVarBndrSpec]
tvbs [Type]
ctxt Type
t) =
            forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TyVarBndrSpec
tvb -> forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrSpec
tvb))
                  (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> Map Name Type
go_pred [Type]
ctxt forall a. Monoid a => a -> a -> a
`mappend` Type -> Map Name Type
go_ty Type
t) [TyVarBndrSpec]
tvbs
          go_ty (AppT Type
t1 Type
t2) = Type -> Map Name Type
go_ty Type
t1 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 -> 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 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 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) =
            forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TyVarBndrUnit
tvb -> forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
tvb)) (Type -> Map Name Type
go_ty Type
t) [TyVarBndrUnit]
tvbs
#endif
          go_ty 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 [] = 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 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
aforall a. a -> [a] -> [a]
:[Name]
as', Set Name
fvs forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
fv_tv forall a. a -> [a] -> [a]
: [Set Name]
fvss')

        | Bool
otherwise
        = (Name
tvforall a. a -> [a] -> [a]
:Name
aforall a. a -> [a] -> [a]
:[Name]
as, Set Name
fvs forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
fv_tv forall a. a -> [a] -> [a]
: Set Name
fvs 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]
_ = forall a. HasCallStack => String -> a
error String
"scopedSort"

      kindFVSet :: Name -> Set Name
kindFVSet Name
n =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty (forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TypeSubstitution a => a -> [Name]
freeVariables) (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 =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> TyVarBndrUnit
plainTV Name
n) (Name -> Type -> TyVarBndrUnit
kindedTV Name
n) (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
        = forall a b. a -> b -> a
const Bool
False
#else
        = (`elem` kindVars)
          where
            kindVars = freeVariables $ Map.elems varKindSigs
#endif

  in forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndrUnit
ascribeWithKind forall a b. (a -> b) -> a -> b
$
     forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. b -> Bool
isKindBinderOnOldGHCs) 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
n)) | Name
n <- forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t]
     Map Name Type
subst <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
T.sequence (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, Q Type)]
xs)
     forall (m :: * -> *) a. Monad m => a -> m a
return (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     = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. TypeSubstitution a => a -> [Name]
freeVariables
  applySubstitution :: Map Name Type -> [a] -> [a]
applySubstitution = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution

instance TypeSubstitution Type where
  applySubstitution :: Map Name Type -> Type -> Type
applySubstitution Map Name Type
subst = Type -> Type
go
    where
      go :: Type -> Type
go (ForallT [TyVarBndrSpec]
tvs [Type]
context Type
t) =
        let (Map Name Type
subst', [TyVarBndrSpec]
tvs') = forall flag.
Map Name Type
-> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag])
substTyVarBndrs Map Name Type
subst [TyVarBndrSpec]
tvs in
        [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
tvs'
                (forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst' [Type]
context)
                (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) (forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
subst Type
k) -- k could be Kind
      go (VarT Name
v)        = 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') = forall flag.
Map Name Type
-> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag])
substTyVarBndrs Map Name Type
subst [TyVarBndrUnit]
tvs in
        [TyVarBndrUnit] -> Type -> Type
ForallVisT [TyVarBndrUnit]
tvs'
                   (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 :: forall flag a. [TyVarBndr_ flag] -> (Map Name Type -> a) -> a
subst_tvbs [TyVarBndr_ flag]
tvs Map Name Type -> a
k = Map Name Type -> a
k forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) Map Name Type
subst (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr_ flag]
tvs)

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

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

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

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

    evade :: Name -> Name
    evade :: Name -> Name
evade Name
n | Name
n forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
substRangeFVs
            = Name -> Name
evade 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 forall a b. (a -> b) -> a -> b
$ Char
'f'forall a. a -> [a] -> [a]
:Name -> String
nameBase Name
n

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

-- | The workhorse for 'substTyVarBndrKinds'.
substTyVarBndrKind :: Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag
substTyVarBndrKind :: forall flag. Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag
substTyVarBndrKind Map Name Type
subst = forall flag. (Type -> Type) -> TyVarBndr_ flag -> TyVarBndr_ flag
mapTVKind (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 = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
y) Map Name Type
x) Map Name Type
y

-- | Compute the type variable substitution that unifies a list of types,
-- or fail in 'Q'.
--
-- All infix issue should be resolved before using 'unifyTypes'
--
-- Alpha equivalent quantified types are not unified.
unifyTypes :: [Type] -> Q (Map Name Type)
unifyTypes :: [Type] -> Q (Map Name Type)
unifyTypes [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. Map k a
Map.empty
unifyTypes (Type
t:[Type]
ts) =
  do Type
t':[Type]
ts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms (Type
tforall a. a -> [a] -> [a]
:[Type]
ts)
     let aux :: Map Name Type -> Type -> Either (Type, Type) (Map Name Type)
aux Map Name Type
sub Type
u =
           do Map Name Type
sub' <- Type -> Type -> Either (Type, Type) (Map Name Type)
unify' (forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
sub Type
t')
                             (forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
sub Type
u)
              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 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 forall k a. Map k a
Map.empty [Type]
ts' of
       Right Map Name Type
m -> forall (m :: * -> *) a. Monad m => a -> m a
return Map Name Type
m
       Left (Type
x,Type
y) ->
         forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Unable to unify types "
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Type
x
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" and "
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Type
y
              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 forall a. Eq a => a -> a -> Bool
== Name
m = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
unify' (VarT Name
n) Type
t | Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t = forall a b. a -> Either a b
Left (Name -> Type
VarT Name
n, Type
t)
                  | Bool
otherwise                = forall a b. b -> Either a b
Right (forall k a. k -> a -> Map k a
Map.singleton Name
n Type
t)
unify' Type
t (VarT Name
n) | Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t = forall a b. a -> Either a b
Left (Name -> Type
VarT Name
n, Type
t)
                  | Bool
otherwise                = forall a b. b -> Either a b
Right (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' (forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
sub1 Type
x1) (forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
sub1 Type
x2)
     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 forall a. Eq a => a -> a -> Bool
== Type
u    = forall a b. b -> Either a b
Right forall k a. Map k a
Map.empty
  | Bool
otherwise = forall a b. a -> Either a b
Left (Type
t,Type
u)


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

-- | Construct a typeclass constraint. The implementation of 'Pred' varies
-- across versions of Template Haskell.
classPred :: Name {- ^ class -} -> [Type] {- ^ parameters -} -> Pred
classPred :: Name -> [Type] -> Type
classPred =
#if MIN_VERSION_template_haskell(2,10,0)
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT 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)                    = forall a. a -> Maybe a
Just (Type
x,Type
y)
asEqualPred (ConT Name
eq   `AppT` Type
x `AppT` Type
y) | Name
eq forall a. Eq a => a -> a -> Bool
== Name
eqTypeName = forall a. a -> Maybe a
Just (Type
x,Type
y)
#else
asEqualPred (EqualP            x        y)                   = Just (x,y)
#endif
asEqualPred Type
_                                                = forall a. Maybe a
Nothing

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

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

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

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

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

giveDIVarsStarKinds :: IsReifiedDec -> DatatypeInfo -> DatatypeInfo
giveDIVarsStarKinds :: Bool -> DatatypeInfo -> DatatypeInfo
giveDIVarsStarKinds Bool
isReified DatatypeInfo
info =
  DatatypeInfo
info { datatypeVars :: [TyVarBndrUnit]
datatypeVars      = forall a b. (a -> b) -> [a] -> [b]
map (Bool -> TyVarBndrUnit -> TyVarBndrUnit
giveTyVarBndrStarKind Bool
isReified) (DatatypeInfo -> [TyVarBndrUnit]
datatypeVars DatatypeInfo
info)
       , datatypeInstTypes :: [Type]
datatypeInstTypes = forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Type -> Type
giveTypeStarKind Bool
isReified) (DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
info) }

giveCIVarsStarKinds :: IsReifiedDec -> ConstructorInfo -> ConstructorInfo
giveCIVarsStarKinds :: Bool -> ConstructorInfo -> ConstructorInfo
giveCIVarsStarKinds Bool
isReified ConstructorInfo
info =
  ConstructorInfo
info { constructorVars :: [TyVarBndrUnit]
constructorVars = 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
  = forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
elimTV (\Name
n -> Name -> Type -> TyVarBndrUnit
kindedTV Name
n Type
starK) (\Name
_ Type
_ -> TyVarBndrUnit
tvb) TyVarBndrUnit
tvb
  | Bool
otherwise
  = TyVarBndrUnit
tvb

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

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

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

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

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

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

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

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

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

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

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

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