{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}

#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#endif

{-|
Module:      Data.Deriving.Via.Internal
Copyright:   (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module
exports functionality which emulates the @GeneralizedNewtypeDeriving@ and
@DerivingVia@ GHC extensions (the latter of which was introduced in GHC 8.6).

On older versions of @template-haskell@/GHC, this module does not export
anything.

Note: this is an internal module, and as such, the API presented here is not
guaranteed to be stable, even between minor releases of this library.
-}
module Data.Deriving.Via.Internal where

#if MIN_VERSION_template_haskell(2,12,0)
import           Control.Monad ((<=<), unless)

import           Data.Deriving.Internal
import qualified Data.List as L
import qualified Data.Map as M
import           Data.Map (Map)
import           Data.Maybe (catMaybes)

import           GHC.Exts (Any)

import           Language.Haskell.TH
import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.Datatype.TyVarBndr

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

{- | Generates an instance for a type class at a newtype by emulating the
behavior of the @GeneralizedNewtypeDeriving@ extension. For example:

@
newtype Foo a = MkFoo a
$('deriveGND' [t| forall a. 'Eq' a => 'Eq' (Foo a) |])
@
-}
deriveGND :: Q Type -> Q [Dec]
deriveGND :: Q Type -> Q [Dec]
deriveGND Q Type
qty = do
  Type
ty <- Q Type
qty
  let ([TyVarBndrSpec]
_instanceTvbs, Cxt
instanceCxt, Type
instanceTy) = Type -> ([TyVarBndrSpec], Cxt, Type)
decomposeType Type
ty
  Type
instanceTy' <- (Type -> Q Type
resolveTypeSynonyms (Type -> Q Type) -> (Type -> Q Type) -> Type -> Q Type
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> Q Type
resolveInfixT) Type
instanceTy
  [Dec]
decs <- Type -> Maybe Type -> Q [Dec]
deriveViaDecs Type
instanceTy' Maybe Type
forall a. Maybe a
Nothing
  (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 -> Q Type -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                         (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceTy)
                         ((Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
decs)

{- | Generates an instance for a type class by emulating the behavior of the
@DerivingVia@ extension. For example:

@
newtype Foo a = MkFoo a
$('deriveVia' [t| forall a. 'Ord' a => 'Ord' (Foo a) ``Via`` Down a |])
@

As shown in the example above, the syntax is a tad strange. One must specify
the type by which to derive the instance using the 'Via' type. This
requirement is in place to ensure that the type variables are scoped
correctly across all the types being used (e.g., to make sure that the same
@a@ is used in @'Ord' a@, @'Ord' (Foo a)@, and @Down a@).
-}
deriveVia :: Q Type -> Q [Dec]
deriveVia :: Q Type -> Q [Dec]
deriveVia Q Type
qty = do
  Type
ty <- Q Type
qty
  let ([TyVarBndrSpec]
_instanceTvbs, Cxt
instanceCxt, Type
viaApp) = Type -> ([TyVarBndrSpec], Cxt, Type)
decomposeType Type
ty
  Type
viaApp' <- (Type -> Q Type
resolveTypeSynonyms (Type -> Q Type) -> (Type -> Q Type) -> Type -> Q Type
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> Q Type
resolveInfixT) Type
viaApp
  (Type
instanceTy, Type
viaTy)
    <- case Type -> (Type, Cxt)
unapplyTy Type
viaApp' of
         (Type
via, [Type
instanceTy,Type
viaTy])
           | Type
via Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT Name
viaTypeName
          -> (Type, Type) -> Q (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
instanceTy, Type
viaTy)
         (Type, Cxt)
_ -> String -> Q (Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                [ String
"Failure to meet ‘deriveVia‘ specification"
                , String
"\tThe ‘Via‘ type must be used, e.g."
                , String
"\t[t| forall a. C (T a) `Via` V a |]"
                ]
  -- This is a stronger requirement than what GHC's implementation of
  -- DerivingVia imposes, but due to Template Haskell restrictions, we
  -- currently can't do better. See #27.
  let viaTyFVs :: [Name]
viaTyFVs           = Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
viaTy
      otherFVs :: [Name]
otherFVs           = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
instanceCxt, Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
instanceTy]
      floatingViaTyFVs :: [Name]
floatingViaTyFVs   = [Name]
viaTyFVs [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Name]
otherFVs
      floatingViaTySubst :: Map Name Type
floatingViaTySubst = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Type)] -> Map Name Type)
-> [(Name, Type)] -> Map Name Type
forall a b. (a -> b) -> a -> b
$ (Name -> (Name, Type)) -> [Name] -> [(Name, Type)]
forall a b. (a -> b) -> [a] -> [b]
map (, Name -> Type
ConT ''Any) [Name]
floatingViaTyFVs
      viaTy' :: Type
viaTy'             = Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
floatingViaTySubst Type
viaTy
  [Dec]
decs <- Type -> Maybe Type -> Q [Dec]
deriveViaDecs Type
instanceTy (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
viaTy')
  (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 -> Q Type -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                         (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceTy)
                         ((Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
decs)

deriveViaDecs :: Type       -- ^ The instance head (e.g., @Eq (Foo a)@)
              -> Maybe Type -- ^ If using 'deriveGND', this is 'Nothing.
                            --   If using 'deriveVia', this is 'Just' the @via@ type.
              -> Q [Dec]
deriveViaDecs :: Type -> Maybe Type -> Q [Dec]
deriveViaDecs Type
instanceTy Maybe Type
mbViaTy = do
  let (Type
clsTy, Cxt
clsArgs) = Type -> (Type, Cxt)
unapplyTy Type
instanceTy
  case Type
clsTy of
    ConT Name
clsName -> do
      Info
clsInfo <- Name -> Q Info
reify Name
clsName
      case Info
clsInfo of
        ClassI (ClassD Cxt
_ Name
_ [TyVarBndrSpec]
clsTvbs [FunDep]
_ [Dec]
clsDecs) [Dec]
_ ->
          case (Cxt -> Maybe (Cxt, Type)
forall a. [a] -> Maybe ([a], a)
unsnoc Cxt
clsArgs, [TyVarBndrSpec] -> Maybe ([TyVarBndrSpec], TyVarBndrSpec)
forall a. [a] -> Maybe ([a], a)
unsnoc [TyVarBndrSpec]
clsTvbs) of
            (Just (Cxt
_, Type
dataApp), Just ([TyVarBndrSpec]
_, TyVarBndrSpec
clsLastTvb)) -> do
              let (Type
dataTy, Cxt
dataArgs) = Type -> (Type, Cxt)
unapplyTy Type
dataApp
                  clsLastTvbKind :: Type
clsLastTvbKind     = TyVarBndrSpec -> Type
forall flag. TyVarBndrSpec -> Type
tvbKind TyVarBndrSpec
clsLastTvb
                  (Cxt
_, Cxt
kindList)      = Type -> (Cxt, Cxt)
uncurryTy Type
clsLastTvbKind
                  numArgsToEtaReduce :: Int
numArgsToEtaReduce = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
kindList Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              Type
repTy <-
                case Maybe Type
mbViaTy of
                  Just Type
viaTy -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
viaTy
                  Maybe Type
Nothing ->
                    case Type
dataTy of
                      ConT Name
dataName -> do
                        DatatypeInfo {
                                       datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
dataInstTypes
                                     , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
dv
                                     , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                                     } <- Name -> Q DatatypeInfo
reifyDatatype Name
dataName
                        case DatatypeVariant -> [ConstructorInfo] -> Maybe Type
newtypeRepType DatatypeVariant
dv [ConstructorInfo]
cons of
                          Just Type
newtypeRepTy ->
                            case Int -> Type -> Maybe Type
etaReduce Int
numArgsToEtaReduce Type
newtypeRepTy of
                              Just Type
etaRepTy ->
                                let repTySubst :: Map Name Type
repTySubst =
                                      [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Type)] -> Map Name Type)
-> [(Name, Type)] -> Map Name Type
forall a b. (a -> b) -> a -> b
$
                                      (Type -> Type -> (Name, Type)) -> Cxt -> Cxt -> [(Name, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Type
var Type
arg -> (Type -> Name
varTToName Type
var, Type
arg))
                                              Cxt
dataInstTypes Cxt
dataArgs
                                in Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
repTySubst Type
etaRepTy
                              Maybe Type
Nothing -> Type -> Q Type
forall a. Type -> Q a
etaReductionError Type
instanceTy
                          Maybe Type
Nothing -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Not a newtype: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
dataName
                      Type
_ -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Not a data type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
dataTy
              [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec])
-> ([Maybe [Dec]] -> [[Dec]]) -> [Maybe [Dec]] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Dec]] -> [[Dec]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Dec]] -> [Dec]) -> Q [Maybe [Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> Q (Maybe [Dec])) -> [Dec] -> Q [Maybe [Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name -> [TyVarBndrSpec] -> Cxt -> Type -> Dec -> Q (Maybe [Dec])
deriveViaDecs' Name
clsName [TyVarBndrSpec]
clsTvbs Cxt
clsArgs Type
repTy) [Dec]
clsDecs
            (Maybe (Cxt, Type)
_, Maybe ([TyVarBndrSpec], TyVarBndrSpec)
_) -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"Cannot derive instance for nullary class " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
clsTy
        Info
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"Not a type class: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
clsTy
    Type
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"Malformed instance: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceTy

deriveViaDecs' :: Name -> [TyVarBndrUnit] -> [Type] -> Type -> Dec -> Q (Maybe [Dec])
deriveViaDecs' :: Name -> [TyVarBndrSpec] -> Cxt -> Type -> Dec -> Q (Maybe [Dec])
deriveViaDecs' Name
clsName [TyVarBndrSpec]
clsTvbs Cxt
clsArgs Type
repTy Dec
dec = do
    let numExpectedArgs :: Int
numExpectedArgs = [TyVarBndrSpec] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndrSpec]
clsTvbs
        numActualArgs :: Int
numActualArgs   = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
clsArgs
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
numExpectedArgs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
numActualArgs) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Mismatched number of class arguments"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\tThe class " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
clsName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" expects " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
numExpectedArgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" argument(s),"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\tbut was provided " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
numActualArgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" argument(s)."
    Dec -> Q (Maybe [Dec])
go Dec
dec
  where
    go :: Dec -> Q (Maybe [Dec])

    go :: Dec -> Q (Maybe [Dec])
go (OpenTypeFamilyD (TypeFamilyHead Name
tfName [TyVarBndrSpec]
tfTvbs FamilyResultSig
_ Maybe InjectivityAnn
_)) = do
      let lhsSubst :: Map Name Type
lhsSubst = [TyVarBndrSpec] -> Cxt -> Map Name Type
forall flag. [TyVarBndrSpec] -> Cxt -> Map Name Type
zipTvbSubst [TyVarBndrSpec]
clsTvbs Cxt
clsArgs
          rhsSubst :: Map Name Type
rhsSubst = [TyVarBndrSpec] -> Cxt -> Map Name Type
forall flag. [TyVarBndrSpec] -> Cxt -> Map Name Type
zipTvbSubst [TyVarBndrSpec]
clsTvbs (Cxt -> Map Name Type) -> Cxt -> Map Name Type
forall a b. (a -> b) -> a -> b
$ Cxt -> Type -> Cxt
forall a. [a] -> a -> [a]
changeLast Cxt
clsArgs Type
repTy
          tfTvbTys :: Cxt
tfTvbTys = (TyVarBndrSpec -> Type) -> [TyVarBndrSpec] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrSpec -> Type
forall flag. TyVarBndrSpec -> Type
tvbToType [TyVarBndrSpec]
tfTvbs
          tfLHSTys :: Cxt
tfLHSTys = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
lhsSubst) Cxt
tfTvbTys
          tfRHSTys :: Cxt
tfRHSTys = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
rhsSubst) Cxt
tfTvbTys
          tfRHSTy :: Type
tfRHSTy  = Type -> Cxt -> Type
applyTy (Name -> Type
ConT Name
tfName) Cxt
tfRHSTys
      Dec
tfInst <- Name -> Maybe [Q TyVarBndrSpec] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat Name
tfName Maybe [Q TyVarBndrSpec]
forall a. Maybe a
Nothing
                                 ((Type -> Q Type) -> Cxt -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
tfLHSTys) (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
tfRHSTy)
      Maybe [Dec] -> Q (Maybe [Dec])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Maybe [Dec]
forall a. a -> Maybe a
Just [Dec
tfInst])

    go (SigD Name
methName Type
methTy) =
      let (Type
fromTy, Type
toTy) = [TyVarBndrSpec] -> Cxt -> Type -> Type -> (Type, Type)
mkCoerceClassMethEqn [TyVarBndrSpec]
clsTvbs Cxt
clsArgs Type
repTy (Type -> (Type, Type)) -> Type -> (Type, Type)
forall a b. (a -> b) -> a -> b
$
                           Type -> Type
stripOuterForallT Type
methTy
          fromTau :: Type
fromTau = Type -> Type
stripOuterForallT Type
fromTy
          toTau :: Type
toTau   = Type -> Type
stripOuterForallT Type
toTy
          rhsExpr :: Exp
rhsExpr = Name -> Exp
VarE Name
coerceValName Exp -> Type -> Exp
`AppTypeE` Type
fromTau
                                       Exp -> Type -> Exp
`AppTypeE` Type
toTau
                                       Exp -> Exp -> Exp
`AppE`     Name -> Exp
VarE Name
methName
          sig :: Dec
sig  = Name -> Type -> Dec
SigD Name
methName Type
toTy
          meth :: Dec
meth = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
methName)
                      (Exp -> Body
NormalB Exp
rhsExpr)
                      []
      in Maybe [Dec] -> Q (Maybe [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Maybe [Dec]
forall a. a -> Maybe a
Just [Dec
sig, Dec
meth])

    go Dec
_ = Maybe [Dec] -> Q (Maybe [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Dec]
forall a. Maybe a
Nothing

mkCoerceClassMethEqn :: [TyVarBndrUnit] -> [Type] -> Type -> Type -> (Type, Type)
mkCoerceClassMethEqn :: [TyVarBndrSpec] -> Cxt -> Type -> Type -> (Type, Type)
mkCoerceClassMethEqn [TyVarBndrSpec]
clsTvbs Cxt
clsArgs Type
repTy Type
methTy
  = ( Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
rhsSubst Type
methTy
    , Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
lhsSubst Type
methTy
    )
  where
    lhsSubst :: Map Name Type
lhsSubst = [TyVarBndrSpec] -> Cxt -> Map Name Type
forall flag. [TyVarBndrSpec] -> Cxt -> Map Name Type
zipTvbSubst [TyVarBndrSpec]
clsTvbs Cxt
clsArgs
    rhsSubst :: Map Name Type
rhsSubst = [TyVarBndrSpec] -> Cxt -> Map Name Type
forall flag. [TyVarBndrSpec] -> Cxt -> Map Name Type
zipTvbSubst [TyVarBndrSpec]
clsTvbs (Cxt -> Map Name Type) -> Cxt -> Map Name Type
forall a b. (a -> b) -> a -> b
$ Cxt -> Type -> Cxt
forall a. [a] -> a -> [a]
changeLast Cxt
clsArgs Type
repTy

zipTvbSubst :: [TyVarBndr_ flag] -> [Type] -> Map Name Type
zipTvbSubst :: [TyVarBndrSpec] -> Cxt -> Map Name Type
zipTvbSubst [TyVarBndrSpec]
tvbs = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Type)] -> Map Name Type)
-> (Cxt -> [(Name, Type)]) -> Cxt -> Map Name Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVarBndrSpec -> Type -> (Name, Type))
-> [TyVarBndrSpec] -> Cxt -> [(Name, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\TyVarBndrSpec
tvb Type
ty -> (TyVarBndrSpec -> Name
forall flag. TyVarBndrSpec -> Name
tvName TyVarBndrSpec
tvb, Type
ty)) [TyVarBndrSpec]
tvbs

-- | Replace the last element of a list with another element.
changeLast :: [a] -> a -> [a]
changeLast :: [a] -> a -> [a]
changeLast []     a
_  = String -> [a]
forall a. HasCallStack => String -> a
error String
"changeLast"
changeLast [a
_]    a
x  = [a
x]
changeLast (a
x:[a]
xs) a
x' = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> a -> [a]
forall a. [a] -> a -> [a]
changeLast [a]
xs a
x'

stripOuterForallT :: Type -> Type
#if __GLASGOW_HASKELL__ < 807
-- Before GHC 8.7, TH-reified classes would put a redundant forall/class
-- context in front of each method's type signature, so we have to strip them
-- off here.
stripOuterForallT (ForallT _ _ ty) = ty
#endif
stripOuterForallT :: Type -> Type
stripOuterForallT Type
ty               = Type
ty

decomposeType :: Type -> ([TyVarBndrSpec], Cxt, Type)
decomposeType :: Type -> ([TyVarBndrSpec], Cxt, Type)
decomposeType (ForallT [TyVarBndrSpec]
tvbs Cxt
ctxt Type
ty) = ([TyVarBndrSpec]
tvbs, Cxt
ctxt, Type
ty)
decomposeType Type
ty                     = ([],   [],   Type
ty)

newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type
newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type
newtypeRepType DatatypeVariant
dv [ConstructorInfo]
cons = do
    Maybe ()
checkIfNewtype
    case [ConstructorInfo]
cons of
      [ConstructorInfo { constructorVars :: ConstructorInfo -> [TyVarBndrSpec]
constructorVars    = []
                       , constructorContext :: ConstructorInfo -> Cxt
constructorContext = []
                       , constructorFields :: ConstructorInfo -> Cxt
constructorFields  = [Type
repTy]
                       }] -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
repTy
      [ConstructorInfo]
_ -> Maybe Type
forall a. Maybe a
Nothing
  where
    checkIfNewtype :: Maybe ()
    checkIfNewtype :: Maybe ()
checkIfNewtype
      | DatatypeVariant
Newtype         <- DatatypeVariant
dv = () -> Maybe ()
forall a. a -> Maybe a
Just ()
      | DatatypeVariant
NewtypeInstance <- DatatypeVariant
dv = () -> Maybe ()
forall a. a -> Maybe a
Just ()
      | Bool
otherwise             = Maybe ()
forall a. Maybe a
Nothing

etaReduce :: Int -> Type -> Maybe Type
etaReduce :: Int -> Type -> Maybe Type
etaReduce Int
num Type
ty =
  let (Type
tyHead, Cxt
tyArgs) = Type -> (Type, Cxt)
unapplyTy Type
ty
      (Cxt
tyArgsRemaining, Cxt
tyArgsDropped) = 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
num) Cxt
tyArgs
  in if Cxt -> Cxt -> Bool
canEtaReduce Cxt
tyArgsRemaining Cxt
tyArgsDropped
        then Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Type -> Cxt -> Type
applyTy Type
tyHead Cxt
tyArgsRemaining
        else Maybe Type
forall a. Maybe a
Nothing
#endif