#include "HsVersions.h"
+import HscTypes
import Parser ( parseHeader )
import Lexer
import FastString
import Util
import Outputable
import Pretty ()
-import Panic
import Maybes
-import Bag ( emptyBag, listToBag )
+import Bag ( emptyBag, listToBag, unitBag )
-import Control.Exception
+import MonadUtils ( MonadIO )
+import Exception
import Control.Monad
-import System.Exit
import System.IO
import Data.List
-#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 601
- -- already imported above
---import System.IO ( openBinaryFile )
-#else
-import IOExts ( openFileEx, IOModeEx(..) )
-#endif
+------------------------------------------------------------------------------
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
-openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
-#endif
-
-getImports :: DynFlags -> StringBuffer -> FilePath -> FilePath
- -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
+-- | Parse the imports of a source file.
+--
+-- Throws a 'SourceError' if parsing fails.
+getImports :: GhcMonad m =>
+ DynFlags
+ -> StringBuffer -- ^ Parse this.
+ -> FilePath -- ^ Filename the buffer came from. Used for
+ -- reporting parse error locations.
+ -> FilePath -- ^ The original source filename (used for locations
+ -- in the function result)
+ -> m ([Located ModuleName], [Located ModuleName], Located ModuleName)
+ -- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
let loc = mkSrcLoc (mkFastString filename) 1 0
case unP parseHeader (mkPState buf loc dflags) of
- PFailed span err -> parseError span err
- POk pst rdr_module -> do
- let ms = getMessages pst
- printErrorsAndWarnings dflags ms
- when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
+ PFailed span err -> parseError span err
+ POk pst rdr_module -> do
+ let ms@(warns, errs) = getMessages pst
+ logWarnings warns
+ if errorsFound dflags ms
+ then liftIO $ throwIO $ mkSrcErr errs
+ else
case rdr_module of
L _ (HsModule mb_mod _ imps _ _ _ _) ->
let
main_loc = mkSrcLoc (mkFastString source_filename) 1 0
mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
- (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
- source_imps = map getImpMod src_idecls
+ imps' = filter isHomeImp (map unLoc imps)
+ (src_idecls, ord_idecls) = partition isSourceIdecl imps'
+ source_imps = map getImpMod src_idecls
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc)
(map getImpMod ord_idecls)
-- GHC.Prim doesn't exist physically, so don't go looking for it.
in
return (source_imps, ordinary_imps, mod)
-parseError :: SrcSpan -> Message -> a
-parseError span err = throwDyn $ mkPlainErrMsg span err
+parseError :: GhcMonad m => SrcSpan -> Message -> m a
+parseError span err = throwOneError $ mkPlainErrMsg span err
+
+-- we aren't interested in package imports here, filter them out
+isHomeImp :: ImportDecl name -> Bool
+isHomeImp (ImportDecl _ (Just p) _ _ _ _) = p == fsLit "this"
+isHomeImp (ImportDecl _ Nothing _ _ _ _) = True
isSourceIdecl :: ImportDecl name -> Bool
-isSourceIdecl (ImportDecl _ s _ _ _) = s
+isSourceIdecl (ImportDecl _ _ s _ _ _) = s
getImpMod :: ImportDecl name -> Located ModuleName
-getImpMod (ImportDecl located_mod _ _ _ _) = located_mod
+getImpMod (ImportDecl located_mod _ _ _ _ _) = located_mod
--------------------------------------------------------------
-- Get options
-> FilePath -- input file
-> IO [Located String] -- options, if any
getOptionsFromFile dflags filename
- = Control.Exception.bracket
+ = Exception.bracket
(openBinaryFile filename ReadMode)
(hClose)
(\handle ->
-----------------------------------------------------------------------------
-- Complain about non-dynamic flags in OPTIONS pragmas
-checkProcessArgsResult :: [String] -> FilePath -> IO ()
-checkProcessArgsResult flags filename
- = do when (notNull flags) (throwDyn (ProgramError (
- showSDoc (hang (text filename <> char ':')
- 4 (text "unknown flags in {-# OPTIONS #-} pragma:" <+>
- hsep (map text flags)))
- )))
+checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
+checkProcessArgsResult flags
+ = when (notNull flags) $
+ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
+ where mkMsg (L loc flag)
+ = mkPlainErrMsg loc $
+ (text "unknown flag in {-# OPTIONS #-} pragma:" <+>
+ text flag)
-----------------------------------------------------------------------------
languagePragParseError :: SrcSpan -> a
languagePragParseError loc =
- pgmError
- (showSDoc (mkLocMessage loc (
- text "cannot parse LANGUAGE pragma: comma-separated list expected")))
+ throw $ mkSrcErr $ unitBag $
+ (mkPlainErrMsg loc $
+ text "cannot parse LANGUAGE pragma: comma-separated list expected")
unsupportedExtnError :: SrcSpan -> String -> a
unsupportedExtnError loc unsup =
- pgmError (showSDoc (mkLocMessage loc (
- text "unsupported extension: " <>
- text unsup)))
+ throw $ mkSrcErr $ unitBag $
+ mkPlainErrMsg loc $
+ text "unsupported extension: " <> text unsup
optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages