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

   , CppOptions(..)
   , defaultCppOptions
   ) where

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 GHC            as GHC hiding (parseModule)
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
#if __GLASGOW_HASKELL__ > 808
import qualified Fingerprint    as GHC
import qualified ToolSettings   as GHC
#endif

import SrcLoc (mkSrcSpan, mkSrcLoc)
import FastString (mkFastString)

#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


-- import Debug.Trace
--
{-# 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]    -- ^ 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, [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
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 (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
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)

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

-- | 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 [Comment]
getCppTokensAsComments :: CppOptions -> String -> m [Comment]
getCppTokensAsComments 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
  -- #ifdef tokens
  [(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
  -- Tokens without #ifdef
  [(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__ > 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
goodComment :: Comment -> Bool
goodComment (Comment String
"" SrcSpan
_ Maybe AnnKeywordId
_) = Bool
False
goodComment Comment
_              = Bool
True

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

-- | 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 a e, b) -> (GenLocated a e, b) -> Ordering
locFn (GHC.L a
l1 e
_,b
_) (GHC.L a
l2 e
_,b
_) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
l1 a
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 a e b e b.
Ord a =>
(GenLocated a e, b) -> (GenLocated a 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 :: [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
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
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
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 a e b e b.
Ord a =>
(GenLocated a e, b) -> (GenLocated a 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

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

-- | 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. [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
  -- (dflags', hspp_fn) <-
  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
-- ---------------------------------------------------------------------

-- | 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. [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
       -- (warns,errs) = GHC.getMessages pst dflags
     -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
     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)

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

-- 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 :: (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