{-# LANGUAGE CPP #-}

{-|
Module:      Data.Functor.Invariant.TH
Copyright:   (C) 2012-2017 Nicolas Frisby, (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

Functions to mechanically derive 'Data.Functor.Invariant.Invariant'
or 'Data.Functor.Invariant.Invariant2' instances,
or to splice 'Data.Functor.Invariant.invmap' or
'Data.Functor.Invariant.invmap2' into Haskell source code. You need to enable
the @TemplateHaskell@ language extension in order to use this module.
-}
module Data.Functor.Invariant.TH (
      -- * @deriveInvariant(2)@
      -- $deriveInvariant
      deriveInvariant
    , deriveInvariantOptions
      -- $deriveInvariant2
    , deriveInvariant2
    , deriveInvariant2Options
      -- * @makeInvmap(2)@
      -- $make
    , makeInvmap
    , makeInvmapOptions
    , makeInvmap2
    , makeInvmap2Options
      -- * 'Options'
    , Options(..)
    , defaultOptions
    ) where

import           Control.Monad (unless, when)

import           Data.Functor.Invariant.TH.Internal
import           Data.List
import qualified Data.Map as Map (fromList, keys, lookup, size)
import           Data.Maybe

import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Ppr
import           Language.Haskell.TH.Syntax

-------------------------------------------------------------------------------
-- User-facing API
-------------------------------------------------------------------------------

-- | Options that further configure how the functions in
-- "Data.Functor.Invariant.TH" should behave.
newtype Options = Options
  { Options -> Bool
emptyCaseBehavior :: Bool
    -- ^ If 'True', derived instances for empty data types (i.e., ones with
    --   no data constructors) will use the @EmptyCase@ language extension.
    --   If 'False', derived instances will simply use 'seq' instead.
    --   (This has no effect on GHCs before 7.8, since @EmptyCase@ is only
    --   available in 7.8 or later.)
  } deriving (Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c== :: Options -> Options -> Bool
Eq, Eq Options
Eq Options
-> (Options -> Options -> Ordering)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Options)
-> (Options -> Options -> Options)
-> Ord Options
Options -> Options -> Bool
Options -> Options -> Ordering
Options -> Options -> Options
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 :: Options -> Options -> Options
$cmin :: Options -> Options -> Options
max :: Options -> Options -> Options
$cmax :: Options -> Options -> Options
>= :: Options -> Options -> Bool
$c>= :: Options -> Options -> Bool
> :: Options -> Options -> Bool
$c> :: Options -> Options -> Bool
<= :: Options -> Options -> Bool
$c<= :: Options -> Options -> Bool
< :: Options -> Options -> Bool
$c< :: Options -> Options -> Bool
compare :: Options -> Options -> Ordering
$ccompare :: Options -> Options -> Ordering
$cp1Ord :: Eq Options
Ord, ReadPrec [Options]
ReadPrec Options
Int -> ReadS Options
ReadS [Options]
(Int -> ReadS Options)
-> ReadS [Options]
-> ReadPrec Options
-> ReadPrec [Options]
-> Read Options
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Options]
$creadListPrec :: ReadPrec [Options]
readPrec :: ReadPrec Options
$creadPrec :: ReadPrec Options
readList :: ReadS [Options]
$creadList :: ReadS [Options]
readsPrec :: Int -> ReadS Options
$creadsPrec :: Int -> ReadS Options
Read, Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show)

-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to
-- prevent users from having to enable that extension at use sites.)
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: Bool -> Options
Options { emptyCaseBehavior :: Bool
emptyCaseBehavior = Bool
False }

{- $deriveInvariant

'deriveInvariant' automatically generates an 'Data.Functor.Invariant.Invariant'
instance declaration for a data type, newtype, or data family instance that has
at least one type variable.  This emulates what would (hypothetically) happen
if you could attach a @deriving 'Data.Functor.Invariant.Invariant'@ clause to
the end of a data declaration. Examples:

@
&#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
import Data.Functor.Invariant.TH

data Pair a = Pair a a
$('deriveInvariant' ''Pair) -- instance Invariant Pair where ...

newtype Alt f a = Alt (f a)
$('deriveInvariant' ''Alt) -- instance Invariant f => Invariant (Alt f) where ...
@

If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),
'deriveInvariant' can also be used to derive 'Data.Functor.Invariant.Invariant' instances for data family
instances (which requires the @-XTypeFamilies@ extension). To do so, pass the name of
a data or newtype instance constructor to 'deriveInvariant'.  Note that the generated
code may require the @-XFlexibleInstances@ extension. Some examples:

@
&#123;-&#35; LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies &#35;-&#125;
import Data.Functor.Invariant.TH

class AssocClass a b where
    data AssocData a b
instance AssocClass Int b where
    data AssocData Int b = AssocDataInt1 Int | AssocDataInt2 b Int
$('deriveInvariant' 'AssocDataInt1) -- instance Invariant (AssocData Int) where ...
-- Alternatively, one could use $(deriveInvariant 'AssocDataInt2)

data family DataFam a b
newtype instance DataFam () b = DataFamB b
$('deriveInvariant' 'DataFamB) -- instance Invariant (DataFam ())
@

Note that there are some limitations:

* The 'Name' argument to 'deriveInvariant' must not be a type synonym.

* With 'deriveInvariant', the argument's last type variable must be of kind @*@.
  For other ones, type variables of kind @* -> *@ are assumed to require an
  'Data.Functor.Invariant.Invariant' context. For more complicated scenarios,
  use 'makeInvmap'.

* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
  extensions, a constraint cannot mention the last type variable. For example,
  @data Illegal a where I :: Ord a => a -> Illegal a@ cannot have a derived
  'Data.Functor.Invariant.Invariant' instance.

* If the last type variable is used within a data field of a constructor, it must only
  be used in the last argument of the data type constructor. For example, @data Legal a
  = Legal (Either Int a)@ can have a derived 'Data.Functor.Invariant.Invariant' instance,
  but @data Illegal a = Illegal (Either a a)@ cannot.

* Data family instances must be able to eta-reduce the last type variable. In other
  words, if you have a instance of the form:

  @
  data family Family a1 ... an t
  data instance Family e1 ... e2 v = ...
  @

  Then the following conditions must hold:

  1. @v@ must be a type variable.
  2. @v@ must not be mentioned in any of @e1@, ..., @e2@.

-}

-- | Generates an 'Data.Functor.Invariant.Invariant' instance declaration for the given
-- data type or data family instance.
deriveInvariant :: Name -> Q [Dec]
deriveInvariant :: Name -> Q [Dec]
deriveInvariant = Options -> Name -> Q [Dec]
deriveInvariantOptions Options
defaultOptions

-- | Like 'deriveInvariant', but takes an 'Options' argument.
deriveInvariantOptions :: Options -> Name -> Q [Dec]
deriveInvariantOptions :: Options -> Name -> Q [Dec]
deriveInvariantOptions = InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass InvariantClass
Invariant

{- $deriveInvariant2

'deriveInvariant2' automatically generates an
'Data.Functor.Invariant.Invariant2' instance declaration for a data type,
newtype, or data family instance that has at least two type variables.  This
emulates what would (hypothetically) happen if you could attach a @deriving
'Data.Functor.Invariant.Invariant2'@ clause to the end of a data declaration.
Examples:

@
&#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
import Data.Functor.Invariant.TH

data OneOrNone a b = OneL a | OneR b | None
$('deriveInvariant2' ''OneOrNone) -- instance Invariant2 OneOrNone where ...

newtype Alt2 f a b = Alt2 (f a b)
$('deriveInvariant2' ''Alt2) -- instance Invariant2 f => Invariant2 (Alt2 f) where ...
@

The same restrictions that apply to 'deriveInvariant' also apply to 'deriveInvariant2',
with some caveats:

* With 'deriveInvariant2', the last type variables must both be of kind @*@. For other
  ones, type variables of kind @* -> *@ are assumed to require an 'Data.Functor.Invariant.Invariant'
  constraint, and type variables of kind @* -> * -> *@ are assumed to require an
  'Data.Functor.Invariant.Invariant2' constraint. For more complicated scenarios, use 'makeInvmap2'.

* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
  extensions, a constraint cannot mention either of the last two type variables. For
  example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot
  have a derived 'Data.Functor.Invariant.Invariant2' instance.

* If either of the last two type variables is used within a data field of a constructor,
  it must only be used in the last two arguments of the data type constructor. For
  example, @data Legal a b = Legal (Int, Int, a, b)@ can have a derived
  'Data.Functor.Invariant.Invariant2' instance, but
  @data Illegal a b = Illegal (a, b, a, b)@ cannot.

* Data family instances must be able to eta-reduce the last two type variables. In other
  words, if you have a instance of the form:

  @
  data family Family a1 ... an t1 t2
  data instance Family e1 ... e2 v1 v2 = ...
  @

  Then the following conditions must hold:

  1. @v1@ and @v2@ must be distinct type variables.
  2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.

-}

-- | Generates an 'Data.Functor.Invariant.Invariant2' instance declaration for
-- the given data type or data family instance.
deriveInvariant2 :: Name -> Q [Dec]
deriveInvariant2 :: Name -> Q [Dec]
deriveInvariant2 = Options -> Name -> Q [Dec]
deriveInvariant2Options Options
defaultOptions

-- | Like 'deriveInvariant2', but takes an 'Options' argument.
deriveInvariant2Options :: Options -> Name -> Q [Dec]
deriveInvariant2Options :: Options -> Name -> Q [Dec]
deriveInvariant2Options = InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass InvariantClass
Invariant2

{- $make

There may be scenarios in which you want to @invmap@ over an arbitrary data
type or data family instance without having to make the type an instance of
'Data.Functor.Invariant.Invariant'. For these cases, this module provides
several functions (all prefixed with @make-@) that splice the appropriate
lambda expression into your source code. Example:

This is particularly useful for creating instances for sophisticated data
types. For example, 'deriveInvariant' cannot infer the correct type context for
@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind
@* -> * -> * -> *@. However, it is still possible to create an
'Data.Functor.Invariant.Invariant' instance for @HigherKinded@ without too much
trouble using 'makeInvmap':

@
&#123;-&#35; LANGUAGE FlexibleContexts, TemplateHaskell &#35;-&#125;
import Data.Functor.Invariant
import Data.Functor.Invariant.TH

newtype HigherKinded f a b c = HigherKinded (f a b c)

instance Invariant (f a b) => Invariant (HigherKinded f a b) where
    invmap = $(makeInvmap ''HigherKinded)
@

-}

-- | Generates a lambda expression which behaves like
-- 'Data.Functor.Invariant.invmap' (without requiring an
-- 'Data.Functor.Invariant.Invariant' instance).
makeInvmap :: Name -> Q Exp
makeInvmap :: Name -> Q Exp
makeInvmap = Options -> Name -> Q Exp
makeInvmapOptions Options
defaultOptions

-- | Like 'makeInvmap', but takes an 'Options' argument.
makeInvmapOptions :: Options -> Name -> Q Exp
makeInvmapOptions :: Options -> Name -> Q Exp
makeInvmapOptions = InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass InvariantClass
Invariant

-- | Generates a lambda expression which behaves like
-- 'Data.Functor.Invariant.invmap2' (without requiring an
-- 'Data.Functor.Invariant.Invariant2' instance).
makeInvmap2 :: Name -> Q Exp
makeInvmap2 :: Name -> Q Exp
makeInvmap2 = Options -> Name -> Q Exp
makeInvmap2Options Options
defaultOptions

-- | Like 'makeInvmap2', but takes an 'Options' argument.
makeInvmap2Options :: Options -> Name -> Q Exp
makeInvmap2Options :: Options -> Name -> Q Exp
makeInvmap2Options = InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass InvariantClass
Invariant2

-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------

-- | Derive an Invariant(2) instance declaration (depending on the InvariantClass
-- argument's value).
deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass InvariantClass
iClass Options
opts Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext   = Cxt
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
#if MIN_VERSION_th_abstraction(0,3,0)
                 , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
#else
                 , datatypeVars      = instTys
#endif
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } -> do
      (Cxt
instanceCxt, Type
instanceType)
        <- InvariantClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance InvariantClass
iClass Name
parentName Cxt
ctxt Cxt
instTys DatatypeVariant
variant
      (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                             (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                             (InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
invmapDecs InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)

-- | Generates a declaration defining the primary function corresponding to a
-- particular class (invmap for Invariant and invmap2 for Invariant2).
invmapDecs :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
           -> [Q Dec]
invmapDecs :: InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
invmapDecs InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons =
    [ Name -> [ClauseQ] -> Q Dec
funD (InvariantClass -> Name
invmapName InvariantClass
iClass)
           [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                    (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeInvmapForCons InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons)
                    []
           ]
    ]

-- | Generates a lambda expression which behaves like invmap (for Invariant),
-- or invmap2 (for Invariant2).
makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass InvariantClass
iClass Options
opts Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext   = Cxt
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
#if MIN_VERSION_th_abstraction(0,3,0)
                 , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
#else
                 , datatypeVars      = instTys
#endif
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } ->
      -- We force buildTypeInstance here since it performs some checks for whether
      -- or not the provided datatype can actually have invmap/invmap2
      -- implemented for it, and produces errors if it can't.
      InvariantClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance InvariantClass
iClass Name
parentName Cxt
ctxt Cxt
instTys DatatypeVariant
variant
        Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeInvmapForCons InvariantClass
iClass Options
opts Name
parentName Cxt
instTys [ConstructorInfo]
cons

-- | Generates a lambda expression for invmap(2) for the given constructors.
-- All constructors must be from the same type.
makeInvmapForCons :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
                  -> Q Exp
makeInvmapForCons :: InvariantClass
-> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeInvmapForCons InvariantClass
iClass Options
opts Name
_parentName Cxt
instTys [ConstructorInfo]
cons = do
    Name
value      <- String -> Q Name
newName String
"value"
    [Name]
covMaps    <- String -> Int -> Q [Name]
newNameList String
"covMap" Int
numNbs
    [Name]
contraMaps <- String -> Int -> Q [Name]
newNameList String
"contraMap" Int
numNbs

    let mapFuns :: [(Name, Name)]
mapFuns    = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
covMaps [Name]
contraMaps
        lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass) Cxt
instTys
        tvMap :: Map Name (Name, Name)
tvMap      = [(Name, (Name, Name))] -> Map Name (Name, Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, (Name, Name))] -> Map Name (Name, Name))
-> [(Name, (Name, Name))] -> Map Name (Name, Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Name, Name)] -> [(Name, (Name, Name))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name)]
mapFuns
        argNames :: [Name]
