{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module HSE.All(
CppFlags(..), ParseFlags(..), defaultParseFlags,
parseFlagsAddFixities, parseFlagsSetLanguage,
ParseError(..), ModuleEx(..),
parseModuleEx, ghcComments,
parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
) where
import Util
import Data.Char
import Data.List.Extra
import Data.Maybe
import Timing
import Language.Preprocessor.Cpphs
import Data.Either
import DynFlags(Language(..))
import qualified Data.Map as Map
import System.IO.Extra
import Data.Functor
import Fixity
import Extension
import FastString
import Prelude
import GHC.Hs
import qualified SrcLoc as GHC
import ErrUtils
import qualified Outputable
import qualified Lexer as GHC
import GHC.LanguageExtensions.Type
import qualified ApiAnnotation as GHC
import qualified BasicTypes as GHC
import qualified DynFlags as GHC
import Bag
import GHC.Util (parsePragmasIntoDynFlags, parseFileGhcLib, parseExpGhcLib, parseDeclGhcLib, parseImportGhcLib, baseDynFlags)
import qualified Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx
data CppFlags
= NoCpp
| CppSimple
| Cpphs CpphsOptions
data ParseFlags = ParseFlags
{cppFlags :: CppFlags
,baseLanguage :: Maybe Language
,extensions :: [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]) -> ParseFlags -> ParseFlags
parseFlagsSetLanguage (l, es) x = x{baseLanguage = l, extensions = es}
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 :: GHC.SrcSpan
, parseErrorMessage :: String
, parseErrorContents :: String
}
data ModuleEx = ModuleEx {
ghcModule :: GHC.Located (HsModule GhcPs)
, ghcAnnotations :: GHC.ApiAnns
}
ghcComments :: ModuleEx -> [GHC.Located GHC.AnnotationComment]
ghcComments m = concat (Map.elems $ snd (ghcAnnotations m))
ghcFailOpParseModuleEx :: String
-> FilePath
-> String
-> (GHC.SrcSpan, ErrUtils.MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx ppstr file str (loc, err) = do
let pe = case loc of
GHC.RealSrcSpan r -> context (GHC.srcSpanStartLine r) ppstr
_ -> ""
msg = Outputable.showSDoc baseDynFlags err
pure $ Left $ ParseError loc msg pe
ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags{extensions=exts}= (exts, [])
ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Fixity)]
ghcFixitiesFromParseFlags = map toFixity . fixities
parseModeToFlags :: ParseFlags -> GHC.DynFlags
parseModeToFlags parseMode =
flip GHC.lang_set (baseLanguage parseMode) $ foldl' GHC.xopt_unset (foldl' GHC.xopt_set baseDynFlags enable) disable
where
(enable, disable) = ghcExtensionsFromParseFlags parseMode
parseExpGhcWithMode :: ParseFlags -> String -> GHC.ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode parseMode s =
let fixities = ghcFixitiesFromParseFlags parseMode
in case parseExpGhcLib s $ parseModeToFlags parseMode of
GHC.POk pst a -> GHC.POk pst (GhclibParserEx.applyFixities fixities a)
f@GHC.PFailed{} -> f
parseImportDeclGhcWithMode :: ParseFlags -> String -> GHC.ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode parseMode s =
parseImportGhcLib s $ parseModeToFlags parseMode
parseDeclGhcWithMode :: ParseFlags -> String -> GHC.ParseResult (LHsDecl GhcPs)
parseDeclGhcWithMode parseMode s =
let fixities = ghcFixitiesFromParseFlags parseMode
in case parseDeclGhcLib s $ parseModeToFlags parseMode of
GHC.POk pst a -> GHC.POk pst (GhclibParserEx.applyFixities fixities a)
f@GHC.PFailed{} -> f
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx flags file str = timedIO "Parse" file $ do
str <- case str of
Just x -> pure x
Nothing | file == "-" -> getContentsUTF8
| otherwise -> readFileUTF8' file
str <- pure $ dropPrefix "\65279" str
ppstr <- runCpp (cppFlags flags) file str
let enableDisableExts = ghcExtensionsFromParseFlags flags
fixities = ghcFixitiesFromParseFlags flags
dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr
case dynFlags of
Right ghcFlags -> do
ghcFlags <- pure $ GHC.lang_set ghcFlags $ baseLanguage flags
case parseFileGhcLib file ppstr ghcFlags of
GHC.POk pst a ->
let anns =
( Map.fromListWith (++) $ GHC.annotations pst
, Map.fromList ((GHC.noSrcSpan, GHC.comment_q pst) : GHC.annotations_comments pst)
) in
let a' = GhclibParserEx.applyFixities fixities a in
pure $ Right (ModuleEx a' anns)
GHC.PFailed s -> do
let (_, errs) = GHC.getMessages s ghcFlags
errMsg = head (bagToList errs)
loc = errMsgSpan errMsg
doc = formatErrDoc ghcFlags (errMsgDoc errMsg)
ghcFailOpParseModuleEx ppstr file str (loc, doc)
Left msg -> do
let loc = GHC.mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)
pure $ Left (ParseError (GHC.mkSrcSpan loc loc) msg ppstr)
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) [" "," ","> "," "," "]