{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Unused LANGUAGE pragma" #-}

-- |
-- Module      :   Grisette.Internal.TH.Util
-- Copyright   :   (c) Sirui Lu 2024
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
module Grisette.Internal.TH.Util
  ( constructorInfoToType,
    tvIsMode,
    tvIsNat,
    tvIsStar,
    tvIsStarToStar,
    substDataType,
    reifyDatatypeWithFreshNames,
    singleParamClassParamKind,
    binaryClassParamKind,
    getTypeWithMaybeSubst,
    dropLastTypeParam,
    dropNTypeParam,
    classParamKinds,
    allSameKind,
    classNumParam,
    kindNumParam,
    concatPreds,
    putHaddock,
    allUsedNamesMaybe,
    allUsedNames,
    isNonUnitTupleString,
    isNonUnitTuple,
    integerE,
    mangleName,
    dataTypeHasExistential,
  )
where

#if MIN_VERSION_template_haskell(2,18,0)
import Language.Haskell.TH.Syntax
  ( DocLoc (DeclDoc),
    ModName (ModName),
    Name (Name),
    NameFlavour (NameG, NameQ, NameS),
    addModFinalizer,
    putDoc,
  )
#else
import Language.Haskell.TH.Syntax
  ( ModName (ModName),
    Name (Name),
    NameFlavour (NameG, NameQ, NameS),
  )
#endif

import Control.Monad (when)
import Data.Char (isAlphaNum, ord)
import qualified Data.Map as M
import qualified Data.Set as S
import GHC.TypeNats (Nat)
import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)
import Language.Haskell.TH
  ( Dec (ClassD),
    Exp
      ( AppE,
        AppTypeE,
        ConE,
        CondE,
        InfixE,
        LamE,
        ListE,
        LitE,
        ParensE,
        SigE,
        TupE,
        UInfixE,
        VarE
      ),
    Info (ClassI),
    Kind,
    Pred,
    Q,
    Type (AppT, ArrowT, ConT, ForallT, StarT, VarT),
    integerL,
    litE,
    nameBase,
    newName,
    pprint,
    reify,
    varT,
  )
import Language.Haskell.TH.Datatype
  ( ConstructorInfo (constructorContext, constructorFields, constructorVars),
    DatatypeInfo (datatypeCons, datatypeInstTypes, datatypeVars),
    TypeSubstitution (applySubstitution),
    datatypeType,
    reifyDatatype,
    tvName,
  )
import Language.Haskell.TH.Datatype.TyVarBndr
  ( Specificity (SpecifiedSpec),
    TyVarBndrUnit,
    TyVarBndr_,
    mapTVFlag,
    mapTVName,
    tvKind,
  )

-- | Convert a 'ConstructorInfo' to a 'Type' of the constructor.
constructorInfoToType :: DatatypeInfo -> ConstructorInfo -> Q Type
constructorInfoToType :: DatatypeInfo -> ConstructorInfo -> Q Type
constructorInfoToType DatatypeInfo
dataType ConstructorInfo
info = do
  let binders :: [TyVarBndr_ Specificity]
binders =
        (() -> Specificity) -> TyVarBndr_ () -> TyVarBndr_ Specificity
