    {-
    (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 GHC.Driver.Session
    import GHC.Driver.Env

    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 )

    -- 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
    _  -> (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)
    mapM GenLocated SrcSpanAnnA (AnnDecl GhcRn)
    -> IOEnv (Env TcGblEnv TcLclEnv) Annotation
    LAnnDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Annotation
    tcAnnotation [GenLocated SrcSpanAnnA (AnnDecl GhcRn)]
    [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 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
    $ WarnReason -> SDoc -> TcRn ()
    addWarnTc WarnReason
    NoReason (SDoc -> TcRn ()) -> SDoc -> TcRn ()
    forall a b. (a -> b) -> a -> b
    $
                 (String -> SDoc
    text String
    "Ignoring ANN annotation" SDoc -> SDoc -> SDoc
    <> [GenLocated SrcSpanAnnA (AnnDecl GhcRn)] -> SDoc
    forall a. [a] -> SDoc
    plural [GenLocated SrcSpanAnnA (AnnDecl GhcRn)]
    [LAnnDecl GhcRn]
    anns SDoc -> SDoc -> SDoc
    <> SDoc
    comma
                 SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    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 SrcSpanAnnA
    loc ann :: AnnDecl GhcRn
    ann@(HsAnnotation XHsAnnotation GhcRn
    _ SourceText
    _ AnnProvenance GhcRn
    provenance XRec GhcRn (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 GhcRn -> AnnTarget Name
    annProvenanceToTarget Module
    mod AnnProvenance GhcRn
    provenance

        -- Run that annotation and construct the full Annotation data structure
        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
          -- 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
    $ SDoc -> TcRn ()
    forall a. SDoc -> TcM a
    failWithTc SDoc
    safeHsErr
          AnnTarget Name
    -> XRec GhcRn (HsExpr GhcRn)
    -> IOEnv (Env TcGblEnv TcLclEnv) Annotation
    runAnnotation AnnTarget Name
    target XRec GhcRn (HsExpr GhcRn)
    expr
        where
          safeHsErr :: SDoc
    safeHsErr = [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "Annotations are not compatible with Safe Haskell."
                      , String -> SDoc
    text String
    "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]

    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
    text String
    "In the annotation:") Int
    2 (AnnDecl (GhcPass p) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr AnnDecl (GhcPass p)
    ann)