{-# LANGUAGE CPP #-}

{-|
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.Map as M
import           Data.Map (Map)
import           Data.Maybe (catMaybes)

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

-------------------------------------------------------------------------------
-- 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 qty :: Q Type
qty = do
  Type
ty <- Q Type
qty
  let (instanceTvbs :: [TyVarBndr]
instanceTvbs, instanceCxt :: Cxt
instanceCxt, instanceTy :: Type
instanceTy) = Type -> ([TyVarBndr], 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
  let instanceHeader :: Type
instanceHeader = [TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
instanceTvbs Cxt
instanceCxt Type
instanceTy
  (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 [])
                         (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceHeader)
                         ((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 qty :: Q Type
qty = do
  Type
ty <- Q Type
qty
  let (instanceTvbs :: [TyVarBndr]
instanceTvbs, instanceCxt :: Cxt
instanceCxt, viaApp :: Type
viaApp) = Type -> ([TyVarBndr], 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
  (instanceTy :: Type
instanceTy, viaTy :: Type
viaTy)
    <- case Type -> Cxt
unapplyTy Type
viaApp' of
         [via :: Type
via,instanceTy :: Type
instanceTy,viaTy :: 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)
         _ -> 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
                [ "Failure to meet ‘deriveVia‘ specification"
                , "\tThe ‘Via‘ type must be used, e.g."
                , "\t[t| forall a. C (T a) `Via` V a |]"
                ]
  [Dec]
decs <- Type -> Maybe Type -> Q [Dec]
deriveViaDecs Type
instanceTy (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
viaTy)
  let instanceHeader :: Type
instanceHeader = [TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
instanceTvbs Cxt
instanceCxt Type
instanceTy
  (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 [])
                         (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceHeader)
                         ((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 instanceTy :: Type
instanceTy mbViaTy :: Maybe Type
mbViaTy = do
  let (clsTy :: Type
clsTy:clsArgs :: Cxt
clsArgs) = Type -> Cxt
unapplyTy Type
instanceTy
  case Type
clsTy of
    ConT clsName :: Name
clsName -> do
      Info
clsInfo <- Name -> Q Info
reify Name
clsName
      case Info
clsInfo of
        ClassI (ClassD _ _ clsTvbs :: [TyVarBndr]
clsTvbs _ clsDecs :: [Dec]
clsDecs) _ ->
          case (Cxt -> Maybe (Cxt, Type)
forall a. [a] -> Maybe ([a], a)
unsnoc Cxt
clsArgs, [TyVarBndr] -> Maybe ([TyVarBndr], TyVarBndr)
forall a. [a] -> Maybe ([a], a)
unsnoc [TyVarBndr]
clsTvbs) of
            (Just (_, dataApp :: Type
dataApp), Just (_, clsLastTvb :: TyVarBndr
clsLastTvb)) -> do
              let (dataTy :: Type
dataTy:dataArgs :: Cxt
dataArgs)  = Type -> Cxt
unapplyTy Type
dataApp
                  clsLastTvbKind :: Type
clsLastTvbKind     = TyVarBndr -> Type
tvbKind TyVarBndr
clsLastTvb
                  (_, kindList :: 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
- 1
              Type
repTy <-
                case Maybe Type
mbViaTy of
                  Just viaTy :: Type
viaTy -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
viaTy
                  Nothing ->
                    case Type
dataTy of
                      ConT dataName :: 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 newtypeRepTy :: Type
newtypeRepTy ->
                            case Int -> Type -> Maybe Type
etaReduce Int
numArgsToEtaReduce Type
newtypeRepTy of
                              Just etaRepTy :: 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 (\var :: Type
var arg :: 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
                              Nothing -> Type -> Q Type
forall a. Type -> Q a
etaReductionError Type
instanceTy
                          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
$ "Not a newtype: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
dataName
                      _ -> 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
$ "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 -> [TyVarBndr] -> Cxt -> Type -> Dec -> Q (Maybe [Dec])
deriveViaDecs' Name
clsName [TyVarBndr]
clsTvbs Cxt
clsArgs Type
repTy) [Dec]
clsDecs
            (_, _) -> 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
$ "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
        _ -> 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
$ "Not a type class: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
clsTy
    _ -> 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
$ "Malformed instance: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceTy

deriveViaDecs' :: Name -> [TyVarBndr] -> [Type] -> Type -> Dec -> Q (Maybe [Dec])
deriveViaDecs' :: Name -> [TyVarBndr] -> Cxt -> Type -> Dec -> Q (Maybe [Dec])
deriveViaDecs' clsName :: Name
clsName clsTvbs :: [TyVarBndr]
clsTvbs clsArgs :: Cxt
clsArgs repTy :: Type
repTy dec :: Dec
dec = do
    let numExpectedArgs :: Int
numExpectedArgs = [TyVarBndr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr]
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
$ "Mismatched number of class arguments"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\tThe class " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
clsName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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]
++ " argument(s),"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\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]
++ " argument(s)."
    Dec -> Q (Maybe [Dec])
go Dec
dec
  where
    go :: Dec -> Q (Maybe [Dec])

    go :: Dec -> Q (Maybe [Dec])
go (OpenTypeFamilyD (TypeFamilyHead tfName :: Name
tfName tfTvbs :: [TyVarBndr]
tfTvbs _ _)) = do
      let lhsSubst :: Map Name Type
lhsSubst = [TyVarBndr] -> Cxt -> Map Name Type
zipTvbSubst [TyVarBndr]
clsTvbs Cxt
clsArgs
          rhsSubst :: Map Name Type
rhsSubst = [TyVarBndr] -> Cxt -> Map Name Type
zipTvbSubst [TyVarBndr]
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 = (TyVarBndr -> Type) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
tvbToType [TyVarBndr]
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 TyVarBndr] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat Name
tfName Maybe [Q TyVarBndr]
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 methName :: Name
methName methTy :: Type
methTy) =
      let (fromTy :: Type
fromTy, toTy :: Type
toTy) = [TyVarBndr] -> Cxt -> Type -> Type -> (Type, Type)
mkCoerceClassMethEqn [TyVarBndr]
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 _ = Maybe [Dec] -> Q (Maybe [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Dec]
forall a. Maybe a
Nothing

mkCoerceClassMethEqn :: [TyVarBndr] -> [Type] -> Type -> Type -> (Type, Type)
mkCoerceClassMethEqn :: [TyVarBndr] -> Cxt -> Type -> Type -> (Type, Type)
mkCoerceClassMethEqn clsTvbs :: [TyVarBndr]
clsTvbs clsArgs :: Cxt
clsArgs repTy :: Type
repTy methTy :: 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 = [TyVarBndr] -> Cxt -> Map Name Type
zipTvbSubst [TyVarBndr]
clsTvbs Cxt
clsArgs
    rhsSubst :: Map Name Type
rhsSubst = [TyVarBndr] -> Cxt -> Map Name Type
zipTvbSubst [TyVarBndr]
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] -> [Type] -> Map Name Type
zipTvbSubst :: [TyVarBndr] -> Cxt -> Map Name Type
zipTvbSubst tvbs :: [TyVarBndr]
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
. (TyVarBndr -> Type -> (Name, Type))
-> [TyVarBndr] -> Cxt -> [(Name, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\tvb :: TyVarBndr
tvb ty :: Type
ty -> (TyVarBndr -> Name
tvName TyVarBndr
tvb, Type
ty)) [TyVarBndr]
tvbs

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

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

newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type
newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type
newtypeRepType dv :: DatatypeVariant
dv cons :: [ConstructorInfo]
cons = do
    Maybe ()
checkIfNewtype
    case [ConstructorInfo]
cons of
      [ConstructorInfo { constructorVars :: ConstructorInfo -> [TyVarBndr]
constructorVars    = []
                       , constructorContext :: ConstructorInfo -> Cxt
constructorContext = []
                       , constructorFields :: ConstructorInfo -> Cxt
constructorFields  = [repTy :: Type
repTy]
                       }] -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
repTy
      _ -> 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 num :: Int
num ty :: Type
ty =
  let (tyHead :: Type
tyHead:tyArgs :: Cxt
tyArgs) = Type -> Cxt
unapplyTy Type
ty
      (tyArgsRemaining :: Cxt
tyArgsRemaining, tyArgsDropped :: 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