diff options
-rw-r--r-- | compiler/hieFile/HieAst.hs | 29 | ||||
-rw-r--r-- | compiler/hieFile/HieBin.hs | 11 | ||||
-rw-r--r-- | compiler/hieFile/HieDebug.hs | 45 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 5 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_compile/Scopes.hs | 13 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_compile/Scopes.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_compile/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_run/PatTypes.hs | 66 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_run/PatTypes.stdout | 4 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_run/all.T | 1 | ||||
m--------- | utils/haddock | 0 |
11 files changed, 159 insertions, 18 deletions
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index e1047692ff..f0b10a3efa 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -38,6 +38,7 @@ import TysWiredIn ( mkListTy, mkSumTy ) import Var ( Id, Var, setVarName, varName, varType ) import TcRnTypes import MkIface ( mkIfaceExports ) +import Panic import HieTypes import HieUtils @@ -161,7 +162,7 @@ getRealSpan _ = Nothing grhss_span :: GRHSs p body -> SrcSpan grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) -grhss_span (XGRHSs _) = error "XGRHS has no span" +grhss_span (XGRHSs _) = panic "XGRHS has no span" bindingsOnly :: [Context Name] -> [HieAST a] bindingsOnly [] = [] @@ -245,7 +246,7 @@ patScopes -> [LPat (GhcPass p)] -> [PScoped (LPat (GhcPass p))] patScopes rsp useScope patScope xs = - map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $ + map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $ listScopes patScope (map dL xs) -- | 'listScopes' specialised to 'TVScoped' things @@ -300,7 +301,8 @@ instance ProtectSig GhcTc where instance ProtectSig GhcRn where protectSig sc (HsWC a (HsIB b sig)) = HsWC a (HsIB b (SH sc sig)) - protectSig _ _ = error "protectSig not given HsWC (HsIB)" + protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec + protectSig _ (XHsWildCardBndrs nec) = noExtCon nec class HasLoc a where -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can @@ -351,6 +353,21 @@ instance HasLoc (HsDataDefn GhcRn) where instance HasLoc (Pat (GhcPass a)) where loc (dL -> L l _) = l +{- Note [Real DataCon Name] +The typechecker subtitutes the conLikeWrapId for the name, but we don't want +this showing up in the hieFile, so we replace the name in the Id with the +original datacon name +See also Note [Data Constructor Naming] +-} +class HasRealDataConName p where + getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) + +instance HasRealDataConName GhcRn where + getRealDataCon _ n = n +instance HasRealDataConName GhcTc where + getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = + L sp (setVarName var (conLikeName con)) + -- | The main worker class class ToHie a where toHie :: a -> HieM [HieAST Type] @@ -737,6 +754,7 @@ instance ( a ~ GhcPass p , Data (HsSplice a) , Data (HsTupArg a) , Data (AmbiguousFieldOcc a) + , (HasRealDataConName a) ) => ToHie (LHsExpr (GhcPass p)) where toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of HsVar _ (L _ var) -> @@ -817,8 +835,9 @@ instance ( a ~ GhcPass p ExplicitList _ _ exprs -> [ toHie exprs ] - RecordCon {rcon_con_name = name, rcon_flds = binds}-> - [ toHie $ C Use name + RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> + [ toHie $ C Use (getRealDataCon @a mrealcon name) + -- See Note [Real DataCon Name] , toHie $ RC RecFieldAssign $ binds ] RecordUpd {rupd_expr = expr, rupd_flds = upds}-> diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs index 61e3d01d0e..a0d0881d9e 100644 --- a/compiler/hieFile/HieBin.hs +++ b/compiler/hieFile/HieBin.hs @@ -2,7 +2,7 @@ Binary serialization for .hie files. -} {-# LANGUAGE ScopedTypeVariables #-} -module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where +module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc) where import GHC.Settings ( maybeRead ) @@ -59,6 +59,15 @@ instance Outputable HieName where ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u +hieNameOcc :: HieName -> OccName +hieNameOcc (ExternalName _ occ _) = occ +hieNameOcc (LocalName occ _) = occ +hieNameOcc (KnownKeyName u) = + case lookupKnownKeyName u of + Just n -> nameOccName n + Nothing -> pprPanic "hieNameOcc:unknown known-key unique" + (ppr (unpkUnique u)) + data HieSymbolTable = HieSymbolTable { hie_symtab_next :: !FastMutInt diff --git a/compiler/hieFile/HieDebug.hs b/compiler/hieFile/HieDebug.hs index ffdfe431d3..855b89861e 100644 --- a/compiler/hieFile/HieDebug.hs +++ b/compiler/hieFile/HieDebug.hs @@ -16,6 +16,7 @@ import Outputable import HieTypes import HieBin import HieUtils +import Name import qualified Data.Map as M import qualified Data.Set as S @@ -56,20 +57,30 @@ type Diff a = a -> a -> [SDoc] diffFile :: Diff HieFile diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) -diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a)) +diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a)) diffAsts f = diffList (diffAst f) `on` M.elems -diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a) +diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a) diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) = infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2 where spanDiff | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]] | otherwise = [] - infoDiff + infoDiff' = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2 ++ (diffList diffType `on` nodeType) info1 info2 ++ (diffIdents `on` nodeIdentifiers) info1 info2 + infoDiff = case infoDiff' of + [] -> [] + xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1) + , "and", ppr (nodeIdentifiers info2,span2) + , "While comparing" + , ppr (normalizeIdents $ nodeIdentifiers info1), "and" + , ppr (normalizeIdents $ nodeIdentifiers info2) + ] + ] + diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b diffIdent (a,b) (c,d) = diffName a c ++ eqDiff b d @@ -81,10 +92,11 @@ diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) = type DiffIdent = Either ModuleName HieName -normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)] -normalizeIdents = sortOn fst . map (first toHieName) . M.toList +normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)] +normalizeIdents = sortOn go . map (first toHieName) . M.toList where first f (a,b) = (fmap f a, b) + go (a,b) = (hieNameOcc <$> a,identInfo b,identType b) diffList :: Diff a -> Diff [a] diffList f xs ys @@ -122,10 +134,14 @@ validAst (Node _ span children) = do -- | Look for any identifiers which occur outside of their supposed scopes. -- Returns a list of error messages. -validateScopes :: M.Map FastString (HieAST a) -> [SDoc] -validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap +validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc] +validateScopes mod asts = validScopes where refMap = generateReferencesMap asts + -- We use a refmap for most of the computation + + -- Check if all the names occur in their calculated scopes + validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap valid (Left _) _ = [] valid (Right n) refs = concatMap inScope refs where @@ -134,13 +150,22 @@ validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap Just xs -> xs Nothing -> [] inScope (sp, dets) - | definedInAsts asts n + | (definedInAsts asts n) && any isOccurrence (identInfo dets) + -- We validate scopes for names which are defined locally, and occur + -- in this span = case scopes of - [] -> [] + [] | (nameIsLocalOrFrom mod n + && not (isDerivedOccName $ nameOccName n)) + -- If we don't get any scopes for a local name then its an error. + -- We can ignore derived names. + -> return $ hsep $ + [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp + , "Doesn't have a calculated scope: ", ppr scopes] + | otherwise -> [] _ -> if any (`scopeContainsSpan` sp) scopes then [] else return $ hsep $ - [ "Name", ppr n, "at position", ppr sp + [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp , "doesn't occur in calculated scope", ppr scopes] | otherwise = [] diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 52501ec15f..47e23edf57 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -175,7 +175,7 @@ import qualified Data.Set as S import Data.Set (Set) import HieAst ( mkHieFile ) -import HieTypes ( getAsts, hie_asts ) +import HieTypes ( getAsts, hie_asts, hie_module ) import HieBin ( readHieFile, writeHieFile , hie_file_result) import HieDebug ( diffFile, validateScopes ) @@ -428,7 +428,8 @@ extract_renamed_stuff mod_summary tc_result = do hs_env <- Hsc $ \e w -> return (e, w) liftIO $ do -- Validate Scopes - case validateScopes $ getAsts $ hie_asts hieFile of + let mdl = hie_module hieFile + case validateScopes mdl $ getAsts $ hie_asts hieFile of [] -> putMsg dflags $ text "Got valid scopes" xs -> do putMsg dflags $ text "Got invalid scopes" diff --git a/testsuite/tests/hiefile/should_compile/Scopes.hs b/testsuite/tests/hiefile/should_compile/Scopes.hs new file mode 100644 index 0000000000..e3cbd8558f --- /dev/null +++ b/testsuite/tests/hiefile/should_compile/Scopes.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE RecordWildCards #-} +module Scopes where +data T = C { x :: Int, y :: Char } + +-- Verify that names generated from record construction are in scope +foo = C { x = 1 , y = 'a' } + +-- Verify that record wildcards are in scope +sdaf :: T +sdaf = C{..} + where + x = 1 + y = 'a' diff --git a/testsuite/tests/hiefile/should_compile/Scopes.stderr b/testsuite/tests/hiefile/should_compile/Scopes.stderr new file mode 100644 index 0000000000..f31d37d99f --- /dev/null +++ b/testsuite/tests/hiefile/should_compile/Scopes.stderr @@ -0,0 +1,2 @@ +Got valid scopes +Got no roundtrip errors diff --git a/testsuite/tests/hiefile/should_compile/all.T b/testsuite/tests/hiefile/should_compile/all.T index fb8092df95..fe0d6d74eb 100644 --- a/testsuite/tests/hiefile/should_compile/all.T +++ b/testsuite/tests/hiefile/should_compile/all.T @@ -11,3 +11,4 @@ test('hie009', normal, compile, ['-fno-code -fwrite-ide- test('hie010', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info']) test('CPP', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info']) test('Constructors', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info']) +test('Scopes', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info']) diff --git a/testsuite/tests/hiefile/should_run/PatTypes.hs b/testsuite/tests/hiefile/should_run/PatTypes.hs new file mode 100644 index 0000000000..af5c42defa --- /dev/null +++ b/testsuite/tests/hiefile/should_run/PatTypes.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import System.Environment + +import NameCache +import SrcLoc +import UniqSupply +import Name + +import HieBin +import HieTypes +import HieUtils + +import DynFlags +import SysTools + +import qualified Data.Map as M +import Data.Foldable + +foo :: Maybe Char -> Char +foo Nothing = 'a' +-- 1^ +foo (Just c) | c == 'a' = c +-- 2^ 3^ +foo x = 'b' +-- 4^ + +p1,p2,p3,p4 :: (Int,Int) +p1 = (22,6) +p2 = (24,5) +p3 = (24,11) +p4 = (26,5) + +makeNc :: IO NameCache +makeNc = do + uniq_supply <- mkSplitUniqSupply 'z' + return $ initNameCache uniq_supply [] + +dynFlagsForPrinting :: String -> IO DynFlags +dynFlagsForPrinting libdir = do + systemSettings <- initSysTools libdir + return $ defaultDynFlags systemSettings ([], []) + +selectPoint :: HieFile -> (Int,Int) -> HieAST Int +selectPoint hf (sl,sc) = case M.toList (getAsts $ hie_asts hf) of + [(fs,ast)] -> + case selectSmallestContaining (sp fs) ast of + Nothing -> error "point not found" + Just ast' -> ast' + _ -> error "map should only contain a single AST" + where + sloc fs = mkRealSrcLoc fs sl sc + sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + +main = do + libdir:_ <- getArgs + df <- dynFlagsForPrinting libdir + nc <- makeNc + (hfr, nc') <- readHieFile nc "PatTypes.hie" + let hf = hie_file_result hfr + forM_ [p1,p2,p3,p4] $ \point -> do + putStr $ "At " ++ show point ++ ", got type: " + let types = nodeType $ nodeInfo $ selectPoint hf point + forM_ types $ \typ -> do + putStrLn (renderHieType df $ recoverFullType typ (hie_types hf)) diff --git a/testsuite/tests/hiefile/should_run/PatTypes.stdout b/testsuite/tests/hiefile/should_run/PatTypes.stdout new file mode 100644 index 0000000000..e86d3cc12a --- /dev/null +++ b/testsuite/tests/hiefile/should_run/PatTypes.stdout @@ -0,0 +1,4 @@ +At (22,6), got type: Maybe Char +At (24,5), got type: Maybe Char +At (24,11), got type: Char +At (26,5), got type: Maybe Char diff --git a/testsuite/tests/hiefile/should_run/all.T b/testsuite/tests/hiefile/should_run/all.T new file mode 100644 index 0000000000..738dadcbe5 --- /dev/null +++ b/testsuite/tests/hiefile/should_run/all.T @@ -0,0 +1 @@ +test('PatTypes', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info']) diff --git a/utils/haddock b/utils/haddock -Subproject 658ad4af237f3da196cca083ad525375260e38a +Subproject 75f71980dfcd9a009e2eeb3a8690a473f47fcdf |