Use the lexer to parse OPTIONS, LANGUAGE and INCLUDE pragmas.
This gives us greater flexibility and far better error
messages. However, I had to make a few quirks:
* The token parser is written manually since Happy doesn't
like lexer errors (we need to extract options before the
buffer is passed through 'cpp'). Still better than
manually parsing a String, though.
* The StringBuffer API has been extended so files can be
read in blocks.
I also made a new field in ModSummary called ms_hspp_opts
which stores the updated DynFlags. Oh, and I took the liberty
of moving 'getImports' into HeaderInfo together with
'getOptions'.
-- DLL building
doMkDLL,
- getOptionsFromStringBuffer, -- used in module GHC
- optionsErrorMsgs, -- ditto
) where
#include "HsVersions.h"
import Packages
-import GetImports
+import HeaderInfo
import DriverPhases
import SysTools ( newTempName, addFilesToClean, getSysMan, copy )
import qualified SysTools
import Ctype ( is_ident )
import StringBuffer ( StringBuffer(..), lexemeToString )
import ParserCoreUtils ( getCoreModuleName )
-import SrcLoc ( srcLocSpan, mkSrcLoc )
+import SrcLoc ( srcLocSpan, mkSrcLoc, unLoc )
import FastString ( mkFastString )
-import Bag ( listToBag, emptyBag )
import SrcLoc ( Located(..) )
import Distribution.Compiler ( extensionsToGHCFlag )
compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do
- let dflags0 = hsc_dflags hsc_env
+ let dflags0 = ms_hspp_opts mod_summary
this_mod = ms_mod mod_summary
src_flavour = ms_hsc_src mod_summary
let location = ms_location mod_summary
let input_fn = expectJust "compile:hs" (ml_hs_file location)
- let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary)
+ let input_fnpp = ms_hspp_file mod_summary
debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
- -- 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 hspp_buf = expectJust "compile:hspp_buf" (ms_hspp_buf mod_summary)
- opts = getOptionsFromStringBuffer hspp_buf input_fn
- (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 (map snd opts)
- if (not (null unhandled_flags))
- then do printErrorsAndWarnings dflags1 (optionsErrorMsgs unhandled_flags opts input_fn)
- return CompErrs
- else do
-
let (basename, _) = splitFilename input_fn
-- We add the directory in which the .hs files resides) to the import path.
-- This is needed when we try to compile the .hc file later, if it
-- imports a _stub.h file that we created here.
let current_dir = directoryOf basename
- old_paths = includePaths dflags1
- dflags = dflags1 { includePaths = current_dir : old_paths }
+ old_paths = includePaths dflags0
+ dflags = dflags0 { includePaths = current_dir : old_paths }
-- Figure out what lang we're generating
let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags)
-- (b) runs cpp if necessary
runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc
- = do src_opts <- getOptionsFromSource input_fn
- (dflags,unhandled_flags) <- parseDynamicFlags dflags0 src_opts
+ = do src_opts <- getOptionsFromFile input_fn
+ (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts)
checkProcessArgsResult unhandled_flags (basename `joinFileExt` suff)
if not (dopt Opt_Cpp dflags) then
-- Some fields are not looked at by hscMain
mod_summary = ModSummary { ms_mod = mod_name,
ms_hsc_src = src_flavour,
- ms_hspp_file = Just input_fn,
+ ms_hspp_file = input_fn,
+ ms_hspp_opts = dflags,
ms_hspp_buf = hspp_buf,
ms_location = location4,
ms_hs_date = src_timestamp,
, "-D__CONCURRENT_HASKELL__"
]
------------------------------------------------------------------------------
--- Reading OPTIONS pragmas
-
--- This is really very ugly and should be rewritten.
--- - some error messages are thrown as exceptions (should return)
--- - we ignore LINE pragmas
--- - parsing is horrible, combination of prefixMatch and 'read'.
-
-getOptionsFromSource
- :: String -- input file
- -> IO [String] -- options, if any
-getOptionsFromSource file
- = do h <- openFile file ReadMode
- look h 1 `finally` hClose h
- where
- look h i = do
- r <- tryJust ioErrors (hGetLine h)
- case r of
- Left e | isEOFError e -> return []
- | otherwise -> ioError e
- Right l' -> do
- let l = removeSpaces l'
- case () of
- () | null l -> look h (i+1)
- | prefixMatch "#" l -> look h (i+1)
- | prefixMatch "{-# LINE" l -> look h (i+1) -- -} wrong!
- | Just opts <- matchOptions i file l
- -> do rest <- look h (i+1)
- return (opts ++ rest)
- | otherwise -> return []
-
-getOptionsFromStringBuffer :: StringBuffer -> FilePath -> [(Int,String)]
-getOptionsFromStringBuffer buffer@(StringBuffer _ len _) fn =
- let
- ls = lines (lexemeToString buffer len) -- lazy, so it's ok
- in
- look 1 ls
- where
- look i [] = []
- look i (l':ls) = do
- let l = removeSpaces l'
- case () of
- () | null l -> look (i+1) ls
- | prefixMatch "#" l -> look (i+1) ls
- | prefixMatch "{-# LINE" l -> look (i+1) ls -- -} wrong!
- | Just opts <- matchOptions i fn l
- -> zip (repeat i) opts ++ look (i+1) ls
- | otherwise -> []
-
--- detect {-# OPTIONS_GHC ... #-}. For the time being, we accept OPTIONS
--- instead of OPTIONS_GHC, but that is deprecated.
-matchOptions i fn s
- | Just s1 <- maybePrefixMatch "{-#" s -- -}
- = matchOptions1 i fn (removeSpaces s1)
- | otherwise
- = Nothing
- where
- matchOptions1 i fn s
- | Just s2 <- maybePrefixMatch "OPTIONS" s
- = case () of
- _ | Just s3 <- maybePrefixMatch "_GHC" s2, not (is_ident (head s3))
- -> matchOptions2 i fn s3
- | not (is_ident (head s2))
- -> matchOptions2 i fn s2
- | otherwise
- -> Just [] -- OPTIONS_anything is ignored, not treated as start of source
- | Just s2 <- maybePrefixMatch "INCLUDE" s, not (is_ident (head s2)),
- Just s3 <- maybePrefixMatch "}-#" (reverse s2)
- = Just ["-#include", removeSpaces (reverse s3)]
-
- | Just s2 <- maybePrefixMatch "LANGUAGE" s, not (is_ident (head s2)),
- Just s3 <- maybePrefixMatch "}-#" (reverse s2)
- = case [ exts | (exts,"") <- reads ('[' : reverse (']':s3))] of
- [] -> languagePragParseError i fn
- exts:_ -> case extensionsToGHCFlag exts of
- ([], opts) -> Just opts
- (unsup,_) -> unsupportedExtnError i fn unsup
- | otherwise = Nothing
- matchOptions2 i fn s
- | Just s3 <- maybePrefixMatch "}-#" (reverse s) = Just (words (reverse s3))
- | otherwise = Nothing
-
-
-languagePragParseError i fn =
- pgmError (showSDoc (mkLocMessage loc (
- text "cannot parse LANGUAGE pragma")))
- where loc = srcLocSpan (mkSrcLoc (mkFastString fn) i 0)
-
-unsupportedExtnError i fn unsup =
- pgmError (showSDoc (mkLocMessage loc (
- text "unsupported extensions: " <>
- hcat (punctuate comma (map (text.show) unsup)))))
- where loc = srcLocSpan (mkSrcLoc (mkFastString fn) i 0)
-
-
-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.
import SrcLoc
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
-import GetImports ( getImports )
+import HeaderInfo ( getImports, getOptions, optionsErrorMsgs )
import Packages ( isHomePackage )
import Finder
import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
-- used to fish out the preprocess output files for the purposes of
-- cleaning up. The preprocessed file *might* be the same as the
-- source file, but that doesn't do any harm.
-ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
+ppFilesFromSummaries summaries = map ms_hspp_file summaries
-- -----------------------------------------------------------------------------
-- Check module
case [ ms | ms <- mg, ms_mod ms == mod ] of
[] -> return Nothing
(ms:_) -> do
- -- 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)
- filename = expectJust "checkModule" (ml_hs_file (ms_location ms))
- opts = getOptionsFromStringBuffer hspp_buf filename
- (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
- if (not (null leftovers))
- then do printErrorsAndWarnings dflags1 (optionsErrorMsgs leftovers opts filename)
- return Nothing
- else do
-
- mbChecked <- hscFileCheck hsc_env{hsc_dflags=dflags1} ms
+ mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
case mbChecked of
Nothing -> return Nothing
Just (HscChecked parsed renamed Nothing) ->
return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
ms_location = location,
- ms_hspp_file = Just hspp_fn,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
ms_hspp_buf = Just buf,
ms_srcimps = srcimps, ms_imps = the_imps,
ms_hs_date = src_timestamp,
return (Just ( ModSummary { ms_mod = wanted_mod,
ms_hsc_src = hsc_src,
ms_location = location,
- ms_hspp_file = Just hspp_fn,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
ms_hspp_buf = Just buf,
ms_srcimps = srcimps,
ms_imps = the_imps,
= do
-- case we bypass the preprocessing stage?
let
- local_opts = getOptionsFromStringBuffer buf src_fn
+ local_opts = getOptions buf src_fn
--
- (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
+ (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
let
needs_preprocessing
+++ /dev/null
------------------------------------------------------------------------------
---
--- Parsing the top of a Haskell source file to get its module name
--- and imports.
---
--- (c) Simon Marlow 2005
---
------------------------------------------------------------------------------
-
-module GetImports ( getImportsFromFile, getImports ) where
-
-#include "HsVersions.h"
-
-import Parser ( parseHeader )
-import Lexer ( P(..), ParseResult(..), mkPState )
-import HsSyn ( ImportDecl(..), HsModule(..) )
-import Module ( Module, mkModule )
-import PrelNames ( gHC_PRIM )
-import StringBuffer ( StringBuffer, hGetStringBuffer )
-import SrcLoc ( Located(..), mkSrcLoc, unLoc, noSrcSpan )
-import FastString ( mkFastString )
-import DynFlags ( DynFlags )
-import ErrUtils
-import Pretty
-import Panic
-import Bag ( unitBag )
-
-import EXCEPTION ( throwDyn )
-import IO
-import List
-
--- 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
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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
+
-------------------
-- PARSE
-------------------
- inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
+ inp <- readFile (ms_hspp_file mod_summary)
case parseCore inp 1 of
FailP s
-> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-})
-- PARSE
-------------------
let dflags = hsc_dflags hsc_env
- hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
+ hspp_file = ms_hspp_file mod_summary
hspp_buf = ms_hspp_buf mod_summary
maybe_parsed <- myParseModule dflags hspp_file hspp_buf
case maybe_parsed of
-- PARSE
-------------------
; let dflags = hsc_dflags hsc_env
- hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
+ hspp_file = ms_hspp_file mod_summary
hspp_buf = ms_hspp_buf mod_summary
; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
ms_obj_date :: Maybe ClockTime, -- Timestamp of object, maybe
ms_srcimps :: [Located Module], -- Source imports
ms_imps :: [Located Module], -- Non-source imports
- ms_hspp_file :: Maybe FilePath, -- Filename of preprocessed source,
- -- once we have preprocessed it.
- ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe.
+ ms_hspp_file :: FilePath, -- Filename of preprocessed source.
+ ms_hspp_opts :: DynFlags, -- Cached flags from OPTIONS, INCLUDE
+ -- and LANGUAGE pragmas.
+ ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe.
}
-- The ModLocation contains both the original source filename and the
FunDeps
GHC
Generics
- GetImports
+ HeaderInfo
HsBinds
HsDecls
HsExpr
{
module Lexer (
- Token(..), lexer, mkPState, PState(..),
+ Token(..), lexer, pragState, mkPState, PState(..),
P(..), ParseResult(..), getSrcLoc,
failLocMsgP, failSpanMsgP, srcParseFail,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
-- generate a matching '}' token.
<layout_left> () { do_layout_left }
-<0,glaexts> \n { begin bol }
+<0,option_prags,glaexts> \n { begin bol }
"{-#" $whitechar* (line|LINE) { begin line_prag2 }
<glaexts>
"{-#" $whitechar* (RULES|rules) { token ITrules_prag }
-<0,glaexts> {
+<0,option_prags,glaexts> {
"{-#" $whitechar* (INLINE|inline) { token (ITinline_prag True) }
"{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
{ token (ITinline_prag False) }
"{-#" $whitechar* (SCC|scc) { token ITscc_prag }
"{-#" $whitechar* (CORE|core) { token ITcore_prag }
"{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag }
-
+
"{-#" { nested_comment }
-- ToDo: should only be valid inside a pragma:
"#-}" { token ITclose_prag}
}
+<option_prags> {
+ "{-#" $whitechar* (OPTIONS|options) { lex_string_prag IToptions_prag }
+ "{-#" $whitechar* (OPTIONS_GHC|options_ghc)
+ { lex_string_prag IToptions_prag }
+ "{-#" $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
+ "{-#" $whitechar* (INCLUDE|include) { lex_string_prag ITinclude_prag }
+}
-- '0' state: ordinary lexemes
-- 'glaexts' state: glasgow extensions (postfix '#', etc.)
"|}" { token ITccurlybar }
}
-<0,glaexts> {
+<0,option_prags,glaexts> {
\( { special IToparen }
\) { special ITcparen }
\[ { special ITobrack }
\} { close_brace }
}
-<0,glaexts> {
+<0,option_prags,glaexts> {
@qual @varid { check_qvarid }
@qual @conid { idtoken qconid }
@varid { varid }
| ITcore_prag -- hdaume: core annotations
| ITunpack_prag
| ITclose_prag
+ | IToptions_prag String
+ | ITinclude_prag String
+ | ITlanguage_prag
| ITdotdot -- reserved symbols
| ITcolon
pushLexState code
lexToken
+
+-- -----------------------------------------------------------------------------
+-- Options, includes and language pragmas.
+
+lex_string_prag :: (String -> Token) -> Action
+lex_string_prag mkTok span buf len
+ = do input <- getInput
+ start <- getSrcLoc
+ tok <- go [] input
+ end <- getSrcLoc
+ return (L (mkSrcSpan start end) tok)
+ where go acc input
+ = if isString input "#-}"
+ then do setInput input
+ return (mkTok (reverse acc))
+ else case alexGetChar input of
+ Just (c,i) -> go (c:acc) i
+ Nothing -> err input
+ isString i [] = True
+ isString i (x:xs)
+ = case alexGetChar i of
+ Just (c,i') | c == x -> isString i' xs
+ _other -> False
+ err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
+
+
-- -----------------------------------------------------------------------------
-- Strings & Chars
tvEnabled flags = testBit flags tvBit
bangPatEnabled flags = testBit flags bangPatBit
+-- PState for parsing options pragmas
+--
+pragState :: StringBuffer -> SrcLoc -> PState
+pragState buf loc =
+ PState {
+ buffer = buf,
+ last_loc = mkSrcSpan loc loc,
+ last_offs = 0,
+ last_len = 0,
+ loc = loc,
+ extsBitmap = 0,
+ context = [],
+ lex_state = [bol, option_prags, 0]
+ }
+
+
-- create a parse state
--
mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
-- * Creation\/destruction
hGetStringBuffer,
+ hGetStringBufferBlock,
+ appendStringBuffers,
stringToStringBuffer,
-- * Inspection
import FastString ( FastString,mkFastString,mkFastStringBytes )
import Foreign
-import System.IO ( hGetBuf, hFileSize,IOMode(ReadMode), hClose )
+import System.IO ( hGetBuf, hFileSize,IOMode(ReadMode), hClose
+ , Handle, hTell )
import GHC.Ptr ( Ptr(..) )
import GHC.Exts
-- sentinels for UTF-8 decoding
return (StringBuffer buf size 0)
+hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer
+hGetStringBufferBlock handle wanted
+ = do size_i <- hFileSize handle
+ offset_i <- hTell handle
+ let size = min wanted (fromIntegral $ size_i-offset_i)
+ buf <- mallocForeignPtrArray (size+3)
+ withForeignPtr buf $ \ptr ->
+ do r <- if size == 0 then return 0 else hGetBuf handle ptr size
+ if r /= size
+ then ioError (userError $ "short read of file: "++show(r,size,fromIntegral size_i,handle))
+ else do pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]
+ return (StringBuffer buf size 0)
+
+appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer
+appendStringBuffers sb1 sb2
+ = do newBuf <- mallocForeignPtrArray (size+3)
+ withForeignPtr newBuf $ \ptr ->
+ withForeignPtr (buf sb1) $ \sb1Ptr ->
+ withForeignPtr (buf sb2) $ \sb2Ptr ->
+ do copyArray (sb1Ptr `advancePtr` cur sb1) ptr (calcLen sb1)
+ copyArray (sb2Ptr `advancePtr` cur sb2) (ptr `advancePtr` cur sb1) (calcLen sb2)
+ pokeArray (ptr `advancePtr` size) [0,0,0]
+ return (StringBuffer newBuf size 0)
+ where calcLen sb = len sb - cur sb
+ size = calcLen sb1 + calcLen sb2
+
stringToStringBuffer :: String -> IO StringBuffer
stringToStringBuffer str = do
let size = utf8EncodedLength str
projects / ghc-hetmet.git / commitdiff