#3645: Layout and pragmas
--------------------------------+-------------------------------------------
Reporter: igloo | Owner:
Type: feature request | Status: new
Priority: normal | Milestone: 7.4.1
Component: Compiler (Parser) | Version: 6.10.4
Resolution: | Keywords:
Testcase: | Blockedby:
Difficulty: Unknown | Os: Unknown/Multiple
Blocking: | Architecture: Unknown/Multiple
Failure: None/Unknown |
--------------------------------+-------------------------------------------
Changes (by igloo):
* milestone: 7.2.1 => 7.4.1
Comment:
One possibility is something along these lines:
{{{
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index a3f7e79..738f4f8 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -39,6 +39,7 @@ import Exception
import Control.Monad
import System.IO
import System.IO.Unsafe
+import Data.Char
import Data.List
------------------------------------------------------------------------------
@@ -227,24 +228,31 @@ getOptions' toks
| ITdocOptionsOld str <- getToken open
= map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
++ parseToks xs
- parseToks (open:xs)
- | ITlanguage_prag <- getToken open
- = parseLanguage xs
+ parseToks (open:close:xs)
+ | ITlanguage_prag str <- getToken open
+ , ITclose_prag <- getToken close
+ = parseLanguage (getLoc open) str
+ ++ parseToks xs
parseToks (x:xs)
| ITdocCommentNext _ <- getToken x
= parseToks xs
parseToks _ = []
- parseLanguage (L loc (ITconid fs):rest)
- = checkExtension (L loc fs) :
- case rest of
- (L _loc ITcomma):more -> parseLanguage more
- (L _loc ITclose_prag):more -> parseToks more
- (L loc _):_ -> languagePragParseError loc
- [] -> panic "getOptions'.parseLanguage(1) went past eof
token
- parseLanguage (tok:_)
- = languagePragParseError (getLoc tok)
- parseLanguage []
- = panic "getOptions'.parseLanguage(2) went past eof token"
+
+ parseLanguage loc str
+ = map (checkExtension loc) $ splits (dropWhile isSpace str)
+ where isSepChar c = isSpace c || c == ','
+ splits [] = languagePragParseError loc
+ splits (',' : _) = languagePragParseError loc
+ splits xs0 = case break isSepChar xs0 of
+ (extension, xs1) ->
+ extension
+ : (case dropWhile isSpace xs1 of
+ ',' : xs2 ->
+ splits (dropWhile isSpace xs2)
+ [] ->
+ []
+ _ ->
+ languagePragParseError loc)
-----------------------------------------------------------------------------
@@ -263,14 +271,13 @@ checkProcessArgsResult flags
-----------------------------------------------------------------------------
-checkExtension :: Located FastString -> Located String
-checkExtension (L l ext)
+checkExtension :: SrcSpan -> String -> Located String
+checkExtension l ext
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
- = let ext' = unpackFS ext in
- if ext' `elem` supportedLanguagesAndExtensions
- then L l ("-X"++ext')
- else unsupportedExtnError l ext'
+ = if ext `elem` supportedLanguagesAndExtensions
+ then L l ("-X" ++ ext)
+ else unsupportedExtnError l ext
languagePragParseError :: SrcSpan -> a
languagePragParseError loc =
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 90e1e66..754247b 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -480,7 +480,7 @@ data Token
| ITclose_prag
| IToptions_prag String
| ITinclude_prag String
- | ITlanguage_prag
+ | ITlanguage_prag String
| ITvect_prag
| ITvect_scalar_prag
| ITnovect_prag
@@ -2233,7 +2233,7 @@ linePrags = Map.singleton "line" (begin line_prag2)
fileHeaderPrags = Map.fromList([("options", lex_string_prag
IToptions_prag),
("options_ghc", lex_string_prag
IToptions_prag
("options_haddock", lex_string_prag
ITdocOptio
- ("language", token ITlanguage_prag),
+ ("language", lex_string_prag
ITlanguage_prag),
("include", lex_string_prag
ITinclude_prag)])
ignoredPrags = Map.fromList (map ignored pragmas)
}}}
This handles LANGUAGE in the same way we handle OPTIONS, just reading the
contents as a String, and happily gets rids of a couple of panics in the
process.
However, locations are slightly worse (as we don't have locations for the
individual extensions), and you can no longer have nested pragmas or
comments. This might be OK, except that currently hsc2hs turns
{{{
{-# LANGUAGE CPP
, ForeignFunctionInterface
, GeneralizedNewtypeDeriving
, NoImplicitPrelude
, BangPatterns
#-}
}}}
in `libraries/base/GHC/Event/EPoll.hsc` into
{{{
{-# LINE 1 "libraries/base/./GHC/Event/EPoll.hsc" #-}
{-# LANGUAGE CPP
{-# LINE 2 "libraries/base/./GHC/Event/EPoll.hsc" #-}
, ForeignFunctionInterface
, GeneralizedNewtypeDeriving
, NoImplicitPrelude
, BangPatterns
#-}
}}}
--
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/3645#comment:14>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler
_______________________________________________
Glasgow-haskell-bugs mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs
