{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}

{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

-- | Names with statically known flavour
--
-- Intended for qualified import.
module Data.Record.Internal.TH.Name (
    -- * Names
    Name(..)
  , Flavour(..)
  , NameFlavour(..)
    -- * Simple functions
  , nameBase
  , mapNameBase
    -- * Working with qualified names
  , Qualifier(..)
  , qualify
  , unqualified
  , nameQualifier
    -- * Fresh names
  , newName
    -- * Conversion
  , fromTH
  , fromTH'
  , toTH
    -- * Resolution
  , LookupName(..)
  , reify
    -- * Construct TH
  , classD
  , conE
  , conT
  , newtypeD
  , patSynD
  , patSynSigD
  , pragCompleteD
  , recC
  , recordPatSyn
  , sigD
  , varBangType
  , varE
  , varLocalP
  , varGlobalP
  ) where

import Data.Kind
import Data.Maybe (fromMaybe)
import Language.Haskell.TH (Q)
import Language.Haskell.TH.Syntax (Quasi, runQ, NameSpace(..))

import qualified Language.Haskell.TH.Syntax as TH
import qualified Language.Haskell.TH.Lib    as TH

{-------------------------------------------------------------------------------
  Names
-------------------------------------------------------------------------------}

-- | Name flavours (used as a kind, not as a type)
--
-- Technically speaking there is one flavour missing: names that are locally
-- bound, but outside of the TH quote, something like
--
-- > foo x = [| .. x .. |]
--
-- However, we won't actually deal with such names.
data Flavour =
    -- | Dynamically bound
    --
    -- Dynamically bound names will be bound to a global name by @ghc@ after
    -- splicing the TH generated Haskelll code.
    --
    -- These are generated with 'mkName' (also used by @haskell-src-meta@).
    Dynamic

    -- | A new name
    --
    -- These are names either generated by 'newName' or are new names in a TH
    -- declaration quote @[d| ... |]@.
  | Unique

    -- | Reference to a specific name defined outside of the TH quote
  | Global

data NameFlavour :: Flavour -> Type where
  -- | Dynamically bound name, with an optional module prefix (@T.foo@)
  NameDynamic :: Maybe TH.ModName -> NameFlavour 'Dynamic

  -- | Unique local name
  NameUnique :: TH.Uniq -> NameFlavour 'Unique

  -- | Global name bound outside of the TH quot
  NameGlobal :: TH.NameSpace -> TH.PkgName -> TH.ModName -> NameFlavour 'Global

-- | Like TH's 'Name', but with statically known flavour.
data Name :: NameSpace -> Flavour -> Type where
  Name :: TH.OccName -> NameFlavour flavour -> Name ns flavour

deriving instance Show (NameFlavour flavour)
deriving instance Eq   (NameFlavour flavour)
deriving instance Ord  (NameFlavour flavour)

deriving instance Show (Name ns flavour)
deriving instance Eq   (Name ns flavour)
deriving instance Ord  (Name ns flavour)

{-------------------------------------------------------------------------------
  Simple functions
-------------------------------------------------------------------------------}

nameBase :: Name ns flavour -> String
nameBase :: Name ns flavour -> String
nameBase (Name (TH.OccName String
occ) NameFlavour flavour
_) = String
occ

-- | Modify the unqualified part of the name
--
-- Since we often to do this derive one kind of name from another, the
-- namespace of the result is not related to the namespace of the argument.
mapNameBase :: (String -> String) -> Name ns flavour -> Name ns' flavour
mapNameBase :: ShowS -> Name ns flavour -> Name ns' flavour
mapNameBase ShowS
f (Name (TH.OccName String
occ) NameFlavour flavour
flav) = OccName -> NameFlavour flavour -> Name ns' flavour
forall (flavour :: Flavour) (ns :: NameSpace).
OccName -> NameFlavour flavour -> Name ns flavour
Name (String -> OccName
TH.OccName (ShowS
f String
occ)) NameFlavour flavour
flav

{-------------------------------------------------------------------------------
  Working with qualified names
-------------------------------------------------------------------------------}

data Qualifier = Unqual | Qual TH.ModName

qualify :: Qualifier -> String -> Name ns 'Dynamic
qualify :: Qualifier -> String -> Name ns 'Dynamic
qualify Qualifier
Unqual   String
occ = OccName -> NameFlavour 'Dynamic -> Name ns 'Dynamic
forall (flavour :: Flavour) (ns :: NameSpace).
OccName -> NameFlavour flavour -> Name ns flavour
Name (String -> OccName
TH.OccName String
occ) (Maybe ModName -> NameFlavour 'Dynamic
NameDynamic Maybe ModName
forall a. Maybe a
Nothing)
qualify (Qual ModName
m) String
occ = OccName -> NameFlavour 'Dynamic -> Name ns 'Dynamic
forall (flavour :: Flavour) (ns :: NameSpace).
OccName -> NameFlavour flavour -> Name ns flavour
Name (String -> OccName
TH.OccName String
occ) (Maybe ModName -> NameFlavour 'Dynamic
NameDynamic (ModName -> Maybe ModName
forall a. a -> Maybe a
Just ModName
m))

unqualified :: String -> Name ns 'Dynamic
unqualified :: String -> Name ns 'Dynamic
unqualified = Qualifier -> String -> Name ns 'Dynamic
forall (ns :: NameSpace). Qualifier -> String -> Name ns 'Dynamic
qualify Qualifier
Unqual

nameQualifier :: Name ns 'Dynamic -> Qualifier
nameQualifier :: Name ns 'Dynamic -> Qualifier
nameQualifier (Name OccName
_ (NameDynamic (Just ModName
m))) = ModName -> Qualifier
Qual ModName
m
nameQualifier (Name OccName
_ (NameDynamic Maybe ModName
Nothing))  = Qualifier
Unqual

{-------------------------------------------------------------------------------
  Singleton
-------------------------------------------------------------------------------}

-- | Singleton type associated with 'Flavour'
data SFlavour :: Flavour -> Type where
  SDynamic :: SFlavour 'Dynamic
  SUnique  :: SFlavour 'Unique
  SGlobal  :: SFlavour 'Global

deriving instance Show (SFlavour flavour)

class IsFlavour flavour where
  isFlavour :: SFlavour flavour

instance IsFlavour 'Dynamic where isFlavour :: SFlavour 'Dynamic
isFlavour = SFlavour 'Dynamic
SDynamic
instance IsFlavour 'Unique  where isFlavour :: SFlavour 'Unique
isFlavour = SFlavour 'Unique
SUnique
instance IsFlavour 'Global  where isFlavour :: SFlavour 'Global
isFlavour = SFlavour 'Global
SGlobal

{-------------------------------------------------------------------------------
  Conversion
-------------------------------------------------------------------------------}

toFlavourF :: SFlavour flavour -> TH.NameFlavour -> Maybe (NameFlavour flavour)
toFlavourF :: SFlavour flavour -> NameFlavour -> Maybe (NameFlavour flavour)
toFlavourF SFlavour flavour
SDynamic (NameFlavour
TH.NameS)       = NameFlavour 'Dynamic -> Maybe (NameFlavour 'Dynamic)
forall a. a -> Maybe a
Just (NameFlavour 'Dynamic -> Maybe (NameFlavour 'Dynamic))
-> NameFlavour 'Dynamic -> Maybe (NameFlavour 'Dynamic)
forall a b. (a -> b) -> a -> b
$ Maybe ModName -> NameFlavour 'Dynamic
NameDynamic Maybe ModName
forall a. Maybe a
Nothing
toFlavourF SFlavour flavour
SDynamic (TH.NameQ ModName
m)     = NameFlavour 'Dynamic -> Maybe (NameFlavour 'Dynamic)
forall a. a -> Maybe a
Just (NameFlavour 'Dynamic -> Maybe (NameFlavour 'Dynamic))
-> NameFlavour 'Dynamic -> Maybe (NameFlavour 'Dynamic)
forall a b. (a -> b) -> a -> b
$ Maybe ModName -> NameFlavour 'Dynamic
NameDynamic (ModName -> Maybe ModName
forall a. a -> Maybe a
Just ModName
m)
toFlavourF SFlavour flavour
SUnique  (TH.NameU Uniq
u)     = NameFlavour 'Unique -> Maybe (NameFlavour 'Unique)
forall a. a -> Maybe a
Just (NameFlavour 'Unique -> Maybe (NameFlavour 'Unique))
-> NameFlavour 'Unique -> Maybe (NameFlavour 'Unique)
forall a b. (a -> b) -> a -> b
$ Uniq -> NameFlavour 'Unique
NameUnique Uniq
u
toFlavourF SFlavour flavour
SGlobal  (TH.NameG NameSpace
n PkgName
p ModName
m) = NameFlavour 'Global -> Maybe (NameFlavour 'Global)
forall a. a -> Maybe a
Just (NameFlavour 'Global -> Maybe (NameFlavour 'Global))
-> NameFlavour 'Global -> Maybe (NameFlavour 'Global)
forall a b. (a -> b) -> a -> b
$ NameSpace -> PkgName -> ModName -> NameFlavour 'Global
NameGlobal NameSpace
n PkgName
p ModName
m
toFlavourF SFlavour flavour
_        NameFlavour
_                = Maybe (NameFlavour flavour)
forall a. Maybe a
Nothing

