compiler/main/HeaderInfo.hs

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