compiler/main/HeaderInfo.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- | Parsing the top of a Haskell source file to get its module name,
   4 -- imports and options.
   5 --
   6 -- (c) Simon Marlow 2005
   7 -- (c) Lemmih 2006
   8 --
   9 -----------------------------------------------------------------------------
  10
  11 module HeaderInfo ( getImports
  12                   , getOptionsFromFile, getOptions
  13                   , optionsErrorMsgs,
  14                     checkProcessArgsResult ) where
  15
  16 #include "HsVersions.h"
  17
  18 import HscTypes
  19 import Parser           ( parseHeader )
  20 import Lexer
  21 import FastString
  22 import HsSyn            ( ImportDecl(..), HsModule(..) )
  23 import Module           ( ModuleName, moduleName )
  24 import PrelNames        ( gHC_PRIM, mAIN_NAME )
  25 import StringBuffer     ( StringBuffer(..), hGetStringBufferBlock
  26                         , appendStringBuffers )
  27 import SrcLoc
  28 import DynFlags
  29 import ErrUtils
  30 import Util
  31 import Outputable
  32 import Pretty           ()
  33 import Maybes
  34 import Bag              ( emptyBag, listToBag, unitBag )
  35
  36 import MonadUtils       ( MonadIO )
  37 import Exception
  38 import Control.Monad
  39 import System.IO
  40 import Data.List
  41
  42 ------------------------------------------------------------------------------
  43
  44 -- | Parse the imports of a source file.
  45 --
  46 -- Throws a 'SourceError' if parsing fails.
  47 getImports :: GhcMonad m =>
  48               DynFlags
  49            -> StringBuffer -- ^ Parse this.
  50            -> FilePath     -- ^ Filename the buffer came from.  Used for
  51                            --   reporting parse error locations.
  52            -> FilePath     -- ^ The original source filename (used for locations
  53                            --   in the function result)
  54            -> m ([Located ModuleName], [Located ModuleName], Located ModuleName)
  55               -- ^ The source imports, normal imports, and the module name.
  56 getImports dflags buf filename source_filename = do
  57   let loc  = mkSrcLoc (mkFastString filename) 1 0
  58   case unP parseHeader (mkPState buf loc dflags) of
  59     PFailed span err -> parseError span err
  60     POk pst rdr_module -> do
  61       let ms@(warns, errs) = getMessages pst
  62       logWarnings warns
  63       if errorsFound dflags ms
  64         then liftIO $ throwIO $ mkSrcErr errs
  65         else
  66           case rdr_module of
  67             L _ (HsModule mb_mod _ imps _ _ _ _) ->
  68               let
  69                 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
  70                 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
  71                 imps' = filter isHomeImp (map unLoc imps)
  72                 (src_idecls, ord_idecls) = partition isSourceIdecl imps'
  73                 source_imps   = map getImpMod src_idecls
  74                 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc)
  75                                         (map getImpMod ord_idecls)
  76                      -- GHC.Prim doesn't exist physically, so don't go looking for it.
  77               in
  78               return (source_imps, ordinary_imps, mod)
  79
  80 parseError :: GhcMonad m => SrcSpan -> Message -> m a
  81 parseError span err = throwOneError $ mkPlainErrMsg span err
  82
  83 -- we aren't interested in package imports here, filter them out
  84 isHomeImp :: ImportDecl name -> Bool
  85 isHomeImp (ImportDecl _ (Just p) _ _ _ _) = p == fsLit "this"
  86 isHomeImp (ImportDecl _ Nothing  _ _ _ _) = True
  87
  88 isSourceIdecl :: ImportDecl name -> Bool
  89 isSourceIdecl (ImportDecl _ _ s _ _ _) = s
  90
  91 getImpMod :: ImportDecl name -> Located ModuleName
  92 getImpMod (ImportDecl located_mod _ _ _ _ _) = located_mod
  93
  94 --------------------------------------------------------------
  95 -- Get options
  96 --------------------------------------------------------------
  97
  98 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
  99 --
 100 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
 101 getOptionsFromFile :: DynFlags
 102                    -> FilePath            -- ^ Input file
 103                    -> IO [Located String] -- ^ Parsed options, if any.
 104 getOptionsFromFile dflags filename
 105     = Exception.bracket
 106               (openBinaryFile filename ReadMode)
 107               (hClose)
 108               (\handle ->
 109                    do buf <- hGetStringBufferBlock handle blockSize
 110                       loop handle buf)
 111     where blockSize = 1024
 112           loop handle buf
 113               | len buf == 0 = return []
 114               | otherwise
 115               = case getOptions' dflags buf filename of
 116                   (Nothing, opts) -> return opts
 117                   (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
 118                                           newBuf <- appendStringBuffers buf' nextBlock
 119                                           if len newBuf == len buf
 120                                              then return opts
 121                                              else do opts' <- loop handle newBuf
 122                                                      return (opts++opts')
 123
 124 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
 125 --
 126 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
 127 getOptions :: DynFlags
 128            -> StringBuffer -- ^ Input Buffer
 129            -> FilePath     -- ^ Source filename.  Used for location info.
 130            -> [Located String] -- ^ Parsed options.
 131 getOptions dflags buf filename
 132     = case getOptions' dflags buf filename of
 133         (_,opts) -> opts
 134
 135 -- The token parser is written manually because Happy can't
 136 -- return a partial result when it encounters a lexer error.
 137 -- We want to extract options before the buffer is passed through
 138 -- CPP, so we can't use the same trick as 'getImports'.
 139 getOptions' :: DynFlags
 140             -> StringBuffer         -- Input buffer
 141             -> FilePath             -- Source file. Used for msgs only.
 142             -> ( Maybe StringBuffer -- Just => we can use more input
 143                , [Located String]   -- Options.
 144                )
 145 getOptions' dflags buf filename
 146     = parseToks (lexAll (pragState dflags buf loc))
 147     where loc  = mkSrcLoc (mkFastString filename) 1 0
 148
 149           getToken (_buf,L _loc tok) = tok
 150           getLoc (_buf,L loc _tok) = loc
 151           getBuf (buf,_tok) = buf
 152           combine opts (flag, opts') = (flag, opts++opts')
 153           add opt (flag, opts) = (flag, opt:opts)
 154
 155           parseToks (open:close:xs)
 156               | IToptions_prag str <- getToken open
 157               , ITclose_prag       <- getToken close
 158               = map (L (getLoc open)) (words str) `combine`
 159                 parseToks xs
 160           parseToks (open:close:xs)
 161               | ITinclude_prag str <- getToken open
 162               , ITclose_prag       <- getToken close
 163               = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
 164                 parseToks xs
 165           parseToks (open:close:xs)
 166               | ITdocOptions str <- getToken open
 167               , ITclose_prag     <- getToken close
 168               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 169                 `combine` parseToks xs
 170           parseToks (open:xs)
 171               | ITdocOptionsOld str <- getToken open
 172               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 173                 `combine` parseToks xs
 174           parseToks (open:xs)
 175               | ITlanguage_prag <- getToken open
 176               = parseLanguage xs
 177           -- The last token before EOF could have been truncated.
 178           -- We ignore it to be on the safe side.
 179           parseToks [tok,eof]
 180               | ITeof <- getToken eof
 181               = (Just (getBuf tok),[])
 182           parseToks (eof:_)
 183               | ITeof <- getToken eof
 184               = (Just (getBuf eof),[])
 185           parseToks _ = (Nothing,[])
 186           parseLanguage ((_buf,L loc (ITconid fs)):rest)
 187               = checkExtension (L loc fs) `add`
 188                 case rest of
 189                   (_,L _loc ITcomma):more -> parseLanguage more
 190                   (_,L _loc ITclose_prag):more -> parseToks more
 191                   (_,L loc _):_ -> languagePragParseError loc
 192                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"
 193           parseLanguage (tok:_)
 194               = languagePragParseError (getLoc tok)
 195           parseLanguage []
 196               = panic "getOptions'.parseLanguage(2) went past eof token"
 197           lexToken t = return t
 198           lexAll state = case unP (lexer lexToken) state of
 199                            POk _      t@(L _ ITeof) -> [(buffer state,t)]
 200                            POk state' t -> (buffer state,t):lexAll state'
 201                            _ -> [(buffer state,L (last_loc state) ITeof)]
 202
 203 -----------------------------------------------------------------------------
 204
 205 -- | Complain about non-dynamic flags in OPTIONS pragmas.
 206 --
 207 -- Throws a 'SourceError' if the input list is non-empty claiming that the
 208 -- input flags are unknown.
 209 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
 210 checkProcessArgsResult flags
 211   = when (notNull flags) $
 212       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
 213     where mkMsg (L loc flag)
 214               = mkPlainErrMsg loc $
 215                   (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
 216                    text flag)
 217
 218 -----------------------------------------------------------------------------
 219
 220 checkExtension :: Located FastString -> Located String
 221 checkExtension (L l ext)
 222 -- Checks if a given extension is valid, and if so returns
 223 -- its corresponding flag. Otherwise it throws an exception.
 224  =  let ext' = unpackFS ext in
 225     if ext' `elem` supportedLanguages
 226        || ext' `elem` (map ("No"++) supportedLanguages)
 227     then L l ("-X"++ext')
 228     else unsupportedExtnError l ext'
 229
 230 languagePragParseError :: SrcSpan -> a
 231 languagePragParseError loc =
 232   throw $ mkSrcErr $ unitBag $
 233      (mkPlainErrMsg loc $
 234        text "cannot parse LANGUAGE pragma: comma-separated list expected")
 235
 236 unsupportedExtnError :: SrcSpan -> String -> a
 237 unsupportedExtnError loc unsup =
 238   throw $ mkSrcErr $ unitBag $
 239     mkPlainErrMsg loc $
 240         text "unsupported extension: " <> text unsup
 241
 242
 243 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
 244 optionsErrorMsgs unhandled_flags flags_lines _filename
 245   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
 246   where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
 247                                           L l f' <- flags_lines, f == f' ]
 248         mkMsg (L flagSpan flag) =
 249             ErrUtils.mkPlainErrMsg flagSpan $
 250                     text "unknown flag in  {-# OPTIONS #-} pragma:" <+> text flag
 251