-- | Metaprogramming types
module GHC.Types.Meta
   ( MetaRequest(..)
   , MetaHook
   , MetaResult -- data constructors not exported to ensure correct response type
   , metaRequestE
   , metaRequestP
   , metaRequestT
   , metaRequestD
   , metaRequestAW
   )
where

import GHC.Prelude

import GHC.Serialized   ( Serialized )

import GHC.Hs
import GHC.Utils.Outputable
import GHC.Utils.Panic


-- | The supported metaprogramming result types
data MetaRequest
  = MetaE  (LHsExpr GhcPs   -> MetaResult)
  | MetaP  (LPat GhcPs      -> MetaResult)
  | MetaT  (LHsType GhcPs   -> MetaResult)
  | MetaD  ([LHsDecl GhcPs] -> MetaResult)
  | MetaAW (Serialized     -> MetaResult)

-- | data constructors not exported to ensure correct result type
data MetaResult
  = MetaResE  (LHsExpr GhcPs)
  | MetaResP  (LPat GhcPs)
  | MetaResT  (LHsType GhcPs)
  | MetaResD  [LHsDecl GhcPs]
  | MetaResAW Serialized

instance Outputable MetaResult where
    ppr :: MetaResult -> SDoc
ppr (MetaResE LHsExpr GhcPs
e)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MetaResE"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e)
    ppr (MetaResP LPat GhcPs
p)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MetaResP"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (GenLocated SrcSpanAnnA (Pat GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p)
    ppr (MetaResT LHsType GhcPs
t)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MetaResT"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t)
    ppr (MetaResD [LHsDecl GhcPs]
d)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MetaResD"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
d)
    ppr (MetaResAW Serialized
aw) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MetaResAW" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (Serialized -> SDoc
forall a. Outputable a => a -> SDoc
ppr Serialized
aw)

-- These unMetaResE ext panics will triger if the MetaHook doesn't
-- take an expression to an expression, pattern to pattern etc.
--
-- ToDo: surely this could be expressed in the type system?
unMetaResE :: MetaResult -> LHsExpr GhcPs
unMetaResE :: MetaResult -> LHsExpr GhcPs
unMetaResE (MetaResE LHsExpr GhcPs
e) = LHsExpr GhcPs
e
unMetaResE MetaResult
mr           = String -> SDoc -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unMetaResE" (MetaResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaResult
mr)

unMetaResP :: MetaResult -> LPat GhcPs
unMetaResP :: MetaResult -> LPat GhcPs
unMetaResP (MetaResP LPat GhcPs
p) = LPat GhcPs
p
unMetaResP MetaResult
mr           = String -> SDoc -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unMetaResP" (MetaResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaResult
mr)

unMetaResT :: MetaResult -> LHsType GhcPs
unMetaResT :: MetaResult -> LHsType GhcPs
unMetaResT (MetaResT LHsType GhcPs
t) = LHsType GhcPs
t
unMetaResT MetaResult
mr           = String -> SDoc -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unMetaResT" (MetaResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaResult
mr)

unMetaResD :: MetaResult -> [LHsDecl GhcPs]
unMetaResD :: MetaResult -> [LHsDecl GhcPs]
unMetaResD (MetaResD [LHsDecl GhcPs]
d) = [LHsDecl GhcPs]
d
unMetaResD MetaResult
mr           = String -> SDoc -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unMetaResD" (MetaResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaResult
mr)

unMetaResAW :: MetaResult -> Serialized
unMetaResAW :: MetaResult -> Serialized
unMetaResAW (MetaResAW Serialized
aw) = Serialized
aw
unMetaResAW MetaResult
mr             = String -> SDoc -> Serialized
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unMetaResAW" (MetaResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaResult
mr)

type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult

metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)
metaRequestE :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)
metaRequestE MetaHook f
h = (MetaResult -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> f MetaResult -> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> LHsExpr GhcPs
MetaResult -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
unMetaResE (f MetaResult -> f (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> f MetaResult)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h ((LHsExpr GhcPs -> MetaResult) -> MetaRequest
MetaE LHsExpr GhcPs -> MetaResult
MetaResE)

metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)
metaRequestP :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)
metaRequestP MetaHook f
h = (MetaResult -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> f MetaResult -> f (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> LPat GhcPs
MetaResult -> GenLocated SrcSpanAnnA (Pat GhcPs)
unMetaResP (f MetaResult -> f (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> f MetaResult)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> f (GenLocated SrcSpanAnnA (Pat GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h ((LPat GhcPs -> MetaResult) -> MetaRequest
MetaP LPat GhcPs -> MetaResult
MetaResP)

metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)
metaRequestT :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)
metaRequestT MetaHook f
h = (MetaResult -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> f MetaResult -> f (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> LHsType GhcPs
MetaResult -> GenLocated SrcSpanAnnA (HsType GhcPs)
unMetaResT (f MetaResult -> f (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> f MetaResult)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> f (GenLocated SrcSpanAnnA (HsType GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h ((LHsType GhcPs -> MetaResult) -> MetaRequest
MetaT LHsType GhcPs -> MetaResult
MetaResT)

metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]
metaRequestD :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]
metaRequestD MetaHook f
h = (MetaResult -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> f MetaResult -> f [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> [LHsDecl GhcPs]
MetaResult -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
unMetaResD (f MetaResult -> f [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> f MetaResult)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> f [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h (([LHsDecl GhcPs] -> MetaResult) -> MetaRequest
MetaD [LHsDecl GhcPs] -> MetaResult
MetaResD)

metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized
metaRequestAW :: forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f Serialized
metaRequestAW MetaHook f
h = (MetaResult -> Serialized) -> f MetaResult -> f Serialized
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaResult -> Serialized
unMetaResAW (f MetaResult -> f Serialized)
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> f MetaResult)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> f Serialized
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaHook f
h ((Serialized -> MetaResult) -> MetaRequest
MetaAW Serialized -> MetaResult
MetaResAW)