ghc/compiler/main/GetImports.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Parsing the top of a Haskell source file to get its module name
   4 -- and imports.
   5 --
   6 -- (c) Simon Marlow 2005
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module GetImports ( getImportsFromFile, getImports ) where
  11
  12 #include "HsVersions.h"
  13
  14 import Parser           ( parseHeader )
  15 import Lexer            ( P(..), ParseResult(..), mkPState )
  16 import HsSyn            ( ImportDecl(..), HsModule(..) )
  17 import Module           ( Module, mkModule )
  18 import StringBuffer     ( StringBuffer, hGetStringBuffer )
  19 import SrcLoc           ( Located(..), mkSrcLoc, unLoc )
  20 import FastString       ( mkFastString )
  21 import CmdLineOpts      ( DynFlags )
  22 import ErrUtils
  23 import Pretty
  24 import Panic
  25 import Bag              ( unitBag )
  26
  27 import EXCEPTION        ( throwDyn )
  28 import IO
  29 import List
  30
  31 -- getImportsFromFile is careful to close the file afterwards, otherwise
  32 -- we can end up with a large number of open handles before the garbage
  33 -- collector gets around to closing them.
  34 getImportsFromFile :: DynFlags -> FilePath -> IO ([Module], [Module], Module)
  35 getImportsFromFile dflags filename = do
  36   buf <- hGetStringBuffer filename
  37   getImports dflags buf filename
  38
  39 getImports :: DynFlags -> StringBuffer -> FilePath -> IO ([Module], [Module], Module)
  40 getImports dflags buf filename = do
  41   let loc  = mkSrcLoc (mkFastString filename) 1 0
  42   case unP parseHeader (mkPState buf loc dflags) of
  43         PFailed span err -> parseError span err
  44         POk _ rdr_module ->
  45           case rdr_module of
  46             L _ (HsModule mod _ imps _ _) ->
  47               let
  48                 mod_name | Just (L _ m) <- mod = m
  49                          | otherwise           = mkModule "Main"
  50                 (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
  51                 source_imps   = map getImpMod src_idecls
  52                 ordinary_imps = map getImpMod ord_idecls
  53               in
  54               return (source_imps, ordinary_imps, mod_name)
  55
  56 parseError span err = throwDyn (ProgramError err_doc)
  57   where err_doc = render (pprBagOfErrors (unitBag (mkPlainErrMsg span err)))
  58
  59 isSourceIdecl (ImportDecl _ s _ _ _) = s
  60
  61 getImpMod (ImportDecl (L _ mod) _ _ _ _) = mod