mirrored from https://gitlab.haskell.org/ghc/ghc.git
/
HeaderInfo.hs
253 lines (224 loc) · 9.63 KB
/
HeaderInfo.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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
-----------------------------------------------------------------------------
--
-- | Parsing the top of a Haskell source file to get its module name,
-- imports and options.
--
-- (c) Simon Marlow 2005
-- (c) Lemmih 2006
--
-----------------------------------------------------------------------------
module HeaderInfo ( getImports
, getOptionsFromFile, getOptions
, optionsErrorMsgs,
checkProcessArgsResult ) where
#include "HsVersions.h"
import RdrName
import HscTypes
import Parser ( parseHeader )
import Lexer
import FastString
import HsSyn ( ImportDecl(..), HsModule(..) )
import Module ( ModuleName, moduleName )
import PrelNames ( gHC_PRIM, mAIN_NAME )
import StringBuffer
import SrcLoc
import DynFlags
import ErrUtils
import Util
import Outputable
import Pretty ()
import Maybes
import Bag ( emptyBag, listToBag, unitBag )
import MonadUtils ( MonadIO )
import Exception
import Control.Monad
import System.IO
import System.IO.Unsafe
import Data.List
------------------------------------------------------------------------------
-- | Parse the imports of a source file.
--
-- Throws a 'SourceError' if parsing fails.
getImports :: GhcMonad m =>
DynFlags
-> StringBuffer -- ^ Parse this.
-> FilePath -- ^ Filename the buffer came from. Used for
-- reporting parse error locations.
-> FilePath -- ^ The original source filename (used for locations
-- in the function result)
-> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
-- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
let loc = mkSrcLoc (mkFastString filename) 1 0
case unP parseHeader (mkPState buf loc dflags) of
PFailed span err -> parseError span err
POk pst rdr_module -> do
let ms@(warns, errs) = getMessages pst
logWarnings warns
if errorsFound dflags ms
then liftIO $ throwIO $ mkSrcErr errs
else
case rdr_module of
L _ (HsModule mb_mod _ imps _ _ _ _) ->
let
main_loc = mkSrcLoc (mkFastString source_filename) 1 0
mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
(src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
ord_idecls
-- GHC.Prim doesn't exist physically, so don't go looking for it.
in
return (src_idecls, ordinary_imps, mod)
parseError :: GhcMonad m => SrcSpan -> Message -> m a
parseError span err = throwOneError $ mkPlainErrMsg span err
--------------------------------------------------------------
-- Get options
--------------------------------------------------------------
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
getOptionsFromFile :: DynFlags
-> FilePath -- ^ Input file
-> IO [Located String] -- ^ Parsed options, if any.
getOptionsFromFile dflags filename
= Exception.bracket
(openBinaryFile filename ReadMode)
(hClose)
(\handle -> do
opts <- fmap getOptions' $ lazyGetToks dflags filename handle
seqList opts $ return opts)
blockSize :: Int
-- blockSize = 17 -- for testing :-)
blockSize = 1024
lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
lazyGetToks dflags filename handle = do
buf <- hGetStringBufferBlock handle blockSize
unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
where
loc = mkSrcLoc (mkFastString filename) 1 0
lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
lazyLexBuf handle state eof = do
case unP (lexer return) state of
POk state' t -> do
-- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
if atEnd (buffer state') && not eof
-- if this token reached the end of the buffer, and we haven't
-- necessarily read up to the end of the file, then the token might
-- be truncated, so read some more of the file and lex it again.
then getMore handle state
else case t of
L _ ITeof -> return [t]
_other -> do rest <- lazyLexBuf handle state' eof
return (t : rest)
_ | not eof -> getMore handle state
| otherwise -> return []
getMore :: Handle -> PState -> IO [Located Token]
getMore handle state = do
-- pprTrace "getMore" (text (show (buffer state))) (return ())
nextbuf <- hGetStringBufferBlock handle blockSize
if (len nextbuf == 0) then lazyLexBuf handle state True else do
newbuf <- appendStringBuffers (buffer state) nextbuf
unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False
getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
where
loc = mkSrcLoc (mkFastString filename) 1 0
lexAll state = case unP (lexer return) state of
POk _ t@(L _ ITeof) -> [t]
POk state' t -> t : lexAll state'
_ -> [L (last_loc state) ITeof]
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
getOptions :: DynFlags
-> StringBuffer -- ^ Input Buffer
-> FilePath -- ^ Source filename. Used for location info.
-> [Located String] -- ^ Parsed options.
getOptions dflags buf filename
= getOptions' (getToks dflags filename buf)
-- The token parser is written manually because Happy can't
-- return a partial result when it encounters a lexer error.
-- We want to extract options before the buffer is passed through
-- CPP, so we can't use the same trick as 'getImports'.
getOptions' :: [Located Token] -- Input buffer
-> [Located String] -- Options.
getOptions' toks
= parseToks toks
where
getToken (L _loc tok) = tok
getLoc (L loc _tok) = loc
parseToks (open:close:xs)
| IToptions_prag str <- getToken open
, ITclose_prag <- getToken close
= map (L (getLoc open)) (words str) ++
parseToks xs
parseToks (open:close:xs)
| ITinclude_prag str <- getToken open
, ITclose_prag <- getToken close
= map (L (getLoc open)) ["-#include",removeSpaces str] ++
parseToks xs
parseToks (open:close:xs)
| ITdocOptions str <- getToken open
, ITclose_prag <- getToken close
= map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
++ parseToks xs
parseToks (open:xs)
| ITdocOptionsOld str <- getToken open
= map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
++ parseToks xs
parseToks (open:xs)
| ITlanguage_prag <- getToken open
= parseLanguage xs
parseToks _ = []
parseLanguage (L loc (ITconid fs):rest)
= checkExtension (L loc fs) :
case rest of
(L _loc ITcomma):more -> parseLanguage more
(L _loc ITclose_prag):more -> parseToks more
(L loc _):_ -> languagePragParseError loc
[] -> panic "getOptions'.parseLanguage(1) went past eof token"
parseLanguage (tok:_)
= languagePragParseError (getLoc tok)
parseLanguage []
= panic "getOptions'.parseLanguage(2) went past eof token"
-----------------------------------------------------------------------------
-- | Complain about non-dynamic flags in OPTIONS pragmas.
--
-- Throws a 'SourceError' if the input list is non-empty claiming that the
-- input flags are unknown.
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
checkProcessArgsResult flags
= when (notNull flags) $
liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
where mkMsg (L loc flag)
= mkPlainErrMsg loc $
(text "unknown flag in {-# OPTIONS #-} pragma:" <+>
text flag)
-----------------------------------------------------------------------------
checkExtension :: Located FastString -> Located String
checkExtension (L l ext)
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
= let ext' = unpackFS ext in
if ext' `elem` supportedLanguages
|| ext' `elem` (map ("No"++) supportedLanguages)
then L l ("-X"++ext')
else unsupportedExtnError l ext'
languagePragParseError :: SrcSpan -> a
languagePragParseError loc =
throw $ mkSrcErr $ unitBag $
(mkPlainErrMsg loc $
text "cannot parse LANGUAGE pragma: comma-separated list expected")
unsupportedExtnError :: SrcSpan -> String -> a
unsupportedExtnError loc unsup =
throw $ mkSrcErr $ unitBag $
mkPlainErrMsg loc $
text "unsupported extension: " <> text unsup
optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
optionsErrorMsgs unhandled_flags flags_lines _filename
= (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
L l f' <- flags_lines, f == f' ]
mkMsg (L flagSpan flag) =
ErrUtils.mkPlainErrMsg flagSpan $
text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag