Commit 8e2fe575 authored by wz1000's avatar wz1000 Committed by Marge Bot

Fix bug preventing information about patterns from being serialized in .hie files

parent 2c1b1ad7
......@@ -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}->
......
......@@ -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
......
......@@ -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 = []
......@@ -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"
......
{-# 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'
Got valid scopes
Got no roundtrip errors
......@@ -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'])
{-# 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))
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
test('PatTypes', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
Subproject commit 658ad4af237f3da196cca083ad525375260e38a7
Subproject commit 75f71980dfcd9a009e2eeb3a8690a473f47fcdfe
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment