{-# LANGUAGE CPP             #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns    #-}

{-# OPTIONS_HADDOCK not-home, prune #-}

-- | Description: TH utilities for generating effect constructors
module Polysemy.Internal.TH.Common
  ( ConLiftInfo (..)
  , getEffectMetadata
  , makeMemberConstraint
  , makeMemberConstraint'
  , makeSemType
  , makeInterpreterType
  , makeEffectType
  , makeUnambiguousSend
  , checkExtensions
  , foldArrowTs
  , splitArrowTs
  , pattern (:->)
  ) where

import           Control.Arrow ((>>>))
import           Control.Monad
import           Data.Bifunctor
import           Data.Char (toLower)
import           Data.Generics hiding (Fixity)
import           Data.List
import qualified Data.Map.Strict as M
import           Data.Tuple
import           Language.Haskell.TH
import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.PprLib
import           Polysemy.Internal (Sem, send)
import           Polysemy.Internal.Union (Member)

#if __GLASGOW_HASKELL__ >= 804
import           Prelude hiding ((<>))
#endif


------------------------------------------------------------------------------
-- Effects TH ----------------------------------------------------------------
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- | Info about constructor being lifted; use 'makeCLInfo' to create one.
data ConLiftInfo = CLInfo
  { -- | Name of effect's type constructor
    ConLiftInfo -> Name
cliEffName   :: Name
  , -- | Effect-specific type arguments
    ConLiftInfo -> [Type]
cliEffArgs   :: [Type]
  , -- | Result type specific to action
    ConLiftInfo -> Type
cliEffRes    :: Type
  , -- | Name of action constructor
    ConLiftInfo -> Name
cliConName   :: Name
  , -- | Name of final function
    ConLiftInfo -> Name
cliFunName   :: Name
  , -- | Fixity of function used as an operator
    ConLiftInfo -> Maybe Fixity
cliFunFixity :: Maybe Fixity
  , -- | Final function arguments
    ConLiftInfo -> [(Name, Type)]
cliFunArgs   :: [(Name, Type)]
  , -- | Constraints of final function
    ConLiftInfo -> [Type]
cliFunCxt    :: Cxt
  , -- | Name of type variable parameterizing 'Sem'
    ConLiftInfo -> Name
cliUnionName :: Name
  } deriving Int -> ConLiftInfo -> ShowS
[ConLiftInfo] -> ShowS
ConLiftInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConLiftInfo] -> ShowS
$cshowList :: [ConLiftInfo] -> ShowS
show :: ConLiftInfo -> String
$cshow :: ConLiftInfo -> String
showsPrec :: Int -> ConLiftInfo -> ShowS
$cshowsPrec :: Int -> ConLiftInfo -> ShowS
Show


------------------------------------------------------------------------------
-- | Given an name of datatype or some of it's constructors/fields, return
-- datatype's name together with info about it's constructors.
getEffectMetadata :: Name -> Q [ConLiftInfo]
getEffectMetadata :: Name -> Q [ConLiftInfo]
getEffectMetadata Name
type_name = do
  DatatypeInfo
dt_info  <- Name -> Q DatatypeInfo
reifyDatatype Name
type_name
  [ConLiftInfo]
cl_infos <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> Q ConLiftInfo
makeCLInfo forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
dt_info
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [ConLiftInfo]
cl_infos


------------------------------------------------------------------------------
-- | Creates name of lifting function from action name.
liftFunNameFromCon :: Name -> Name
liftFunNameFromCon :: Name -> Name
liftFunNameFromCon Name
n = String -> Name
mkName forall a b. (a -> b) -> a -> b
$
  case Name -> String
nameBase Name
n of
    Char
':' : String
cs -> String
cs
    Char
c   : String
cs -> Char -> Char
toLower Char
c forall a. a -> [a] -> [a]
: String
cs
    String
""       -> forall a. HasCallStack => String -> a
error String
"liftFunNameFromCon: empty constructor name"


------------------------------------------------------------------------------
-- | Creates info about smart constructor being created from name of the
-- original one.
makeCLInfo :: Name -> Q ConLiftInfo
makeCLInfo :: Name -> Q ConLiftInfo
makeCLInfo Name
cliConName = do
  (Type
con_type, Name
cliEffName) <- Name -> Q Info
reify Name
cliConName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    DataConI Name
_ Type
t Name
p -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
t, Name
p)
    Info
