{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples #-}

module Language.Haskell.TH.Syntax (
    Quote (..),
    Exp (..),
    Match (..),
    Clause (..),
    Q (..),
    Pat (..),
    Stmt (..),
    Con (..),
    Type (..),
    Dec (..),
    BangType,
    VarBangType,
    FieldExp,
    FieldPat,
    Name (..),
    FunDep (..),
    Pred,
    RuleBndr (..),
    TySynEqn (..),
    InjectivityAnn (..),
    Kind,
    Overlap (..),
    DerivClause (..),
    DerivStrategy (..),
    Code (..),
    ModName (..),
    addCorePlugin,
    addDependentFile,
    addForeignFile,
    addForeignFilePath,
    addForeignSource,
    addModFinalizer,
    addTempFile,
    addTopDecls,
    badIO,
    bindCode,
    bindCode_,
    cmpEq,
    compareBytes,
    counter,
    defaultFixity,
    eqBytes,
    extsEnabled,
    getDoc,
    getPackageRoot,
    getQ,
    get_cons_names,
    hoistCode,
    isExtEnabled,
    isInstance,
    joinCode,
    liftCode,
    location,
    lookupName,
    lookupTypeName,
    lookupValueName,
    manyName,
    maxPrecedence,
    memcmp,
    mkNameG,
    mkNameU,
    mkOccName,
    mkPkgName,
    mk_tup_name,
    mkName,
    mkNameG_v,
    mkNameG_d,
    mkNameG_tc,
    mkNameL,
    mkNameS,
    unTypeCode,
    mkModName,
    unsafeCodeCoerce,
    mkNameQ,
    mkNameG_fld,
    modString,
    nameBase,
    nameModule,
    namePackage,
    nameSpace,
    newDeclarationGroup,
    newNameIO,
    occString,
    oneName,
    pkgString,
    putDoc,
    putQ,
    recover,
    reify,
    reifyAnnotations,
    reifyConStrictness,
    reifyFixity,
    reifyInstances,
    reifyModule,
    reifyRoles,
    reifyType,
    report,
    reportError,
    reportWarning,
    runIO,
    sequenceQ,
    runQ,
    showName,
    showName',
    thenCmp,
    tupleDataName,
    tupleTypeName,
    unTypeQ,
    unboxedSumDataName,
    unboxedSumTypeName,
    unboxedTupleDataName,
    unboxedTupleTypeName,
    unsafeTExpCoerce,
    ForeignSrcLang (..),
    Extension (..),
    AnnLookup (..),
    AnnTarget (..),
    Arity,
    Bang (..),
    BndrVis (..),
    Body (..),
    Bytes (..),
    Callconv (..),
    CharPos,
    Cxt,
    DecidedStrictness (..),
    DocLoc (..),
    FamilyResultSig (..),
    Fixity (..),
    FixityDirection (..),
    Foreign (..),
    Guard (..),
    Info (..),
    Inline (..),
    InstanceDec,
    Lit (..),
    Loc (..),
    Module (..),
    ModuleInfo (..),
    NameFlavour (..),
    NameIs (..),
    NameSpace (..),
    NamespaceSpecifier (..),
    OccName (..),
    ParentName,
    PatSynArgs (..),
    PatSynDir (..),
    PatSynType,
    Phases (..),
    PkgName (..),
    Pragma (..),
    Quasi (..),
    Range (..),
    Role (..),
    RuleMatch (..),
    Safety (..),
    SourceStrictness (..),
    SourceUnpackedness (..),
    Specificity (..),
    Strict,
    StrictType,
    SumAlt,
    SumArity,
    TExp (..),
    TyLit (..),
    TyVarBndr (..),
    TypeFamilyHead (..),
    Uniq,
    Unlifted,
    VarStrictType,
    makeRelativeToProject,
    liftString,
    Lift (..),
    dataToCodeQ,
    dataToExpQ,
    dataToPatQ,
    dataToQa,
    falseName,
    justName,
    leftName,
    liftData,
    liftDataTyped,
    nonemptyName,
    nothingName,
    rightName,
    trueName,
    -- * Notes
    -- ** Unresolved Infix
    -- $infix
)
where

import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
import System.FilePath
import Data.Data hiding (Fixity(..))
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Lexeme ( startsVarSym, startsVarId )

-- This module completely re-exports 'GHC.Boot.TH.Syntax',
-- and exports additionally functions that depend on filepath.

-- |
addForeignFile :: ForeignSrcLang -> String -> Q ()
addForeignFile :: ForeignSrcLang -> String -> Q ()
addForeignFile = ForeignSrcLang -> String -> Q ()
addForeignSource
{-# DEPRECATED addForeignFile
               "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"
  #-} -- deprecated in 8.6

-- | The input is a filepath, which if relative is offset by the package root.
makeRelativeToProject :: FilePath -> Q FilePath
makeRelativeToProject :: String -> Q String
makeRelativeToProject String
fp | String -> Bool
isRelative String
fp = do
  root <- Q String
getPackageRoot
  return (root </> fp)
makeRelativeToProject String
fp = String -> Q String
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return String
fp

trueName, falseName :: Name
trueName :: Name
trueName  = 'True
falseName :: Name
falseName = 'False

nothingName, justName :: Name
nothingName :: Name
nothingName = 'Nothing
justName :: Name
justName    = 'Just

leftName, rightName :: Name
leftName :: Name
leftName  = 'Left
rightName :: Name
rightName = 'Right

nonemptyName :: Name
nonemptyName :: Name
nonemptyName = '(:|)

-----------------------------------------------------
--
--              Generic Lift implementations
--
-----------------------------------------------------

-- | 'dataToQa' is an internal utility function for constructing generic
-- conversion functions from types with 'Data' instances to various
-- quasi-quoting representations.  See the source of 'dataToExpQ' and
-- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@
-- and @appQ@ are overloadable to account for different syntax for
-- expressions and patterns; @antiQ@ allows you to override type-specific
-- cases, a common usage is just @const Nothing@, which results in
-- no overloading.
dataToQa  ::  forall m a k q. (Quote m, Data a)
          =>  (Name -> k)
          ->  (Lit -> m q)
          ->  (k -> [m q] -> m q)
          ->  (forall b . Data b => b -> Maybe (m q))
          ->  a
          ->  m q
dataToQa :: forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> k
mkCon Lit -> m q
mkLit k -> [m q] -> m q
appCon forall b. Data b => b -> Maybe (m q)
antiQ a
t =
    case a -> Maybe (m q)
forall b. Data b => b -> Maybe (m q)
antiQ a
t of
      Maybe (m q)
Nothing ->
          case Constr -> ConstrRep
constrRep Constr
constr of
            AlgConstr ConIndex
_ ->
                k -> [m q] -> m q
appCon (Name -> k
mkCon Name
funOrConName) [m q]
conArgs
              where
                funOrConName :: Name
                funOrConName :: Name
funOrConName =
                    case Constr -> String
showConstr Constr
constr of
                      String
"(:)"       -> OccName -> NameFlavour -> Name
Name (String -> OccName
mkOccName String
":")
                                          (NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
DataName
                                                (String -> PkgName
mkPkgName String
"ghc-internal")
                                                (String -> ModName
mkModName String
"GHC.Internal.Types"))
                      con :: String
con@String
"[]"    -> OccName -> NameFlavour -> Name
Name (String -> OccName
mkOccName String
con)
                                          (NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
DataName
                                                (String -> PkgName
mkPkgName String
"ghc-internal")
                                                (String -> ModName
mkModName String
"GHC.Internal.Types"))
                      con :: String
con@(Char
'(':String
_) -> OccName -> NameFlavour -> Name
Name (String -> OccName
mkOccName String
con)
                                          (NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
DataName
                                                (String -> PkgName
mkPkgName String
"ghc-internal")
                                                (String -> ModName
mkModName String
"GHC.Internal.Tuple"))

                      -- Tricky case: see Note [Data for non-algebraic types]
                      fun :: String
fun@(Char
x:String
_)   | Char -> Bool
startsVarSym Char
x Bool -> Bool -> Bool
|| Char -> Bool
startsVarId Char
x
                                  -> String -> String -> String -> Name
mkNameG_v String
tyconPkg String
tyconMod String
fun
                      String
con         -> String -> String -> String -> Name
mkNameG_d String
tyconPkg String
tyconMod String
con

                  where
                    tycon :: TyCon
                    tycon :: TyCon
tycon = (TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> (a -> TypeRep) -> a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf) a
t

                    tyconPkg, tyconMod :: String
                    tyconPkg :: String
tyconPkg = TyCon -> String
tyConPackage TyCon
tycon
                    tyconMod :: String
tyconMod = TyCon -> String
tyConModule  TyCon
tycon

                conArgs :: [m q]
                conArgs :: [m q]
conArgs = (forall d. Data d => d -> m q) -> a -> [m q]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ ((Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> d
-> m q
forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> k
mkCon Lit -> m q
mkLit k -> [m q] -> m q
appCon b -> Maybe (m q)
forall b. Data b => b -> Maybe (m q)
antiQ) a
t
            IntConstr Integer
n ->
                Lit -> m q
mkLit (Lit -> m q) -> Lit -> m q
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
n
            FloatConstr Rational
n ->
                Lit -> m q
mkLit (Lit -> m q) -> Lit -> m q
forall a b. (a -> b) -> a -> b
$ Rational -> Lit
RationalL Rational
n
            CharConstr Char
c ->
                Lit -> m q
mkLit (Lit -> m q) -> Lit -> m q
forall a b. (a -> b) -> a -> b
$ Char -> Lit
CharL Char
c
        where
          constr :: Constr
          constr :: Constr
constr = a -> Constr
forall a. Data a => a -> Constr
toConstr a
t

      Just m q
y -> m q
y


{- Note [Data for non-algebraic types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Class Data was originally intended for algebraic data types.  But
it is possible to use it for abstract types too.  For example, in
package `text` we find

  instance Data Text where
    ...
    toConstr _ = packConstr

  packConstr :: Constr
  packConstr = mkConstr textDataType "pack" [] Prefix

Here `packConstr` isn't a real data constructor, it's an ordinary
function.  Two complications

* In such a case, we must take care to build the Name using
  mkNameG_v (for values), not mkNameG_d (for data constructors).
  See #10796.

* The pseudo-constructor is named only by its string, here "pack".
  But 'dataToQa' needs the TyCon of its defining module, and has
  to assume it's defined in the same module as the TyCon itself.
  But nothing enforces that; #12596 shows what goes wrong if
  "pack" is defined in a different module than the data type "Text".
  -}

-- | A typed variant of 'dataToExpQ'.
dataToCodeQ :: (Quote m, Data a)
            => (forall b . Data b => b -> Maybe (Code m b))
            ->                       a ->        Code m a
dataToCodeQ :: forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (Code m b)) -> a -> Code m a
dataToCodeQ forall b. Data b => b -> Maybe (Code m b)
f = m Exp -> Code m a
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (m Exp -> Code m a) -> (a -> m Exp) -> a -> Code m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ ((Code m b -> m Exp) -> Maybe (Code m b) -> Maybe (m Exp)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Code m b -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode (Maybe (Code m b) -> Maybe (m Exp))
-> (b -> Maybe (Code m b)) -> b -> Maybe (m Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe (Code m b)
forall b. Data b => b -> Maybe (Code m b)
f)

-- | 'dataToExpQ' converts a value to a 'Exp' representation of the
-- same value, in the SYB style. It is generalized to take a function
-- override type-specific cases; see 'liftData' for a more commonly
-- used variant.
dataToExpQ  ::  (Quote m, Data a)
            =>  (forall b . Data b => b -> Maybe (m Exp))
            ->  a
            ->  m Exp
dataToExpQ :: forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ = (Name -> m Exp)
-> (Lit -> m Exp)
-> (m Exp -> [m Exp] -> m Exp)
-> (forall b. Data b => b -> Maybe (m Exp))
-> a
-> m Exp
forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> m Exp
forall {m :: * -> *}. Monad m => Name -> m Exp
varOrConE Lit -> m Exp
forall {m :: * -> *}. Monad m => Lit -> m Exp
litE ((m Exp -> m Exp -> m Exp) -> m Exp -> [m Exp] -> m Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Exp -> m Exp -> m Exp
forall {m :: * -> *}. Monad m => m Exp -> m Exp -> m Exp
appE)
    where
          -- Make sure that VarE is used if the Constr value relies on a
          -- function underneath the surface (instead of a constructor).
          -- See #10796.
          varOrConE :: Name -> m Exp
varOrConE Name
s =
            case Name -> Maybe NameSpace
nameSpace Name
s of
                 Just NameSpace
VarName      -> Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
s)
                 Just (FldName {}) -> Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
s)
                 Just NameSpace
DataName     -> Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
ConE Name
s)
                 Maybe NameSpace
_ -> String -> m Exp
forall a. HasCallStack => String -> a
error (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"Can't construct an expression from name "
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
showName Name
s
          appE :: m Exp -> m Exp -> m Exp
appE m Exp
x m Exp
y = do { a <- m Exp
x; b <- y; return (AppE a b)}
          litE :: Lit -> m Exp
litE Lit
c = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE Lit
c)

-- | A typed variant of 'liftData'.
liftDataTyped :: (Quote m, Data a) => a -> Code m a
liftDataTyped :: forall (m :: * -> *) a. (Quote m, Data a) => a -> Code m a
liftDataTyped = (forall b. Data b => b -> Maybe (Code m b)) -> a -> Code m a
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (Code m b)) -> a -> Code m a
dataToCodeQ (Maybe (Code m b) -> b -> Maybe (Code m b)
forall a b. a -> b -> a
const Maybe (Code m b)
forall a. Maybe a
Nothing)

-- | 'liftData' is a variant of 'lift' in the 'Lift' type class which
-- works for any type with a 'Data' instance.
liftData :: (Quote m, Data a) => a -> m Exp
liftData :: forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData = (forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ (Maybe (m Exp) -> b -> Maybe (m Exp)
forall a b. a -> b -> a
const Maybe (m Exp)
forall a. Maybe a
Nothing)

-- | 'dataToPatQ' converts a value to a 'Pat' representation of the same
-- value, in the SYB style. It takes a function to handle type-specific cases,
-- alternatively, pass @const Nothing@ to get default behavior.
dataToPatQ  ::  (Quote m, Data a)
            =>  (forall b . Data b => b -> Maybe (m Pat))
            ->  a
            ->  m Pat
dataToPatQ :: forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Pat)) -> a -> m Pat
dataToPatQ = (Name -> Name)
-> (Lit -> m Pat)
-> (Name -> [m Pat] -> m Pat)
-> (forall b. Data b => b -> Maybe (m Pat))
-> a
-> m Pat
forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> Name
forall a. a -> a
id Lit -> m Pat
forall {m :: * -> *}. Monad m => Lit -> m Pat
litP Name -> [m Pat] -> m Pat
forall {m :: * -> *}. Monad m => Name -> [m Pat] -> m Pat
conP
    where litP :: Lit -> m Pat
litP Lit
l = Pat -> m Pat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP Lit
l)
          conP :: Name -> [m Pat] -> m Pat
conP Name
n [m Pat]
ps =
            case Name -> Maybe NameSpace
nameSpace Name
n of
                Just NameSpace
DataName -> do
                    ps' <- [m Pat] -> m [Pat]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [m Pat]
ps
                    return (ConP n [] ps')
                Maybe NameSpace
_ -> String -> m Pat
forall a. HasCallStack => String -> a
error (String -> m Pat) -> String -> m Pat
forall a b. (a -> b) -> a -> b
$ String
"Can't construct a pattern from name "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
showName Name
n

{-
Note [Unresolved infix]
~~~~~~~~~~~~~~~~~~~~~~~
-}
{- $infix #infix#

When implementing antiquotation for quasiquoters, one often wants
to parse strings into expressions:

> parse :: String -> Maybe Exp

But how should we parse @a + b * c@? If we don't know the fixities of
@+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a
+ b) * c@.

In cases like this, use 'UInfixE', 'UInfixP', 'UInfixT', or 'PromotedUInfixT',
which stand for \"unresolved infix expression / pattern / type / promoted
constructor\", respectively. When the compiler is given a splice containing a
tree of @UInfixE@ applications such as

> UInfixE
>   (UInfixE e1 op1 e2)
>   op2
>   (UInfixE e3 op3 e4)

it will look up and the fixities of the relevant operators and
reassociate the tree as necessary.

  * trees will not be reassociated across 'ParensE', 'ParensP', or 'ParensT',
    which are of use for parsing expressions like

    > (a + b * c) + d * e

  * 'InfixE', 'InfixP', 'InfixT', and 'PromotedInfixT' expressions are never
    reassociated.

  * The 'UInfixE' constructor doesn't support sections. Sections
    such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer
    sections such as @(a + b * c -)@, use an 'InfixE' constructor for the
    outer-most section, and use 'UInfixE' constructors for all
    other operators:

    > InfixE
    >   Just (UInfixE ...a + b * c...)
    >   op
    >   Nothing

    Sections such as @(a + b +)@ and @((a + b) +)@ should be rendered
    into 'Exp's differently:

    > (+ a + b)   ---> InfixE Nothing + (Just $ UInfixE a + b)
    >                    -- will result in a fixity error if (+) is left-infix
    > (+ (a + b)) ---> InfixE Nothing + (Just $ ParensE $ UInfixE a + b)
    >                    -- no fixity errors

  * Quoted expressions such as

    > [| a * b + c |] :: Q Exp
    > [p| a : b : c |] :: Q Pat
    > [t| T + T |] :: Q Type

    will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'PromotedUInfixT',
    'InfixT', 'PromotedInfixT, 'ParensE', 'ParensP', or 'ParensT' constructors.

-}