{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.GHC.ExactPrint.Preprocess
(
stripLinePragmas
, getCppTokensAsComments
, getPreprocessedSrcDirect
, readFileGhc
, CppOptions(..)
, defaultCppOptions
) where
import qualified GHC as GHC hiding (parseModule)
#if __GLASGOW_HASKELL__ >= 900
import qualified Control.Monad.IO.Class as GHC
import qualified GHC.Data.Bag as GHC
import qualified GHC.Data.FastString as GHC
import qualified GHC.Data.StringBuffer as GHC
import qualified GHC.Driver.Phases as GHC
import qualified GHC.Driver.Pipeline as GHC
import qualified GHC.Driver.Types as GHC
import qualified GHC.Fingerprint.Type as GHC
import qualified GHC.Utils.Fingerprint as GHC
import qualified GHC.Parser.Lexer as GHC
import qualified GHC.Settings as GHC
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Error as GHC
import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc)
import GHC.Data.FastString (mkFastString)
#else
import qualified Bag as GHC
import qualified DriverPhases as GHC
import qualified DriverPipeline as GHC
import qualified DynFlags as GHC
import qualified ErrUtils as GHC
import qualified FastString as GHC
import qualified HscTypes as GHC
import qualified Lexer as GHC
import qualified MonadUtils as GHC
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
import SrcLoc (mkSrcSpan, mkSrcLoc)
import FastString (mkFastString)
#endif
#if (__GLASGOW_HASKELL__ > 808) && (__GLASGOW_HASKELL__ < 900)
import qualified Fingerprint as GHC
import qualified ToolSettings as GHC
#endif
#if __GLASGOW_HASKELL__ > 808
#else
import Control.Exception
#endif
import Data.List hiding (find)
import Data.Maybe
#if __GLASGOW_HASKELL__ <= 800
import Language.Haskell.GHC.ExactPrint.GhcInterim (commentToAnnotation)
#endif
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils
import qualified Data.Set as Set
{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
data CppOptions = CppOptions
{ CppOptions -> [String]
cppDefine :: [String]
, CppOptions -> [String]
cppInclude :: [FilePath]
, CppOptions -> [String]
cppFile :: [FilePath]
}
defaultCppOptions :: CppOptions
defaultCppOptions :: CppOptions
defaultCppOptions = [String] -> [String] -> [String] -> CppOptions
CppOptions [] [] []
stripLinePragmas :: String -> (String, [Comment])
stripLinePragmas :: String -> (String, [Comment])
stripLinePragmas = ([String], [Maybe Comment]) -> (String, [Comment])
forall a. ([String], [Maybe a]) -> (String, [a])
unlines' (([String], [Maybe Comment]) -> (String, [Comment]))
-> (String -> ([String], [Maybe Comment]))
-> String
-> (String, [Comment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Maybe Comment)] -> ([String], [Maybe Comment])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(String, Maybe Comment)] -> ([String], [Maybe Comment]))
-> (String -> [(String, Maybe Comment)])
-> String
-> ([String], [Maybe Comment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [(String, Maybe Comment)]
findLines ([String] -> [(String, Maybe Comment)])
-> (String -> [String]) -> String -> [(String, Maybe Comment)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
where
unlines' :: ([String], [Maybe a]) -> (String, [a])
unlines' ([String]
a, [Maybe a]
b) = ([String] -> String
unlines [String]
a, [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes [Maybe a]
b)
findLines :: [String] -> [(String, Maybe Comment)]
findLines :: [String] -> [(String, Maybe Comment)]
findLines = (Int -> String -> (String, Maybe Comment))
-> [Int] -> [String] -> [(String, Maybe Comment)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> String -> (String, Maybe Comment)
checkLine [Int
1..]
checkLine :: Int -> String -> (String, Maybe Comment)
checkLine :: Int -> String -> (String, Maybe Comment)
checkLine Int
line String
s
| String
"{-# LINE" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s =
let (String
pragma, String
res) = String -> (String, String)
getPragma String
s
size :: Int
size = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pragma
mSrcLoc :: Int -> Int -> SrcLoc
mSrcLoc = FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
mkFastString String
"LINE")
ss :: SrcSpan
ss = SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (Int -> Int -> SrcLoc
mSrcLoc Int
line Int
1) (Int -> Int -> SrcLoc
mSrcLoc Int
line (Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
in (String
res, Comment -> Maybe Comment
forall a. a -> Maybe a
Just (Comment -> Maybe Comment) -> Comment -> Maybe Comment
forall a b. (a -> b) -> a -> b
$ String -> SrcSpan -> Comment
mkComment String
pragma (SrcSpan -> SrcSpan
rs SrcSpan
ss))
| String
"#!" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s =
let mSrcLoc :: Int -> Int -> SrcLoc
mSrcLoc = FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
mkFastString String
"SHEBANG")
ss :: SrcSpan
ss = SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (Int -> Int -> SrcLoc
mSrcLoc Int
line Int
1) (Int -> Int -> SrcLoc
mSrcLoc Int
line (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s))
in
(String
"",Comment -> Maybe Comment
forall a. a -> Maybe a
Just (Comment -> Maybe Comment) -> Comment -> Maybe Comment
forall a b. (a -> b) -> a -> b
$ String -> SrcSpan -> Comment
mkComment String
s (SrcSpan -> SrcSpan
rs SrcSpan
ss))
| Bool
otherwise = (String
s, Maybe Comment
forall a. Maybe a
Nothing)
getPragma :: String -> (String, String)
getPragma :: String -> (String, String)
getPragma [] = String -> (String, String)
forall a. HasCallStack => String -> a
error String
"Input must not be empty"
getPragma s :: String
s@(Char
x:String
xs)
| String
"#-}" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = (String
"#-}", String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
3 String
s)
| Bool
otherwise =
let (String
prag, String
remline) = String -> (String, String)
getPragma String
xs
in (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
prag, Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
remline)
getCppTokensAsComments :: GHC.GhcMonad m
=> CppOptions
-> FilePath
-> m [Comment]
CppOptions
cppOptions String
sourceFile = do
StringBuffer
source <- IO StringBuffer -> m StringBuffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO StringBuffer -> m StringBuffer)
-> IO StringBuffer -> m StringBuffer
forall a b. (a -> b) -> a -> b
$ String -> IO StringBuffer
GHC.hGetStringBuffer String
sourceFile
let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (String -> FastString
GHC.mkFastString String
sourceFile) Int
1 Int
1
(String
_txt,StringBuffer
strSrcBuf,DynFlags
flags2) <- CppOptions -> String -> m (String, StringBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
CppOptions -> String -> m (String, StringBuffer, DynFlags)
getPreprocessedSrcDirectPrim CppOptions
cppOptions String
sourceFile
[(Located Token, String)]
directiveToks <- IO [(Located Token, String)] -> m [(Located Token, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO [(Located Token, String)] -> m [(Located Token, String)])
-> IO [(Located Token, String)] -> m [(Located Token, String)]
forall a b. (a -> b) -> a -> b
$ String -> IO [(Located Token, String)]
getPreprocessorAsComments String
sourceFile
[(Located Token, String)]
nonDirectiveToks <- RealSrcLoc
-> DynFlags -> StringBuffer -> m [(Located Token, String)]
forall (m :: * -> *).
GhcMonad m =>
RealSrcLoc
-> DynFlags -> StringBuffer -> m [(Located Token, String)]
tokeniseOriginalSrc RealSrcLoc
startLoc DynFlags
flags2 StringBuffer
source
case StringBuffer
-> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
GHC.lexTokenStream StringBuffer
strSrcBuf RealSrcLoc
startLoc DynFlags
flags2 of
GHC.POk PState
_ [Located Token]
ts ->
do
let toks :: [(Located Token, String)]
toks = RealSrcLoc
-> StringBuffer -> [Located Token] -> [(Located Token, String)]
GHC.addSourceToTokens RealSrcLoc
startLoc StringBuffer
source [Located Token]
ts
cppCommentToks :: [(Located Token, String)]
cppCommentToks = [(Located Token, String)]
-> [(Located Token, String)]
-> [(Located Token, String)]
-> [(Located Token, String)]
getCppTokens [(Located Token, String)]
directiveToks [(Located Token, String)]
nonDirectiveToks [(Located Token, String)]
toks
[Comment] -> m [Comment]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Comment] -> m [Comment]) -> [Comment] -> m [Comment]
forall a b. (a -> b) -> a -> b
$ (Comment -> Bool) -> [Comment] -> [Comment]
forall a. (a -> Bool) -> [a] -> [a]
filter Comment -> Bool
goodComment
#if __GLASGOW_HASKELL__ >= 900
$ map (tokComment . GHC.commentToAnnotation . toRealLocated . fst) cppCommentToks
#elif __GLASGOW_HASKELL__ > 800
([Comment] -> [Comment]) -> [Comment] -> [Comment]
forall a b. (a -> b) -> a -> b
$ ((Located Token, String) -> Comment)
-> [(Located Token, String)] -> [Comment]
forall a b. (a -> b) -> [a] -> [b]
map (Located AnnotationComment -> Comment
tokComment (Located AnnotationComment -> Comment)
-> ((Located Token, String) -> Located AnnotationComment)
-> (Located Token, String)
-> Comment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located Token -> Located AnnotationComment
GHC.commentToAnnotation (Located Token -> Located AnnotationComment)
-> ((Located Token, String) -> Located Token)
-> (Located Token, String)
-> Located AnnotationComment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located Token, String) -> Located Token
forall a b. (a, b) -> a
fst) [(Located Token, String)]
cppCommentToks
#else
$ map (tokComment . commentToAnnotation . fst) cppCommentToks
#endif
#if __GLASGOW_HASKELL__ > 808
GHC.PFailed PState
pst -> DynFlags -> PState -> m [Comment]
forall (m :: * -> *) b. MonadIO m => DynFlags -> PState -> m b
parseError DynFlags
flags2 PState
pst
#elif __GLASGOW_HASKELL__ >= 804
GHC.PFailed _ sspan err -> parseError flags2 sspan err
#else
GHC.PFailed sspan err -> parseError flags2 sspan err
#endif
goodComment :: Comment -> Bool
(Comment String
"" SrcSpan
_ Maybe AnnKeywordId
_) = Bool
False
goodComment Comment
_ = Bool
True
#if __GLASGOW_HASKELL__ >= 900
toRealLocated :: GHC.Located a -> GHC.RealLocated a
toRealLocated (GHC.L (GHC.RealSrcSpan s _) x) = GHC.L s x
toRealLocated (GHC.L _ x) = GHC.L badRealSrcSpan x
#endif
getCppTokens ::
[(GHC.Located GHC.Token, String)]
-> [(GHC.Located GHC.Token, String)]
-> [(GHC.Located GHC.Token, String)]
-> [(GHC.Located GHC.Token, String)]
getCppTokens :: [(Located Token, String)]
-> [(Located Token, String)]
-> [(Located Token, String)]
-> [(Located Token, String)]
getCppTokens [(Located Token, String)]
directiveToks [(Located Token, String)]
origSrcToks [(Located Token, String)]
postCppToks = [(Located Token, String)]
toks
where
locFn :: (GenLocated SrcSpan e, b) -> (GenLocated SrcSpan e, b) -> Ordering
locFn (GHC.L SrcSpan
l1 e
_,b
_) (GHC.L SrcSpan
l2 e
_,b
_) = SrcSpan -> SrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SrcSpan -> SrcSpan
rs SrcSpan
l1) (SrcSpan -> SrcSpan
rs SrcSpan
l2)
m1Toks :: [(Located Token, String)]
m1Toks = ((Located Token, String) -> (Located Token, String) -> Ordering)
-> [(Located Token, String)]
-> [(Located Token, String)]
-> [(Located Token, String)]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy (Located Token, String) -> (Located Token, String) -> Ordering
forall e b e b.
(GenLocated SrcSpan e, b) -> (GenLocated SrcSpan e, b) -> Ordering
locFn [(Located Token, String)]
postCppToks [(Located Token, String)]
directiveToks
origSpans :: [SrcSpan]
origSpans = ((Located Token, String) -> SrcSpan)
-> [(Located Token, String)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (\(GHC.L SrcSpan
l Token
_,String
_) -> SrcSpan -> SrcSpan
rs SrcSpan
l) [(Located Token, String)]
origSrcToks
m1Spans :: [SrcSpan]
m1Spans = ((Located Token, String) -> SrcSpan)
-> [(Located Token, String)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (\(GHC.L SrcSpan
l Token
_,String
_) -> SrcSpan -> SrcSpan
rs SrcSpan
l) [(Located Token, String)]
m1Toks
missingSpans :: Set SrcSpan
missingSpans = [SrcSpan] -> Set SrcSpan
forall a. Ord a => [a] -> Set a
Set.fromList [SrcSpan]
origSpans Set SrcSpan -> Set SrcSpan -> Set SrcSpan
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ [SrcSpan] -> Set SrcSpan
forall a. Ord a => [a] -> Set a
Set.fromList [SrcSpan]
m1Spans
missingToks :: [(Located Token, String)]
missingToks = ((Located Token, String) -> Bool)
-> [(Located Token, String)] -> [(Located Token, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(GHC.L SrcSpan
l Token
_,String
_) -> SrcSpan -> Set SrcSpan -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (SrcSpan -> SrcSpan
rs SrcSpan
l) Set SrcSpan
missingSpans) [(Located Token, String)]
origSrcToks
missingAsComments :: [(Located Token, String)]
missingAsComments = ((Located Token, String) -> (Located Token, String))
-> [(Located Token, String)] -> [(Located Token, String)]
forall a b. (a -> b) -> [a] -> [b]
map (Located Token, String) -> (Located Token, String)
mkCommentTok [(Located Token, String)]
missingToks
where
mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String)
mkCommentTok :: (Located Token, String) -> (Located Token, String)
mkCommentTok (GHC.L SrcSpan
l Token
_,String
s) = (SrcSpan -> Token -> Located Token
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (String -> Token
GHC.ITlineComment String
s),String
s)
toks :: [(Located Token, String)]
toks = ((Located Token, String) -> (Located Token, String) -> Ordering)
-> [(Located Token, String)]
-> [(Located Token, String)]
-> [(Located Token, String)]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy (Located Token, String) -> (Located Token, String) -> Ordering
forall e b e b.
(GenLocated SrcSpan e, b) -> (GenLocated SrcSpan e, b) -> Ordering
locFn [(Located Token, String)]
directiveToks [(Located Token, String)]
missingAsComments
tokeniseOriginalSrc ::
GHC.GhcMonad m
=> GHC.RealSrcLoc -> GHC.DynFlags -> GHC.StringBuffer
-> m [(GHC.Located GHC.Token, String)]
tokeniseOriginalSrc :: RealSrcLoc
-> DynFlags -> StringBuffer -> m [(Located Token, String)]
tokeniseOriginalSrc RealSrcLoc
startLoc DynFlags
flags StringBuffer
buf = do
let src :: StringBuffer
src = StringBuffer -> StringBuffer
stripPreprocessorDirectives StringBuffer
buf
case StringBuffer
-> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
GHC.lexTokenStream StringBuffer
src RealSrcLoc
startLoc DynFlags
flags of
GHC.POk PState
_ [Located Token]
ts -> [(Located Token, String)] -> m [(Located Token, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Located Token, String)] -> m [(Located Token, String)])
-> [(Located Token, String)] -> m [(Located Token, String)]
forall a b. (a -> b) -> a -> b
$ RealSrcLoc
-> StringBuffer -> [Located Token] -> [(Located Token, String)]
GHC.addSourceToTokens RealSrcLoc
startLoc StringBuffer
src [Located Token]
ts
#if __GLASGOW_HASKELL__ > 808
GHC.PFailed PState
pst -> DynFlags -> PState -> m [(Located Token, String)]
forall (m :: * -> *) b. MonadIO m => DynFlags -> PState -> m b
parseError DynFlags
flags PState
pst
#elif __GLASGOW_HASKELL__ >= 804
GHC.PFailed _ sspan err -> parseError flags sspan err
#else
GHC.PFailed sspan err -> parseError flags sspan err
#endif
stripPreprocessorDirectives :: GHC.StringBuffer -> GHC.StringBuffer
stripPreprocessorDirectives :: StringBuffer -> StringBuffer
stripPreprocessorDirectives StringBuffer
buf = StringBuffer
buf'
where
srcByLine :: [String]
srcByLine = String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ StringBuffer -> String
sbufToString StringBuffer
buf
noDirectivesLines :: [String]
noDirectivesLines = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
line -> if String
line String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& String -> Char
forall a. [a] -> a
head String
line Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#' then String
"" else String
line) [String]
srcByLine
buf' :: StringBuffer
buf' = String -> StringBuffer
GHC.stringToStringBuffer (String -> StringBuffer) -> String -> StringBuffer
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
noDirectivesLines
sbufToString :: GHC.StringBuffer -> String
sbufToString :: StringBuffer -> String
sbufToString sb :: StringBuffer
sb@(GHC.StringBuffer ForeignPtr Word8
_buf Int
len Int
_cur) = StringBuffer -> Int -> String
GHC.lexemeToString StringBuffer
sb Int
len
getPreprocessedSrcDirect :: (GHC.GhcMonad m)
=> CppOptions
-> FilePath
-> m (String, GHC.DynFlags)
getPreprocessedSrcDirect :: CppOptions -> String -> m (String, DynFlags)
getPreprocessedSrcDirect CppOptions
cppOptions String
src =
(\(String
s,StringBuffer
_,DynFlags
d) -> (String
s,DynFlags
d)) ((String, StringBuffer, DynFlags) -> (String, DynFlags))
-> m (String, StringBuffer, DynFlags) -> m (String, DynFlags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CppOptions -> String -> m (String, StringBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
CppOptions -> String -> m (String, StringBuffer, DynFlags)
getPreprocessedSrcDirectPrim CppOptions
cppOptions String
src
getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m)
=> CppOptions
-> FilePath
-> m (String, GHC.StringBuffer, GHC.DynFlags)
getPreprocessedSrcDirectPrim :: CppOptions -> String -> m (String, StringBuffer, DynFlags)
getPreprocessedSrcDirectPrim CppOptions
cppOptions String
src_fn = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
let dfs :: DynFlags
dfs = HscEnv -> DynFlags
GHC.hsc_dflags HscEnv
hsc_env
new_env :: HscEnv
new_env = HscEnv
hsc_env { hsc_dflags :: DynFlags
GHC.hsc_dflags = CppOptions -> DynFlags -> DynFlags
injectCppOptions CppOptions
cppOptions DynFlags
dfs }
#if __GLASGOW_HASKELL__ >= 808
Either ErrorMessages (DynFlags, String)
r <- IO (Either ErrorMessages (DynFlags, String))
-> m (Either ErrorMessages (DynFlags, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO (Either ErrorMessages (DynFlags, String))
-> m (Either ErrorMessages (DynFlags, String)))
-> IO (Either ErrorMessages (DynFlags, String))
-> m (Either ErrorMessages (DynFlags, String))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> String
-> Maybe StringBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, String))
GHC.preprocess HscEnv
new_env String
src_fn Maybe StringBuffer
forall a. Maybe a
Nothing (Phase -> Maybe Phase
forall a. a -> Maybe a
Just (HscSource -> Phase
GHC.Cpp HscSource
GHC.HsSrcFile))
case Either ErrorMessages (DynFlags, String)
r of
Left ErrorMessages
err -> String -> m (String, StringBuffer, DynFlags)
forall a. HasCallStack => String -> a
error (String -> m (String, StringBuffer, DynFlags))
-> String -> m (String, StringBuffer, DynFlags)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> String
showErrorMessages ErrorMessages
err
Right (DynFlags
dflags', String
hspp_fn) -> do
StringBuffer
buf <- IO StringBuffer -> m StringBuffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO StringBuffer -> m StringBuffer)
-> IO StringBuffer -> m StringBuffer
forall a b. (a -> b) -> a -> b
$ String -> IO StringBuffer
GHC.hGetStringBuffer String
hspp_fn
String
txt <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFileGhc String
hspp_fn
(String, StringBuffer, DynFlags)
-> m (String, StringBuffer, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
txt, StringBuffer
buf, DynFlags
dflags')
#else
(dflags', hspp_fn) <-
GHC.liftIO $ GHC.preprocess new_env (src_fn, Just (GHC.Cpp GHC.HsSrcFile))
buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn
txt <- GHC.liftIO $ readFileGhc hspp_fn
return (txt, buf, dflags')
#endif
#if __GLASGOW_HASKELL__ >= 808
showErrorMessages :: GHC.ErrorMessages -> String
showErrorMessages :: ErrorMessages -> String
showErrorMessages ErrorMessages
msgs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (ErrMsg -> String) -> [ErrMsg] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> String
forall a. Show a => a -> String
show ([ErrMsg] -> [String]) -> [ErrMsg] -> [String]
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> [ErrMsg]
forall a. Bag a -> [a]
GHC.bagToList ErrorMessages
msgs
#endif
injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags
injectCppOptions :: CppOptions -> DynFlags -> DynFlags
injectCppOptions CppOptions{[String]
cppFile :: [String]
cppInclude :: [String]
cppDefine :: [String]
cppFile :: CppOptions -> [String]
cppInclude :: CppOptions -> [String]
cppDefine :: CppOptions -> [String]
..} DynFlags
dflags =
(String -> DynFlags -> DynFlags)
-> DynFlags -> [String] -> DynFlags
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> DynFlags -> DynFlags
addOptP DynFlags
dflags ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mkDefine [String]
cppDefine [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mkIncludeDir [String]
cppInclude [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mkInclude [String]
cppFile)
where
mkDefine :: String -> String
mkDefine = (String
"-D" String -> String -> String
forall a. [a] -> [a] -> [a]
++)
mkIncludeDir :: String -> String
mkIncludeDir = (String
"-I" String -> String -> String
forall a. [a] -> [a] -> [a]
++)
mkInclude :: String -> String
mkInclude = (String
"-include" String -> String -> String
forall a. [a] -> [a] -> [a]
++)
#if __GLASGOW_HASKELL__ > 808
addOptP :: String -> GHC.DynFlags -> GHC.DynFlags
addOptP :: String -> DynFlags -> DynFlags
addOptP String
f = (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
alterToolSettings ((ToolSettings -> ToolSettings) -> DynFlags -> DynFlags)
-> (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ \ToolSettings
s -> ToolSettings
s
{ toolSettings_opt_P :: [String]
GHC.toolSettings_opt_P = String
f String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ToolSettings -> [String]
GHC.toolSettings_opt_P ToolSettings
s
, toolSettings_opt_P_fingerprint :: Fingerprint
GHC.toolSettings_opt_P_fingerprint = [String] -> Fingerprint
fingerprintStrings (String
f String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ToolSettings -> [String]
GHC.toolSettings_opt_P ToolSettings
s)
}
alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags
alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
alterToolSettings ToolSettings -> ToolSettings
f DynFlags
dynFlags = DynFlags
dynFlags { toolSettings :: ToolSettings
GHC.toolSettings = ToolSettings -> ToolSettings
f (DynFlags -> ToolSettings
GHC.toolSettings DynFlags
dynFlags) }
fingerprintStrings :: [String] -> GHC.Fingerprint
fingerprintStrings :: [String] -> Fingerprint
fingerprintStrings [String]
ss = [Fingerprint] -> Fingerprint
GHC.fingerprintFingerprints ([Fingerprint] -> Fingerprint) -> [Fingerprint] -> Fingerprint
forall a b. (a -> b) -> a -> b
$ (String -> Fingerprint) -> [String] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map String -> Fingerprint
GHC.fingerprintString [String]
ss
#else
addOptP :: String -> GHC.DynFlags -> GHC.DynFlags
addOptP f = alterSettings (\s -> s { GHC.sOpt_P = f : GHC.sOpt_P s})
alterSettings :: (GHC.Settings -> GHC.Settings) -> GHC.DynFlags -> GHC.DynFlags
alterSettings f dflags = dflags { GHC.settings = f (GHC.settings dflags) }
#endif
getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)]
String
srcFile = do
String
fcontents <- String -> IO String
readFileGhc String
srcFile
let directives :: [(Int, String)]
directives = ((Int, String) -> Bool) -> [(Int, String)] -> [(Int, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_lineNum,String
line) -> String
line String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& String -> Char
forall a. [a] -> a
head String
line Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#')
([(Int, String)] -> [(Int, String)])
-> [(Int, String)] -> [(Int, String)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] (String -> [String]
lines String
fcontents)
let mkTok :: (Int, String) -> (Located Token, String)
mkTok (Int
lineNum,String
line) = (SrcSpan -> Token -> Located Token
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (String -> Token
GHC.ITlineComment String
line),String
line)
where
start :: SrcLoc
start = FastString -> Int -> Int -> SrcLoc
GHC.mkSrcLoc (String -> FastString
GHC.mkFastString String
srcFile) Int
lineNum Int
1
end :: SrcLoc
end = FastString -> Int -> Int -> SrcLoc
GHC.mkSrcLoc (String -> FastString
GHC.mkFastString String
srcFile) Int
lineNum (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
line)
l :: SrcSpan
l = SrcLoc -> SrcLoc -> SrcSpan
GHC.mkSrcSpan SrcLoc
start SrcLoc
end
let toks :: [(Located Token, String)]
toks = ((Int, String) -> (Located Token, String))
-> [(Int, String)] -> [(Located Token, String)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> (Located Token, String)
mkTok [(Int, String)]
directives
[(Located Token, String)] -> IO [(Located Token, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Located Token, String)]
toks
#if __GLASGOW_HASKELL__ > 808
parseError :: (GHC.MonadIO m) => GHC.DynFlags -> GHC.PState -> m b
parseError :: DynFlags -> PState -> m b
parseError DynFlags
dflags PState
pst = do
let
ErrorMessages -> m b
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
GHC.throwErrors (PState -> DynFlags -> ErrorMessages
GHC.getErrorMessages PState
pst DynFlags
dflags)
#else
parseError :: GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b
parseError dflags sspan err = do
throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
#endif
readFileGhc :: FilePath -> IO String
readFileGhc :: String -> IO String
readFileGhc String
file = do
buf :: StringBuffer
buf@(GHC.StringBuffer ForeignPtr Word8
_ Int
len Int
_) <- String -> IO StringBuffer
GHC.hGetStringBuffer String
file
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer -> Int -> String
GHC.lexemeToString StringBuffer
buf Int
len)
mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy a -> a -> Ordering
_cmp [] [a]
ys = [a]
ys
mergeBy a -> a -> Ordering
_cmp [a]
xs [] = [a]
xs
mergeBy a -> a -> Ordering
cmp (allx :: [a]
allx@(a
x:[a]
xs)) (ally :: [a]
ally@(a
y:[a]
ys))
| (a
x a -> a -> Ordering
`cmp` a
y) Ordering -> Ordering -> Bool
forall a. Ord a => a -> a -> Bool
<= Ordering
EQ = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a -> Ordering) -> [a] -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy a -> a -> Ordering
cmp [a]
xs [a]
ally
| Bool
otherwise = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a -> Ordering) -> [a] -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy a -> a -> Ordering
cmp [a]
allx [a]
ys