forall flag flag'.
(flag -> flag') -> TyVarBndr_ flag -> TyVarBndr_ flag'
mapTVFlag (Specificity -> () -> Specificity
forall a b. a -> b -> a
const Specificity
SpecifiedSpec)
          (TyVarBndr_ () -> TyVarBndr_ Specificity)
-> [TyVarBndr_ ()] -> [TyVarBndr_ Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [TyVarBndr_ ()]
datatypeVars DatatypeInfo
dataType [TyVarBndr_ ()] -> [TyVarBndr_ ()] -> [TyVarBndr_ ()]
forall a. [a] -> [a] -> [a]
++ ConstructorInfo -> [TyVarBndr_ ()]
constructorVars ConstructorInfo
info
  let ctx :: Cxt
ctx = ConstructorInfo -> Cxt
constructorContext ConstructorInfo
info
  let fields :: Cxt
fields = ConstructorInfo -> Cxt
constructorFields ConstructorInfo
info
  let tyBody :: Type
tyBody =
        (Type -> Type -> Type) -> Type -> Cxt -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT) (DatatypeInfo -> Type
datatypeType DatatypeInfo
dataType) Cxt
fields
  if [TyVarBndr_ Specificity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr_ Specificity]
binders then Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
tyBody else Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ [TyVarBndr_ Specificity] -> Cxt -> Type -> Type
ForallT [TyVarBndr_ Specificity]
binders Cxt
ctx Type
tyBody

-- | Check if a type variable is of kind 'EvalModeTag'.
tvIsMode :: TyVarBndr_ flag -> Bool
tvIsMode :: forall flag. TyVarBndr_ flag -> Bool
tvIsMode = (Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''EvalModeTag) (Type -> Bool)
-> (TyVarBndr_ flag -> Type) -> TyVarBndr_ flag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind

-- | Check if a type variable is of kind 'Nat'.
tvIsNat :: TyVarBndr_ flag -> Bool
tvIsNat :: forall flag. TyVarBndr_ flag -> Bool
tvIsNat = (Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Nat) (Type -> Bool)
-> (TyVarBndr_ flag -> Type) -> TyVarBndr_ flag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind

-- | Check if a type variable is of kind 'Data.Kind.Type'.
tvIsStar :: TyVarBndr_ flag -> Bool
tvIsStar :: forall flag. TyVarBndr_ flag -> Bool
tvIsStar = (Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
StarT) (Type -> Bool)
-> (TyVarBndr_ flag -> Type) -> TyVarBndr_ flag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind

-- | Check if a type variable is of kind 'Data.Kind.Type -> Data.Kind.Type'.
tvIsStarToStar :: TyVarBndr_ flag -> Bool
tvIsStarToStar :: forall flag. TyVarBndr_ flag -> Bool
tvIsStarToStar = (Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
StarT) Type
StarT)) (Type -> Bool)
-> (TyVarBndr_ flag -> Type) -> TyVarBndr_ flag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind

-- | Substitute the type variables in a 'DatatypeInfo' with the given
-- substitution map.
substDataType :: DatatypeInfo -> M.Map Name Type -> DatatypeInfo
substDataType :: DatatypeInfo -> Map Name Type -> DatatypeInfo
substDataType DatatypeInfo
d Map Name Type
substMap =
  DatatypeInfo
d
    { datatypeInstTypes = applySubstitution substMap <$> datatypeInstTypes d,
      datatypeCons = applySubstitution substMap <$> datatypeCons d
    }

-- | Convert a 'DatatypeInfo' to a 'DatatypeInfo' with fresh type variable
-- names.
datatypeToFreshNames :: DatatypeInfo -> Q DatatypeInfo
datatypeToFreshNames :: DatatypeInfo -> Q DatatypeInfo
datatypeToFreshNames DatatypeInfo
d = do
  let vars :: [TyVarBndr_ ()]
vars = DatatypeInfo -> [TyVarBndr_ ()]
datatypeVars DatatypeInfo
d
  let names :: [Name]
names = TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (TyVarBndr_ () -> Name) -> [TyVarBndr_ ()] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr_ ()]
vars
  freshNames <- (Name -> Q Name) -> [Name] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show) [Name]
names
  let newDTVars = (TyVarBndr_ () -> Name -> TyVarBndr_ ())
-> [TyVarBndr_ ()] -> [Name] -> [TyVarBndr_ ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\TyVarBndr_ ()
v Name
n -> (Name -> Name) -> TyVarBndr_ () -> TyVarBndr_ ()
forall flag. (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
mapTVName (Name -> Name -> Name
forall a b. a -> b -> a
const Name
n) TyVarBndr_ ()
v) [TyVarBndr_ ()]
vars [Name]
freshNames
  let substMap = [(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] -> Cxt -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names (Name -> Type
VarT (Name -> Type) -> [Name] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
freshNames)
  return $ substDataType d {datatypeVars = newDTVars} substMap

-- | Reify a datatype with fresh type variable names.
reifyDatatypeWithFreshNames :: Name -> Q DatatypeInfo
reifyDatatypeWithFreshNames :: Name -> Q DatatypeInfo
reifyDatatypeWithFreshNames Name
name = do
  d <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  datatypeToFreshNames d

-- | Check if all type variables have the same kind.
allSameKind :: [TyVarBndrUnit] -> Bool
allSameKind :: [TyVarBndr_ ()] -> Bool
allSameKind [] = Bool
True
allSameKind (TyVarBndr_ ()
x : [TyVarBndr_ ()]
xs) = (TyVarBndr_ () -> Bool) -> [TyVarBndr_ ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== TyVarBndr_ () -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr_ ()
x) (Type -> Bool) -> (TyVarBndr_ () -> Type) -> TyVarBndr_ () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr_ () -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind) [TyVarBndr_ ()]
xs

-- | Get the kinds of the type parameters of a class.
classParamKinds :: Name -> Q [Kind]
classParamKinds :: Name -> Q Cxt
classParamKinds Name
className = do
  cls <- Name -> Q Info
reify Name
className
  case cls of
    ClassI (ClassD Cxt
_ Name
_ [TyVarBndr BndrVis]
bndrs [FunDep]
_ [Dec]
_) [Dec]
_ -> Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt -> Q Cxt) -> Cxt -> Q Cxt
forall a b. (a -> b) -> a -> b
$ TyVarBndr BndrVis -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind (TyVarBndr BndrVis -> Type) -> [TyVarBndr BndrVis] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr BndrVis]
bndrs
    Info
_ ->
      String -> Q Cxt
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Cxt) -> String -> Q Cxt
forall a b. (a -> b) -> a -> b
$
        String
"symmetricClassParamKind:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
className String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a class"

-- | Get the number of type parameters of a class.
classNumParam :: Name -> Q Int
classNumParam :: Name -> Q Int
classNumParam Name
className = do
  cls <- Name -> Q Info
reify Name
className
  case cls of
    ClassI (ClassD Cxt
_ Name
_ [TyVarBndr BndrVis]
bndrs [FunDep]
_ [Dec]
_) [Dec]
_ -> Int -> Q Int
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Q Int) -> Int -> Q Int
forall a b. (a -> b) -> a -> b
$ [TyVarBndr BndrVis] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr BndrVis]
bndrs
    Info
_ ->
      String -> Q Int
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Int) -> String -> Q Int
forall a b. (a -> b) -> a -> b
$
        String
"classNumParam:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
className String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a class"

-- | Get the kind of the single type parameter of a class.
singleParamClassParamKind :: Name -> Q Kind
singleParamClassParamKind :: Name -> Q Type
singleParamClassParamKind Name
className = do
  cls <- Name -> Q Info
reify Name
className
  case cls of
    ClassI (ClassD Cxt
_ Name
_ [TyVarBndr BndrVis]
bndrs [FunDep]
_ [Dec]
_) [Dec]
_ ->
      case [TyVarBndr BndrVis]
bndrs of
        [TyVarBndr BndrVis
x] -> Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr BndrVis -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr BndrVis
x
        [TyVarBndr BndrVis]
_ ->
          String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$
            String
"singleParamClassParamKind: only support classes with one type "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"parameter, but "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
className
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" has "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([TyVarBndr BndrVis] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr BndrVis]
bndrs)
    Info
_ ->
      String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$
        String
"singleParamClassParamKind:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
className String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a class"

-- | Get the kind of the binary type parameter of a class.
binaryClassParamKind :: Name -> Q Kind
binaryClassParamKind :: Name -> Q Type
binaryClassParamKind Name
className = do
  cls <- Name -> Q Info
reify Name
className
  case cls of
    ClassI (ClassD Cxt
_ Name
_ [TyVarBndr BndrVis]
bndrs [FunDep]
_ [Dec]
_) [Dec]
_ ->
      case [TyVarBndr BndrVis]
bndrs of
        [TyVarBndr BndrVis
x, TyVarBndr BndrVis
y] -> do
          Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyVarBndr BndrVis -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr BndrVis
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= TyVarBndr BndrVis -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr BndrVis
y) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
            String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"binaryClassParamKind: type parameters have different kinds"
          Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr BndrVis -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr BndrVis
x
        [TyVarBndr BndrVis]
_ ->
          String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$
            String
"binaryClassParamKind: only support classes with two type "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"parameters, but "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
className
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" has "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([TyVarBndr BndrVis] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr BndrVis]
bndrs)
    Info
_ ->
      String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$
        String
"binaryClassParamKind:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
className String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a class"

-- | Get a type with a possible substitution.
getTypeWithMaybeSubst :: TyVarBndrUnit -> Maybe Type -> Q Type
getTypeWithMaybeSubst :: TyVarBndr_ () -> Maybe Type -> Q Type
getTypeWithMaybeSubst TyVarBndr_ ()
tv Maybe Type
Nothing = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ ()
tv
getTypeWithMaybeSubst TyVarBndr_ ()
_ (Just Type
t) = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t

-- | Drop the last instantiated type parameter of a type.
dropLastTypeParam :: Type -> Q Type
dropLastTypeParam :: Type -> Q Type
dropLastTypeParam (AppT Type
c Type
_) = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
c
dropLastTypeParam Type
v =
  String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$
    String
"dropLastTypeParam: have no type parameters: "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Ppr a => a -> String
pprint Type
v
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" / "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
v

-- | Drop the last N instantiated type parameters of a type.
dropNTypeParam :: Int -> Type -> Q Type
dropNTypeParam :: Int -> Type -> Q Type
dropNTypeParam Int
0 Type
t = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
dropNTypeParam Int
n Type
t = Type -> Q Type
dropLastTypeParam Type
t Q Type -> (Type -> Q Type) -> Q Type
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Type -> Q Type
dropNTypeParam (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- | Get the number of type parameters of a kind.
kindNumParam :: Kind -> Q Int
kindNumParam :: Type -> Q Int
kindNumParam (AppT (AppT Type
ArrowT Type
_) Type
k) = (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Q Int -> Q Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Int
kindNumParam Type
k
kindNumParam Type
_ = Int -> Q Int
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

-- | Concatenate two 'Maybe [Pred]'.
concatPreds :: Maybe [Pred] -> Maybe [Pred] -> Maybe [Pred]
concatPreds :: Maybe Cxt -> Maybe Cxt -> Maybe Cxt
concatPreds Maybe Cxt
Nothing Maybe Cxt
Nothing = Maybe Cxt
forall a. Maybe a
Nothing
concatPreds (Just Cxt
ps) Maybe Cxt
Nothing = Cxt -> Maybe Cxt
forall a. a -> Maybe a
Just Cxt
ps
concatPreds Maybe Cxt
Nothing (Just Cxt
ps) = Cxt -> Maybe Cxt
forall a. a -> Maybe a
Just Cxt
ps
concatPreds (Just Cxt
ps1) (Just Cxt
ps2) = Cxt -> Maybe Cxt
forall a. a -> Maybe a
Just (Cxt -> Maybe Cxt) -> Cxt -> Maybe Cxt
forall a b. (a -> b) -> a -> b
$ Cxt
ps1 Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
ps2

#if MIN_VERSION_template_haskell(2,18,0)
-- | Put a haddock comment on a declaration.
putHaddock :: Name -> String -> Q ()
putHaddock :: Name -> String -> Q ()
putHaddock Name
name = Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> (String -> Q ()) -> String -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc Name
name) 
#else
-- | Put a haddock comment on a declaration.
-- (No-op because compiling with GHC < 9.2)
putHaddock :: Name -> String -> Q ()
putHaddock _ _ = return ()
#endif

-- | Get the names used in an expression.
allUsedNamesMaybe :: Maybe Exp -> S.Set Name
allUsedNamesMaybe :: Maybe Exp -> Set Name
allUsedNamesMaybe Maybe Exp
Nothing = Set Name
forall a. Set a
S.empty
allUsedNamesMaybe (Just Exp
exp) = Exp -> Set Name
allUsedNames Exp
exp

-- | Get the names used in an expression.
allUsedNames :: Exp -> S.Set Name
allUsedNames :: Exp -> Set Name
allUsedNames (VarE Name
nm) = Name -> Set Name
forall a. a -> Set a
S.singleton Name
nm
allUsedNames (ConE Name
n) = Name -> Set Name
forall a. a -> Set a
S.singleton Name
n
allUsedNames (LitE Lit
_) = Set Name
forall a. Set a
S.empty
allUsedNames (AppE Exp
e1 Exp
e2) = Exp -> Set Name
allUsedNames Exp
e1 Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Exp -> Set Name
allUsedNames Exp
e2
allUsedNames (AppTypeE Exp
e1 Type
_) = Exp -> Set Name
allUsedNames Exp
e1
allUsedNames (InfixE Maybe Exp
l Exp
e Maybe Exp
r) =
  Maybe Exp -> Set Name
allUsedNamesMaybe Maybe Exp
l Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Exp -> Set Name
allUsedNames Exp
e Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Maybe Exp -> Set Name
allUsedNamesMaybe Maybe Exp
r
allUsedNames (UInfixE Exp
l Exp
e Exp
r) =
  Exp -> Set Name
allUsedNames Exp
l Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Exp -> Set Name
allUsedNames Exp
e Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Exp -> Set Name
allUsedNames Exp
r
allUsedNames (ParensE Exp
e) = Exp -> Set Name
allUsedNames Exp
e
allUsedNames (LamE [Pat]
_ Exp
e) = Exp -> Set Name
allUsedNames Exp
e
allUsedNames (TupE [Maybe Exp]
es) = [Set Name] -> Set Name
forall a. Monoid a => [a] -> a
mconcat ([Set Name] -> Set Name) -> [Set Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ Maybe Exp -> Set Name
allUsedNamesMaybe (Maybe Exp -> Set Name) -> [Maybe Exp] -> [Set Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe Exp]
es
allUsedNames (CondE Exp
e1 Exp
e2 Exp
e3) =
  Exp -> Set Name
allUsedNames Exp
e1 Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Exp -> Set Name
allUsedNames Exp
e2 Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Exp -> Set Name
allUsedNames Exp
e3
allUsedNames (ListE [Exp]
es) = [Set Name] -> Set Name
forall a. Monoid a => [a] -> a
mconcat ([Set Name] -> Set Name) -> [Set Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ Exp -> Set Name
allUsedNames (Exp -> Set Name) -> [Exp] -> [Set Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp]
es
allUsedNames (SigE Exp
e Type
_) = Exp -> Set Name
allUsedNames Exp
e
allUsedNames Exp
exp = String -> Set Name
forall a. HasCallStack => String -> a
error (String -> Set Name) -> String -> Set Name
forall a b. (a -> b) -> a -> b
$ String
"allUsedNames: unsupported expression: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Exp -> String
forall a. Show a => a -> String
show Exp
exp

-- | Check if a string is the data constructor name of a non-unit tuple.
isNonUnitTupleString :: String -> Bool
isNonUnitTupleString :: String -> Bool
isNonUnitTupleString (Char
'(' : Char
',' : String
_) = Bool
True
isNonUnitTupleString String
_ = Bool
False

-- | Check if a name is the data constructor name of a non-unit tuple.
isNonUnitTuple :: Name -> Bool
isNonUnitTuple :: Name -> Bool
isNonUnitTuple Name
nm =
  String -> Bool
isNonUnitTupleString (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
nm

-- | Convert an integer to an 'Exp'.
integerE :: (Integral a) => a -> Q Exp
integerE :: forall a. Integral a => a -> Q Exp
integerE = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (a -> Lit) -> a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (a -> Integer) -> a -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Mangle a name string to contain only alphanumeric characters and
-- underscores.
mangleName :: Name -> String
mangleName :: Name -> String
mangleName nm :: Name
nm@(Name OccName
_ NameFlavour
flavor) =
  case NameFlavour
flavor of
    NameFlavour
NameS -> String -> String
mangleBaseName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
nm
    NameQ ModName
mod -> ModName -> String
mangleModName ModName
mod String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
mangleBaseName (Name -> String
nameBase Name
nm)
    NameG NameSpace
_ PkgName
_ ModName
mod -> ModName -> String
mangleModName ModName
mod String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
mangleBaseName (Name -> String
nameBase Name
nm)
    NameFlavour
_ -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"mangleName: unsupported name flavor: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NameFlavour -> String
forall a. Show a => a -> String
show NameFlavour
flavor
  where
    mangleModName :: ModName -> String
mangleModName (ModName String
m) = String -> String
mangleBaseName String
m
    mangleBaseName :: String -> String
mangleBaseName String
l = String
"Mangled" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
go String
l
    go :: String -> String
go [] = []
    go (Char
c : String
cs)
      | Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
cs
      | Bool
otherwise = String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Char -> Int
ord Char
c) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
go String
cs

-- | Check if a data type has existential variables in constructors.
dataTypeHasExistential :: Name -> Q Bool
dataTypeHasExistential :: Name -> Q Bool
dataTypeHasExistential Name
typName = do
  d <- Name -> Q DatatypeInfo
reifyDatatype Name
typName
  return $ not $ all (null . constructorVars) $ datatypeCons d