1{-# LANGUAGE CPP #-} 2{-# LANGUAGE ViewPatterns #-} 3{-# LANGUAGE TypeFamilies #-} 4 5----------------------------------------------------------------------------- 6-- 7-- | Parsing the top of a Haskell source file to get its module name, 8-- imports and options. 9-- 10-- (c) Simon Marlow 2005 11-- (c) Lemmih 2006 12-- 13----------------------------------------------------------------------------- 14 15module GHC.Parser.Header 16 ( getImports 17 , mkPrelImports -- used by the renamer too 18 , getOptionsFromFile 19 , getOptions 20 , optionsErrorMsgs 21 , checkProcessArgsResult 22 ) 23where 24 25#include "GhclibHsVersions.h" 26 27import GHC.Prelude 28 29import GHC.Platform 30import GHC.Driver.Types 31import GHC.Parser ( parseHeader ) 32import GHC.Parser.Lexer 33import GHC.Data.FastString 34import GHC.Hs 35import GHC.Unit.Module 36import GHC.Builtin.Names 37import GHC.Data.StringBuffer 38import GHC.Types.SrcLoc 39import GHC.Driver.Session 40import GHC.Utils.Error 41import GHC.Utils.Misc 42import GHC.Utils.Outputable as Outputable 43import GHC.Data.Maybe 44import GHC.Data.Bag ( emptyBag, listToBag, unitBag ) 45import GHC.Utils.Monad 46import GHC.Utils.Exception as Exception 47import GHC.Types.Basic 48import qualified GHC.LanguageExtensions as LangExt 49 50import Control.Monad 51import System.IO 52import System.IO.Unsafe 53import Data.List 54 55------------------------------------------------------------------------------ 56 57-- | Parse the imports of a source file. 58-- 59-- Throws a 'SourceError' if parsing fails. 60getImports :: DynFlags 61 -> StringBuffer -- ^ Parse this. 62 -> FilePath -- ^ Filename the buffer came from. Used for 63 -- reporting parse error locations. 64 -> FilePath -- ^ The original source filename (used for locations 65 -- in the function result) 66 -> IO (Either 67 ErrorMessages 68 ([(Maybe FastString, Located ModuleName)], 69 [(Maybe FastString, Located ModuleName)], 70 Located ModuleName)) 71 -- ^ The source imports and normal imports (with optional package 72 -- names from -XPackageImports), and the module name. 73getImports dflags buf filename source_filename = do 74 let loc = mkRealSrcLoc (mkFastString filename) 1 1 75 case unP parseHeader (mkPState dflags buf loc) of 76 PFailed pst -> 77 -- assuming we're not logging warnings here as per below 78 return $ Left $ getErrorMessages pst dflags 79 POk pst rdr_module -> fmap Right $ do 80 let _ms@(_warns, errs) = getMessages pst dflags 81 -- don't log warnings: they'll be reported when we parse the file 82 -- for real. See #2500. 83 ms = (emptyBag, errs) 84 -- logWarnings warns 85 if errorsFound dflags ms 86 then throwIO $ mkSrcErr errs 87 else 88 let hsmod = unLoc rdr_module 89 mb_mod = hsmodName hsmod 90 imps = hsmodImports hsmod 91 main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 92 1 1) 93 mod = mb_mod `orElse` L main_loc mAIN_NAME 94 (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps 95 96 -- GHC.Prim doesn't exist physically, so don't go looking for it. 97 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc 98 . ideclName . unLoc) 99 ord_idecls 100 101 implicit_prelude = xopt LangExt.ImplicitPrelude dflags 102 implicit_imports = mkPrelImports (unLoc mod) main_loc 103 implicit_prelude imps 104 convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) 105 in 106 return (map convImport src_idecls, 107 map convImport (implicit_imports ++ ordinary_imps), 108 mod) 109 110mkPrelImports :: ModuleName 111 -> SrcSpan -- Attribute the "import Prelude" to this location 112 -> Bool -> [LImportDecl GhcPs] 113 -> [LImportDecl GhcPs] 114-- Construct the implicit declaration "import Prelude" (or not) 115-- 116-- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); 117-- because the former doesn't even look at Prelude.hi for instance 118-- declarations, whereas the latter does. 119mkPrelImports this_mod loc implicit_prelude import_decls 120 | this_mod == pRELUDE_NAME 121 || explicit_prelude_import 122 || not implicit_prelude 123 = [] 124 | otherwise = [preludeImportDecl] 125 where 126 explicit_prelude_import 127 = notNull [ () | L _ (ImportDecl { ideclName = mod 128 , ideclPkgQual = Nothing }) 129 <- import_decls 130 , unLoc mod == pRELUDE_NAME ] 131 132 preludeImportDecl :: LImportDecl GhcPs 133 preludeImportDecl 134 = L loc $ ImportDecl { ideclExt = noExtField, 135 ideclSourceSrc = NoSourceText, 136 ideclName = L loc pRELUDE_NAME, 137 ideclPkgQual = Nothing, 138 ideclSource = NotBoot, 139 ideclSafe = False, -- Not a safe import 140 ideclQualified = NotQualified, 141 ideclImplicit = True, -- Implicit! 142 ideclAs = Nothing, 143 ideclHiding = Nothing } 144 145-------------------------------------------------------------- 146-- Get options 147-------------------------------------------------------------- 148 149-- | Parse OPTIONS and LANGUAGE pragmas of the source file. 150-- 151-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) 152getOptionsFromFile :: DynFlags 153 -> FilePath -- ^ Input file 154 -> IO [Located String] -- ^ Parsed options, if any. 155getOptionsFromFile dflags filename 156 = Exception.bracket 157 (openBinaryFile filename ReadMode) 158 (hClose) 159 (\handle -> do 160 opts <- fmap (getOptions' dflags) 161 (lazyGetToks dflags' filename handle) 162 seqList opts $ return opts) 163 where -- We don't need to get haddock doc tokens when we're just 164 -- getting the options from pragmas, and lazily lexing them 165 -- correctly is a little tricky: If there is "\n" or "\n-" 166 -- left at the end of a buffer then the haddock doc may 167 -- continue past the end of the buffer, despite the fact that 168 -- we already have an apparently-complete token. 169 -- We therefore just turn Opt_Haddock off when doing the lazy 170 -- lex. 171 dflags' = gopt_unset dflags Opt_Haddock 172 173blockSize :: Int 174-- blockSize = 17 -- for testing :-) 175blockSize = 1024 176 177lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] 178lazyGetToks dflags filename handle = do 179 buf <- hGetStringBufferBlock handle blockSize 180 unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize 181 where 182 loc = mkRealSrcLoc (mkFastString filename) 1 1 183 184 lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] 185 lazyLexBuf handle state eof size = do 186 case unP (lexer False return) state of 187 POk state' t -> do 188 -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) 189 if atEnd (buffer state') && not eof 190 -- if this token reached the end of the buffer, and we haven't 191 -- necessarily read up to the end of the file, then the token might 192 -- be truncated, so read some more of the file and lex it again. 193 then getMore handle state size 194 else case unLoc t of 195 ITeof -> return [t] 196 _other -> do rest <- lazyLexBuf handle state' eof size 197 return (t : rest) 198 _ | not eof -> getMore handle state size 199 | otherwise -> return [L (mkSrcSpanPs (last_loc state)) ITeof] 200 -- parser assumes an ITeof sentinel at the end 201 202 getMore :: Handle -> PState -> Int -> IO [Located Token] 203 getMore handle state size = do 204 -- pprTrace "getMore" (text (show (buffer state))) (return ()) 205 let new_size = size * 2 206 -- double the buffer size each time we read a new block. This 207 -- counteracts the quadratic slowdown we otherwise get for very 208 -- large module names (#5981) 209 nextbuf <- hGetStringBufferBlock handle new_size 210 if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do 211 newbuf <- appendStringBuffers (buffer state) nextbuf 212 unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size 213 214 215getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] 216getToks dflags filename buf = lexAll (pragState dflags buf loc) 217 where 218 loc = mkRealSrcLoc (mkFastString filename) 1 1 219 220 lexAll state = case unP (lexer False return) state of 221 POk _ t@(L _ ITeof) -> [t] 222 POk state' t -> t : lexAll state' 223 _ -> [L (mkSrcSpanPs (last_loc state)) ITeof] 224 225 226-- | Parse OPTIONS and LANGUAGE pragmas of the source file. 227-- 228-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) 229getOptions :: DynFlags 230 -> StringBuffer -- ^ Input Buffer 231 -> FilePath -- ^ Source filename. Used for location info. 232 -> [Located String] -- ^ Parsed options. 233getOptions dflags buf filename 234 = getOptions' dflags (getToks dflags filename buf) 235 236-- The token parser is written manually because Happy can't 237-- return a partial result when it encounters a lexer error. 238-- We want to extract options before the buffer is passed through 239-- CPP, so we can't use the same trick as 'getImports'. 240getOptions' :: DynFlags 241 -> [Located Token] -- Input buffer 242 -> [Located String] -- Options. 243getOptions' dflags toks 244 = parseToks toks 245 where 246 parseToks (open:close:xs) 247 | IToptions_prag str <- unLoc open 248 , ITclose_prag <- unLoc close 249 = case toArgs str of 250 Left _err -> optionsParseError str dflags $ -- #15053 251 combineSrcSpans (getLoc open) (getLoc close) 252 Right args -> map (L (getLoc open)) args ++ parseToks xs 253 parseToks (open:close:xs) 254 | ITinclude_prag str <- unLoc open 255 , ITclose_prag <- unLoc close 256 = map (L (getLoc open)) ["-#include",removeSpaces str] ++ 257 parseToks xs 258 parseToks (open:close:xs) 259 | ITdocOptions str <- unLoc open 260 , ITclose_prag <- unLoc close 261 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str] 262 ++ parseToks xs 263 parseToks (open:xs) 264 | ITlanguage_prag <- unLoc open 265 = parseLanguage xs 266 parseToks (comment:xs) -- Skip over comments 267 | isComment (unLoc comment) 268 = parseToks xs 269 parseToks _ = [] 270 parseLanguage ((L loc (ITconid fs)):rest) 271 = checkExtension dflags (L loc fs) : 272 case rest of 273 (L _loc ITcomma):more -> parseLanguage more 274 (L _loc ITclose_prag):more -> parseToks more 275 (L loc _):_ -> languagePragParseError dflags loc 276 [] -> panic "getOptions'.parseLanguage(1) went past eof token" 277 parseLanguage (tok:_) 278 = languagePragParseError dflags (getLoc tok) 279 parseLanguage [] 280 = panic "getOptions'.parseLanguage(2) went past eof token" 281 282 isComment :: Token -> Bool 283 isComment c = 284 case c of 285 (ITlineComment {}) -> True 286 (ITblockComment {}) -> True 287 (ITdocCommentNext {}) -> True 288 (ITdocCommentPrev {}) -> True 289 (ITdocCommentNamed {}) -> True 290 (ITdocSection {}) -> True 291 _ -> False 292 293----------------------------------------------------------------------------- 294 295-- | Complain about non-dynamic flags in OPTIONS pragmas. 296-- 297-- Throws a 'SourceError' if the input list is non-empty claiming that the 298-- input flags are unknown. 299checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () 300checkProcessArgsResult dflags flags 301 = when (notNull flags) $ 302 liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags 303 where mkMsg (L loc flag) 304 = mkPlainErrMsg dflags loc $ 305 (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> 306 text flag) 307 308----------------------------------------------------------------------------- 309 310checkExtension :: DynFlags -> Located FastString -> Located String 311checkExtension dflags (L l ext) 312-- Checks if a given extension is valid, and if so returns 313-- its corresponding flag. Otherwise it throws an exception. 314 = if ext' `elem` supported 315 then L l ("-X"++ext') 316 else unsupportedExtnError dflags l ext' 317 where 318 ext' = unpackFS ext 319 supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags 320 321languagePragParseError :: DynFlags -> SrcSpan -> a 322languagePragParseError dflags loc = 323 throwErr dflags loc $ 324 vcat [ text "Cannot parse LANGUAGE pragma" 325 , text "Expecting comma-separated list of language options," 326 , text "each starting with a capital letter" 327 , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ] 328 329unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a 330unsupportedExtnError dflags loc unsup = 331 throwErr dflags loc $ 332 text "Unsupported extension: " <> text unsup $$ 333 if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) 334 where 335 supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags 336 suggestions = fuzzyMatch unsup supported 337 338 339optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages 340optionsErrorMsgs dflags unhandled_flags flags_lines _filename 341 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) 342 where unhandled_flags_lines :: [Located String] 343 unhandled_flags_lines = [ L l f 344 | f <- unhandled_flags 345 , L l f' <- flags_lines 346 , f == f' ] 347 mkMsg (L flagSpan flag) = 348 GHC.Utils.Error.mkPlainErrMsg dflags flagSpan $ 349 text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag 350 351optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053 352optionsParseError str dflags loc = 353 throwErr dflags loc $ 354 vcat [ text "Error while parsing OPTIONS_GHC pragma." 355 , text "Expecting whitespace-separated list of GHC options." 356 , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}" 357 , text ("Input was: " ++ show str) ] 358 359throwErr :: DynFlags -> SrcSpan -> SDoc -> a -- #15053 360throwErr dflags loc doc = 361 throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc 362