fromFlavourF :: NameFlavour flavour -> TH.NameFlavour
fromFlavourF :: NameFlavour flavour -> NameFlavour
fromFlavourF (NameDynamic Maybe ModName
Nothing)  = NameFlavour
TH.NameS
fromFlavourF (NameDynamic (Just ModName
m)) = ModName -> NameFlavour
TH.NameQ ModName
m
fromFlavourF (NameUnique Uniq
u)         = Uniq -> NameFlavour
TH.NameU Uniq
u
fromFlavourF (NameGlobal NameSpace
n PkgName
p ModName
m)     = NameSpace -> PkgName -> ModName -> NameFlavour
TH.NameG NameSpace
n PkgName
p ModName
m

-- | Translate from a dynamically typed TH name
--
-- Returns 'Nothing' if the TH name does not have the specified flavour.
fromTH :: IsFlavour flavour => TH.Name -> Maybe (Name ns flavour)
fromTH :: Name -> Maybe (Name ns flavour)
fromTH (TH.Name OccName
occ NameFlavour
flavour') = OccName -> NameFlavour flavour -> Name ns flavour
forall (flavour :: Flavour) (ns :: NameSpace).
OccName -> NameFlavour flavour -> Name ns flavour
Name OccName
occ (NameFlavour flavour -> Name ns flavour)
-> Maybe (NameFlavour flavour) -> Maybe (Name ns flavour)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SFlavour flavour -> NameFlavour -> Maybe (NameFlavour flavour)
forall (flavour :: Flavour).
SFlavour flavour -> NameFlavour -> Maybe (NameFlavour flavour)
toFlavourF SFlavour flavour
forall (flavour :: Flavour). IsFlavour flavour => SFlavour flavour
isFlavour NameFlavour
flavour'

-- | Variation on 'fromTH' that throws an exception on a flavour mismatch
fromTH' :: forall ns flavour. IsFlavour flavour => TH.Name -> Name ns flavour
fromTH' :: Name -> Name ns flavour
fromTH' name :: Name
name@(TH.Name OccName
occ NameFlavour
flavour') =
    Name ns flavour -> Maybe (Name ns flavour) -> Name ns flavour
forall a. a -> Maybe a -> a
fromMaybe (String -> Name ns flavour
forall a. HasCallStack => String -> a
error String
err) (Maybe (Name ns flavour) -> Name ns flavour)
-> Maybe (Name ns flavour) -> Name ns flavour
forall a b. (a -> b) -> a -> b
$ Name -> Maybe (Name ns flavour)
forall (flavour :: Flavour) (ns :: NameSpace).
IsFlavour flavour =>
Name -> Maybe (Name ns flavour)
fromTH Name
name
  where
    err :: String
    err :: String
err = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [
          String
"fromTH': name "
        , OccName -> String
forall a. Show a => a -> String
show OccName
occ
        , String
" has the wrong flavour: "
        , SFlavour flavour -> String
forall a. Show a => a -> String
show (SFlavour flavour
forall (flavour :: Flavour). IsFlavour flavour => SFlavour flavour
isFlavour :: SFlavour flavour)
        , String
" /= "
        , NameFlavour -> String
forall a. Show a => a -> String
show NameFlavour
flavour'
        ]

-- | Forget type level information
toTH :: Name ns flavour -> TH.Name
toTH :: Name ns flavour -> Name
toTH (Name OccName
occ NameFlavour flavour
flavour) = OccName -> NameFlavour -> Name
TH.Name OccName
occ (NameFlavour flavour -> NameFlavour
forall (flavour :: Flavour). NameFlavour flavour -> NameFlavour
fromFlavourF NameFlavour flavour
flavour)

{-------------------------------------------------------------------------------
  Resolution
-------------------------------------------------------------------------------}

class LookupName ns where
  -- | Resolve existing name
  lookupName :: Quasi m => Name ns 'Dynamic -> m (Maybe (Name ns 'Global))

instance LookupName 'TcClsName where
  lookupName :: Name 'TcClsName 'Dynamic -> m (Maybe (Name 'TcClsName 'Global))
lookupName (Name OccName
occ (NameDynamic Maybe ModName
mMod)) =
      (Name -> Name 'TcClsName 'Global)
-> Maybe Name -> Maybe (Name 'TcClsName 'Global)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Name 'TcClsName 'Global
forall (ns :: NameSpace) (flavour :: Flavour).
IsFlavour flavour =>
Name -> Name ns flavour
fromTH' (Maybe Name -> Maybe (Name 'TcClsName 'Global))
-> m (Maybe Name) -> m (Maybe (Name 'TcClsName 'Global))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Q (Maybe Name) -> m (Maybe Name)
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (String -> Q (Maybe Name)
TH.lookupTypeName (String -> Q (Maybe Name)) -> String -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Maybe ModName -> OccName -> String
qualifyDotted Maybe ModName
mMod OccName
occ)

instance LookupName 'DataName where
  lookupName :: Name 'DataName 'Dynamic -> m (Maybe (Name 'DataName 'Global))
lookupName (Name OccName
occ (NameDynamic Maybe ModName
mMod)) =
      (Name -> Name 'DataName 'Global)
-> Maybe Name -> Maybe (Name 'DataName 'Global)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Name 'DataName 'Global
forall (ns :: NameSpace) (flavour :: Flavour).
IsFlavour flavour =>
Name -> Name ns flavour
fromTH' (Maybe Name -> Maybe (Name 'DataName 'Global))
-> m (Maybe Name) -> m (Maybe (Name 'DataName 'Global))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Q (Maybe Name) -> m (Maybe Name)
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (String -> Q (Maybe Name)
TH.lookupValueName (String -> Q (Maybe Name)) -> String -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Maybe ModName -> OccName -> String
qualifyDotted Maybe ModName
mMod OccName
occ)

instance LookupName 'VarName where
  lookupName :: Name 'VarName 'Dynamic -> m (Maybe (Name 'VarName 'Global))
lookupName (Name OccName
occ (NameDynamic Maybe ModName
mMod)) =
      (Name -> Name 'VarName 'Global)
-> Maybe Name -> Maybe (Name 'VarName 'Global)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Name 'VarName 'Global
forall (ns :: NameSpace) (flavour :: Flavour).
IsFlavour flavour =>
Name -> Name ns flavour
fromTH' (Maybe Name -> Maybe (Name 'VarName 'Global))
-> m (Maybe Name) -> m (Maybe (Name 'VarName 'Global))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Q (Maybe Name) -> m (Maybe Name)
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (String -> Q (Maybe Name)
TH.lookupValueName (String -> Q (Maybe Name)) -> String -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Maybe ModName -> OccName -> String
qualifyDotted Maybe ModName
mMod OccName
occ)

-- | Get info about the given name
--
-- Only global names can be reified. See 'lookupName'.
reify :: Quasi m => Name ns 'Global -> m TH.Info
reify :: Name ns 'Global -> m Info
reify = Q Info -> m Info
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (Q Info -> m Info)
-> (Name ns 'Global -> Q Info) -> Name ns 'Global -> m Info
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Info
TH.reify (Name -> Q Info)
-> (Name ns 'Global -> Name) -> Name ns 'Global -> Q Info
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name ns 'Global -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

{-------------------------------------------------------------------------------
  Fresh names
-------------------------------------------------------------------------------}

newName :: String -> Q (Name ns 'Unique)
newName :: String -> Q (Name ns 'Unique)
newName = (Name -> Name ns 'Unique) -> Q Name -> Q (Name ns 'Unique)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Name ns 'Unique
forall (ns :: NameSpace) (flavour :: Flavour).
IsFlavour flavour =>
Name -> Name ns flavour
fromTH' (Q Name -> Q (Name ns 'Unique))
-> (String -> Q Name) -> String -> Q (Name ns 'Unique)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Name
TH.newName

{-------------------------------------------------------------------------------
  /Defining/ global names

  Since these are all meant to define capturable names, these functions all take
  an 'Dynamic' name as argument.
-------------------------------------------------------------------------------}

-- | Define pattern synonym
patSynD :: Name 'DataName 'Dynamic -> _
patSynD :: Name 'DataName 'Dynamic
-> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
patSynD = Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
TH.patSynD (Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ)
-> (Name 'DataName 'Dynamic -> Name)
-> Name 'DataName 'Dynamic
-> PatSynArgsQ
-> PatSynDirQ
-> PatQ
-> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'DataName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Define pattern synonym signature
patSynSigD :: Name 'DataName 'Dynamic -> _
patSynSigD :: Name 'DataName 'Dynamic -> TypeQ -> DecQ
patSynSigD = Name -> TypeQ -> DecQ
TH.patSynSigD (Name -> TypeQ -> DecQ)
-> (Name 'DataName 'Dynamic -> Name)
-> Name 'DataName 'Dynamic
-> TypeQ
-> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'DataName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Define function signature
sigD :: Name 'VarName 'Dynamic -> _
sigD :: Name 'VarName 'Dynamic -> TypeQ -> DecQ
sigD = Name -> TypeQ -> DecQ
TH.sigD (Name -> TypeQ -> DecQ)
-> (Name 'VarName 'Dynamic -> Name)
-> Name 'VarName 'Dynamic
-> TypeQ
-> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'VarName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Define record field signature
varBangType :: Name 'VarName 'Dynamic -> _
varBangType :: Name 'VarName 'Dynamic -> BangTypeQ -> VarBangTypeQ
varBangType = Name -> BangTypeQ -> VarBangTypeQ
TH.varBangType (Name -> BangTypeQ -> VarBangTypeQ)
-> (Name 'VarName 'Dynamic -> Name)
-> Name 'VarName 'Dynamic
-> BangTypeQ
-> VarBangTypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'VarName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Define record constructor
recC :: Name 'DataName 'Dynamic -> _
recC :: Name 'DataName 'Dynamic -> [VarBangTypeQ] -> ConQ
recC = Name -> [VarBangTypeQ] -> ConQ
TH.recC (Name -> [VarBangTypeQ] -> ConQ)
-> (Name 'DataName 'Dynamic -> Name)
-> Name 'DataName 'Dynamic
-> [VarBangTypeQ]
-> ConQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'DataName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Define class
classD :: _ -> Name 'TcClsName 'Dynamic -> _
classD :: CxtQ
-> Name 'TcClsName 'Dynamic
-> [TyVarBndr]
-> [FunDep]
-> [DecQ]
-> DecQ
classD CxtQ
cxt = CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
TH.classD CxtQ
cxt (Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ)
-> (Name 'TcClsName 'Dynamic -> Name)
-> Name 'TcClsName 'Dynamic
-> [TyVarBndr]
-> [FunDep]
-> [DecQ]
-> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'TcClsName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Define newtype
newtypeD :: _ -> Name 'TcClsName 'Dynamic -> _
newtypeD :: CxtQ
-> Name 'TcClsName 'Dynamic
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> DecQ
newtypeD CxtQ
cxt = CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> DecQ
TH.newtypeD CxtQ
cxt (Name
 -> [TyVarBndr] -> Maybe Kind -> ConQ -> [DerivClauseQ] -> DecQ)
-> (Name 'TcClsName 'Dynamic -> Name)
-> Name 'TcClsName 'Dynamic
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'TcClsName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Define record pattern synonym
recordPatSyn :: [String] -> _
recordPatSyn :: [String] -> PatSynArgsQ
recordPatSyn = [Name] -> PatSynArgsQ
TH.recordPatSyn ([Name] -> PatSynArgsQ)
-> ([String] -> [Name]) -> [String] -> PatSynArgsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name Any 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH (Name Any 'Dynamic -> Name)
-> (String -> Name Any 'Dynamic) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name Any 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
unqualified)

-- | Define COMPLETE pragma
pragCompleteD :: [Name 'DataName 'Dynamic] -> Maybe (Name 'TcClsName 'Dynamic) -> _
pragCompleteD :: [Name 'DataName 'Dynamic]
-> Maybe (Name 'TcClsName 'Dynamic) -> DecQ
pragCompleteD [Name 'DataName 'Dynamic]
constrs Maybe (Name 'TcClsName 'Dynamic)
typ =
    [Name] -> Maybe Name -> DecQ
TH.pragCompleteD (Name 'DataName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH (Name 'DataName 'Dynamic -> Name)
-> [Name 'DataName 'Dynamic] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name 'DataName 'Dynamic]
constrs) (Name 'TcClsName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH (Name 'TcClsName 'Dynamic -> Name)
-> Maybe (Name 'TcClsName 'Dynamic) -> Maybe Name
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Name 'TcClsName 'Dynamic)
typ)

-- | Define pattern variable for use in a record pattern synonym
varGlobalP :: Name 'VarName 'Dynamic -> _
varGlobalP :: Name 'VarName 'Dynamic -> PatQ
varGlobalP = Name -> PatQ
TH.varP (Name -> PatQ)
-> (Name 'VarName 'Dynamic -> Name)
-> Name 'VarName 'Dynamic
-> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'VarName 'Dynamic -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Define pattern variable for use in a local pattern match
varLocalP :: Name 'VarName 'Unique -> _
varLocalP :: Name 'VarName 'Unique -> PatQ
varLocalP = Name -> PatQ
TH.varP (Name -> PatQ)
-> (Name 'VarName 'Unique -> Name) -> Name 'VarName 'Unique -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'VarName 'Unique -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

{-------------------------------------------------------------------------------
  Referencing existing names

  We can reference any flavour of name.
-------------------------------------------------------------------------------}

-- | Reference constructor
conE :: Name 'DataName flavour -> _
conE :: Name 'DataName flavour -> ExpQ
conE = Name -> ExpQ
TH.conE (Name -> ExpQ)
-> (Name 'DataName flavour -> Name)
-> Name 'DataName flavour
-> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'DataName flavour -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Reference type
conT :: Name 'TcClsName flavour -> _
conT :: Name 'TcClsName flavour -> TypeQ
conT = Name -> TypeQ
TH.conT (Name -> TypeQ)
-> (Name 'TcClsName flavour -> Name)
-> Name 'TcClsName flavour
-> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'TcClsName flavour -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

-- | Reference variable
varE :: Name 'VarName flavour -> _
varE :: Name 'VarName flavour -> ExpQ
varE = Name -> ExpQ
TH.varE (Name -> ExpQ)
-> (Name 'VarName flavour -> Name) -> Name 'VarName flavour -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name 'VarName flavour -> Name
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> Name
toTH

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

-- | Qualify a name (for use in 'lookupTypeName' and co)
qualifyDotted :: Maybe TH.ModName -> TH.OccName -> String
qualifyDotted :: Maybe ModName -> OccName -> String
qualifyDotted Maybe ModName
Nothing               (TH.OccName String
occ) = String
occ
qualifyDotted (Just (TH.ModName String
m)) (TH.OccName String
occ) = String
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
occ