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