{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1993-1998

-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

-- | Typechecking annotations
module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where

import GHC.Prelude

import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation )
import GHC.Unit.Module
import GHC.Driver.Session
import Control.Monad ( when )

import GHC.Hs
import GHC.Types.Name
import GHC.Types.Annotations
import GHC.Tc.Utils.Monad
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Driver.Types

-- Some platforms don't support the interpreter, and compilation on those
-- platforms shouldn't fail just due to annotations
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
_  -> (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
    Maybe Interp
Nothing -> [LAnnDecl GhcRn] -> TcM [Annotation]
warnAnns [LAnnDecl GhcRn]
anns

warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
--- No GHCI; emit a warning (not an error) and ignore. cf #4268
warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
warnAnns [] = [Annotation] -> TcM [Annotation]
forall (m :: * -> *) a. Monad m => a -> m a
return []
warnAnns anns :: [LAnnDecl GhcRn]
anns@(L SrcSpan
loc AnnDecl GhcRn
_ : [LAnnDecl GhcRn]
_)
  = do { SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ WarnReason -> MsgDoc -> TcRn ()
addWarnTc WarnReason
NoReason (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
             (String -> MsgDoc
text String
"Ignoring ANN annotation" MsgDoc -> MsgDoc -> MsgDoc
<> [LAnnDecl GhcRn] -> MsgDoc
forall a. [a] -> MsgDoc
plural [LAnnDecl GhcRn]
anns MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
comma
             MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")
       ; [Annotation] -> TcM [Annotation]
forall (m :: * -> *) a. Monad m => a -> m a
return [] }

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
    -- Work out what the full target of this annotation was
    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 Name
AnnProvenance (IdP GhcRn)
provenance

    -- Run that annotation and construct the full Annotation data structure
    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 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
      -- See #10826 -- Annotations allow one to bypass Safe Haskell.
      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
$ MsgDoc -> TcRn ()
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://gitlab.haskell.org/ghc/ghc/issues/10826" ]

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 p) => AnnDecl (GhcPass p) -> SDoc
annCtxt :: forall (p :: Pass).
OutputableBndrId p =>
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)