path: root/compiler/GHC/Parser/Header.hs

{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------
--
-- | Parsing the top of a Haskell source file to get its module name,
-- imports and options.
--
-- (c) Simon Marlow 2005
-- (c) Lemmih 2006
--
-----------------------------------------------------------------------------

module GHC.Parser.Header
   ( getImports
   , mkPrelImports -- used by the renamer too
   , getOptionsFromFile
   , getOptions
   , toArgs
   , checkProcessArgsResult
   )
where

import GHC.Prelude

import GHC.Platform

import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions!

import GHC.Parser.Errors.Types
import GHC.Parser           ( parseHeader )
import GHC.Parser.Lexer

import GHC.Hs
import GHC.Unit.Module
import GHC.Builtin.Names

import GHC.Types.Error hiding ( getErrorMessages, getWarningMessages, getMessages )
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.SourceText

import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Monad
import GHC.Utils.Error
import GHC.Utils.Exception as Exception

import GHC.Data.StringBuffer
import GHC.Data.Maybe
import GHC.Data.FastString
import qualified GHC.Data.Strict as Strict

import Control.Monad
import System.IO
import System.IO.Unsafe
import Data.List (partition)
import Data.Char (isSpace)
import Text.ParserCombinators.ReadP (readP_to_S, gather)
import Text.ParserCombinators.ReadPrec (readPrec_to_P)
import Text.Read (readPrec)

------------------------------------------------------------------------------

-- | Parse the imports of a source file.
--
-- Throws a 'SourceError' if parsing fails.
getImports :: ParserOpts   -- ^ Parser options
           -> Bool         -- ^ Implicit Prelude?
           -> 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)
           -> IO (Either
               (Messages PsMessage)
               ([(Maybe FastString, Located ModuleName)],
                [(Maybe FastString, Located ModuleName)],
                Located ModuleName))
              -- ^ The source imports and normal imports (with optional package
              -- names from -XPackageImports), and the module name.
getImports popts implicit_prelude buf filename source_filename = do
  let loc  = mkRealSrcLoc (mkFastString filename) 1 1
  case unP parseHeader (initParserState popts buf loc) of
    PFailed pst ->
        -- assuming we're not logging warnings here as per below
      return $ Left $ getErrorMessages pst
    POk pst rdr_module -> fmap Right $ do
      let (_warns, errs) = getMessages pst
      -- don't log warnings: they'll be reported when we parse the file
      -- for real.  See #2500.
      if not (isEmptyMessages errs)
        then throwErrors (GhcPsMessage <$> errs)
        else
          let   hsmod = unLoc rdr_module
                mb_mod = hsmodName hsmod
                imps = hsmodImports hsmod
                main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
                                       1 1)
                mod = mb_mod `orElse` L main_loc mAIN_NAME
                (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps

               -- GHC.Prim doesn't exist physically, so don't go looking for it.
                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
                                        . ideclName . unLoc)
                                       ord_idecls

                implicit_imports = mkPrelImports (unLoc mod) main_loc
                                                 implicit_prelude imps
                convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
              in
              return (map convImport src_idecls,
                      map convImport (implicit_imports ++ ordinary_imps),
                      mod)

mkPrelImports :: ModuleName
              -> SrcSpan    -- Attribute the "import Prelude" to this location
              -> Bool -> [LImportDecl GhcPs]
              -> [LImportDecl GhcPs]
-- Construct the implicit declaration "import Prelude" (or not)
--
-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
-- because the former doesn't even look at Prelude.hi for instance
-- declarations, whereas the latter does.
mkPrelImports this_mod loc implicit_prelude import_decls
  | this_mod == pRELUDE_NAME
   || explicit_prelude_import
   || not implicit_prelude
  = []
  | otherwise = [preludeImportDecl]
  where
      explicit_prelude_import = any is_prelude_import import_decls

      is_prelude_import (L _ decl) =
        unLoc (ideclName decl) == pRELUDE_NAME
        -- allow explicit "base" package qualifier (#19082, #17045)
        && case ideclPkgQual decl of
            Nothing -> True
            Just b  -> sl_fs b == unitIdFS baseUnitId


      loc' = noAnnSrcSpan loc
      preludeImportDecl :: LImportDecl GhcPs
      preludeImportDecl
        = L loc' $ ImportDecl { ideclExt       = noAnn,
                                ideclSourceSrc = NoSourceText,
                                ideclName      = L loc pRELUDE_NAME,
                                ideclPkgQual   = Nothing,
                                ideclSource    = NotBoot,
                                ideclSafe      = False,  -- Not a safe import
                                ideclQualified = NotQualified,
                                ideclImplicit  = True,   -- Implicit!
                                ideclAs        = Nothing,
                                ideclHiding    = Nothing  }

--------------------------------------------------------------
-- Get options
--------------------------------------------------------------

-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
getOptionsFromFile :: DynFlags
                   -> FilePath            -- ^ Input file
                   -> IO [Located String] -- ^ Parsed options, if any.
getOptionsFromFile dflags filename
    = Exception.bracket
              (openBinaryFile filename ReadMode)
              (hClose)
              (\handle -> do
                  opts <- fmap (getOptions' dflags)
                               (lazyGetToks (initParserOpts dflags') filename handle)
                  seqList opts $ return opts)
    where -- We don't need to get haddock doc tokens when we're just
          -- getting the options from pragmas, and lazily lexing them
          -- correctly is a little tricky: If there is "\n" or "\n-"
          -- left at the end of a buffer then the haddock doc may
          -- continue past the end of the buffer, despite the fact that
          -- we already have an apparently-complete token.
          -- We therefore just turn Opt_Haddock off when doing the lazy
          -- lex.
          dflags' = gopt_unset dflags Opt_Haddock

blockSize :: Int
-- blockSize = 17 -- for testing :-)
blockSize = 1024

lazyGetToks :: ParserOpts -> FilePath -> Handle -> IO [Located Token]
lazyGetToks popts filename handle = do
  buf <- hGetStringBufferBlock handle blockSize
  let prag_state = initPragState popts buf loc
  unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize
 where
  loc  = mkRealSrcLoc (mkFastString filename) 1 1

  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
  lazyLexBuf handle state eof size =
    case unP (lexer False return) state of
      POk state' t -> do
        -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
        if atEnd (buffer state') && not eof
           -- if this token reached the end of the buffer, and we haven't
           -- necessarily read up to the end of the file, then the token might
           -- be truncated, so read some more of the file and lex it again.
           then getMore handle state size
           else case unLoc t of
                  ITeof  -> return [t]
                  _other -> do rest <- lazyLexBuf handle state' eof size
                               return (t : rest)
      _ | not eof   -> getMore handle state size
        | otherwise -> return [L (mkSrcSpanPs (last_loc state)) ITeof]
                         -- parser assumes an ITeof sentinel at the end

  getMore :: Handle -> PState -> Int -> IO [Located Token]
  getMore handle state size = do
     -- pprTrace "getMore" (text (show (buffer state))) (return ())
     let new_size = size * 2
       -- double the buffer size each time we read a new block.  This
       -- counteracts the quadratic slowdown we otherwise get for very
       -- large module names (#5981)
     nextbuf <- hGetStringBufferBlock handle new_size
     if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
       newbuf <- appendStringBuffers (buffer state) nextbuf
       unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size


getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
getToks popts filename buf = lexAll pstate
 where
  pstate = initPragState popts buf loc
  loc  = mkRealSrcLoc (mkFastString filename) 1 1

  lexAll state = case unP (lexer False return) state of
                   POk _      t@(L _ ITeof) -> [t]
                   POk state' t -> t : lexAll state'
                   _ -> [L (mkSrcSpanPs (last_loc state)) ITeof]


-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
getOptions :: DynFlags
           -> StringBuffer -- ^ Input Buffer
           -> FilePath     -- ^ Source filename.  Used for location info.
           -> [Located String] -- ^ Parsed options.
getOptions dflags buf filename
    = getOptions' dflags (getToks (initParserOpts dflags) filename buf)

-- The token parser is written manually because Happy can't
-- return a partial result when it encounters a lexer error.
-- We want to extract options before the buffer is passed through
-- CPP, so we can't use the same trick as 'getImports'.
getOptions' :: DynFlags
            -> [Located Token]      -- Input buffer
            -> [Located String]     -- Options.
getOptions' dflags toks
    = parseToks toks
    where
          parseToks (open:close:xs)
              | IToptions_prag str <- unLoc open
              , ITclose_prag       <- unLoc close
              = case toArgs starting_loc str of
                  Left _err -> optionsParseError str $   -- #15053
                                 combineSrcSpans (getLoc open) (getLoc close)
                  Right args -> args ++ parseToks xs
            where
              src_span      = getLoc open
              real_src_span = expectJust "getOptions'" (srcSpanToRealSrcSpan src_span)
              starting_loc  = realSrcSpanStart real_src_span
          parseToks (open:close:xs)
              | ITinclude_prag str <- unLoc open
              , ITclose_prag       <- unLoc close
              = map (L (getLoc open)) ["-#include",removeSpaces str] ++
                parseToks xs
          parseToks (open:close:xs)
              | ITdocOptions str _ <- unLoc open
              , ITclose_prag       <- unLoc close
              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
                ++ parseToks xs
          parseToks (open:xs)
              | ITlanguage_prag <- unLoc open
              = parseLanguage xs
          parseToks (comment:xs) -- Skip over comments
              | isComment (unLoc comment)
              = parseToks xs
          parseToks _ = []
          parseLanguage ((L loc (ITconid fs)):rest)
              = checkExtension dflags (L loc fs) :
                case rest of
                  (L _loc ITcomma):more -> parseLanguage more
                  (L _loc ITclose_prag):more -> parseToks more
                  (L loc _):_ -> languagePragParseError loc
                  [] -> panic "getOptions'.parseLanguage(1) went past eof token"
          parseLanguage (tok:_)
              = languagePragParseError (getLoc tok)
          parseLanguage []
              = panic "getOptions'.parseLanguage(2) went past eof token"

          isComment :: Token -> Bool
          isComment c =
            case c of
              (ITlineComment {})     -> True
              (ITblockComment {})    -> True
              (ITdocCommentNext {})  -> True
              (ITdocCommentPrev {})  -> True
              (ITdocCommentNamed {}) -> True
              (ITdocSection {})      -> True
              _                      -> False

toArgs :: RealSrcLoc
       -> String -> Either String   -- Error
                           [Located String] -- Args
toArgs starting_loc orig_str
    = let (after_spaces_loc, after_spaces_str) = consume_spaces starting_loc orig_str in
      case after_spaces_str of
      '[':after_bracket ->
        let after_bracket_loc = advanceSrcLoc after_spaces_loc '['
            (after_bracket_spaces_loc, after_bracket_spaces_str)
              = consume_spaces after_bracket_loc after_bracket in
        case after_bracket_spaces_str of
          ']':rest | all isSpace rest -> Right []
          _ -> readAsList after_bracket_spaces_loc after_bracket_spaces_str

      _ -> toArgs' after_spaces_loc after_spaces_str
 where
  consume_spaces :: RealSrcLoc -> String -> (RealSrcLoc, String)
  consume_spaces loc [] = (loc, [])
  consume_spaces loc (c:cs)
    | isSpace c = consume_spaces (advanceSrcLoc loc c) cs
    | otherwise = (loc, c:cs)

  break_with_loc :: (Char -> Bool) -> RealSrcLoc -> String
                 -> (String, RealSrcLoc, String)  -- location is start of second string
  break_with_loc p = go []
    where
      go reversed_acc loc [] = (reverse reversed_acc, loc, [])
      go reversed_acc loc (c:cs)
        | p c       = (reverse reversed_acc, loc, c:cs)
        | otherwise = go (c:reversed_acc) (advanceSrcLoc loc c) cs

  advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc
  advance_src_loc_many = foldl' advanceSrcLoc

  locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a
  locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Strict.Nothing) x

  toArgs' :: RealSrcLoc -> String -> Either String [Located String]
  -- Remove outer quotes:
  -- > toArgs' "\"foo\" \"bar baz\""
  -- Right ["foo", "bar baz"]
  --
  -- Keep inner quotes:
  -- > toArgs' "-DFOO=\"bar baz\""
  -- Right ["-DFOO=\"bar baz\""]
  toArgs' loc s =
    let (after_spaces_loc, after_spaces_str) = consume_spaces loc s in
    case after_spaces_str of
      [] -> Right []
      '"' : _ -> do
        -- readAsString removes outer quotes
        (arg, new_loc, rest) <- readAsString after_spaces_loc after_spaces_str
        check_for_space rest
        (locate after_spaces_loc new_loc arg:)
          `fmap` toArgs' new_loc rest
      _ -> case break_with_loc (isSpace <||> (== '"')) after_spaces_loc after_spaces_str of
            (argPart1, loc2, s''@('"':_)) -> do
                (argPart2, loc3, rest) <- readAsString loc2 s''
                check_for_space rest
                -- show argPart2 to keep inner quotes
                (locate after_spaces_loc loc3 (argPart1 ++ show argPart2):)
                  `fmap` toArgs' loc3 rest
            (arg, loc2, s'') -> (locate after_spaces_loc loc2 arg:)
                                  `fmap` toArgs' loc2 s''

  check_for_space :: String -> Either String ()
  check_for_space [] = Right ()
  check_for_space (c:_)
    | isSpace c = Right ()
    | otherwise = Left ("Whitespace expected after string in " ++ show orig_str)

  reads_with_consumed :: Read a => String
                      -> [((String, a), String)]
                        -- ((consumed string, parsed result), remainder of input)
  reads_with_consumed = readP_to_S (gather (readPrec_to_P readPrec 0))

  readAsString :: RealSrcLoc
               -> String
               -> Either String (String, RealSrcLoc, String)
  readAsString loc s = case reads_with_consumed s of
                [((consumed, arg), rest)] ->
                    Right (arg, advance_src_loc_many loc consumed, rest)
                _ ->
                    Left ("Couldn't read " ++ show s ++ " as String")

   -- input has had the '[' stripped off
  readAsList :: RealSrcLoc -> String -> Either String [Located String]
  readAsList loc s = do
    let (after_spaces_loc, after_spaces_str) = consume_spaces loc s
    (arg, after_arg_loc, after_arg_str) <- readAsString after_spaces_loc after_spaces_str
    let (after_arg_spaces_loc, after_arg_spaces_str)
          = consume_spaces after_arg_loc after_arg_str
    (locate after_spaces_loc after_arg_loc arg :) <$>
      case after_arg_spaces_str of
        ',':after_comma -> readAsList (advanceSrcLoc after_arg_spaces_loc ',') after_comma
        ']':after_bracket
          | all isSpace after_bracket
          -> Right []
        _ -> Left ("Couldn't read " ++ show ('[' : s) ++ " as [String]")
             -- reinsert missing '[' for clarity.

-----------------------------------------------------------------------------

-- | Complain about non-dynamic flags in OPTIONS pragmas.
--
-- Throws a 'SourceError' if the input list is non-empty claiming that the
-- input flags are unknown.
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
checkProcessArgsResult flags
  = when (notNull flags) $
      liftIO $ throwErrors $ foldMap (singleMessage . mkMsg) flags
    where mkMsg (L loc flag)
              = mkPlainErrorMsgEnvelope loc $
                GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $
                  text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
                  text flag

-----------------------------------------------------------------------------

checkExtension :: DynFlags -> Located FastString -> Located String
checkExtension dflags (L l ext)
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
  = if ext' `elem` supported
    then L l ("-X"++ext')
    else unsupportedExtnError dflags l ext'
  where
    ext' = unpackFS ext
    supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags

languagePragParseError :: SrcSpan -> a
languagePragParseError loc =
    throwErr loc $
       vcat [ text "Cannot parse LANGUAGE pragma"
            , text "Expecting comma-separated list of language options,"
            , text "each starting with a capital letter"
            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]

unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
unsupportedExtnError dflags loc unsup =
    throwErr loc $
        text "Unsupported extension: " <> text unsup $$
        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
  where
     supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags
     suggestions = fuzzyMatch unsup supported

optionsParseError :: String -> SrcSpan -> a     -- #15053
optionsParseError str loc =
  throwErr loc $
      vcat [ text "Error while parsing OPTIONS_GHC pragma."
           , text "Expecting whitespace-separated list of GHC options."
           , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
           , text ("Input was: " ++ show str) ]

throwErr :: SrcSpan -> SDoc -> a                -- #15053
throwErr loc doc =
  let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints doc
  in throw $ mkSrcErr $ singleMessage msg