{-# 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

-- | What C pre processor should be used.
data CppFlags
    = NoCpp -- ^ No pre processing is done.
    | CppSimple -- ^ Lines prefixed with @#@ are stripped.
    | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.

-- | Created with 'defaultParseFlags', used by 'parseModuleEx'.
data ParseFlags = ParseFlags
    {ParseFlags -> CppFlags
cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').
    ,ParseFlags -> Maybe Language
baseLanguage :: Maybe Language -- ^ Base language (e.g. Haskell98, Haskell2010), defaults to 'Nothing'.
    ,ParseFlags -> [Extension]
enabledExtensions :: [Extension] -- ^ List of extensions enabled for parsing, defaults to many non-conflicting extensions.
    ,ParseFlags -> [Extension]
disabledExtensions :: [Extension] -- ^ List of extensions disabled for parsing, usually empty.
    ,ParseFlags -> [FixityInfo]
fixities :: [FixityInfo] -- ^ List of fixities to be aware of, defaults to those defined in @base@.
    }

-- | Default value for 'ParseFlags'.
defaultParseFlags :: ParseFlags
defaultParseFlags :: ParseFlags
defaultParseFlags = CppFlags
-> Maybe Language
-> [Extension]
-> [Extension]
-> [FixityInfo]
-> ParseFlags
ParseFlags CppFlags
NoCpp Maybe Language
forall a. Maybe a
Nothing [Extension]
defaultExtensions [] [FixityInfo]
defaultFixities

-- | Given some fixities, add them to the existing fixities in 'ParseFlags'.
parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags
parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags
parseFlagsAddFixities [FixityInfo]
fx ParseFlags
x = ParseFlags
x{fixities :: [FixityInfo]
fixities = [FixityInfo]
fx [FixityInfo] -> [FixityInfo] -> [FixityInfo]
forall a. [a] -> [a] -> [a]
++ ParseFlags -> [FixityInfo]
fixities ParseFlags
x}

parseFlagsSetLanguage :: (Maybe Language, ([Extension], [Extension])) -> ParseFlags -> ParseFlags
parseFlagsSetLanguage :: (Maybe Language, ([Extension], [Extension]))
-> ParseFlags -> ParseFlags
parseFlagsSetLanguage (Maybe Language
l, ([Extension]
es, [Extension]
ds)) ParseFlags
x = ParseFlags
x{baseLanguage :: Maybe Language
baseLanguage = Maybe Language
l, enabledExtensions :: [Extension]
enabledExtensions = [Extension]
es, disabledExtensions :: [Extension]
disabledExtensions = [Extension]
ds}


runCpp :: CppFlags -> FilePath -> String -> IO String
runCpp :: CppFlags -> FilePath -> FilePath -> IO FilePath
runCpp CppFlags
NoCpp FilePath
_ FilePath
x = FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
runCpp CppFlags
CppSimple FilePath
_ FilePath
x = FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [if FilePath
"#" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath -> FilePath
trimStart FilePath
x then FilePath
"" else FilePath
x | FilePath
x <- FilePath -> [FilePath]
lines FilePath
x]
runCpp (Cpphs CpphsOptions
o) FilePath
file FilePath
x = FilePath -> FilePath
dropLine (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CpphsOptions -> FilePath -> FilePath -> IO FilePath
runCpphs CpphsOptions
o FilePath
file FilePath
x
    where
        -- LINE pragmas always inserted when locations=True
        dropLine :: FilePath -> FilePath
dropLine (FilePath -> (FilePath, FilePath)
line1 -> (FilePath
a,FilePath
b)) | FilePath
"{-# LINE " FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
a = FilePath
b
        dropLine FilePath
x = FilePath
x

---------------------------------------------------------------------
-- PARSING

-- | A parse error.
data ParseError = ParseError
    { ParseError -> SrcSpan
parseErrorLocation :: SrcSpan -- ^ Location of the error.
    , ParseError -> FilePath
parseErrorMessage :: String  -- ^ Message about the cause of the error.
    , ParseError -> FilePath
parseErrorContents :: String -- ^ Snippet of several lines (typically 5) including a @>@ character pointing at the faulty line.
    }

-- | Result of 'parseModuleEx', representing a parsed module.
data ModuleEx = ModuleEx {
    ModuleEx -> Located (HsModule GhcPs)
ghcModule :: Located (HsModule GhcPs)
  , ModuleEx -> ApiAnns
ghcAnnotations :: ApiAnns
}

-- | Extract a list of all of a parsed module's comments.
ghcComments :: ModuleEx -> [Located AnnotationComment]
ghcComments :: ModuleEx -> [Located AnnotationComment]
ghcComments ModuleEx
m = [[Located AnnotationComment]] -> [Located AnnotationComment]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall k a. Map k a -> [a]
Map.elems (Map SrcSpan [Located AnnotationComment]
 -> [[Located AnnotationComment]])
-> Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall a b. (a -> b) -> a -> b
$ ApiAnns -> Map SrcSpan [Located AnnotationComment]
forall a b. (a, b) -> b
snd (ModuleEx -> ApiAnns
ghcAnnotations ModuleEx
m))


-- | The error handler invoked when GHC parsing has failed.
ghcFailOpParseModuleEx :: String
                       -> FilePath
                       -> String
                       -> (SrcSpan, ErrUtils.MsgDoc)
                       -> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx :: FilePath
-> FilePath
-> FilePath
-> (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx FilePath
ppstr FilePath
file FilePath
str (SrcSpan
loc, MsgDoc
err) = do
   let pe :: FilePath
pe = case SrcSpan
loc of
            RealSrcSpan RealSrcSpan
r -> Int -> FilePath -> FilePath
context (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r) FilePath
ppstr
            SrcSpan
_ -> FilePath
""
       msg :: FilePath
msg = DynFlags -> MsgDoc -> FilePath
Outputable.showSDoc DynFlags
baseDynFlags MsgDoc
err
   Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseError ModuleEx -> IO (Either ParseError ModuleEx))
-> Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ ParseError -> Either ParseError ModuleEx
forall a b. a -> Either a b
Left (ParseError -> Either ParseError ModuleEx)
-> ParseError -> Either ParseError ModuleEx
forall a b. (a -> b) -> a -> b
$ SrcSpan -> FilePath -> FilePath -> ParseError
ParseError SrcSpan
loc FilePath
msg FilePath
pe

-- GHC extensions to enable/disable given HSE parse flags.
ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags{enabledExtensions :: ParseFlags -> [Extension]
enabledExtensions=[Extension]
es, disabledExtensions :: ParseFlags -> [Extension]
disabledExtensions=[Extension]
ds}= ([Extension]
es, [Extension]
ds)

-- GHC fixities given HSE parse flags.
ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]
ghcFixitiesFromParseFlags :: ParseFlags -> [(FilePath, Fixity)]
ghcFixitiesFromParseFlags = (FixityInfo -> (FilePath, Fixity))
-> [FixityInfo] -> [(FilePath, Fixity)]
forall a b. (a -> b) -> [a] -> [b]
map FixityInfo -> (FilePath, Fixity)
toFixity ([FixityInfo] -> [(FilePath, Fixity)])
-> (ParseFlags -> [FixityInfo])
-> ParseFlags
-> [(FilePath, Fixity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseFlags -> [FixityInfo]
fixities

-- These next two functions get called frorm 'Config/Yaml.hs' for user
-- defined hint rules.

parseModeToFlags :: ParseFlags -> DynFlags
parseModeToFlags :: ParseFlags -> DynFlags
parseModeToFlags ParseFlags
parseMode =
    (DynFlags -> Maybe Language -> DynFlags)
-> Maybe Language -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> Maybe Language -> DynFlags
lang_set (ParseFlags -> Maybe Language
baseLanguage ParseFlags
parseMode) (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_unset ((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_set DynFlags
baseDynFlags [Extension]
enable) [Extension]
disable
  where
    ([Extension]
enable, [Extension]
disable) = ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags
parseMode

parseExpGhcWithMode :: ParseFlags -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode :: ParseFlags -> FilePath -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode ParseFlags
parseMode FilePath
s =
  let fixities :: [(FilePath, Fixity)]
fixities = ParseFlags -> [(FilePath, Fixity)]
ghcFixitiesFromParseFlags ParseFlags
parseMode
  in case FilePath -> DynFlags -> ParseResult (LHsExpr GhcPs)
parseExpression FilePath
s (DynFlags -> ParseResult (LHsExpr GhcPs))
-> DynFlags -> ParseResult (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ParseFlags -> DynFlags
parseModeToFlags ParseFlags
parseMode of
    POk PState
pst LHsExpr GhcPs
a -> PState -> LHsExpr GhcPs -> ParseResult (LHsExpr GhcPs)
forall a. PState -> a -> ParseResult a
POk PState
pst (LHsExpr GhcPs -> ParseResult (LHsExpr GhcPs))
-> LHsExpr GhcPs -> ParseResult (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [(FilePath, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities [(FilePath, Fixity)]
fixities LHsExpr GhcPs
a
    f :: ParseResult (LHsExpr GhcPs)
f@PFailed{} -> ParseResult (LHsExpr GhcPs)
f

parseImportDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode :: ParseFlags -> FilePath -> ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode ParseFlags
parseMode FilePath
s =
  FilePath -> DynFlags -> ParseResult (LImportDecl GhcPs)
parseImport FilePath
s (DynFlags -> ParseResult (LImportDecl GhcPs))
-> DynFlags -> ParseResult (LImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ParseFlags -> DynFlags
parseModeToFlags ParseFlags
parseMode

parseDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LHsDecl GhcPs)
parseDeclGhcWithMode :: ParseFlags -> FilePath -> ParseResult (LHsDecl GhcPs)
parseDeclGhcWithMode ParseFlags
parseMode FilePath
s =
  let fixities :: [(FilePath, Fixity)]
fixities = ParseFlags -> [(FilePath, Fixity)]
ghcFixitiesFromParseFlags ParseFlags
parseMode
  in case FilePath -> DynFlags -> ParseResult (LHsDecl GhcPs)
parseDeclaration FilePath
s (DynFlags -> ParseResult (LHsDecl GhcPs))
-> DynFlags -> ParseResult (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ParseFlags -> DynFlags
parseModeToFlags ParseFlags
parseMode of
    POk PState
pst LHsDecl GhcPs
a -> PState -> LHsDecl GhcPs -> ParseResult (LHsDecl GhcPs)
forall a. PState -> a -> ParseResult a
POk PState
pst (LHsDecl GhcPs -> ParseResult (LHsDecl GhcPs))
-> LHsDecl GhcPs -> ParseResult (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ [(FilePath, Fixity)] -> LHsDecl GhcPs -> LHsDecl GhcPs
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities [(FilePath, Fixity)]
fixities LHsDecl GhcPs
a
    f :: ParseResult (LHsDecl GhcPs)
f@PFailed{} -> ParseResult (LHsDecl GhcPs)
f

-- | Create a 'ModuleEx' from GHC annotations and module tree. It
-- is assumed the incoming parse module has not been adjusted to
-- account for operator fixities (it uses the HLint default fixities).
createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
createModuleEx ApiAnns
anns Located (HsModule GhcPs)
ast =
  Located (HsModule GhcPs) -> ApiAnns -> ModuleEx
ModuleEx ([(FilePath, Fixity)]
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities (Located (HsModule GhcPs) -> [(FilePath, Fixity)]
fixitiesFromModule Located (HsModule GhcPs)
ast [(FilePath, Fixity)]
-> [(FilePath, Fixity)] -> [(FilePath, Fixity)]
forall a. [a] -> [a] -> [a]
++ (FixityInfo -> (FilePath, Fixity))
-> [FixityInfo] -> [(FilePath, Fixity)]
forall a b. (a -> b) -> [a] -> [b]
map FixityInfo -> (FilePath, Fixity)
toFixity [FixityInfo]
defaultFixities) Located (HsModule GhcPs)
ast) ApiAnns
anns

-- | Parse a Haskell module. Applies the C pre processor, and uses
-- best-guess fixity resolution if there are ambiguities.  The
-- filename @-@ is treated as @stdin@. Requires some flags (often
-- 'defaultParseFlags'), the filename, and optionally the contents of
-- that file.
--
-- Note that certain programs, e.g. @main = do@ successfully parse
-- with GHC, but then fail with an error in the renamer. These
-- programs will return a successful parse.
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx :: ParseFlags
-> FilePath -> Maybe FilePath -> IO (Either ParseError ModuleEx)
parseModuleEx ParseFlags
flags FilePath
file Maybe FilePath
str = FilePath
-> FilePath
-> IO (Either ParseError ModuleEx)
-> IO (Either ParseError ModuleEx)
forall a. FilePath -> FilePath -> IO a -> IO a
timedIO FilePath
"Parse" FilePath
file (IO (Either ParseError ModuleEx)
 -> IO (Either ParseError ModuleEx))
-> IO (Either ParseError ModuleEx)
-> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError IO ModuleEx -> IO (Either ParseError ModuleEx)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ParseError IO ModuleEx -> IO (Either ParseError ModuleEx))
-> ExceptT ParseError IO ModuleEx
-> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ do
  FilePath
str <- case Maybe FilePath
str of
    Just FilePath
x -> FilePath -> ExceptT ParseError IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
    Maybe FilePath
Nothing | FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"-" -> IO FilePath -> ExceptT ParseError IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getContentsUTF8
            | Bool
otherwise -> IO FilePath -> ExceptT ParseError IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT ParseError IO FilePath)
-> IO FilePath -> ExceptT ParseError IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFileUTF8' FilePath
file
  FilePath
str <- FilePath -> ExceptT ParseError IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> ExceptT ParseError IO FilePath)
-> FilePath -> ExceptT ParseError IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
forall a. Eq a => [a] -> [a] -> [a]
dropPrefix FilePath
"\65279" FilePath
str -- Remove the BOM if it exists, see #130.
  let enableDisableExts :: ([Extension], [Extension])
enableDisableExts = ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags
flags
  -- Read pragmas for the first time.
  DynFlags
dynFlags <- (FilePath -> ParseError)
-> ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (FilePath -> FilePath -> ParseError
parsePragmasErr FilePath
str) (ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags)
-> ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags
forall a b. (a -> b) -> a -> b
$ IO (Either FilePath DynFlags) -> ExceptT FilePath IO DynFlags
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (DynFlags
-> ([Extension], [Extension])
-> FilePath
-> FilePath
-> IO (Either FilePath DynFlags)
parsePragmasIntoDynFlags DynFlags
baseDynFlags ([Extension], [Extension])
enableDisableExts FilePath
file FilePath
str)
  DynFlags
dynFlags <- DynFlags -> ExceptT ParseError IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynFlags -> ExceptT ParseError IO DynFlags)
-> DynFlags -> ExceptT ParseError IO DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe Language -> DynFlags
lang_set DynFlags
dynFlags (Maybe Language -> DynFlags) -> Maybe Language -> DynFlags
forall a b. (a -> b) -> a -> b
$ ParseFlags -> Maybe Language
baseLanguage ParseFlags
flags
  -- Avoid running cpp unless CPP is enabled, see #1075.
  FilePath
str <- if Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
Cpp DynFlags
dynFlags) then FilePath -> ExceptT ParseError IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
str else IO FilePath -> ExceptT ParseError IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT ParseError IO FilePath)
-> IO FilePath -> ExceptT ParseError IO FilePath
forall a b. (a -> b) -> a -> b
$ CppFlags -> FilePath -> FilePath -> IO FilePath
runCpp (ParseFlags -> CppFlags
cppFlags ParseFlags
flags) FilePath
file FilePath
str
  -- If we preprocessed the file, re-read the pragmas.
  DynFlags
dynFlags <- if Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
Cpp DynFlags
dynFlags) then DynFlags -> ExceptT ParseError IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dynFlags
              else (FilePath -> ParseError)
-> ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (FilePath -> FilePath -> ParseError
parsePragmasErr FilePath
str) (ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags)
-> ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags
forall a b. (a -> b) -> a -> b
$ IO (Either FilePath DynFlags) -> ExceptT FilePath IO DynFlags
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (DynFlags
-> ([Extension], [Extension])
-> FilePath
-> FilePath
-> IO (Either FilePath DynFlags)
parsePragmasIntoDynFlags DynFlags
baseDynFlags ([Extension], [Extension])
enableDisableExts FilePath
file FilePath
str)
  DynFlags
dynFlags <- DynFlags -> ExceptT ParseError IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynFlags -> ExceptT ParseError IO DynFlags)
-> DynFlags -> ExceptT ParseError IO DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe Language -> DynFlags
lang_set DynFlags
dynFlags (Maybe Language -> DynFlags) -> Maybe Language -> DynFlags
forall a b. (a -> b) -> a -> b
$ ParseFlags -> Maybe Language
baseLanguage ParseFlags
flags
  -- Done with pragmas. Proceed to parsing.
  case FilePath
-> FilePath -> DynFlags -> ParseResult (Located (HsModule GhcPs))
fileToModule FilePath
file FilePath
str DynFlags
dynFlags of
    POk PState
s Located (HsModule GhcPs)
a -> do
      let errs :: [ErrMsg]
errs = Bag ErrMsg -> [ErrMsg]
forall a. Bag a -> [a]
bagToList (Bag ErrMsg -> [ErrMsg])
-> ((Bag ErrMsg, Bag ErrMsg) -> Bag ErrMsg)
-> (Bag ErrMsg, Bag ErrMsg)
-> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag ErrMsg, Bag ErrMsg) -> Bag ErrMsg
forall a b. (a, b) -> b
snd ((Bag ErrMsg, Bag ErrMsg) -> [ErrMsg])
-> (Bag ErrMsg, Bag ErrMsg) -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ PState -> DynFlags -> (Bag ErrMsg, Bag ErrMsg)
getMessages PState
s DynFlags
dynFlags
      if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ErrMsg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrMsg]