_              -> forall a. Name -> Q a
notDataCon Name
cliConName

  let ([Type]
con_args, [Type
con_return_type]) = forall a. Int -> [a] -> ([a], [a])
splitAtEnd Int
1
                                    forall a b. (a -> b) -> a -> b
$ Type -> [Type]
splitArrowTs Type
con_type

  ([Type]
ty_con_args, [Type
monad_arg, Type
res_arg]) <-
    case forall a. Int -> [a] -> ([a], [a])
splitAtEnd Int
2 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ Type -> [Type]
splitAppTs forall a b. (a -> b) -> a -> b
$ Type
con_return_type of
      r :: ([Type], [Type])
r@([Type]
_, [Type
_, Type
_]) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type], [Type])
r
      ([Type], [Type])
_             -> forall a. Name -> Q a
missingEffArgs Name
cliEffName

  Name
monad_name   <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Name -> Type -> Q a
argNotVar Name
cliEffName Type
monad_arg)
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        (Type -> Maybe Name
tVarName Type
monad_arg)

  Name
cliUnionName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"

  let normalize_types :: (TypeSubstitution t, Data t) => t -> t
      normalize_types :: forall t. (TypeSubstitution t, Data t) => t -> t
normalize_types = forall t. TypeSubstitution t => Name -> Name -> t -> t
replaceMArg Name
monad_name Name
cliUnionName
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Data t => t -> t
simplifyKinds

      cliEffArgs :: [Type]
cliEffArgs      = forall t. (TypeSubstitution t, Data t) => t -> t
normalize_types [Type]
ty_con_args
      cliEffRes :: Type
cliEffRes       = forall t. (TypeSubstitution t, Data t) => t -> t
normalize_types Type
res_arg
      cliFunName :: Name
cliFunName      = Name -> Name
liftFunNameFromCon Name
cliConName

  Maybe Fixity
cliFunFixity  <- Name -> Q (Maybe Fixity)
reifyFixity Name
cliConName

  [Name]
fun_arg_names <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
con_args) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"

  let cliFunArgs :: [(Name, Type)]
cliFunArgs    = forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fun_arg_names forall a b. (a -> b) -> a -> b
$ forall t. (TypeSubstitution t, Data t) => t -> t
normalize_types [Type]
con_args
      -- GADTs seem to forbid constraints further in signature, so top level
      -- ones should be fine.
      cliFunCxt :: [Type]
cliFunCxt     = Type -> [Type]
topLevelConstraints Type
con_type

  forall (f :: * -> *) a. Applicative f => a -> f a
pure CLInfo{[Type]
[(Name, Type)]
Maybe Fixity
Type
Name
cliFunCxt :: [Type]
cliFunArgs :: [(Name, Type)]
cliFunFixity :: Maybe Fixity
cliFunName :: Name
cliEffRes :: Type
cliEffArgs :: [Type]
cliUnionName :: Name
cliEffName :: Name
cliConName :: Name
cliUnionName :: Name
cliFunCxt :: [Type]
cliFunArgs :: [(Name, Type)]
cliFunFixity :: Maybe Fixity
cliFunName :: Name
cliConName :: Name
cliEffRes :: Type
cliEffArgs :: [Type]
cliEffName :: Name
..}


------------------------------------------------------------------------------
-- | Given a 'ConLiftInfo', get the corresponding effect type.
makeEffectType :: ConLiftInfo -> Type
makeEffectType :: ConLiftInfo -> Type
makeEffectType ConLiftInfo
cli = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Name
cliEffName ConLiftInfo
cli) forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [Type]
cliEffArgs ConLiftInfo
cli


------------------------------------------------------------------------------
-- | @'makeInterpreterType' con r a@ will produce a @'Polysemy.Sem' (Effect ':
-- r) a -> 'Polysemy.Sem' r a@ type, where @Effect@ is the effect
-- corresponding to the 'ConLiftInfo' for @con@.
makeInterpreterType :: ConLiftInfo -> Name -> Type -> Type
makeInterpreterType :: ConLiftInfo -> Name -> Type -> Type
makeInterpreterType ConLiftInfo
cli Name
r Type
result = Type
sem_with_eff Type -> Type -> Type
:-> Name -> Type -> Type
makeSemType Name
r Type
result where
  sem_with_eff :: Type
sem_with_eff = Name -> Type
ConT ''Sem Type -> Type -> Type
`AppT` Type
r_with_eff Type -> Type -> Type
`AppT` Type
result
  r_with_eff :: Type
r_with_eff   = Type
PromotedConsT Type -> Type -> Type
`AppT` ConLiftInfo -> Type
makeEffectType ConLiftInfo
cli Type -> Type -> Type
`AppT` Name -> Type
VarT Name
r


------------------------------------------------------------------------------
-- | Turn a 'ConLiftInfo' for @Foo@ into a @Member Foo r@ constraint.
makeMemberConstraint :: Name -> ConLiftInfo -> Pred
makeMemberConstraint :: Name -> ConLiftInfo -> Type
makeMemberConstraint Name
r ConLiftInfo
cli = Name -> Type -> Type
makeMemberConstraint' Name
r forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Type
makeEffectType ConLiftInfo
cli


------------------------------------------------------------------------------
-- | @'makeMemberConstraint'' r type@ will produce a @Member type r@
-- constraint.
makeMemberConstraint' :: Name -> Type -> Pred
makeMemberConstraint' :: Name -> Type -> Type
makeMemberConstraint' Name
r Type
eff = Name -> [Type] -> Type
classPred ''Member [Type
eff, Name -> Type
VarT Name
r]


------------------------------------------------------------------------------
-- | @'makeSemType' r a@ will produce a @'Polysemy.Sem' r a@ type.
makeSemType :: Name -> Type -> Type
makeSemType :: Name -> Type -> Type
makeSemType Name
r Type
result = Name -> Type
ConT ''Sem Type -> Type -> Type
`AppT` Name -> Type
VarT Name
r Type -> Type -> Type
`AppT` Type
result


------------------------------------------------------------------------------
-- | Given a 'ConLiftInfo', this will produce an action for it. It's arguments
-- will come from any variables in scope that correspond to the 'cliEffArgs'
-- of the 'ConLiftInfo'.
makeUnambiguousSend :: Bool -> ConLiftInfo -> Exp
makeUnambiguousSend :: Bool -> ConLiftInfo -> Exp
makeUnambiguousSend Bool
should_make_sigs ConLiftInfo
cli =
  let fun_args_names :: [Name]
fun_args_names = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
cli
      action :: Exp
action = forall a. (a -> a -> a) -> [a] -> a
foldl1' Exp -> Exp -> Exp
AppE
             forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE (ConLiftInfo -> Name
cliConName ConLiftInfo
cli) forall a. a -> [a] -> [a]
: (Name -> Exp
VarE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fun_args_names)
      eff :: Type
eff    = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Name
cliEffName ConLiftInfo
cli) forall a b. (a -> b) -> a -> b
$ [Type]
args
               -- see NOTE(makeSem_)
      args :: [Type]
args   = (if Bool
should_make_sigs then forall a. a -> a
id else forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
capturableTVars)
             forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [Type]
cliEffArgs ConLiftInfo
cli forall a. [a] -> [a] -> [a]
++ [Type
sem, ConLiftInfo -> Type
cliEffRes ConLiftInfo
cli]
      sem :: Type
sem    = Name -> Type
ConT ''Sem Type -> Type -> Type
`AppT` Name -> Type
VarT (ConLiftInfo -> Name
cliUnionName ConLiftInfo
cli)
   in Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'send) forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
SigE Exp
action Type
eff


-- Error messages and checks -------------------------------------------------

argNotVar :: Name -> Type -> Q a
argNotVar :: forall a. Name -> Type -> Q a
argNotVar Name
eff_name Type
arg = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show
  forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Argument ‘" Doc -> Doc -> Doc
<> forall a. Ppr a => a -> Doc
ppr Type
arg Doc -> Doc -> Doc
<> String -> Doc
text String
"’ in effect ‘" Doc -> Doc -> Doc
<> forall a. Ppr a => a -> Doc
ppr Name
eff_name
    Doc -> Doc -> Doc
<> String -> Doc
text String
"’ is not a type variable"

-- | Fail the 'Q' monad whenever the given 'Extension's aren't enabled in the
-- current module.
checkExtensions :: [Extension] -> Q ()
checkExtensions :: [Extension] -> Q ()
checkExtensions [Extension]
exts = do
  [(Extension, Bool)]
states <- forall a b. [a] -> [b] -> [(a, b)]
zip [Extension]
exts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Extension -> Q Bool
isExtEnabled [Extension]
exts
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        (\(Extension
ext, Bool
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show
          forall a b. (a -> b) -> a -> b
$ Char -> Doc
char Char
'‘' Doc -> Doc -> Doc
<> String -> Doc
text (forall a. Show a => a -> String
show Extension
ext) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'’'
            Doc -> Doc -> Doc
<+> String -> Doc
text String
"extension needs to be enabled for Polysemy's Template Haskell to work")
        (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Extension, Bool)]
states)

missingEffArgs :: Name -> Q a
missingEffArgs :: forall a. Name -> Q a
missingEffArgs Name
name = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show
  forall a b. (a -> b) -> a -> b
$   String -> Doc
text String
"Effect ‘" Doc -> Doc -> Doc
<> forall a. Ppr a => a -> Doc
ppr Name
name
      Doc -> Doc -> Doc
<> String -> Doc
text String
"’ has not enough type arguments"
  Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest Int
4
      (   String -> Doc
text String
"At least monad and result argument are required, e.g.:"
      Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest Int
4
          (   String -> Doc
text String
""
          Doc -> Doc -> Doc
$+$ forall a. Ppr a => a -> Doc
ppr ([Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
base [TyVarBndr ()]
args forall a. Maybe a
Nothing [] []) Doc -> Doc -> Doc
<+> String -> Doc
text String
"..."
          Doc -> Doc -> Doc
$+$ String -> Doc
text String
""
          )
      )
  where
    base :: Name
base = Name -> Name
capturableBase Name
name
#if MIN_VERSION_template_haskell(2,17,0)
    args :: [TyVarBndr ()]
args = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall flag. Name -> flag -> TyVarBndr flag
PlainTV () forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"m", String
"a"]
#else
    args = PlainTV . mkName <$> ["m", "a"]
#endif

notDataCon :: Name -> Q a
notDataCon :: forall a. Name -> Q a
notDataCon Name
name = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show
  forall a b. (a -> b) -> a -> b
$ Char -> Doc
char Char
'‘' Doc -> Doc -> Doc
<> forall a. Ppr a => a -> Doc
ppr Name
name Doc -> Doc -> Doc
<> String -> Doc
text String
"’ is not a data constructor"


------------------------------------------------------------------------------
-- TH utilities --------------------------------------------------------------
------------------------------------------------------------------------------

arrows :: Type -> Bool
arrows :: Type -> Bool
arrows = \case
  Type
ArrowT -> Bool
True
#if MIN_VERSION_template_haskell(2,17,0)
  AppT Type
MulArrowT Type
_ -> Bool
True
#endif
  Type
_ -> Bool
False

------------------------------------------------------------------------------
-- | Pattern constructing function type and matching on one that may contain
-- type annotations on arrow itself.
infixr 1 :->
pattern (:->) :: Type -> Type -> Type
pattern a $b:-> :: Type -> Type -> Type
$m:-> :: forall {r}. Type -> (Type -> Type -> r) -> ((# #) -> r) -> r
:-> b <- (arrows . removeTyAnns -> True) `AppT` a `AppT` b where
  Type
a :-> Type
b = Type
ArrowT Type -> Type -> Type
`AppT` Type
a Type -> Type -> Type
`AppT` Type
b


------------------------------------------------------------------------------
-- | Constructs capturable name from base of input name.
capturableBase :: Name -> Name
capturableBase :: Name -> Name
capturableBase = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase


------------------------------------------------------------------------------
-- | Converts names of all type variables in type to capturable ones based on
-- original name base. Use with caution, may create name conflicts!
capturableTVars :: Type -> Type
capturableTVars :: Type -> Type
capturableTVars = (forall t. Data t => t -> t) -> forall t. Data t => t -> t
everywhere forall a b. (a -> b) -> a -> b
$ forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT forall a b. (a -> b) -> a -> b
$ \case
  VarT Name
n          -> Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ Name -> Name
capturableBase Name
n
  ForallT [TyVarBndr Specificity]
bs [Type]
cs Type
t -> [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT (forall {flag}. TyVarBndr flag -> TyVarBndr flag
goBndr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
bs) (Type -> Type
capturableTVars forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
cs) Type
t
    where
#if MIN_VERSION_template_haskell(2,17,0)
      goBndr :: TyVarBndr flag -> TyVarBndr flag
goBndr (PlainTV Name
n flag
flag) = forall flag. Name -> flag -> TyVarBndr flag
PlainTV (Name -> Name
capturableBase Name
n) flag
flag
      goBndr (KindedTV Name
n flag
flag Type
k) = forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV (Name -> Name
capturableBase Name
n) flag
flag forall a b. (a -> b) -> a -> b
$ Type -> Type
capturableTVars Type
k
#else
      goBndr (PlainTV n   ) = PlainTV $ capturableBase n
      goBndr (KindedTV n k) = KindedTV (capturableBase n) $ capturableTVars k
#endif
  Type
t -> Type
t


------------------------------------------------------------------------------
-- | Folds a list of 'Type's into a right-associative arrow 'Type'.
foldArrowTs :: Type -> [Type] -> Type
foldArrowTs :: Type -> [Type] -> Type
foldArrowTs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(:->)


------------------------------------------------------------------------------
-- | Replaces use of @m@ in type with @Sem r@.
replaceMArg :: TypeSubstitution t => Name -> Name -> t -> t
replaceMArg :: forall t. TypeSubstitution t => Name -> Name -> t -> t
replaceMArg Name
m Name
r = forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
M.singleton Name
m forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Sem Type -> Type -> Type
`AppT` Name -> Type
VarT Name
r


------------------------------------------------------------------------------
-- Removes 'Type' and variable kind signatures from type.
simplifyKinds :: Data t => t -> t
simplifyKinds :: forall t. Data t => t -> t
simplifyKinds = (forall t. Data t => t -> t) -> forall t. Data t => t -> t
everywhere forall a b. (a -> b) -> a -> b
$ forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT forall a b. (a -> b) -> a -> b
$ \case
  SigT Type
t Type
StarT    -> Type
t
  SigT Type
t VarT{}   -> Type
t
  ForallT [TyVarBndr Specificity]
bs [Type]
cs Type
t -> [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT (forall {flag}. TyVarBndr flag -> TyVarBndr flag
goBndr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
bs) (forall t. Data t => t -> t
simplifyKinds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
cs) Type
t
    where
#if MIN_VERSION_template_haskell(2,17,0)
      goBndr :: TyVarBndr flag -> TyVarBndr flag
goBndr (KindedTV Name
n flag
flag Type
StarT) = forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n flag
flag
      goBndr (KindedTV Name
n flag
flag VarT{}) = forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n flag
flag
#else
      goBndr (KindedTV n StarT) = PlainTV n
      goBndr (KindedTV n VarT{}) = PlainTV n
#endif
      goBndr TyVarBndr flag
b = TyVarBndr flag
b
  Type
t -> Type
t


------------------------------------------------------------------------------
splitAppTs :: Type -> [Type]
splitAppTs :: Type -> [Type]
splitAppTs = Type -> Type
removeTyAnns forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
  Type
t `AppT` Type
arg -> Type -> [Type]
splitAppTs Type
t forall a. [a] -> [a] -> [a]
++ [Type
arg]
  Type
t            -> [Type
t]


------------------------------------------------------------------------------
splitArrowTs :: Type -> [Type]
splitArrowTs :: Type -> [Type]
splitArrowTs = Type -> Type
removeTyAnns forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
  Type
t :-> Type
ts -> Type
t forall a. a -> [a] -> [a]
: Type -> [Type]
splitArrowTs Type
ts
  Type
t        -> [Type
t]


------------------------------------------------------------------------------
-- | Extracts name from type variable (possibly nested in signature and/or
-- some context), returns 'Nothing' otherwise.
tVarName :: Type -> Maybe Name
tVarName :: Type -> Maybe Name
tVarName = Type -> Type
removeTyAnns forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
  VarT Name
n -> forall a. a -> Maybe a
Just Name
n
  Type
_      -> forall a. Maybe a
Nothing


------------------------------------------------------------------------------
topLevelConstraints :: Type -> Cxt
topLevelConstraints :: Type -> [Type]
topLevelConstraints = \case
  ForallT [TyVarBndr Specificity]
_ [Type]
cs Type
_ -> [Type]
cs
  Type
_              -> []


------------------------------------------------------------------------------
removeTyAnns :: Type -> Type
removeTyAnns :: Type -> Type
removeTyAnns = \case
  ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t -> Type -> Type
removeTyAnns Type
t
  SigT Type
t Type
_      -> Type -> Type
removeTyAnns Type
t
  ParensT Type
t     -> Type -> Type
removeTyAnns Type
t
  Type
t -> Type
t


------------------------------------------------------------------------------
-- Miscellaneous -------------------------------------------------------------
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- | 'splitAt' counting from the end.
splitAtEnd :: Int -> [a] -> ([a], [a])
splitAtEnd :: forall a. Int -> [a] -> ([a], [a])
splitAtEnd Int
n = forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> ([a], [a])
splitAt Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse