{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.All(
CppFlags(..), ParseFlags(..), defaultParseFlags,
parseFlagsAddFixities, parseFlagsSetLanguage,
ParseError(..), ModuleEx(..),
parseModuleEx, createModuleEx, ghcComments,
parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
) where
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
import Util
import Data.Char
import Data.List.Extra
import Timing
import Language.Preprocessor.Cpphs
import qualified Data.Map as Map
import System.IO.Extra
import Fixity
import Extension
import FastString
import GHC.Hs
import SrcLoc
import ErrUtils
import Outputable
import Lexer hiding (context)
import GHC.LanguageExtensions.Type
import ApiAnnotation
import DynFlags hiding (extensions)
import Bag
import Language.Haskell.GhclibParserEx.GHC.Parser
import Language.Haskell.GhclibParserEx.Fixity
import GHC.Util
data CppFlags
= NoCpp
| CppSimple
| Cpphs CpphsOptions
data ParseFlags = ParseFlags
{cppFlags :: CppFlags
,baseLanguage :: Maybe Language
,enabledExtensions :: [Extension]
,disabledExtensions :: [Extension]
,fixities :: [FixityInfo]
}
defaultParseFlags :: ParseFlags
defaultParseFlags = ParseFlags NoCpp Nothing defaultExtensions [] defaultFixities
parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags
parseFlagsAddFixities fx x = x{fixities = fx ++ fixities x}
parseFlagsSetLanguage :: (Maybe Language, ([Extension], [Extension])) -> ParseFlags -> ParseFlags
parseFlagsSetLanguage (l, (es, ds)) x = x{baseLanguage = l, enabledExtensions = es, disabledExtensions = ds}
runCpp :: CppFlags -> FilePath -> String -> IO String
runCpp NoCpp _ x = pure x
runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x]
runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x
where
dropLine (line1 -> (a,b)) | "{-# LINE " `isPrefixOf` a = b
dropLine x = x
data ParseError = ParseError
{ parseErrorLocation :: SrcSpan
, parseErrorMessage :: String
, parseErrorContents :: String
}
data ModuleEx = ModuleEx {
ghcModule :: Located (HsModule GhcPs)
, ghcAnnotations :: ApiAnns
}
ghcComments :: ModuleEx -> [Located AnnotationComment]
ghcComments m = concat (Map.elems $ snd (ghcAnnotations m))
ghcFailOpParseModuleEx :: String
-> FilePath
-> String
-> (SrcSpan, ErrUtils.MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx ppstr file str (loc, err) = do
let pe = case loc of
RealSrcSpan r -> context (srcSpanStartLine r) ppstr
_ -> ""
msg = Outputable.showSDoc baseDynFlags err
pure $ Left $ ParseError loc msg pe
ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds)
ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]
ghcFixitiesFromParseFlags = map toFixity . fixities
parseModeToFlags :: ParseFlags -> DynFlags
parseModeToFlags parseMode =
flip lang_set (baseLanguage parseMode) $ foldl' xopt_unset (foldl' xopt_set baseDynFlags enable) disable
where
(enable, disable) = ghcExtensionsFromParseFlags parseMode
parseExpGhcWithMode :: ParseFlags -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode parseMode s =
let fixities = ghcFixitiesFromParseFlags parseMode
in case parseExpression s $ parseModeToFlags parseMode of
POk pst a -> POk pst $ applyFixities fixities a
f@PFailed{} -> f
parseImportDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode parseMode s =
parseImport s $ parseModeToFlags parseMode
parseDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LHsDecl GhcPs)
parseDeclGhcWithMode parseMode s =
let fixities = ghcFixitiesFromParseFlags parseMode
in case parseDeclaration s $ parseModeToFlags parseMode of
POk pst a -> POk pst $ applyFixities fixities a
f@PFailed{} -> f
createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
createModuleEx anns ast =
ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do
str <- case str of
Just x -> pure x
Nothing | file == "-" -> liftIO getContentsUTF8
| otherwise -> liftIO $ readFileUTF8' file
str <- pure $ dropPrefix "\65279" str
let enableDisableExts = ghcExtensionsFromParseFlags flags
dynFlags <- withExceptT (parsePragmasErr str) $ ExceptT (parsePragmasIntoDynFlags baseDynFlags enableDisableExts file str)
dynFlags <- pure $ lang_set dynFlags $ baseLanguage flags
str <- if not (xopt Cpp dynFlags) then pure str else liftIO $ runCpp (cppFlags flags) file str
dynFlags <- if not (xopt Cpp dynFlags) then pure dynFlags
else withExceptT (parsePragmasErr str) $ ExceptT (parsePragmasIntoDynFlags baseDynFlags enableDisableExts file str)
dynFlags <- pure $ lang_set dynFlags $ baseLanguage flags
case fileToModule file str dynFlags of
POk s a -> do
let errs = bagToList . snd $ getMessages s dynFlags
if not $ null errs then
ExceptT $ parseFailureErr dynFlags str file str errs
else do
let anns =
( Map.fromListWith (++) $ annotations s
, Map.fromList ((noSrcSpan, comment_q s) : annotations_comments s)
)
let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags
pure $ ModuleEx (applyFixities fixes a) anns
PFailed s ->
ExceptT $ parseFailureErr dynFlags str file str $ bagToList . snd $ getMessages s dynFlags
where
parsePragmasErr src msg =
let loc = mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)
in ParseError (mkSrcSpan loc loc) msg src
parseFailureErr dynFlags ppstr file str errs =
let errMsg = head errs
loc = errMsgSpan errMsg
doc = formatErrDoc dynFlags (errMsgDoc errMsg)
in ghcFailOpParseModuleEx ppstr file str (loc, doc)
context :: Int -> String -> String
context lineNo src =
unlines $ dropWhileEnd (all isSpace) $ dropWhile (all isSpace) $
zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ ["","","","",""]
where ticks = drop (3 - lineNo) [" "," ","> "," "," "]