{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module TcAnnotations ( tcAnnotations, annCtxt ) where
import GhcPrelude
import {-# SOURCE #-} TcSplice ( runAnnotation )
import Module
import DynFlags
import Control.Monad ( when )
import HsSyn
import Name
import Annotations
import TcRnMonad
import SrcLoc
import Outputable
#ifndef GHCI
tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations anns = do
dflags <- getDynFlags
case gopt Opt_ExternalInterpreter dflags of
True -> tcAnnotations' anns
False -> warnAnns anns
warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
warnAnns [] = return []
warnAnns anns@(L loc _ : _)
= do { setSrcSpan loc $ addWarnTc NoReason $
(text "Ignoring ANN annotation" <> plural anns <> comma
<+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")
; return [] }
#else
tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations = [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations'
#endif
tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations' [LAnnDecl GhcRn]
anns = (LAnnDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Annotation)
-> [LAnnDecl GhcRn] -> TcM [Annotation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LAnnDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Annotation
tcAnnotation [LAnnDecl GhcRn]
anns
tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation
tcAnnotation :: LAnnDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Annotation
tcAnnotation (L SrcSpan
loc ann :: AnnDecl GhcRn
ann@(HsAnnotation XHsAnnotation GhcRn
_ SourceText
_ AnnProvenance (IdP GhcRn)
provenance Located (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 Name -> AnnTarget Name
annProvenanceToTarget Module
mod AnnProvenance (IdP GhcRn)
AnnProvenance Name
provenance
SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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
$ MsgDoc
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (AnnDecl GhcRn -> MsgDoc
forall (p :: Pass).
OutputableBndrId (GhcPass p) =>
AnnDecl (GhcPass p) -> MsgDoc
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
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
safeLanguageOn DynFlags
dflags) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. MsgDoc -> TcM a
failWithTc MsgDoc
safeHsErr
AnnTarget Name
-> Located (HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) Annotation
runAnnotation AnnTarget Name
target Located (HsExpr GhcRn)
expr
where
safeHsErr :: MsgDoc
safeHsErr = [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Annotations are not compatible with Safe Haskell."
, String -> MsgDoc
text String
"See https://ghc.haskell.org/trac/ghc/ticket/10826" ]
tcAnnotation (L SrcSpan
_ (XAnnDecl XXAnnDecl GhcRn
_)) = String -> IOEnv (Env TcGblEnv TcLclEnv) Annotation
forall a. String -> a
panic String
"tcAnnotation"
annProvenanceToTarget :: Module -> AnnProvenance Name
-> AnnTarget Name
annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name
annProvenanceToTarget Module
_ (ValueAnnProvenance (L SrcSpan
_ Name
name)) = Name -> AnnTarget Name
forall name. name -> AnnTarget name
NamedTarget Name
name
annProvenanceToTarget Module
_ (TypeAnnProvenance (L SrcSpan
_ Name
name)) = Name -> AnnTarget Name
forall name. name -> AnnTarget name
NamedTarget Name
name
annProvenanceToTarget Module
mod AnnProvenance Name
ModuleAnnProvenance = Module -> AnnTarget Name
forall name. Module -> AnnTarget name
ModuleTarget Module
mod
annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc
annCtxt :: AnnDecl (GhcPass p) -> MsgDoc
annCtxt AnnDecl (GhcPass p)
ann
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"In the annotation:") Int
2 (AnnDecl (GhcPass p) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr AnnDecl (GhcPass p)
ann)