{-# 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 -> [[Char]]
cppDefine :: [String]
, CppOptions -> [[Char]]
cppInclude :: [FilePath]
, CppOptions -> [[Char]]
cppFile :: [FilePath]
}
defaultCppOptions :: CppOptions
defaultCppOptions :: CppOptions
defaultCppOptions = [[Char]] -> [[Char]] -> [[Char]] -> CppOptions
CppOptions [] [] []
stripLinePragmas :: String -> (String, [Comment])
stripLinePragmas :: [Char] -> ([Char], [Comment])
stripLinePragmas = ([[Char]], [Maybe Comment]) -> ([Char], [Comment])
forall {a}. ([[Char]], [Maybe a]) -> ([Char], [a])
unlines' (([[Char]], [Maybe Comment]) -> ([Char], [Comment]))
-> ([Char] -> ([[Char]], [Maybe Comment]))
-> [Char]
-> ([Char], [Comment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Char], Maybe Comment)] -> ([[Char]], [Maybe Comment])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Char], Maybe Comment)] -> ([[Char]], [Maybe Comment]))
-> ([Char] -> [([Char], Maybe Comment)])
-> [Char]
-> ([[Char]], [Maybe Comment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [([Char], Maybe Comment)]
findLines ([[Char]] -> [([Char], Maybe Comment)])
-> ([Char] -> [[Char]]) -> [Char] -> [([Char], Maybe Comment)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
where
unlines' :: ([[Char]], [Maybe a]) -> ([Char], [a])
unlines' ([[Char]]
a, [Maybe a]
b) = ([[Char]] -> [Char]
unlines [[Char]]
a, [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes [Maybe a]
b)
findLines :: [String] -> [(String, Maybe Comment)]
findLines :: [[Char]] -> [([Char], Maybe Comment)]
findLines = (Int -> [Char] -> ([Char], Maybe Comment))
-> [Int] -> [[Char]] -> [([Char], Maybe Comment)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [Char] -> ([Char], Maybe Comment)
checkLine [Int
1..]
checkLine :: Int -> String -> (String, Maybe Comment)
checkLine :: Int -> [Char] -> ([Char], Maybe Comment)
checkLine Int
line [Char]
s
| [Char]
"{-# LINE" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
s =
let ([Char]
pragma, [Char]
res) = [Char] -> ([Char], [Char])
getPragma [Char]
s
size :: Int
size = [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
pragma
mSrcLoc :: Int -> Int -> SrcLoc
mSrcLoc = FastString -> Int -> Int -> SrcLoc
mkSrcLoc ([Char] -> FastString
mkFastString [Char]
"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 ([Char]
res, Comment -> Maybe Comment
forall a. a -> Maybe a
Just (Comment -> Maybe Comment) -> Comment -> Maybe Comment
forall a b. (a -> b) -> a -> b
$ [Char] -> RealSrcSpan -> Comment
mkComment [Char]
pragma (SrcSpan -> RealSrcSpan
rs SrcSpan
ss))
| [Char]
"#!" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
s =
let mSrcLoc :: Int -> Int -> SrcLoc
mSrcLoc = FastString -> Int -> Int -> SrcLoc
mkSrcLoc ([Char] -> FastString
mkFastString [Char]
"SHEBANG")
ss :: SrcSpan
ss = SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (Int -> Int -> SrcLoc
mSrcLoc Int
line Int
1) (Int -> Int -> SrcLoc
mSrcLoc Int
line ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s))
in
([Char]
"",Comment -> Maybe Comment
forall a. a -> Maybe a
Just (Comment -> Maybe Comment) -> Comment -> Maybe Comment
forall a b. (a -> b) -> a -> b
$ [Char] -> RealSrcSpan -> Comment
mkComment [Char]
s (SrcSpan -> RealSrcSpan
rs SrcSpan
ss))
| Bool
otherwise = ([Char]
s, Maybe Comment
forall a. Maybe a
Nothing)
getPragma :: String -> (String, String)
getPragma :: [Char] -> ([Char], [Char])
getPragma [] = [Char] -> ([Char], [Char])
forall a. HasCallStack => [Char] -> a
error [Char]
"Input must not be empty"
getPragma s :: [Char]
s@(Char
x:[Char]
xs)
| [Char]
"#-}" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
s = ([Char]
"#-}", [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
3 [Char]
s)
| Bool
otherwise =
let ([Char]
prag, [Char]
remline) = [Char] -> ([Char], [Char])
getPragma [Char]
xs
in (Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
prag, Char
' 'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
remline)
getCppTokensAsComments :: GHC.GhcMonad m
=> CppOptions
-> FilePath
-> m [Comment]
CppOptions
cppOptions [Char]
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
$ [Char] -> IO StringBuffer
GHC.hGetStringBuffer [Char]
sourceFile
let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc ([Char] -> FastString
GHC.mkFastString [Char]
sourceFile) Int
1 Int
1
([Char]
_txt,StringBuffer
strSrcBuf,DynFlags
flags2) <- CppOptions -> [Char] -> m ([Char], StringBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
CppOptions -> [Char] -> m ([Char], StringBuffer, DynFlags)
getPreprocessedSrcDirectPrim CppOptions
cppOptions [Char]
sourceFile
[(Located Token, [Char])]
directiveToks <- IO [(Located Token, [Char])] -> m [(Located Token, [Char])]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO [(Located Token, [Char])] -> m [(Located Token, [Char])])
-> IO [(Located Token, [Char])] -> m [(Located Token, [Char])]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [(Located Token, [Char])]
getPreprocessorAsComments [Char]
sourceFile
[(Located Token, [Char])]
nonDirectiveToks <- RealSrcLoc
-> DynFlags -> StringBuffer -> m [(Located Token, [Char])]
forall (m :: * -> *).
GhcMonad m =>
RealSrcLoc
-> DynFlags -> StringBuffer -> m [(Located Token, [Char])]
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, [Char])]
toks = RealSrcLoc
-> StringBuffer -> [Located Token] -> [(Located Token, [Char])]
GHC.addSourceToTokens RealSrcLoc
startLoc StringBuffer
source [Located Token]
ts
cppCommentToks :: [(Located Token, [Char])]
cppCommentToks = [(Located Token, [Char])]
-> [(Located Token, [Char])]
-> [(Located Token, [Char])]
-> [(Located Token, [Char])]
getCppTokens [(Located Token, [Char])]
directiveToks [(Located Token, [Char])]
nonDirectiveToks [(Located Token, [Char])]
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
([Comment] -> [Comment]) -> [Comment] -> [Comment]
forall a b. (a -> b) -> a -> b
$ ((Located Token, [Char]) -> Comment)
-> [(Located Token, [Char])] -> [Comment]
forall a b. (a -> b) -> [a] -> [b]
map (RealLocated AnnotationComment -> Comment
tokComment (RealLocated AnnotationComment -> Comment)
-> ((Located Token, [Char]) -> RealLocated AnnotationComment)
-> (Located Token, [Char])
-> Comment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealLocated Token -> RealLocated AnnotationComment
GHC.commentToAnnotation (RealLocated Token -> RealLocated AnnotationComment)
-> ((Located Token, [Char]) -> RealLocated Token)
-> (Located Token, [Char])
-> RealLocated AnnotationComment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located Token -> RealLocated Token
forall a. Located a -> RealLocated a
toRealLocated (Located Token -> RealLocated Token)
-> ((Located Token, [Char]) -> Located Token)
-> (Located Token, [Char])
-> RealLocated Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located Token, [Char]) -> Located Token
forall a b. (a, b) -> a
fst) [(Located Token, [Char])]
cppCommentToks
#elif __GLASGOW_HASKELL__ > 800
$ map (tokComment . GHC.commentToAnnotation . fst) 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 [Char]
"" RealSrcSpan
_ Maybe AnnKeywordId
_) = Bool
False
goodComment Comment
_ = Bool
True
#if __GLASGOW_HASKELL__ >= 900
toRealLocated :: GHC.Located a -> GHC.RealLocated a
toRealLocated :: forall a. Located a -> RealLocated a
toRealLocated (GHC.L (GHC.RealSrcSpan RealSrcSpan
s Maybe BufSpan
_) a
x) = RealSrcSpan -> a -> GenLocated RealSrcSpan a
forall l e. l -> e -> GenLocated l e
GHC.L RealSrcSpan
s a
x
toRealLocated (GHC.L SrcSpan
_ a
x) = RealSrcSpan -> a -> GenLocated RealSrcSpan a
forall l e. l -> e -> GenLocated l e
GHC.L RealSrcSpan
badRealSrcSpan a
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, [Char])]
-> [(Located Token, [Char])]
-> [(Located Token, [Char])]
-> [(Located Token, [Char])]
getCppTokens [(Located Token, [Char])]
directiveToks [(Located Token, [Char])]
origSrcToks [(Located Token, [Char])]
postCppToks = [(Located Token, [Char])]
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
_) = RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SrcSpan -> RealSrcSpan
rs SrcSpan
l1) (SrcSpan -> RealSrcSpan
rs SrcSpan
l2)
m1Toks :: [(Located Token, [Char])]
m1Toks = ((Located Token, [Char]) -> (Located Token, [Char]) -> Ordering)
-> [(Located Token, [Char])]
-> [(Located Token, [Char])]
-> [(Located Token, [Char])]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy (Located Token, [Char]) -> (Located Token, [Char]) -> Ordering
forall {e} {b} {e} {b}.
(GenLocated SrcSpan e, b) -> (GenLocated SrcSpan e, b) -> Ordering
locFn [(Located Token, [Char])]
postCppToks [(Located Token, [Char])]
directiveToks
origSpans :: [RealSrcSpan]
origSpans = ((Located Token, [Char]) -> RealSrcSpan)
-> [(Located Token, [Char])] -> [RealSrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (\(GHC.L SrcSpan
l Token
_,[Char]
_) -> SrcSpan -> RealSrcSpan
rs SrcSpan
l) [(Located Token, [Char])]
origSrcToks
m1Spans :: [RealSrcSpan]
m1Spans = ((Located Token, [Char]) -> RealSrcSpan)
-> [(Located Token, [Char])] -> [RealSrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (\(GHC.L SrcSpan
l Token
_,[Char]
_) -> SrcSpan -> RealSrcSpan
rs SrcSpan
l) [(Located Token, [Char])]
m1Toks
missingSpans :: Set RealSrcSpan
missingSpans = [RealSrcSpan] -> Set RealSrcSpan
forall a. Ord a => [a] -> Set a
Set.fromList [RealSrcSpan]
origSpans Set RealSrcSpan -> Set RealSrcSpan -> Set RealSrcSpan
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ [RealSrcSpan] -> Set RealSrcSpan
forall a. Ord a => [a] -> Set a
Set.fromList [RealSrcSpan]
m1Spans
missingToks :: [(Located Token, [Char])]
missingToks = ((Located Token, [Char]) -> Bool)
-> [(Located Token, [Char])] -> [(Located Token, [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(GHC.L SrcSpan
l Token
_,[Char]
_) -> RealSrcSpan -> Set RealSrcSpan -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (SrcSpan -> RealSrcSpan
rs SrcSpan
l) Set RealSrcSpan
missingSpans) [(Located Token, [Char])]
origSrcToks
missingAsComments :: [(Located Token, [Char])]
missingAsComments = ((Located Token, [Char]) -> (Located Token, [Char]))
-> [(Located Token, [Char])] -> [(Located Token, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (Located Token, [Char]) -> (Located Token, [Char])
mkCommentTok [(Located Token, [Char])]
missingToks
where
mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String)
mkCommentTok :: (Located Token, [Char]) -> (Located Token, [Char])
mkCommentTok (GHC.L SrcSpan
l Token
_,[Char]
s) = (SrcSpan -> Token -> Located Token
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l ([Char] -> Token
GHC.ITlineComment [Char]
s),[Char]
s)
toks :: [(Located Token, [Char])]
toks = ((Located Token, [Char]) -> (Located Token, [Char]) -> Ordering)
-> [(Located Token, [Char])]
-> [(Located Token, [Char])]
-> [(Located Token, [Char])]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy (Located Token, [Char]) -> (Located Token, [Char]) -> Ordering
forall {e} {b} {e} {b}.
(GenLocated SrcSpan e, b) -> (GenLocated SrcSpan e, b) -> Ordering
locFn [(Located Token, [Char])]
directiveToks [(Located Token, [Char])]
missingAsComments
tokeniseOriginalSrc ::
GHC.GhcMonad m
=> GHC.RealSrcLoc -> GHC.DynFlags -> GHC.StringBuffer
-> m [(GHC.Located GHC.Token, String)]
tokeniseOriginalSrc :: forall (m :: * -> *).
GhcMonad m =>
RealSrcLoc
-> DynFlags -> StringBuffer -> m [(Located Token, [Char])]
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, [Char])] -> m [(Located Token, [Char])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Located Token, [Char])] -> m [(Located Token, [Char])])
-> [(Located Token, [Char])] -> m [(Located Token, [Char])]
forall a b. (a -> b) -> a -> b
$ RealSrcLoc
-> StringBuffer -> [Located Token] -> [(Located Token, [Char])]
GHC.addSourceToTokens RealSrcLoc
startLoc StringBuffer
src [Located Token]
ts
#if __GLASGOW_HASKELL__ > 808
GHC.PFailed PState
pst -> DynFlags -> PState -> m [(Located Token, [Char])]
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 :: [[Char]]
srcByLine = [Char] -> [[Char]]
lines ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ StringBuffer -> [Char]
sbufToString StringBuffer
buf
noDirectivesLines :: [[Char]]
noDirectivesLines = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
line -> if [Char]
line [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& [Char] -> Char
forall a. [a] -> a
head [Char]
line Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#' then [Char]
"" else [Char]
line) [[Char]]
srcByLine
buf' :: StringBuffer
buf' = [Char] -> StringBuffer
GHC.stringToStringBuffer ([Char] -> StringBuffer) -> [Char] -> StringBuffer
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
noDirectivesLines
sbufToString :: GHC.StringBuffer -> String
sbufToString :: StringBuffer -> [Char]
sbufToString sb :: StringBuffer
sb@(GHC.StringBuffer ForeignPtr Word8
_buf Int
len Int
_cur) = StringBuffer -> Int -> [Char]
GHC.lexemeToString StringBuffer
sb Int
len
getPreprocessedSrcDirect :: (GHC.GhcMonad m)
=> CppOptions
-> FilePath
-> m (String, GHC.DynFlags)
getPreprocessedSrcDirect :: forall (m :: * -> *).
GhcMonad m =>
CppOptions -> [Char] -> m ([Char], DynFlags)
getPreprocessedSrcDirect CppOptions
cppOptions [Char]
src =
(\([Char]
s,StringBuffer
_,DynFlags
d) -> ([Char]
s,DynFlags
d)) (([Char], StringBuffer, DynFlags) -> ([Char], DynFlags))
-> m ([Char], StringBuffer, DynFlags) -> m ([Char], DynFlags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CppOptions -> [Char] -> m ([Char], StringBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
CppOptions -> [Char] -> m ([Char], StringBuffer, DynFlags)
getPreprocessedSrcDirectPrim CppOptions
cppOptions [Char]
src
getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m)
=> CppOptions
-> FilePath
-> m (String, GHC.StringBuffer, GHC.DynFlags)
getPreprocessedSrcDirectPrim :: forall (m :: * -> *).
GhcMonad m =>
CppOptions -> [Char] -> m ([Char], StringBuffer, DynFlags)
getPreprocessedSrcDirectPrim CppOptions
cppOptions [Char]
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, [Char])
r <- IO (Either ErrorMessages (DynFlags, [Char]))
-> m (Either ErrorMessages (DynFlags, [Char]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO (Either ErrorMessages (DynFlags, [Char]))
-> m (Either ErrorMessages (DynFlags, [Char])))
-> IO (Either ErrorMessages (DynFlags, [Char]))
-> m (Either ErrorMessages (DynFlags, [Char]))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [Char]
-> Maybe StringBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, [Char]))
GHC.preprocess HscEnv
new_env [Char]
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, [Char])
r of
Left ErrorMessages
err -> [Char] -> m ([Char], StringBuffer, DynFlags)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ([Char], StringBuffer, DynFlags))
-> [Char] -> m ([Char], StringBuffer, DynFlags)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> [Char]
showErrorMessages ErrorMessages
err
Right (DynFlags
dflags', [Char]
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
$ [Char] -> IO StringBuffer
GHC.hGetStringBuffer [Char]
hspp_fn
[Char]
txt <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
readFileGhc [Char]
hspp_fn
([Char], StringBuffer, DynFlags)
-> m ([Char], StringBuffer, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
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 -> [Char]
showErrorMessages ErrorMessages
msgs = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (ErrMsg -> [Char]) -> [ErrMsg] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> [Char]
forall a. Show a => a -> [Char]
show ([ErrMsg] -> [[Char]]) -> [ErrMsg] -> [[Char]]
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{[[Char]]
cppFile :: [[Char]]
cppInclude :: [[Char]]
cppDefine :: [[Char]]
cppFile :: CppOptions -> [[Char]]
cppInclude :: CppOptions -> [[Char]]
cppDefine :: CppOptions -> [[Char]]
..} DynFlags
dflags =
([Char] -> DynFlags -> DynFlags)
-> DynFlags -> [[Char]] -> DynFlags
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> DynFlags -> DynFlags
addOptP DynFlags
dflags (([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
mkDefine [[Char]]
cppDefine [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
mkIncludeDir [[Char]]
cppInclude [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
mkInclude [[Char]]
cppFile)
where
mkDefine :: [Char] -> [Char]
mkDefine = ([Char]
"-D" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
mkIncludeDir :: [Char] -> [Char]
mkIncludeDir = ([Char]
"-I" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
mkInclude :: [Char] -> [Char]
mkInclude = ([Char]
"-include" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
#if __GLASGOW_HASKELL__ > 808
addOptP :: String -> GHC.DynFlags -> GHC.DynFlags
addOptP :: [Char] -> DynFlags -> DynFlags
addOptP [Char]
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 :: [[Char]]
GHC.toolSettings_opt_P = [Char]
f [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ToolSettings -> [[Char]]
GHC.toolSettings_opt_P ToolSettings
s
, toolSettings_opt_P_fingerprint :: Fingerprint
GHC.toolSettings_opt_P_fingerprint = [[Char]] -> Fingerprint
fingerprintStrings ([Char]
f [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ToolSettings -> [[Char]]
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 :: [[Char]] -> Fingerprint
fingerprintStrings [[Char]]
ss = [Fingerprint] -> Fingerprint
GHC.fingerprintFingerprints ([Fingerprint] -> Fingerprint) -> [Fingerprint] -> Fingerprint
forall a b. (a -> b) -> a -> b
$ ([Char] -> Fingerprint) -> [[Char]] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Fingerprint
GHC.fingerprintString [[Char]]
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)]
[Char]
srcFile = do
[Char]
fcontents <- [Char] -> IO [Char]
readFileGhc [Char]
srcFile
let directives :: [(Int, [Char])]
directives = ((Int, [Char]) -> Bool) -> [(Int, [Char])] -> [(Int, [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_lineNum,[Char]
line) -> [Char]
line [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& [Char] -> Char
forall a. [a] -> a
head [Char]
line Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#')
([(Int, [Char])] -> [(Int, [Char])])
-> [(Int, [Char])] -> [(Int, [Char])]
forall a b. (a -> b) -> a -> b
$ [Int] -> [[Char]] -> [(Int, [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([Char] -> [[Char]]
lines [Char]
fcontents)
let mkTok :: (Int, [Char]) -> (Located Token, [Char])
mkTok (Int
lineNum,[Char]
line) = (SrcSpan -> Token -> Located Token
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l ([Char] -> Token
GHC.ITlineComment [Char]
line),[Char]
line)
where
start :: SrcLoc
start = FastString -> Int -> Int -> SrcLoc
GHC.mkSrcLoc ([Char] -> FastString
GHC.mkFastString [Char]
srcFile) Int
lineNum Int
1
end :: SrcLoc
end = FastString -> Int -> Int -> SrcLoc
GHC.mkSrcLoc ([Char] -> FastString
GHC.mkFastString [Char]
srcFile) Int
lineNum ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
line)
l :: SrcSpan
l = SrcLoc -> SrcLoc -> SrcSpan
GHC.mkSrcSpan SrcLoc
start SrcLoc
end
let toks :: [(Located Token, [Char])]
toks = ((Int, [Char]) -> (Located Token, [Char]))
-> [(Int, [Char])] -> [(Located Token, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [Char]) -> (Located Token, [Char])
mkTok [(Int, [Char])]
directives
[(Located Token, [Char])] -> IO [(Located Token, [Char])]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Located Token, [Char])]
toks
#if __GLASGOW_HASKELL__ > 808
parseError :: (GHC.MonadIO m) => GHC.DynFlags -> GHC.PState -> m b
parseError :: forall (m :: * -> *) b. MonadIO m => 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 :: [Char] -> IO [Char]
readFileGhc [Char]
file = do
buf :: StringBuffer
buf@(GHC.StringBuffer ForeignPtr Word8
_ Int
len Int
_) <- [Char] -> IO StringBuffer
GHC.hGetStringBuffer [Char]
file
[Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer -> Int -> [Char]
GHC.lexemeToString StringBuffer
buf Int
len)
mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy :: forall a. (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