blob: 61c4e192b08f06b77f5049d10b378fb7f8e9df21 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
{-
(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 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 )
-- 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 anns = do
hsc_env <- getTopEnv
case hsc_interp hsc_env of
Just _ -> mapM tcAnnotation anns
Nothing -> warnAnns anns
warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
--- No GHCI; emit a warning (not an error) and ignore. cf #4268
warnAnns [] = return []
warnAnns anns@(L loc _ : _)
= do { setSrcSpanA loc $ addDiagnosticTc (TcRnIgnoringAnnotations anns)
; return [] }
tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation
tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do
-- Work out what the full target of this annotation was
mod <- getModule
let target = annProvenanceToTarget mod provenance
-- Run that annotation and construct the full Annotation data structure
setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do
-- See #10826 -- Annotations allow one to bypass Safe Haskell.
dflags <- getDynFlags
when (safeLanguageOn dflags) $ failWithTc TcRnAnnotationInSafeHaskell
runAnnotation target expr
annProvenanceToTarget :: Module -> AnnProvenance GhcRn
-> AnnTarget Name
annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name
annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name
annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod
annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc
annCtxt ann
= hang (text "In the annotation:") 2 (ppr ann)
|
