-
Notifications
You must be signed in to change notification settings - Fork 0
/
OldAbtPlg.hs
93 lines (82 loc) · 2.77 KB
/
OldAbtPlg.hs
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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
{-#LANGUAGE DeriveGeneric, StandaloneDeriving#-}
module AbortPlugin (plugin) where
import Control.Monad
import Control.Monad.IO.Class
import qualified EnumSet as S
import GhcPlugins hiding (errorMsg,(<>))
import ErrUtils
import Data.Traversable
import GHC.LanguageExtensions
import GHC.Generics
import Data.List (foldl',(\\))
import Data.Monoid
import Data.Data
import Control.Exception (throw)
import qualified Bag
import qualified HscTypes
import HsSyn
import ApiAnnotation
import HeaderInfo
plugin :: Plugin
plugin = defaultPlugin
{ parsedResultAction = \_ modSummary parsedModule ->
parsedModule <$ checkExts modSummary parsedModule
}
deriving instance Typeable DynFlags
checkExts :: (HasDynFlags m, MonadIO m) => ModSummary -> HsParsedModule -> m ()
checkExts modSummary (HsParsedModule { hpm_module = L pos parsedModule, hpm_src_files = src_files, hpm_annotations = (annKeys, annotations) })
= do
flags <- getDynFlags
let allowedImports :: [String]
allowedImports = "Prelude" : ["Data.List"]
let allowed :: [Extension]
allowed =
[ MonomorphismRestriction
, RelaxedPolyRec
, ForeignFunctionInterface
, ImplicitPrelude
, DoAndIfThenElse
, EmptyDataDecls
, PatternGuards
, NondecreasingIndentation
, TraditionalRecordSyntax
, MonadFailDesugaring
, StarIsType
]
-- let pppr = showSDoc flags . ppr
let
HsModule { hsmodName = name, hsmodExports = exports, hsmodImports = imports, hsmodDecls = decls }
= parsedModule
cachedFlags = ms_hspp_opts modSummary
let imports = map snd (ms_textual_imps modSummary <> ms_srcimps modSummary)
badImports =
[ rval
| rval@(L _ n) <- imports
, moduleNameString n `notElem` allowedImports
]
liftIO $ putStrLn (showSDoc flags (ppr decls))
let extensions = extensionFlags flags
bad = S.toList (foldl' (flip S.delete) extensions allowed)
let currentSettings = settings flags
let
importErrors =
[ ErrUtils.mkPlainErrMsg
flags
importPosition
(ErrUtils.formatErrDoc
flags
(ErrUtils.errDoc
[ text ("Forbidden import used: " ++ moduleNameString importName) ]
[]
[]
)
)
| L importPosition importName <- badImports
]
liftIO (throw (HscTypes.mkSrcErr (Bag.listToBag importErrors)))
unless (null bad) $ liftIO $ do
errorMsg flags $ mkLocMessage
SevFatal
pos
(text ("Forbidden extension used: " ++ show bad))
ghcExit flags 2