summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/GHC.hs10
-rw-r--r--compiler/main/HeaderInfo.hs107
-rw-r--r--compiler/main/HscStats.hs27
-rw-r--r--compiler/main/HscTypes.hs3
4 files changed, 82 insertions, 65 deletions
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index da5ef8ba2d..8817b41c8a 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
-- -----------------------------------------------------------------------------
--
@@ -250,6 +252,10 @@ module GHC (
-- *** Deconstructing Located
getLoc, unLoc,
+ getRealSrcSpan, unRealSrcSpan,
+
+ -- ** HasSrcSpan
+ HasSrcSpan(..), SrcSpanLess, dL, cL,
-- *** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
@@ -1380,7 +1386,7 @@ getRichTokenStream mod = do
addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens _ _ [] = []
-addSourceToTokens loc buf (t@(L span _) : ts)
+addSourceToTokens loc buf (t@(dL->L span _) : ts)
= case span of
UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts
@@ -1406,7 +1412,7 @@ showRichTokenStream ts = go startLoc ts ""
getFile (RealSrcSpan s : _) = srcSpanFile s
startLoc = mkRealSrcLoc sourceFile 1 1
go _ [] = id
- go loc ((L span _, str):ts)
+ go loc ((dL->L span _, str):ts)
= case span of
UnhelpfulSpan _ -> go loc ts
RealSrcSpan s
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 127cc6d911..3fd510bb86 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
--
@@ -76,23 +78,24 @@ getImports dflags buf filename source_filename = do
if errorsFound dflags ms
then throwIO $ mkSrcErr errs
else
- case rdr_module of
- L _ hsmod ->
- let
+ 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
+ main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
+ 1 1)
+ mod = mb_mod `orElse` cL main_loc mAIN_NAME
(src_idecls, ord_idecls) = partition (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)
+ -- 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_prelude = xopt LangExt.ImplicitPrelude dflags
implicit_imports = mkPrelImports (unLoc mod) main_loc
implicit_prelude imps
- convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
+ convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i)
+ , ideclName i)
in
return (map convImport src_idecls,
map convImport (implicit_imports ++ ordinary_imps),
@@ -115,23 +118,23 @@ mkPrelImports this_mod loc implicit_prelude import_decls
| otherwise = [preludeImportDecl]
where
explicit_prelude_import
- = notNull [ () | L _ (ImportDecl { ideclName = mod
- , ideclPkgQual = Nothing })
+ = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod
+ , ideclPkgQual = Nothing }))
<- import_decls
, unLoc mod == pRELUDE_NAME ]
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
- = L loc $ ImportDecl { ideclExt = noExt,
- ideclSourceSrc = NoSourceText,
- ideclName = L loc pRELUDE_NAME,
- ideclPkgQual = Nothing,
- ideclSource = False,
- ideclSafe = False, -- Not a safe import
- ideclQualified = False,
- ideclImplicit = True, -- Implicit!
- ideclAs = Nothing,
- ideclHiding = Nothing }
+ = cL loc $ ImportDecl { ideclExt = noExt,
+ ideclSourceSrc = NoSourceText,
+ ideclName = cL loc pRELUDE_NAME,
+ ideclPkgQual = Nothing,
+ ideclSource = False,
+ ideclSafe = False, -- Not a safe import
+ ideclQualified = False,
+ ideclImplicit = True, -- Implicit!
+ ideclAs = Nothing,
+ ideclHiding = Nothing }
parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
@@ -185,12 +188,12 @@ lazyGetToks dflags filename handle = do
-- 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 t of
- L _ ITeof -> return [t]
- _other -> do rest <- lazyLexBuf handle state' eof size
- return (t : rest)
+ 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 (RealSrcSpan (last_loc state)) ITeof]
+ | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof]
-- parser assumes an ITeof sentinel at the end
getMore :: Handle -> PState -> Int -> IO [Located Token]
@@ -212,9 +215,9 @@ getToks dflags filename buf = lexAll (pragState dflags buf loc)
loc = mkRealSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer False return) state of
- POk _ t@(L _ ITeof) -> [t]
+ POk _ t@(dL->L _ ITeof) -> [t]
POk state' t -> t : lexAll state'
- _ -> [L (RealSrcSpan (last_loc state)) ITeof]
+ _ -> [cL (RealSrcSpan (last_loc state)) ITeof]
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
@@ -237,39 +240,36 @@ getOptions' :: DynFlags
getOptions' dflags toks
= parseToks toks
where
- getToken (L _loc tok) = tok
- getLoc (L loc _tok) = loc
-
parseToks (open:close:xs)
- | IToptions_prag str <- getToken open
- , ITclose_prag <- getToken close
+ | IToptions_prag str <- unLoc open
+ , ITclose_prag <- unLoc close
= case toArgs str of
Left _err -> optionsParseError str dflags $ -- #15053
combineSrcSpans (getLoc open) (getLoc close)
- Right args -> map (L (getLoc open)) args ++ parseToks xs
+ Right args -> map (cL (getLoc open)) args ++ parseToks xs
parseToks (open:close:xs)
- | ITinclude_prag str <- getToken open
- , ITclose_prag <- getToken close
- = map (L (getLoc open)) ["-#include",removeSpaces str] ++
+ | ITinclude_prag str <- unLoc open
+ , ITclose_prag <- unLoc close
+ = map (cL (getLoc open)) ["-#include",removeSpaces str] ++
parseToks xs
parseToks (open:close:xs)
- | ITdocOptions str <- getToken open
- , ITclose_prag <- getToken close
- = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
+ | ITdocOptions str <- unLoc open
+ , ITclose_prag <- unLoc close
+ = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str]
++ parseToks xs
parseToks (open:xs)
- | ITlanguage_prag <- getToken open
+ | ITlanguage_prag <- unLoc open
= parseLanguage xs
parseToks (comment:xs) -- Skip over comments
- | isComment (getToken comment)
+ | isComment (unLoc comment)
= parseToks xs
parseToks _ = []
- parseLanguage (L loc (ITconid fs):rest)
- = checkExtension dflags (L loc fs) :
+ parseLanguage ((dL->L loc (ITconid fs)):rest)
+ = checkExtension dflags (cL loc fs) :
case rest of
- (L _loc ITcomma):more -> parseLanguage more
- (L _loc ITclose_prag):more -> parseToks more
- (L loc _):_ -> languagePragParseError dflags loc
+ (dL->L _loc ITcomma):more -> parseLanguage more
+ (dL->L _loc ITclose_prag):more -> parseToks more
+ (dL->L loc _):_ -> languagePragParseError dflags loc
[] -> panic "getOptions'.parseLanguage(1) went past eof token"
parseLanguage (tok:_)
= languagePragParseError dflags (getLoc tok)
@@ -297,7 +297,7 @@ checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
checkProcessArgsResult dflags flags
= when (notNull flags) $
liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
- where mkMsg (L loc flag)
+ where mkMsg (dL->L loc flag)
= mkPlainErrMsg dflags loc $
(text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
text flag)
@@ -305,12 +305,12 @@ checkProcessArgsResult dflags flags
-----------------------------------------------------------------------------
checkExtension :: DynFlags -> Located FastString -> Located String
-checkExtension dflags (L l ext)
+checkExtension dflags (dL->L l ext)
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
= let ext' = unpackFS ext in
if ext' `elem` supportedLanguagesAndExtensions
- then L l ("-X"++ext')
+ then cL l ("-X"++ext')
else unsupportedExtnError dflags l ext'
languagePragParseError :: DynFlags -> SrcSpan -> a
@@ -333,9 +333,12 @@ unsupportedExtnError dflags loc unsup =
optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
optionsErrorMsgs dflags unhandled_flags flags_lines _filename
= (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
- where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
- L l f' <- flags_lines, f == f' ]
- mkMsg (L flagSpan flag) =
+ where unhandled_flags_lines :: [Located String]
+ unhandled_flags_lines = [ cL l f
+ | f <- unhandled_flags
+ , (dL->L l f') <- flags_lines
+ , f == f' ]
+ mkMsg (dL->L flagSpan flag) =
ErrUtils.mkPlainErrMsg dflags flagSpan $
text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index 72f45346d1..44edb82c5e 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -4,7 +4,9 @@
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--
-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
module HscStats ( ppSourceStats ) where
@@ -20,7 +22,7 @@ import Data.Char
-- | Source Statistics
ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc
-ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
+ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
= (if short then hcat else vcat)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
@@ -82,9 +84,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
val_decls = [d | ValD _ d <- decls]
- real_exports = case exports of { Nothing -> []; Just (L _ es) -> es }
+ real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es }
n_exports = length real_exports
- export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False})
+ export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True
+ ; _ -> False})
real_exports
export_ds = n_exports - export_ms
export_all = case exports of { Nothing -> 1; _ -> 0 }
@@ -101,7 +104,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
= sum5 (map inst_info inst_decls)
- count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0)
+ count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0)
count_bind (PatBind {}) = (0,1,0)
count_bind (FunBind {}) = (0,1,0)
count_bind (PatSynBind {}) = (0,0,1)
@@ -116,10 +119,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
sig_info (ClassOpSig {}) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
- import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
- , ideclAs = as, ideclHiding = spec }))
+ import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
+ , ideclAs = as, ideclHiding = spec }))
= add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
- import_info (L _ (XImportDecl _)) = panic "import_info"
+ import_info (dL->L _ (XImportDecl _)) = panic "import_info"
+ import_info _ = panic " import_info: Impossible Match"
+ -- due to #15884
+
safe_info = qual_info
qual_info False = 0
qual_info True = 1
@@ -129,8 +135,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,0,1)
- data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs
- , dd_derivs = L _ derivs}})
+ data_info (DataDecl { tcdDataDefn = HsDataDefn
+ { dd_cons = cs
+ , dd_derivs = (dL->L _ derivs)}})
= ( length cs
, foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
0 derivs )
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index bb89c58344..d57d69bda6 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
-- | Types for the per-module compiler
module HscTypes (
@@ -344,7 +345,7 @@ handleFlagWarnings dflags warns = do
-- It would be nicer if warns :: [Located MsgDoc], but that
-- has circular import problems.
bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
- | Warn _ (L loc warn) <- warns' ]
+ | Warn _ (dL->L loc warn) <- warns' ]
printOrThrowWarnings dflags bag
View Lorry Controller Status