{-
(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)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
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
External instance of the constraint type forall m. Monad (IOEnv m)
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
External instance of the constraint type forall m. Monad (IOEnv m)
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
External instance of the constraint type forall env. ContainsModule env => HasModule (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsModule gbl => ContainsModule (Env gbl lcl)
External instance of the constraint type ContainsModule TcGblEnv
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
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
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
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
      Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
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 :: 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
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (AnnDecl (GhcPass p))
Evidence bound by a type signature of the constraint type OutputableBndrId p
ppr AnnDecl (GhcPass p)
ann)