{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Tc.Errors.Types
import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation )
import GHC.Tc.Utils.Monad
import GHC.Unit.Module
import GHC.Hs
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Annotations
import GHC.Types.SrcLoc
import Control.Monad ( when )
tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations [LAnnDecl GhcRn]
anns = do
HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
case HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env of
Just Interp
_ -> (GenLocated SrcSpanAnnA (AnnDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation)
-> [GenLocated SrcSpanAnnA (AnnDecl GhcRn)] -> TcM [Annotation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LAnnDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Annotation
GenLocated SrcSpanAnnA (AnnDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
tcAnnotation [LAnnDecl GhcRn]
[GenLocated SrcSpanAnnA (AnnDecl GhcRn)]
anns
Maybe Interp
Nothing -> [LAnnDecl GhcRn] -> TcM [Annotation]
warnAnns [LAnnDecl GhcRn]
anns
warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
warnAnns [] = [Annotation] -> TcM [Annotation]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
warnAnns anns :: [LAnnDecl GhcRn]
anns@(L SrcSpanAnnA
loc AnnDecl GhcRn
_ : [LAnnDecl GhcRn]
_)
= do { SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addDiagnosticTc ([LAnnDecl GhcRn] -> TcRnMessage
TcRnIgnoringAnnotations [LAnnDecl GhcRn]
anns)
; [Annotation] -> TcM [Annotation]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [] }
tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation
tcAnnotation :: LAnnDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Annotation
tcAnnotation (L SrcSpanAnnA
loc ann :: AnnDecl GhcRn
ann@(HsAnnotation XHsAnnotation GhcRn
_ AnnProvenance GhcRn
provenance XRec GhcRn (HsExpr GhcRn)
expr)) = do
Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
let target :: AnnTarget Name
target = Module -> AnnProvenance GhcRn -> AnnTarget Name
annProvenanceToTarget Module
mod AnnProvenance GhcRn
provenance
SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv (Env TcGblEnv TcLclEnv) Annotation
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation)
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
forall a b. (a -> b) -> a -> b
$ SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (AnnDecl GhcRn -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
AnnDecl (GhcPass p) -> SDoc
annCtxt AnnDecl GhcRn
ann) (IOEnv (Env TcGblEnv TcLclEnv) Annotation
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation)
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
safeLanguageOn DynFlags
dflags) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc TcRnMessage
TcRnAnnotationInSafeHaskell
AnnTarget Name
-> XRec GhcRn (HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
runAnnotation AnnTarget Name
target XRec GhcRn (HsExpr GhcRn)
expr
annProvenanceToTarget :: Module -> AnnProvenance GhcRn
-> AnnTarget Name
annProvenanceToTarget :: Module -> AnnProvenance GhcRn -> AnnTarget Name
annProvenanceToTarget Module
_ (ValueAnnProvenance (L SrcSpanAnnN
_ Name
name)) = Name -> AnnTarget Name
forall name. name -> AnnTarget name
NamedTarget Name
name
annProvenanceToTarget Module
_ (TypeAnnProvenance (L SrcSpanAnnN
_ Name
name)) = Name -> AnnTarget Name
forall name. name -> AnnTarget name
NamedTarget Name
name
annProvenanceToTarget Module
mod AnnProvenance GhcRn
ModuleAnnProvenance = Module -> AnnTarget Name
forall name. Module -> AnnTarget name
ModuleTarget Module
mod
annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc
annCtxt :: forall (p :: Pass).
OutputableBndrId p =>
AnnDecl (GhcPass p) -> SDoc
annCtxt AnnDecl (GhcPass p)
ann
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the annotation:") Int
2 (AnnDecl (GhcPass p) -> SDoc
forall a. Outputable a => a -> SDoc
ppr AnnDecl (GhcPass p)
ann)