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
|
-----------------------------------------------------------------------------
--
-- 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 ( getImportsFromFile, getImports
, getOptionsFromFile, getOptions
, optionsErrorMsgs ) where
#include "HsVersions.h"
import Parser ( parseHeader )
import Lexer ( P(..), ParseResult(..), mkPState, pragState
, lexer, Token(..), PState(..) )
import FastString
import HsSyn ( ImportDecl(..), HsModule(..) )
import Module ( Module, mkModule )
import PrelNames ( gHC_PRIM )
import StringBuffer ( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock
, appendStringBuffers )
import SrcLoc ( Located(..), mkSrcLoc, unLoc, noSrcSpan )
import FastString ( mkFastString )
import DynFlags ( DynFlags )
import ErrUtils
import Util
import Outputable
import Pretty ()
import Panic
import Bag ( unitBag, emptyBag, listToBag )
import Distribution.Compiler
import TRACE
import EXCEPTION ( throwDyn )
import IO
import List
#if __GLASGOW_HASKELL__ >= 601
import System.IO ( openBinaryFile )
#else
import IOExts ( openFileEx, IOModeEx(..) )
#endif
#if __GLASGOW_HASKELL__ < 601
openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
#endif
-- getImportsFromFile is careful to close the file afterwards, otherwise
-- we can end up with a large number of open handles before the garbage
-- collector gets around to closing them.
getImportsFromFile :: DynFlags -> FilePath
-> IO ([Located Module], [Located Module], Located Module)
getImportsFromFile dflags filename = do
buf <- hGetStringBuffer filename
getImports dflags buf filename
getImports :: DynFlags -> StringBuffer -> FilePath
-> IO ([Located Module], [Located Module], Located Module)
getImports dflags buf filename = do
let loc = mkSrcLoc (mkFastString filename) 1 0
case unP parseHeader (mkPState buf loc dflags) of
PFailed span err -> parseError span err
POk _ rdr_module ->
case rdr_module of
L _ (HsModule mod _ imps _ _) ->
let
mod_name | Just located_mod <- mod = located_mod
| otherwise = L noSrcSpan (mkModule "Main")
(src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
source_imps = map getImpMod src_idecls
ordinary_imps = filter ((/= gHC_PRIM) . unLoc)
(map getImpMod ord_idecls)
-- GHC.Prim doesn't exist physically, so don't go looking for it.
in
return (source_imps, ordinary_imps, mod_name)
parseError span err = throwDyn $ mkPlainErrMsg span err
isSourceIdecl (ImportDecl _ s _ _ _) = s
getImpMod (ImportDecl located_mod _ _ _ _) = located_mod
--------------------------------------------------------------
-- Get options
--------------------------------------------------------------
getOptionsFromFile :: FilePath -- input file
-> IO [Located String] -- options, if any
getOptionsFromFile filename
= bracket (openBinaryFile filename ReadMode)
(hClose)
(\handle ->
do buf <- hGetStringBufferBlock handle blockSize
loop handle buf)
where blockSize = 1024
loop handle buf
| len buf == 0 = return []
| otherwise
= case getOptions' buf filename of
(Nothing, opts) -> return opts
(Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
newBuf <- appendStringBuffers buf' nextBlock
if len newBuf == len buf
then return opts
else do opts' <- loop handle newBuf
return (opts++opts')
getOptions :: StringBuffer -> FilePath -> [Located String]
getOptions buf filename
= case getOptions' buf filename of
(_,opts) -> opts
-- 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' :: StringBuffer -- Input buffer
-> FilePath -- Source file. Used for msgs only.
-> ( Maybe StringBuffer -- Just => we can use more input
, [Located String] -- Options.
)
getOptions' buf filename
= parseToks (lexAll (pragState buf loc))
where loc = mkSrcLoc (mkFastString filename) 1 0
getToken (buf,L _loc tok) = tok
getLoc (buf,L loc _tok) = loc
getBuf (buf,_tok) = buf
combine opts (flag, opts') = (flag, opts++opts')
add opt (flag, opts) = (flag, opt:opts)
parseToks (open:close:xs)
| IToptions_prag str <- getToken open
, ITclose_prag <- getToken close
= map (L (getLoc open)) (words str) `combine`
parseToks xs
parseToks (open:close:xs)
| ITinclude_prag str <- getToken open
, ITclose_prag <- getToken close
= map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
parseToks xs
parseToks (open:xs)
| ITlanguage_prag <- getToken open
= parseLanguage xs
-- The last token before EOF could have been truncated.
-- We ignore it to be on the safe side.
parseToks [tok,eof]
| ITeof <- getToken eof
= (Just (getBuf tok),[])
parseToks (eof:_)
| ITeof <- getToken eof
= (Just (getBuf eof),[])
parseToks _ = (Nothing,[])
parseLanguage ((_buf,L loc (ITconid fs)):rest)
= checkExtension (L loc fs) `add`
case rest of
(_,L loc ITcomma):more -> parseLanguage more
(_,L loc ITclose_prag):more -> parseToks more
(_,L loc _):_ -> languagePragParseError loc
parseLanguage (tok:_)
= languagePragParseError (getLoc tok)
lexToken t = return t
lexAll state = case unP (lexer lexToken) state of
POk state' t@(L _ ITeof) -> [(buffer state,t)]
POk state' t -> (buffer state,t):lexAll state'
_ -> [(buffer state,L (last_loc state) ITeof)]
checkExtension :: Located FastString -> Located String
checkExtension (L l ext)
= case reads (unpackFS ext) of
[] -> languagePragParseError l
(okExt,""):_ -> case extensionsToGHCFlag [okExt] of
([],[opt]) -> L l opt
_ -> unsupportedExtnError l okExt
languagePragParseError loc =
pgmError (showSDoc (mkLocMessage loc (
text "cannot parse LANGUAGE pragma")))
unsupportedExtnError loc unsup =
pgmError (showSDoc (mkLocMessage loc (
text "unsupported extension: " <>
(text.show) 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
|
