Major Overhaul of Pattern Match Checking (Fixes #595)
[ghc.git] / compiler / typecheck / TcAnnotations.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1993-1998
4
5 \section[TcAnnotations]{Typechecking annotations}
6 -}
7
8 {-# LANGUAGE CPP #-}
9
10 module TcAnnotations ( tcAnnotations, annCtxt ) where
11
12 #ifdef GHCI
13 import {-# SOURCE #-} TcSplice ( runAnnotation )
14 import Module
15 import DynFlags
16 import Control.Monad ( when )
17 #endif
18
19 import HsSyn
20 import Annotations
21 import Name
22 import TcRnMonad
23 import SrcLoc
24 import Outputable
25
26 import FastString
27
28 #ifndef GHCI
29
30 tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation]
31 -- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268
32 tcAnnotations [] = return []
33 tcAnnotations anns@(L loc _ : _)
34 = do { setSrcSpan loc $ addWarnTc $
35 (ptext (sLit "Ignoring ANN annotation") <> plural anns <> comma
36 <+> ptext (sLit "because this is a stage-1 compiler or doesn't support GHCi"))
37 ; return [] }
38
39 #else
40
41 tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation]
42 -- GHCI exists, typecheck the annotations
43 tcAnnotations anns = mapM tcAnnotation anns
44
45 tcAnnotation :: LAnnDecl Name -> TcM Annotation
46 tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do
47 -- Work out what the full target of this annotation was
48 mod <- getModule
49 let target = annProvenanceToTarget mod provenance
50
51 -- Run that annotation and construct the full Annotation data structure
52 setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do
53 -- See #10826 -- Annotations allow one to bypass Safe Haskell.
54 dflags <- getDynFlags
55 when (safeLanguageOn dflags) $ failWithTc safeHsErr
56 runAnnotation target expr
57 where
58 safeHsErr = vcat [ ptext (sLit "Annotations are not compatible with Safe Haskell.")
59 , ptext (sLit "See https://ghc.haskell.org/trac/ghc/ticket/10826") ]
60
61 annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name
62 annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name
63 annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name
64 annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod
65 #endif
66
67 annCtxt :: OutputableBndr id => AnnDecl id -> SDoc
68 annCtxt ann
69 = hang (ptext (sLit "In the annotation:")) 2 (ppr ann)