errs then
        IO (Either ParseError ModuleEx) -> ExceptT ParseError IO ModuleEx
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ParseError ModuleEx) -> ExceptT ParseError IO ModuleEx)
-> IO (Either ParseError ModuleEx)
-> ExceptT ParseError IO ModuleEx
forall a b. (a -> b) -> a -> b
$ DynFlags
-> FilePath
-> FilePath
-> FilePath
-> [ErrMsg]
-> IO (Either ParseError ModuleEx)
parseFailureErr DynFlags
dynFlags FilePath
str FilePath
file FilePath
str [ErrMsg]
errs
      else do
        let anns :: ApiAnns
anns =
              ( ([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
(++) ([(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall a b. (a -> b) -> a -> b
$ PState -> [(ApiAnnKey, [SrcSpan])]
annotations PState
s
              , [(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((SrcSpan
noSrcSpan, PState -> [Located AnnotationComment]
comment_q PState
s) (SrcSpan, [Located AnnotationComment])
-> [(SrcSpan, [Located AnnotationComment])]
-> [(SrcSpan, [Located AnnotationComment])]
forall a. a -> [a] -> [a]
: PState -> [(SrcSpan, [Located AnnotationComment])]
annotations_comments PState
s)
              )
        let fixes :: [(FilePath, Fixity)]
fixes = Located (HsModule GhcPs) -> [(FilePath, Fixity)]
fixitiesFromModule Located (HsModule GhcPs)
a [(FilePath, Fixity)]
-> [(FilePath, Fixity)] -> [(FilePath, Fixity)]
forall a. [a] -> [a] -> [a]
++ ParseFlags -> [(FilePath, Fixity)]
ghcFixitiesFromParseFlags ParseFlags
flags
        ModuleEx -> ExceptT ParseError IO ModuleEx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleEx -> ExceptT ParseError IO ModuleEx)
-> ModuleEx -> ExceptT ParseError IO ModuleEx
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs) -> ApiAnns -> ModuleEx
ModuleEx ([(FilePath, Fixity)]
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities [(FilePath, Fixity)]
fixes Located (HsModule GhcPs)
a) ApiAnns
anns
    PFailed PState
s ->
      IO (Either ParseError ModuleEx) -> ExceptT ParseError IO ModuleEx
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ParseError ModuleEx) -> ExceptT ParseError IO ModuleEx)
-> IO (Either ParseError ModuleEx)
-> ExceptT ParseError IO ModuleEx
forall a b. (a -> b) -> a -> b
$ DynFlags
-> FilePath
-> FilePath
-> FilePath
-> [ErrMsg]
-> IO (Either ParseError ModuleEx)
parseFailureErr DynFlags
dynFlags FilePath
str FilePath
file FilePath
str ([ErrMsg] -> IO (Either ParseError ModuleEx))
-> [ErrMsg] -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$  Bag ErrMsg -> [ErrMsg]
forall a. Bag a -> [a]
bagToList (Bag ErrMsg -> [ErrMsg])
-> ((Bag ErrMsg, Bag ErrMsg) -> Bag ErrMsg)
-> (Bag ErrMsg, Bag ErrMsg)
-> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag ErrMsg, Bag ErrMsg) -> Bag ErrMsg
forall a b. (a, b) -> b
snd ((Bag ErrMsg, Bag ErrMsg) -> [ErrMsg])
-> (Bag ErrMsg, Bag ErrMsg) -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ PState -> DynFlags -> (Bag ErrMsg, Bag ErrMsg)
getMessages PState
s DynFlags
dynFlags
  where
    -- If parsing pragmas fails, synthesize a parse error from the
    -- error message.
    parsePragmasErr :: FilePath -> FilePath -> ParseError
parsePragmasErr FilePath
src FilePath
msg =
      let loc :: SrcLoc
loc = FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
mkFastString FilePath
file) (Int
1 :: Int) (Int
1 :: Int)
      in SrcSpan -> FilePath -> FilePath -> ParseError
ParseError (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc) FilePath
msg FilePath
src

    parseFailureErr :: DynFlags
-> FilePath
-> FilePath
-> FilePath
-> [ErrMsg]
-> IO (Either ParseError ModuleEx)
parseFailureErr DynFlags
dynFlags FilePath
ppstr FilePath
file FilePath
str [ErrMsg]
errs =
      let errMsg :: ErrMsg
errMsg = [ErrMsg] -> ErrMsg
forall a. [a] -> a
head [ErrMsg]
errs
          loc :: SrcSpan
loc = ErrMsg -> SrcSpan
errMsgSpan ErrMsg
errMsg
          doc :: MsgDoc
doc = DynFlags -> ErrDoc -> MsgDoc
formatErrDoc DynFlags
dynFlags (ErrMsg -> ErrDoc
errMsgDoc ErrMsg
errMsg)
      in FilePath
-> FilePath
-> FilePath
-> (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx FilePath
ppstr FilePath
file FilePath
str (SrcSpan
loc, MsgDoc
doc)

-- | Given a line number, and some source code, put bird ticks around the appropriate bit.
context :: Int -> String -> String
context :: Int -> FilePath -> FilePath
context Int
lineNo FilePath
src =
    [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd ((Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
    (FilePath -> FilePath -> FilePath)
-> [FilePath] -> [FilePath] -> [FilePath]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
(++) [FilePath]
ticks ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take Int
5 ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop (Int
lineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
src [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"",FilePath
"",FilePath
"",FilePath
"",FilePath
""]
    where ticks :: [FilePath]
ticks = Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineNo) [FilePath
"  ",FilePath
"  ",FilePath
"> ",FilePath
"  ",FilePath
"  "]