argNames   = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [[Name]]
forall a. [[a]] -> [[a]]
transpose [[Name]
covMaps, [Name]
contraMaps]) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
value]
    [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
argNames)
        (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
        ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ InvariantClass -> Name
invmapConstName InvariantClass
iClass
          , Name -> Map Name (Name, Name) -> Q Exp
makeFun Name
value Map Name (Name, Name)
tvMap
          ] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
argNames
  where
    numNbs :: Int
    numNbs :: Int
numNbs = InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass

    makeFun :: Name -> TyVarMap -> Q Exp
    makeFun :: Name -> Map Name (Name, Name) -> Q Exp
makeFun Name
value Map Name (Name, Name)
tvMap = do
#if MIN_VERSION_template_haskell(2,9,0)
      [Role]
roles <- Name -> Q [Role]
reifyRoles Name
_parentName
      let rroles :: [Role]
rroles = [Role]
roles
#endif
      case () of
        ()
_

#if MIN_VERSION_template_haskell(2,9,0)
          | ([Role] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Role]
rroles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numNbs) Bool -> Bool -> Bool
&&
            ((Role -> Bool) -> [Role] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
PhantomR) (Int -> [Role] -> [Role]
forall a. Int -> [a] -> [a]
take Int
numNbs [Role]
rroles))
         -> Name -> Q Exp
varE Name
coerceValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
value
#endif

          | [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& Options -> Bool
emptyCaseBehavior Options
opts Bool -> Bool -> Bool
&& Bool
ghc7'8OrLater
         -> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) []

          | [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
         -> Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
seqValName) (Name -> Q Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
`appE`
            Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
errorValName)
                 (String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Void " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (InvariantClass -> Name
invmapName InvariantClass
iClass))

          | Bool
otherwise
         -> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value)
                  ((ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (InvariantClass
-> Map Name (Name, Name) -> ConstructorInfo -> MatchQ
makeInvmapForCon InvariantClass
iClass Map Name (Name, Name)
tvMap) [ConstructorInfo]
cons)

    ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
    ghc7'8OrLater :: Bool
ghc7'8OrLater = Bool
True
#else
    ghc7'8OrLater = False
#endif

-- | Generates a lambda expression for invmap(2) for a single constructor.
makeInvmapForCon :: InvariantClass -> TyVarMap -> ConstructorInfo -> Q Match
makeInvmapForCon :: InvariantClass
-> Map Name (Name, Name) -> ConstructorInfo -> MatchQ
makeInvmapForCon InvariantClass
iClass Map Name (Name, Name)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
                   , constructorFields :: ConstructorInfo -> Cxt
constructorFields  = Cxt
ts })= do
    Cxt
ts'      <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
ts
    [Name]
argNames <- String -> Int -> Q [Name]
newNameList String
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts'
    if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` Map Name (Name, Name) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (Name, Name)
tvMap) Cxt
ctxt
         Bool -> Bool -> Bool
|| Map Name (Name, Name) -> Int
forall k a. Map k a -> Int
Map.size Map Name (Name, Name)
tvMap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass
       then Name -> MatchQ
forall a. Name -> a
existentialContextError Name
conName
       else InvariantClass
-> Map Name (Name, Name) -> Name -> Cxt -> [Name] -> MatchQ
makeInvmapForArgs InvariantClass
iClass Map Name (Name, Name)
tvMap Name
conName Cxt
ts' [Name]
argNames

makeInvmapForArgs :: InvariantClass
                  -> TyVarMap
                  -> Name
                  -> [Type]
                  -> [Name]
                  -> Q Match
makeInvmapForArgs :: InvariantClass
-> Map Name (Name, Name) -> Name -> Cxt -> [Name] -> MatchQ
makeInvmapForArgs InvariantClass
iClass Map Name (Name, Name)
tvMap Name
conName Cxt
tys [Name]
args =
    let mappedArgs :: [Q Exp]
        mappedArgs :: [Q Exp]
mappedArgs = (Type -> Name -> Q Exp) -> Cxt -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (InvariantClass
-> Name -> Map Name (Name, Name) -> Type -> Name -> Q Exp
makeInvmapForArg InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap) Cxt
tys [Name]
args
     in PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
              (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE ([Q Exp] -> BodyQ) -> [Q Exp] -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
conNameQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
mappedArgs)
              []

-- | Generates a lambda expression for invmap(2) for an argument of a constructor.
makeInvmapForArg :: InvariantClass
                 -> Name
                 -> TyVarMap
                 -> Type
                 -> Name
                 -> Q Exp
makeInvmapForArg :: InvariantClass
-> Name -> Map Name (Name, Name) -> Type -> Name -> Q Exp
makeInvmapForArg InvariantClass
iClass Name
conName Map Name (Name, Name)
tvis Type
ty Name
tyExpName =
    Q Exp -> Q Exp -> Q Exp
appE (InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvis Bool
True Type
ty) (Name -> Q Exp
varE Name
tyExpName)

-- | Generates a lambda expression for invmap(2) for a specific type.
-- The generated expression depends on the number of type variables.
makeInvmapForType :: InvariantClass
                  -> Name
                  -> TyVarMap
                  -> Bool
                  -> Type
                  -> Q Exp
makeInvmapForType :: InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
_ Name
_ Map Name (Name, Name)
tvMap Bool
covariant (VarT Name
tyName) =
    case Name -> Map Name (Name, Name) -> Maybe (Name, Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (Name, Name)
tvMap of
         Just (Name
covMap, Name
contraMap) ->
             Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ if Bool
covariant then Name
covMap else Name
contraMap
         Maybe (Name, Name)
Nothing -> do -- Produce a lambda expression rather than id, addressing Trac #7436
             Name
x <- String -> Q Name
newName String
"x"
             [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
x
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant (SigT Type
ty Type
_) =
    InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
ty
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant (ForallT [TyVarBndr]
_ Cxt
_ Type
ty)
    = InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
ty
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
ty =
    let tyCon  :: Type
        tyArgs :: [Type]
        Type
tyCon:Cxt
tyArgs = Type -> Cxt
unapplyTy Type
ty

        numLastArgs :: Int
        numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass) (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)

        lhsArgs, rhsArgs :: [Type]
        (Cxt
lhsArgs, Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs

        tyVarNames :: [Name]
        tyVarNames :: [Name]
tyVarNames = Map Name (Name, Name) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (Name, Name)
tvMap

        doubleMap :: (Bool -> Type -> Q Exp) -> [Type] -> [Q Exp]
        doubleMap :: (Bool -> Type -> Q Exp) -> Cxt -> [Q Exp]
doubleMap Bool -> Type -> Q Exp
_ []     = []
        doubleMap Bool -> Type -> Q Exp
f (Type
t:Cxt
ts) = Bool -> Type -> Q Exp
f Bool
covariant Type
t Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: Bool -> Type -> Q Exp
f (Bool -> Bool
not Bool
covariant) Type
t Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Bool -> Type -> Q Exp) -> Cxt -> [Q Exp]
doubleMap Bool -> Type -> Q Exp
f Cxt
ts

        mentionsTyArgs :: Bool
        mentionsTyArgs :: Bool
mentionsTyArgs = (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs

        makeInvmapTuple :: ([Q Pat] -> Q Pat) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp
        makeInvmapTuple :: ([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp
makeInvmapTuple [PatQ] -> PatQ
mkTupP [Q Exp] -> Q Exp
mkTupE Int
n = do
            Name
x  <- String -> Q Name
newName String
"x"
            [Name]
xs <- String -> Int -> Q [Name]
newNameList String
"x" Int
n
            [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
x)
                [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match ([PatQ] -> PatQ
mkTupP ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)
                        (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
mkTupE ([Q Exp] -> BodyQ) -> [Q Exp] -> BodyQ
forall a b. (a -> b) -> a -> b
$ (Type -> Name -> Q Exp) -> Cxt -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Name -> Q Exp
makeInvmapTupleField Cxt
tyArgs [Name]
xs)
                        []
                ]

        makeInvmapTupleField :: Type -> Name -> Q Exp
        makeInvmapTupleField :: Type -> Name -> Q Exp
makeInvmapTupleField Type
fieldTy Name
fieldName =
            Q Exp -> Q Exp -> Q Exp
appE (InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
fieldTy) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
fieldName

     in case Type
tyCon of
          Type
ArrowT | Bool
mentionsTyArgs ->
              let [Type
argTy, Type
resTy] = Cxt
tyArgs
               in do Name
x <- String -> Q Name
newName String
"x"
                     Name
b <- String -> Q Name
newName String
"b"
                     [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
b] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
                       InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap Bool
covariant Type
resTy Q Exp -> Q Exp -> Q Exp
`appE` (Name -> Q Exp
varE Name
x Q Exp -> Q Exp -> Q Exp
`appE`
                         (InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap (Bool -> Bool
not Bool
covariant) Type
argTy Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
b))
#if MIN_VERSION_template_haskell(2,6,0)
          UnboxedTupleT Int
n
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp
makeInvmapTuple [PatQ] -> PatQ
unboxedTupP [Q Exp] -> Q Exp
unboxedTupE Int
n
#endif
          TupleT Int
n
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp
makeInvmapTuple [PatQ] -> PatQ
tupP [Q Exp] -> Q Exp
tupE Int
n
          Type
_ -> do
              Bool
itf <- Type -> Q Bool
isTyFamily Type
tyCon
              if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs Bool -> Bool -> Bool
|| (Bool
itf Bool -> Bool -> Bool
&& Bool
mentionsTyArgs)
                   then Name -> [Name] -> Q Exp
forall a. Name -> a
outOfPlaceTyVarError Name
conName [Name]
tyVarNames
                   else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
                        then [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
                             ( Name -> Q Exp
varE (InvariantClass -> Name
invmapName (Int -> InvariantClass
forall a. Enum a => Int -> a
toEnum Int
numLastArgs))
                             Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Bool -> Type -> Q Exp) -> Cxt -> [Q Exp]
doubleMap (InvariantClass
-> Name -> Map Name (Name, Name) -> Bool -> Type -> Q Exp
makeInvmapForType InvariantClass
iClass Name
conName Map Name (Name, Name)
tvMap) Cxt
rhsArgs
                             )
                        else do Name
x <- String -> Q Name
newName String
"x"
                                [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
x

-------------------------------------------------------------------------------
-- Template Haskell reifying and AST manipulation
-------------------------------------------------------------------------------

-- For the given Types, generate an instance context and head. Coming up with
-- the instance type isn't as simple as dropping the last types, as you need to
-- be wary of kinds being instantiated with *.
-- See Note [Type inference in derived instances]
buildTypeInstance :: InvariantClass
                  -- ^ Invariant or Invariant2
                  -> Name
                  -- ^ The type constructor or data family name
                  -> Cxt
                  -- ^ The datatype context
                  -> [Type]
                  -- ^ The types to instantiate the instance with
                  -> DatatypeVariant
                  -- ^ Are we dealing with a data family instance or not
                  -> Q (Cxt, Type)
buildTypeInstance :: InvariantClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance InvariantClass
iClass Name
tyConName Cxt
dataCxt Cxt
varTysOrig DatatypeVariant
variant = do
    -- Make sure to expand through type/kind synonyms! Otherwise, the
    -- eta-reduction check might get tripped up over type variables in a
    -- synonym that are actually dropped.
    -- (See GHC Trac #11416 for a scenario where this actually happened.)
    Cxt
varTysExp <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
varTysOrig

    let remainingLength :: Int
        remainingLength :: Int
remainingLength = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
varTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass

        droppedTysExp :: [Type]
        droppedTysExp :: Cxt
droppedTysExp = Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop Int
remainingLength Cxt
varTysExp

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> Cxt -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar Cxt
droppedTysExp

    -- Check there are enough types to drop and that all of them are either of
    -- kind * or kind k (for some kind variable k). If not, throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| (StarKindStatus -> Bool) -> [StarKindStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (StarKindStatus -> StarKindStatus -> Bool
forall a. Eq a => a -> a -> Bool
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      InvariantClass -> Name -> Q ()
forall a. InvariantClass -> Name -> a
derivingKindError InvariantClass
iClass Name
tyConName

    let droppedKindVarNames :: [Name]
        droppedKindVarNames :: [Name]
droppedKindVarNames = [StarKindStatus] -> [Name]
catKindVarNames [StarKindStatus]
droppedStarKindStati

        -- Substitute kind * for any dropped kind variables
        varTysExpSubst :: [Type]
        varTysExpSubst :: Cxt
varTysExpSubst = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) Cxt
varTysExp

        remainingTysExpSubst, droppedTysExpSubst :: [Type]
        (Cxt
remainingTysExpSubst, Cxt
droppedTysExpSubst) =
          Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength Cxt
varTysExpSubst

        -- All of the type variables mentioned in the dropped types
        -- (post-synonym expansion)
        droppedTyVarNames :: [Name]
        droppedTyVarNames :: [Name]
droppedTyVarNames = Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
droppedTysExpSubst

    -- If any of the dropped types were polykinded, ensure that there are of kind *
    -- after substituting * for the dropped kind variables. If not, throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      InvariantClass -> Name -> Q ()
forall a. InvariantClass -> Name -> a
derivingKindError InvariantClass
iClass Name
tyConName

    let preds    :: [Maybe Pred]
        kvNames  :: [[Name]]
        kvNames' :: [Name]
        -- Derive instance constraints (and any kind variables which are specialized
        -- to * in those constraints)
        ([Maybe Type]
preds, [[Name]]
kvNames) = [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Type, [Name])] -> ([Maybe Type], [[Name]]))
-> [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. (a -> b) -> a -> b
$ (Type -> (Maybe Type, [Name])) -> Cxt -> [(Maybe Type, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (InvariantClass -> Type -> (Maybe Type, [Name])
deriveConstraint InvariantClass
iClass) Cxt
remainingTysExpSubst
        kvNames' :: [Name]
kvNames' = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
kvNames

        -- Substitute the kind variables specialized in the constraints with *
        remainingTysExpSubst' :: [Type]
        remainingTysExpSubst' :: Cxt
remainingTysExpSubst' =
          (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
kvNames') Cxt
remainingTysExpSubst

        -- We now substitute all of the specialized-to-* kind variable names with
        -- *, but in the original types, not the synonym-expanded types. The reason
        -- we do this is a superficial one: we want the derived instance to resemble
        -- the datatype written in source code as closely as possible. For example,
        -- for the following data family instance:
        --
        --   data family Fam a
        --   newtype instance Fam String = Fam String
        --
        -- We'd want to generate the instance:
        --
        --   instance C (Fam String)
        --
        -- Not:
        --
        --   instance C (Fam [Char])
        remainingTysOrigSubst :: [Type]
        remainingTysOrigSubst :: Cxt
remainingTysOrigSubst =
          (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar ([Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
union [Name]
droppedKindVarNames [Name]
kvNames'))
            (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take Int
remainingLength Cxt
varTysOrig

        isDataFamily :: Bool
        isDataFamily :: Bool
isDataFamily = case DatatypeVariant
variant of
                         DatatypeVariant
Datatype        -> Bool
False
                         DatatypeVariant
Newtype         -> Bool
False
                         DatatypeVariant
DataInstance    -> Bool
True
                         DatatypeVariant
NewtypeInstance -> Bool
True

        remainingTysOrigSubst' :: [Type]
        -- See Note [Kind signatures in derived instances] for an explanation
        -- of the isDataFamily check.
        remainingTysOrigSubst' :: Cxt
remainingTysOrigSubst' =
          if Bool
isDataFamily
             then Cxt
remainingTysOrigSubst
             else (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT Cxt
remainingTysOrigSubst

        instanceCxt :: Cxt
        instanceCxt :: Cxt
instanceCxt = [Maybe Type] -> Cxt
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
preds

        instanceType :: Type
        instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ InvariantClass -> Name
invariantClassName InvariantClass
iClass)
                     (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Type
applyTyCon Name
tyConName Cxt
remainingTysOrigSubst'

    -- If the datatype context mentions any of the dropped type variables,
    -- we can't derive an instance, so throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) Cxt
dataCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Name -> Type -> Q ()
forall a. Name -> Type -> a
datatypeContextError Name
tyConName Type
instanceType
    -- Also ensure the dropped types can be safely eta-reduced. Otherwise,
    -- throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Cxt -> Cxt -> Bool
canEtaReduce Cxt
remainingTysExpSubst' Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Type -> Q ()
forall a. Type -> a
etaReductionError Type
instanceType
    (Cxt, Type) -> Q (Cxt, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
instanceCxt, Type
instanceType)

-- | Attempt to derive a constraint on a Type. If successful, return
-- Just the constraint and any kind variable names constrained to *.
-- Otherwise, return Nothing and the empty list.
--
-- See Note [Type inference in derived instances] for the heuristics used to
-- come up with constraints.
deriveConstraint :: InvariantClass -> Type -> (Maybe Pred, [Name])
deriveConstraint :: InvariantClass -> Type -> (Maybe Type, [Name])
deriveConstraint InvariantClass
iClass Type
t
  | Bool -> Bool
not (Type -> Bool
isTyVar Type
t) = (Maybe Type
forall a. Maybe a
Nothing, [])
  | Bool
otherwise = case Int -> Type -> Maybe [Name]
hasKindVarChain Int
1 Type
t of
      Just [Name]
ns | InvariantClass
iClass InvariantClass -> InvariantClass -> Bool
forall a. Ord a => a -> a -> Bool
>= InvariantClass
Invariant
              -> (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyClass Name
invariantTypeName Name
tName), [Name]
ns)
      Maybe [Name]
_ -> case Int -> Type -> Maybe [Name]
hasKindVarChain Int
2 Type
t of
                Just [Name]
ns | InvariantClass
iClass InvariantClass -> InvariantClass -> Bool
forall a. Eq a => a -> a -> Bool
== InvariantClass
Invariant2
                        -> (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyClass Name
invariant2TypeName Name
tName), [Name]
ns)
                Maybe [Name]
_       -> (Maybe Type
forall a. Maybe a
Nothing, [])
  where
    tName :: Name
    tName :: Name
tName = Type -> Name
varTToName Type
t

{-
Note [Kind signatures in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

It is possible to put explicit kind signatures into the derived instances, e.g.,

  instance C a => C (Data (f :: * -> *)) where ...

But it is preferable to avoid this if possible. If we come up with an incorrect
kind signature (which is entirely possible, since our type inferencer is pretty
unsophisticated - see Note [Type inference in derived instances]), then GHC will
flat-out reject the instance, which is quite unfortunate.

Plain old datatypes have the advantage that you can avoid using any kind signatures
at all in their instances. This is because a datatype declaration uses all type
variables, so the types that we use in a derived instance uniquely determine their
kinds. As long as we plug in the right types, the kind inferencer can do the rest
of the work. For this reason, we use unSigT to remove all kind signatures before
splicing in the instance context and head.

Data family instances are trickier, since a data family can have two instances that
are distinguished by kind alone, e.g.,

  data family Fam (a :: k)
  data instance Fam (a :: * -> *)
  data instance Fam (a :: *)

If we dropped the kind signatures for C (Fam a), then GHC will have no way of
knowing which instance we are talking about. To avoid this scenario, we always
include explicit kind signatures in data family instances. There is a chance that
the inferred kind signatures will be incorrect, but if so, we can always fall back
on the make- functions.

Note [Type inference in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Type inference is can be tricky to get right, and we want to avoid recreating the
entirety of GHC's type inferencer in Template Haskell. For this reason, we will
probably never come up with derived instance contexts that are as accurate as
GHC's. But that doesn't mean we can't do anything! There are a couple of simple
things we can do to make instance contexts that work for 80% of use cases:

1. If one of the last type parameters is polykinded, then its kind will be
   specialized to * in the derived instance. We note what kind variable the type
   parameter had and substitute it with * in the other types as well. For example,
   imagine you had

     data Data (a :: k) (b :: k) (c :: k)

   Then you'd want to derived instance to be:

     instance C (Data (a :: *))

   Not:

     instance C (Data (a :: k))

2. We naïvely come up with instance constraints using the following criteria:

   (i)  If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind
        variables), then generate an Invariant n constraint, and if k1/k2 are kind
        variables, then substitute k1/k2 with * elsewhere in the types. We must
        consider the case where they are kind variables because you might have a
        scenario like this:

          newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2)
            = Compose (f (g a b))

        Which would have a derived Invariant2 instance of:

          instance (Invariant f, Invariant2 g) => Invariant2 (Compose f g) where ...

   (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
        * or kind variables), then generate a Invariant2 n constraint and perform
        kind substitution as in the other case.
-}

-------------------------------------------------------------------------------
-- Error messages
-------------------------------------------------------------------------------

-- | Either the given data type doesn't have enough type variables, or one of
-- the type variables to be eta-reduced cannot realize kind *.
derivingKindError :: InvariantClass -> Name -> a
derivingKindError :: InvariantClass -> Name -> a
derivingKindError InvariantClass
iClass Name
tyConName = String -> a
forall a. HasCallStack => String -> a
error
    (String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Cannot derive well-kinded instance of form ‘"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True
      ( String -> ShowS
showString (Name -> String
nameBase Name
tyConName)
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ..."
      )
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘\n\tClass "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
className
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" expects an argument of kind "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Type -> String
forall a. Ppr a => a -> String
pprint (Type -> String) -> (Int -> Type) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
createKindChain (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ InvariantClass -> Int
forall a. Enum a => a -> Int
fromEnum InvariantClass
iClass)
    (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
""
  where
    className :: String
    className :: String
className = Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ InvariantClass -> Name
invariantClassName InvariantClass
iClass

-- | The data type has a DatatypeContext which mentions one of the eta-reduced
-- type variables.
datatypeContextError :: Name -> Type -> a
datatypeContextError :: Name -> Type -> a
datatypeContextError Name
dataName Type
instanceType = String -> a
forall a. HasCallStack => String -> a
error
    (String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Can't make a derived instance of ‘"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceType)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘:\n\tData type ‘"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
dataName)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must not have a class context involving the last type argument(s)"
    (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type has an existential constraint which mentions one of the
-- eta-reduced type variables.
existentialContextError :: Name -> a
existentialContextError :: Name -> a
existentialContextError Name
conName = String -> a
forall a. HasCallStack => String -> a
error
    (String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must be truly polymorphic in the last argument(s) of the data type"
    (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type mentions one of the n eta-reduced type variables in a place other
-- than the last nth positions of a data type in a constructor's field.
outOfPlaceTyVarError :: Name -> a
outOfPlaceTyVarError :: Name -> a
outOfPlaceTyVarError Name
conName = String -> a
forall a. HasCallStack => String -> a
error
  (String -> a) -> ShowS -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Constructor ‘"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Name -> String
nameBase Name
conName)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"‘ must only use its last two type variable(s) within"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" the last two argument(s) of a data type"
  (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
""

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