Skip to content

Commit 06a2a32

Browse files
alanzalanz
committed
Feed preset macros into the pragma parsing too
With matching changes on the GHC side
1 parent 82547be commit 06a2a32

File tree

1 file changed

+156
-5
lines changed

1 file changed

+156
-5
lines changed

‎src/Language/Haskell/GHC/ExactPrint/Parsers.hs‎

Lines changed: 156 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -51,12 +51,14 @@ import Language.Haskell.GHC.ExactPrint.Preprocess
5151

5252
import Data.Functor (void)
5353
import Data.IORef
54+
import System.IO
5455
import System.IO.Unsafe
5556
import qualified Data.Map as Map
5657
import Data.Maybe
5758

5859
import qualified GHC hiding (parseModule)
5960
import qualified Control.Monad.IO.Class as GHC
61+
import qualified GHC.Data.Bag as GHC
6062
import qualified GHC.Data.FastString as GHC
6163
import qualified GHC.Data.StringBuffer as GHC
6264
import qualified GHC.Driver.Config.Diagnostic as GHC
@@ -66,14 +68,21 @@ import qualified GHC.Driver.Errors.Types as GHC
6668
import qualified GHC.Driver.Session as GHC
6769
import qualified GHC.Parser as GHC
6870
import qualified GHC.Parser.Header as GHC
69-
import qualified GHC.Parser.Lexer as GHC hiding (initParserState)
71+
import qualified GHC.Parser.Lexer as GHC hiding (initParserState, initPragState,lexer)
7072
import qualified GHC.Parser.PreProcess.State as GHC
7173
import qualified GHC.Parser.PostProcess as GHC
74+
import qualified GHC.Types.Error as GHC
7275
import qualified GHC.Types.SrcLoc as GHC
76+
import qualified GHC.Unit.Env as GHC
77+
import qualified GHC.Utils.Misc as GHC
78+
import qualified GHC.Parser.Lexer as Lexer
7379

80+
81+
import GHC.Utils.Exception as Exception
7482
import qualified GHC.LanguageExtensions as LangExt
7583
import qualified GHC.Parser.PreProcess as GHC
7684
import GHC (GhcMonad(getSession))
85+
import Debug.Trace
7786

7887
-- ---------------------------------------------------------------------
7988

@@ -115,9 +124,9 @@ runParser parser flags filename str = GHC.unP parser parseState
115124
-- parseState = GHC.initParserState (GHC.initParserOpts flags) buffer location
116125
-- parseState = GHC.initParserStateWithMacros flags Nothing (GHC.initParserOpts flags) buffer location
117126

118-
-- TODO: precompute the macros first, store them in an IORef
119-
-- macros = Nothing
120-
macros = fromMaybe Map.empty macrosFromIORef
127+
-- macros = fromMaybe Map.empty macrosFromIORef
128+
macros = fromMaybe (error "macroIORef not set up") macrosFromIORef
129+
121130
-- opts0 = GHC.initParserOpts flags
122131
-- opts1 = GHC.enableExtBit GHC.UsePosPragsBit opts0
123132
-- opts = opts1
@@ -438,7 +447,8 @@ initDynFlags useGhcCpp file = do
438447
let logger = GHC.hsc_logger hsc
439448
let unit_env = GHC.hsc_unit_env hsc
440449
let supported_pragmas = "JavaScriptFFI" : GHC.supportedLanguagePragmas dflags0
441-
(_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 unit_env parser_opts0 supported_pragmas file
450+
(_, src_opts) <- GHC.liftIO $ myGetOptionsFromFile dflags0 unit_env parser_opts0 supported_pragmas file
451+
-- error $ "initDynFlags:src_opts: " ++ show (map GHC.unLoc src_opts)
442452
(dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 src_opts
443453
-- Turn this on last to avoid T10942
444454
let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
@@ -481,3 +491,144 @@ initDynFlagsPure fp s = do
481491
return dflags3
482492

483493
-- ---------------------------------------------------------------------
494+
495+
myGetOptionsFromFile :: GHC.DynFlags
496+
-> GHC.UnitEnv
497+
-> GHC.ParserOpts
498+
-> [String] -- ^ Supported LANGUAGE pragmas
499+
-> FilePath -- ^ Input file
500+
-> IO (GHC.Messages GHC.PsMessage, [GHC.Located String]) -- ^ Parsed options, if any.
501+
myGetOptionsFromFile df unit_env popts supported filename
502+
= Exception.bracket
503+
(openBinaryFile filename ReadMode)
504+
(hClose)
505+
(\handle -> do
506+
(warns, opts) <- fmap (GHC.getOptions' popts supported)
507+
(myGetPragState df unit_env popts' filename handle
508+
-- >>= \prag_state -> traceToks <$> GHC.lazyGetToks prag_state handle)
509+
>>= \prag_state -> GHC.lazyGetToks prag_state handle)
510+
GHC.seqList opts
511+
$ GHC.seqList (GHC.bagToList $ GHC.getMessages warns)
512+
$ return (warns, opts))
513+
where -- We don't need to get haddock doc tokens when we're just
514+
-- getting the options from pragmas, and lazily lexing them
515+
-- correctly is a little tricky: If there is "\n" or "\n-"
516+
-- left at the end of a buffer then the haddock doc may
517+
-- continue past the end of the buffer, despite the fact that
518+
-- we already have an apparently-complete token.
519+
-- We therefore just turn Opt_Haddock off when doing the lazy
520+
-- lex.
521+
popts' = GHC.disableHaddock popts
522+
523+
blockSize :: Int
524+
-- blockSize = 17 -- for testing :-)
525+
blockSize = 1024
526+
527+
myGetPragState :: GHC.DynFlags -> GHC.UnitEnv -> GHC.ParserOpts -> FilePath -> Handle -> IO (GHC.PState GHC.PpState)
528+
myGetPragState df unit_env popts filename handle = do
529+
buf <- GHC.hGetStringBufferBlock handle blockSize
530+
531+
let macros = fromMaybe (error "macroIORef not set up") macrosFromIORef
532+
533+
-- opts0 = GHC.initParserOpts flags
534+
-- opts1 = GHC.enableExtBit GHC.UsePosPragsBit opts0
535+
-- opts = opts1
536+
let popts = myInitParserOpts df
537+
let loc = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
538+
let prag_state = if Lexer.ghcCppEnabled popts
539+
then GHC.initPragStateWithMacros df unit_env popts buf loc
540+
else GHC.initPragState popts buf loc
541+
return prag_state { GHC.pp = (GHC.pp prag_state) { GHC.pp_defines = macros }
542+
, GHC.buffer = buf }
543+
544+
545+
-- getOptions :: ParserOpts
546+
-- -> [String] -- ^ Supported LANGUAGE pragmas
547+
-- -> StringBuffer -- ^ Input Buffer
548+
-- -> FilePath -- ^ Source filename. Used for location info.
549+
-- -> (Messages PsMessage,[Located String]) -- ^ warnings and parsed options.
550+
-- getOptions opts supported buf filename
551+
-- = getOptions' opts supported (getToks opts filename buf)
552+
-- myGetOptions :: GHC.ParserOpts
553+
-- -> [String] -- ^ Supported LANGUAGE pragmas
554+
-- -> GHC.StringBuffer -- ^ Input Buffer
555+
-- -> FilePath -- ^ Source filename. Used for location info.
556+
-- -> (GHC.Messages GHC.PsMessage,[GHC.Located String]) -- ^ warnings and parsed options.
557+
-- myGetOptions opts supported buf filename
558+
-- = GHC.getOptions' opts supported (myGetToks opts filename buf)
559+
560+
-- getOptions' :: GHC.ParserOpts
561+
-- -> [String]
562+
-- -> [GHC.Located GHC.Token] -- Input buffer
563+
-- -> (GHC.Messages GHC.PsMessage,[GHC.Located String]) -- Options.
564+
-- getOptions' opts supported toks =
565+
-- error $ "getOptions': toks " ++ show toks
566+
567+
traceToks :: [GHC.Located GHC.Token] -> [GHC.Located GHC.Token]
568+
traceToks [] = []
569+
traceToks (h:t) = trace ("tok: " ++ show (GHC.unLoc h)) h : traceToks t
570+
571+
572+
-- getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
573+
-- getToks popts filename buf = lexAll pstate
574+
-- where
575+
-- pstate = initPragState popts buf loc
576+
-- loc = mkRealSrcLoc (mkFastString filename) 1 1
577+
578+
-- lexAll state = case unP (lexer False return) state of
579+
-- POk _ t@(L _ ITeof) -> [t]
580+
-- POk state' t -> t : lexAll state'
581+
-- _ -> [L (mkSrcSpanPs (last_loc state)) ITeof]
582+
583+
-- lazyGetToks :: DynFlags -> UnitEnv -> ParserOpts -> FilePath -> Handle -> IO [Located Token]
584+
-- lazyGetToks df unit_env popts filename handle = do
585+
-- buf <- hGetStringBufferBlock handle blockSize
586+
-- let prag_state = if Lexer.ghcCppEnabled popts
587+
-- then initPragStateWithMacros df unit_env popts buf loc
588+
-- else initPragState popts buf loc
589+
-- unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize
590+
-- where
591+
-- loc = mkRealSrcLoc (mkFastString filename) 1 1
592+
593+
-- ....
594+
595+
myGetToks :: GHC.DynFlags -> GHC.UnitEnv -> GHC.ParserOpts -> FilePath -> Handle -> IO [GHC.Located GHC.Token]
596+
myGetToks df unit_env popts filename handle = do
597+
buf <- GHC.hGetStringBufferBlock handle blockSize
598+
let loc = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
599+
let prag_state = if Lexer.ghcCppEnabled popts
600+
then GHC.initPragStateWithMacros df unit_env popts buf loc
601+
else GHC.initPragState popts buf loc
602+
-- GHC.getToks popts filename buf
603+
return $ lexAll prag_state
604+
where
605+
lexAll state = case GHC.unP (GHC.lexer False return) state of
606+
GHC.POk _ t@(GHC.L _ GHC.ITeof) -> [t]
607+
GHC.POk state' t -> t : lexAll state'
608+
_ -> [GHC.L (GHC.mkSrcSpanPs (GHC.last_loc state)) GHC.ITeof]
609+
610+
611+
-- getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
612+
-- getToks popts filename buf = lexAll pstate
613+
-- where
614+
-- pstate = initPragState popts buf loc
615+
-- loc = mkRealSrcLoc (mkFastString filename) 1 1
616+
617+
-- lexAll state = case unP (lexer False return) state of
618+
-- POk _ t@(L _ ITeof) -> [t]
619+
-- POk state' t -> t : lexAll state'
620+
-- _ -> [L (mkSrcSpanPs (last_loc state)) ITeof]
621+
622+
623+
-- doGetToks :: GHC.ParserOpts -> FilePath -> GHC.StringBuffer -> [GHC.Located GHC.Token]
624+
-- doGetToks popts filename buf = lexAll pstate
625+
-- where
626+
-- pstate = initPragState popts buf loc
627+
-- loc = mkRealSrcLoc (mkFastString filename) 1 1
628+
629+
-- lexAll state = case unP (lexer False return) state of
630+
-- GHC.POk _ t@(GHC.L _ GHC.ITeof) -> [t]
631+
-- GHC.POk state' t -> t : lexAll state'
632+
-- _ -> [L (mkSrcSpanPs (last_loc state)) GHC.ITeof]
633+
634+
-- ---------------------------------------------------------------------

0 commit comments

Comments
 (0)