From 44eaf25ca41ba4ec730a4d02ecf3dc4592714908 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 19 Apr 2005 15:28:35 +0000 Subject: [PATCH] [project @ 2005-04-19 15:28:35 by simonmar] - DriverPipeline.compile: report errors in GHC_OPTIONS pragmas using the Message callback, and give them a proper line number. - GHC.checkModule: read the GHC_OPTIONS pragma, and report errors appropriately. --- ghc/compiler/main/DriverPipeline.hs | 42 ++++++++++++++++++++++++++--------- ghc/compiler/main/GHC.hs | 22 +++++++++++++++--- 2 files changed, 50 insertions(+), 14 deletions(-) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index c36e008..20487c4 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -22,7 +22,8 @@ module DriverPipeline ( -- DLL building doMkDLL, - getOptionsFromStringBuffer, -- used in module GHC + getOptionsFromStringBuffer, -- used in module GHC + optionsErrorMsgs, -- ditto ) where #include "HsVersions.h" @@ -50,6 +51,9 @@ import Maybes ( expectJust ) import Ctype ( is_ident ) import StringBuffer ( StringBuffer(..), lexemeToString ) import ParserCoreUtils ( getCoreModuleName ) +import SrcLoc ( srcLocSpan, mkSrcLoc ) +import FastString ( mkFastString ) +import Bag ( listToBag, emptyBag ) import EXCEPTION import DATA_IOREF ( readIORef, writeIORef, IORef ) @@ -127,8 +131,11 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods -- It might be better to cache the flags in the ml_hspp_file field,say let hspp_buf = expectJust "compile:hspp_buf" (ms_hspp_buf mod_summary) opts = getOptionsFromStringBuffer hspp_buf - (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 opts - checkProcessArgsResult unhandled_flags input_fn + (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 (map snd opts) + if (not (null unhandled_flags)) + then do msg_act (optionsErrorMsgs unhandled_flags opts input_fn) + return CompErrs + else do let (basename, _) = splitFilename input_fn @@ -1307,22 +1314,22 @@ getOptionsFromSource file return (opts ++ rest) | otherwise -> return [] -getOptionsFromStringBuffer :: StringBuffer -> [String] +getOptionsFromStringBuffer :: StringBuffer -> [(Int,String)] getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) = let ls = lines (lexemeToString buffer (I# len#)) -- lazy, so it's ok in - look ls + look 1 ls where - look [] = [] - look (l':ls) = do + look i [] = [] + look i (l':ls) = do let l = removeSpaces l' case () of - () | null l -> look ls - | prefixMatch "#" l -> look ls - | prefixMatch "{-# LINE" l -> look ls -- -} + () | null l -> look (i+1) ls + | prefixMatch "#" l -> look (i+1) ls + | prefixMatch "{-# LINE" l -> look (i+1) ls -- -} | Just opts <- matchOptions l - -> opts ++ look ls + -> zip (repeat i) opts ++ look (i+1) ls | otherwise -> [] -- detect {-# OPTIONS_GHC ... #-}. For the time being, we accept OPTIONS @@ -1351,6 +1358,19 @@ matchOptions s | otherwise = Nothing +optionsErrorMsgs :: [String] -> [(Int,String)] -> FilePath -> Messages +optionsErrorMsgs unhandled_flags flags_lines filename + = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) + where + unhandled_flags_lines = [ (l,f) | f <- unhandled_flags, + (l,f') <- flags_lines, f == f' ] + mkMsg (line,flag) = + ErrUtils.mkPlainErrMsg (srcLocSpan loc) $ + text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag + where + loc = mkSrcLoc (mkFastString filename) line 0 + -- ToDo: we need a better SrcSpan here + -- ----------------------------------------------------------------------------- -- Misc. diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 215b381..7ba62c4 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -155,7 +155,7 @@ import DataCon ( DataCon ) import Name ( Name, getName, nameModule_maybe ) import RdrName ( RdrName, gre_name, globalRdrEnvElts ) import NameEnv ( nameEnvElts ) -import SrcLoc ( Located(..) ) +import SrcLoc ( Located(..), mkSrcLoc, srcLocSpan ) import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import GetImports ( getImports ) @@ -179,6 +179,8 @@ import SysTools ( cleanTempFilesExcept ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Maybes ( orElse, expectJust, mapCatMaybes ) import TcType ( tcSplitSigmaTy, isDictTy ) +import Bag ( unitBag, emptyBag ) +import FastString ( mkFastString ) import Directory ( getModificationTime, doesFileExist ) import Maybe ( isJust, isNothing, fromJust, fromMaybe, catMaybes ) @@ -652,7 +654,21 @@ checkModule session@(Session ref) mod msg_act = do case [ ms | ms <- mg, ms_mod ms == mod ] of [] -> return Nothing (ms:_) -> do - r <- hscFileCheck hsc_env msg_act ms + -- Add in the OPTIONS from the source file This is nasty: + -- we've done this once already, in the compilation manager + -- It might be better to cache the flags in the + -- ml_hspp_file field, say + let dflags0 = hsc_dflags hsc_env + hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms) + opts = getOptionsFromStringBuffer hspp_buf + (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts) + if (not (null leftovers)) + then do let filename = fromJust (ml_hs_file (ms_location ms)) + msg_act (optionsErrorMsgs leftovers opts filename) + return Nothing + else do + + r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms case r of HscFail -> return Nothing @@ -1398,7 +1414,7 @@ preprocessFile dflags src_fn (Just (buf, time)) let local_opts = getOptionsFromStringBuffer buf -- - (dflags', errs) <- parseDynamicFlags dflags local_opts + (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts) let needs_preprocessing -- 1.7.10.4