{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
-- | This module provides support for CPP, interpreter directives and line
-- pragmas.
module Language.Haskell.GHC.ExactPrint.Preprocess
   (
     stripLinePragmas
   , getCppTokensAsComments
   , getPreprocessedSrcDirect
   , readFileGhc

   , CppOptions(..)
   , defaultCppOptions
   , showErrorMessages
   ) where

import qualified GHC            as GHC hiding (parseModule)

import qualified Control.Monad.IO.Class as GHC
import qualified GHC.Data.FastString   as GHC
import qualified GHC.Data.StringBuffer as GHC
import qualified GHC.Driver.Config.Parser as GHC
import qualified GHC.Driver.Env        as GHC
import qualified GHC.Driver.Errors.Types as GHC
import qualified GHC.Driver.Phases     as GHC
import qualified GHC.Driver.Pipeline   as GHC
import qualified GHC.Fingerprint.Type  as GHC
-- import qualified GHC.Parser.Errors.Ppr as GHC
import qualified GHC.Parser.Lexer      as GHC
import qualified GHC.Settings          as GHC
import qualified GHC.Types.Error       as GHC
import qualified GHC.Types.SourceError as GHC
import qualified GHC.Types.SourceFile  as GHC
import qualified GHC.Types.SrcLoc      as GHC
import qualified GHC.Utils.Error       as GHC
import qualified GHC.Utils.Fingerprint as GHC
import qualified GHC.Utils.Outputable  as GHC
import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc)
import GHC.Data.FastString (mkFastString)

import Data.List (isPrefixOf)
import Data.Maybe
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils
import qualified Data.Set as Set


-- import Debug.Trace
--

-- ---------------------------------------------------------------------

data CppOptions = CppOptions
                { CppOptions -> [String]
cppDefine :: [String]    -- ^ CPP #define macros
                , CppOptions -> [String]
cppInclude :: [FilePath] -- ^ CPP Includes directory
                , CppOptions -> [String]
cppFile :: [FilePath]    -- ^ CPP pre-include file
                }

defaultCppOptions :: CppOptions
defaultCppOptions :: CppOptions
defaultCppOptions = [String] -> [String] -> [String] -> CppOptions
CppOptions [] [] []

-- ---------------------------------------------------------------------
-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into comments.
stripLinePragmas :: String -> (String, [GHC.LEpaComment])
stripLinePragmas :: String -> (String, [LEpaComment])
stripLinePragmas = ([String], [Maybe LEpaComment]) -> (String, [LEpaComment])
forall {a}. ([String], [Maybe a]) -> (String, [a])
unlines' (([String], [Maybe LEpaComment]) -> (String, [LEpaComment]))
-> (String -> ([String], [Maybe LEpaComment]))
-> String
-> (String, [LEpaComment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Maybe LEpaComment)] -> ([String], [Maybe LEpaComment])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(String, Maybe LEpaComment)] -> ([String], [Maybe LEpaComment]))
-> (String -> [(String, Maybe LEpaComment)])
-> String
-> ([String], [Maybe LEpaComment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [(String, Maybe LEpaComment)]
findLines ([String] -> [(String, Maybe LEpaComment)])
-> (String -> [String]) -> String -> [(String, Maybe LEpaComment)]
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 GHC.LEpaComment)]
findLines :: [String] -> [(String, Maybe LEpaComment)]
findLines = (Int -> String -> (String, Maybe LEpaComment))
-> [Int] -> [String] -> [(String, Maybe LEpaComment)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> String -> (String, Maybe LEpaComment)
checkLine [Int
1..]

checkLine :: Int -> String -> (String, Maybe GHC.LEpaComment)
checkLine :: Int -> String -> (String, Maybe LEpaComment)
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 a. [a] -> 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, LEpaComment -> Maybe LEpaComment
forall a. a -> Maybe a
Just (LEpaComment -> Maybe LEpaComment)
-> LEpaComment -> Maybe LEpaComment
forall a b. (a -> b) -> a -> b
$ String -> Anchor -> RealSrcSpan -> LEpaComment
mkLEpaComment String
pragma (SrcSpan -> Anchor
GHC.spanAsAnchor SrcSpan
ss) (SrcSpan -> RealSrcSpan
GHC.realSrcSpan SrcSpan
ss))
  -- Deal with shebang/cpp directives too
  -- x |  "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s)
  |  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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s))
    in
    (String
"",LEpaComment -> Maybe LEpaComment
forall a. a -> Maybe a
Just (LEpaComment -> Maybe LEpaComment)
-> LEpaComment -> Maybe LEpaComment
forall a b. (a -> b) -> a -> b
$ String -> Anchor -> RealSrcSpan -> LEpaComment
mkLEpaComment String
s (SrcSpan -> Anchor
GHC.spanAsAnchor SrcSpan
ss) (SrcSpan -> RealSrcSpan
GHC.realSrcSpan SrcSpan
ss))
  | Bool
otherwise = (String
s, Maybe LEpaComment
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)

-- ---------------------------------------------------------------------

-- | Replacement for original 'getRichTokenStream' which will return
-- the tokens for a file processed by CPP.
-- See bug <http://ghc.haskell.org/trac/ghc/ticket/8265>
getCppTokensAsComments :: GHC.GhcMonad m
                       => CppOptions  -- ^ Preprocessor Options
                       -> FilePath    -- ^ Path to source file
                       -> m [GHC.LEpaComment]
getCppTokensAsComments :: forall (m :: * -> *).
GhcMonad m =>
CppOptions -> String -> m [LEpaComment]
getCppTokensAsComments CppOptions
cppOptions String
sourceFile = do
  StringBuffer
source <- IO StringBuffer -> m StringBuffer
forall a. IO a -> m a
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
  let flags2 :: ParserOpts
flags2 = DynFlags -> ParserOpts
GHC.initParserOpts DynFlags
flags2'
  -- hash-ifdef tokens
  [(Located Token, String)]
directiveToks <- IO [(Located Token, String)] -> m [(Located Token, String)]
forall a. IO a -> m a
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
  -- Tokens without hash-ifdef
  [(Located Token, String)]
nonDirectiveToks <- RealSrcLoc
-> ParserOpts -> StringBuffer -> m [(Located Token, String)]
forall (m :: * -> *).
GhcMonad m =>
RealSrcLoc
-> ParserOpts -> StringBuffer -> m [(Located Token, String)]
tokeniseOriginalSrc RealSrcLoc
startLoc ParserOpts
flags2 StringBuffer
source
  case ParserOpts
-> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]
GHC.lexTokenStream ParserOpts
flags2 StringBuffer
strSrcBuf RealSrcLoc
startLoc 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
                  [LEpaComment] -> m [LEpaComment]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LEpaComment] -> m [LEpaComment])
-> [LEpaComment] -> m [LEpaComment]
forall a b. (a -> b) -> a -> b
$ (LEpaComment -> Bool) -> [LEpaComment] -> [LEpaComment]
forall a. (a -> Bool) -> [a] -> [a]
filter LEpaComment -> Bool
goodComment
                         ([LEpaComment] -> [LEpaComment]) -> [LEpaComment] -> [LEpaComment]
forall a b. (a -> b) -> a -> b
$  ((Located Token, String) -> LEpaComment)
-> [(Located Token, String)] -> [LEpaComment]
forall a b. (a -> b) -> [a] -> [b]
map (RealLocated Token -> LEpaComment
GHC.commentToAnnotation (RealLocated Token -> LEpaComment)
-> ((Located Token, String) -> RealLocated Token)
-> (Located Token, String)
-> LEpaComment
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, String) -> Located Token)
-> (Located Token, String)
-> RealLocated Token
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
        GHC.PFailed PState
pst -> PState -> m [LEpaComment]
forall (m :: * -> *) b. MonadIO m => PState -> m b
parseError PState
pst


goodComment :: GHC.LEpaComment -> Bool
goodComment :: LEpaComment -> Bool
goodComment LEpaComment
c = [Comment] -> Bool
isGoodComment (LEpaComment -> [Comment]
tokComment LEpaComment
c)
  where
    isGoodComment :: [Comment] -> Bool
    isGoodComment :: [Comment] -> Bool
isGoodComment []                 = Bool
False
    isGoodComment [Comment String
"" Anchor
_ RealSrcSpan
_ Maybe AnnKeywordId
_] = Bool
False
    isGoodComment [Comment]
_                  = Bool
True


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

-- ---------------------------------------------------------------------

-- | Combine the three sets of tokens to produce a single set that
-- represents the code compiled, and will regenerate the original
-- source file.
-- [@directiveToks@] are the tokens corresponding to preprocessor
--                   directives, converted to comments
-- [@origSrcToks@] are the tokenised source of the original code, with
--                 the preprocessor directives stripped out so that
--                 the lexer  does not complain
-- [@postCppToks@] are the tokens that the compiler saw originally
-- NOTE: this scheme will only work for cpp in -nomacro mode
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
_) = RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SrcSpan -> RealSrcSpan
rs SrcSpan
l1) (SrcSpan -> RealSrcSpan
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

    -- We must now find the set of tokens that are in origSrcToks, but
    -- not in m1Toks

    -- GHC.Token does not have Ord, can't use a set directly
    origSpans :: [RealSrcSpan]
origSpans = ((Located Token, String) -> RealSrcSpan)
-> [(Located Token, String)] -> [RealSrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (\(GHC.L SrcSpan
l Token
_,String
_) -> SrcSpan -> RealSrcSpan
rs SrcSpan
l) [(Located Token, String)]
origSrcToks
    m1Spans :: [RealSrcSpan]
m1Spans = ((Located Token, String) -> RealSrcSpan)
-> [(Located Token, String)] -> [RealSrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (\(GHC.L SrcSpan
l Token
_,String
_) -> SrcSpan -> RealSrcSpan
rs SrcSpan
l) [(Located Token, String)]
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, 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
_) -> RealSrcSpan -> Set RealSrcSpan -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (SrcSpan -> RealSrcSpan
rs SrcSpan
l) Set RealSrcSpan
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 -> PsSpan -> Token
GHC.ITlineComment String
s (SrcSpan -> PsSpan
makeBufSpan SrcSpan
l)),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.ParserOpts -> GHC.StringBuffer
  -> m [(GHC.Located GHC.Token, String)]
tokeniseOriginalSrc :: forall (m :: * -> *).
GhcMonad m =>
RealSrcLoc
-> ParserOpts -> StringBuffer -> m [(Located Token, String)]
tokeniseOriginalSrc RealSrcLoc
startLoc ParserOpts
flags StringBuffer
buf = do
  let src :: StringBuffer
src = StringBuffer -> StringBuffer
stripPreprocessorDirectives StringBuffer
buf
  case ParserOpts
-> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]
GHC.lexTokenStream ParserOpts
flags StringBuffer
src RealSrcLoc
startLoc of
    GHC.POk PState
_ [Located Token]
ts -> [(Located Token, String)] -> m [(Located Token, String)]
forall a. a -> m a
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
    GHC.PFailed PState
pst -> PState -> m [(Located Token, String)]
forall (m :: * -> *) b. MonadIO m => PState -> m b
parseError PState
pst

-- ---------------------------------------------------------------------

-- | Strip out the CPP directives so that the balance of the source
-- can tokenised.
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. HasCallStack => [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 :: forall (m :: * -> *).
GhcMonad m =>
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 :: forall (m :: * -> *).
GhcMonad m =>
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 { GHC.hsc_dflags = injectCppOptions cppOptions dfs }
  Either DriverMessages (DynFlags, String)
r <- IO (Either DriverMessages (DynFlags, String))
-> m (Either DriverMessages (DynFlags, String))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO (Either DriverMessages (DynFlags, String))
 -> m (Either DriverMessages (DynFlags, String)))
-> IO (Either DriverMessages (DynFlags, String))
-> m (Either DriverMessages (DynFlags, String))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> String
-> Maybe StringBuffer
-> Maybe Phase
-> IO (Either DriverMessages (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 DriverMessages (DynFlags, String)
r of
    Left DriverMessages
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
$ DriverMessages -> String
forall a. Diagnostic a => Messages a -> String
showErrorMessages DriverMessages
err
    Right (DynFlags
dflags', String
hspp_fn) -> do
      StringBuffer
buf <- IO StringBuffer -> m StringBuffer
forall a. IO a -> m a
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 a. IO a -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
txt, StringBuffer
buf, DynFlags
dflags')

showErrorMessages :: (GHC.Diagnostic a) => GHC.Messages a -> String
showErrorMessages :: forall a. Diagnostic a => Messages a -> String
showErrorMessages Messages a
msgs =
  SDocContext -> SDoc -> String
GHC.renderWithContext SDocContext
GHC.defaultSDocContext
    (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
GHC.vcat
    ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope a) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
GHC.pprMsgEnvelopeBagWithLocDefault
    (Bag (MsgEnvelope a) -> [SDoc]) -> Bag (MsgEnvelope a) -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Messages a -> Bag (MsgEnvelope a)
forall e. Messages e -> Bag (MsgEnvelope e)
GHC.getMessages
    (Messages a -> Bag (MsgEnvelope a))
-> Messages a -> Bag (MsgEnvelope a)
forall a b. (a -> b) -> a -> b
$ Messages a
msgs

injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags
injectCppOptions :: CppOptions -> DynFlags -> DynFlags
injectCppOptions CppOptions{[String]
cppDefine :: CppOptions -> [String]
cppInclude :: CppOptions -> [String]
cppFile :: CppOptions -> [String]
cppDefine :: [String]
cppInclude :: [String]
cppFile :: [String]
..} DynFlags
dflags =
  (String -> DynFlags -> DynFlags)
-> DynFlags -> [String] -> DynFlags
forall a b. (a -> b -> b) -> b -> [a] -> b
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]
++)


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
          { GHC.toolSettings_opt_P   = f : GHC.toolSettings_opt_P s
          , GHC.toolSettings_opt_P_fingerprint = fingerprintStrings (f : GHC.toolSettings_opt_P s)
          }
alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags
alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
alterToolSettings ToolSettings -> ToolSettings
f DynFlags
dynFlags = DynFlags
dynFlags { GHC.toolSettings = f (GHC.toolSettings 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

-- ---------------------------------------------------------------------

-- | Get the preprocessor directives as comment tokens from the
-- source.
getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)]
getPreprocessorAsComments :: String -> IO [(Located Token, String)]
getPreprocessorAsComments 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. HasCallStack => [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 -> PsSpan -> Token
GHC.ITlineComment String
line (SrcSpan -> PsSpan
makeBufSpan SrcSpan
l)),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 a. [a] -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Located Token, String)]
toks

makeBufSpan :: GHC.SrcSpan -> GHC.PsSpan
makeBufSpan :: SrcSpan -> PsSpan
makeBufSpan SrcSpan
ss = PsSpan
pspan
  where
    bl :: BufPos
bl = Int -> BufPos
GHC.BufPos Int
0
    pspan :: PsSpan
pspan = RealSrcSpan -> BufSpan -> PsSpan
GHC.PsSpan (SrcSpan -> RealSrcSpan
GHC.realSrcSpan SrcSpan
ss) (BufPos -> BufPos -> BufSpan
GHC.BufSpan BufPos
bl BufPos
bl)

-- ---------------------------------------------------------------------

parseError :: (GHC.MonadIO m) => GHC.PState -> m b
parseError :: forall (m :: * -> *) b. MonadIO m => PState -> m b
parseError PState
pst = do
     let
       -- (warns,errs) = GHC.getMessages pst dflags
     -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
     -- GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst))
     Messages GhcMessage -> m b
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
GHC.throwErrors ((PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsMessage -> GhcMessage
GHC.GhcPsMessage (PState -> Messages PsMessage
GHC.getPsErrorMessages PState
pst))

-- ---------------------------------------------------------------------

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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer -> Int -> String
GHC.lexemeToString StringBuffer
buf Int
len)

-- ---------------------------------------------------------------------

-- Copied over from MissingH, the dependency cause travis to fail

{- | Merge two sorted lists using into a single, sorted whole,
allowing the programmer to specify the comparison function.

QuickCheck test property:

prop_mergeBy xs ys =
    mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys)
          where types = xs :: [ (Int, Int) ]
                cmp (x1,_) (x2,_) = compare x1 x2
-}
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))
        -- Ordering derives Eq, Ord, so the comparison below is valid.
        -- Explanation left as an exercise for the reader.
        -- Someone please put this code out of its misery.
    | (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