summaryrefslogtreecommitdiff
path: root/compiler/GHC/Iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Iface')
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs6
-rw-r--r--compiler/GHC/Iface/Ext/Debug.hs5
-rw-r--r--compiler/GHC/Iface/Ext/Types.hs45
-rw-r--r--compiler/GHC/Iface/Ext/Utils.hs26
-rw-r--r--compiler/GHC/Iface/Make.hs2
-rw-r--r--compiler/GHC/Iface/Recomp.hs5
6 files changed, 61 insertions, 28 deletions
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 452e649f5d..448ae5dc54 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -342,7 +342,7 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
, exps
]
- modulify file xs' = do
+ modulify (HiePath file) xs' = do
top_ev_asts <-
toHie $ EvBindContext ModuleScope Nothing
@@ -363,12 +363,12 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
case mergeSortAsts $ moduleNode : xs of
[x] -> return x
- xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs)
+ xs -> panicDoc "enrichHie: mergeSortAsts retur:ed more than one result" (ppr $ map nodeSpan xs)
asts' <- sequence
$ M.mapWithKey modulify
$ M.fromListWith (++)
- $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
+ $ map (\x -> (HiePath (srcSpanFile (nodeSpan x)),[x])) flat_asts
let asts = HieASTs $ resolveTyVarScopes asts'
return asts
diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs
index 903413eaab..b10b4c982c 100644
--- a/compiler/GHC/Iface/Ext/Debug.hs
+++ b/compiler/GHC/Iface/Ext/Debug.hs
@@ -11,7 +11,6 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Unit.Module
-import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Iface.Ext.Types
@@ -28,7 +27,7 @@ type Diff a = a -> a -> [SDoc]
diffFile :: Diff HieFile
diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
-diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a))
+diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map HiePath (HieAST a))
diffAsts f = diffList (diffAst f) `on` M.elems
diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)
@@ -106,7 +105,7 @@ validAst (Node _ span children) = do
-- | Look for any identifiers which occur outside of their supposed scopes.
-- Returns a list of error messages.
-validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]
+validateScopes :: Module -> M.Map HiePath (HieAST a) -> [SDoc]
validateScopes mod asts = validScopes ++ validEvs
where
refMap = generateReferencesMap asts
diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs
index fe11bd094c..75331a273e 100644
--- a/compiler/GHC/Iface/Ext/Types.hs
+++ b/compiler/GHC/Iface/Ext/Types.hs
@@ -10,13 +10,15 @@ For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
module GHC.Iface.Ext.Types where
import GHC.Prelude
import GHC.Settings.Config
import GHC.Utils.Binary
-import GHC.Data.FastString ( FastString )
+import GHC.Data.FastString
import GHC.Builtin.Utils
import GHC.Iface.Type
import GHC.Unit.Module ( ModuleName, Module )
@@ -211,9 +213,18 @@ instance Binary (HieArgs TypeIndex) where
put_ bh (HieArgs xs) = put_ bh xs
get bh = HieArgs <$> get bh
--- | Mapping from filepaths (represented using 'FastString') to the
--- corresponding AST
-newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }
+
+-- A HiePath is just a lexical FastString. We use a lexical FastString to avoid
+-- non-determinism when printing or storing HieASTs which are sorted by their
+-- HiePath.
+type HiePath = LexicalFastString
+
+{-# COMPLETE HiePath #-}
+pattern HiePath :: FastString -> HiePath
+pattern HiePath fs = LexicalFastString fs
+
+-- | Mapping from filepaths to the corresponding AST
+newtype HieASTs a = HieASTs { getAsts :: M.Map HiePath (HieAST a) }
deriving (Functor, Foldable, Traversable)
instance Binary (HieASTs TypeIndex) where
@@ -285,13 +296,35 @@ instance Binary NodeOrigin where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+-- | A node annotation
+data NodeAnnotation = NodeAnnotation
+ { nodeAnnotConstr :: !FastString -- ^ name of the AST node constructor
+ , nodeAnnotType :: !FastString -- ^ name of the AST node Type
+ }
+ deriving (Eq)
+
+instance Ord NodeAnnotation where
+ compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1)
+ = mconcat [uniqCompareFS c0 c1, uniqCompareFS t0 t1]
+
+instance Outputable NodeAnnotation where
+ ppr (NodeAnnotation c t) = ppr (c,t)
+
+instance Binary NodeAnnotation where
+ put_ bh (NodeAnnotation c t) = do
+ put_ bh c
+ put_ bh t
+ get bh = NodeAnnotation
+ <$> get bh
+ <*> get bh
+
-- | The information stored in one AST node.
--
-- The type parameter exists to provide flexibility in representation of types
-- (see Note [Efficient serialization of redundant type info]).
data NodeInfo a = NodeInfo
- { nodeAnnotations :: S.Set (FastString,FastString)
- -- ^ (name of the AST node constructor, name of the AST node Type)
+ { nodeAnnotations :: S.Set NodeAnnotation
+ -- ^ Annotations
, nodeType :: [a]
-- ^ The Haskell types of this node, if any.
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index d1b6db6fb7..9245a11f7b 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -85,7 +85,7 @@ foldType f (Roll t) = f $ fmap (foldType f) t
selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int)
selectPoint hf (sl,sc) = getFirst $
- flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(fs,ast) -> First $
+ flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(HiePath fs,ast) -> First $
case selectSmallestContaining (sp fs) ast of
Nothing -> Nothing
Just ast' -> Just ast'
@@ -248,12 +248,12 @@ getTypeIndex t
return $ HCastTy i
go (CoercionTy _) = return HCoercionTy
-resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)
+resolveTyVarScopes :: M.Map HiePath (HieAST a) -> M.Map HiePath (HieAST a)
resolveTyVarScopes asts = M.map go asts
where
go ast = resolveTyVarScopeLocal ast asts
-resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a
+resolveTyVarScopeLocal :: HieAST a -> M.Map HiePath (HieAST a) -> HieAST a
resolveTyVarScopeLocal ast asts = go ast
where
resolveNameScope dets = dets{identInfo =
@@ -278,12 +278,12 @@ resolveTyVarScopeLocal ast asts = go ast
where
idents = M.map resolveNameScope $ nodeIdentifiers i
-getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
+getNameBinding :: Name -> M.Map HiePath (HieAST a) -> Maybe Span
getNameBinding n asts = do
(_,msp) <- getNameScopeAndBinding n asts
msp
-getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]
+getNameScope :: Name -> M.Map HiePath (HieAST a) -> Maybe [Scope]
getNameScope n asts = do
(scopes,_) <- getNameScopeAndBinding n asts
return scopes
@@ -291,10 +291,10 @@ getNameScope n asts = do
getNameBindingInClass
:: Name
-> Span
- -> M.Map FastString (HieAST a)
+ -> M.Map HiePath (HieAST a)
-> Maybe Span
getNameBindingInClass n sp asts = do
- ast <- M.lookup (srcSpanFile sp) asts
+ ast <- M.lookup (HiePath (srcSpanFile sp)) asts
getFirst $ foldMap First $ do
child <- flattenAst ast
dets <- maybeToList
@@ -304,11 +304,11 @@ getNameBindingInClass n sp asts = do
getNameScopeAndBinding
:: Name
- -> M.Map FastString (HieAST a)
+ -> M.Map HiePath (HieAST a)
-> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding n asts = case nameSrcSpan n of
RealSrcSpan sp _ -> do -- @Maybe
- ast <- M.lookup (srcSpanFile sp) asts
+ ast <- M.lookup (HiePath (srcSpanFile sp)) asts
defNode <- selectLargestContainedBy sp ast
getFirst $ foldMap First $ do -- @[]
node <- flattenAst defNode
@@ -369,9 +369,9 @@ selectSmallestContaining sp node
| sp `containsSpan` nodeSpan node = Nothing
| otherwise = Nothing
-definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool
+definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool
definedInAsts asts n = case nameSrcSpan n of
- RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts
+ RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts
_ -> False
getEvidenceBindDeps :: ContextInfo -> [Name]
@@ -515,7 +515,7 @@ mergeSortAsts = go . map pure
mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss
simpleNodeInfo :: FastString -> FastString -> NodeInfo a
-simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty
+simpleNodeInfo cons typ = NodeInfo (S.singleton (NodeAnnotation cons typ)) [] M.empty
locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a]
locOnly (RealSrcSpan span _) = do
@@ -568,7 +568,7 @@ makeTypeNode x spn etyp = do
org <- ask
pure $ case spn of
RealSrcSpan span _ ->
- [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
+ [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []]
_ -> []
where
cons = mkFastString . show . toConstr $ x
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index a179beff18..3fd0eaac29 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -292,7 +292,7 @@ mkIface_ hsc_env
mi_final_exts = (),
mi_ext_fields = emptyExtensibleFields }
where
- cmp_rule = comparing ifRuleName
+ cmp_rule = lexicalCompareFS `on` ifRuleName
-- Compare these lexicographically by OccName, *not* by unique,
-- because the latter is not stable across compilations:
cmp_inst = comparing (nameOccName . ifDFun)
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 2ffb094b11..7e72633622 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -39,6 +39,7 @@ import GHC.Utils.Outputable as Outputable
import GHC.Types.Unique
import GHC.Utils.Misc hiding ( eqListBy )
import GHC.Data.Maybe
+import GHC.Data.FastString
import GHC.Utils.Binary
import GHC.Utils.Fingerprint
import GHC.Utils.Exception
@@ -1081,11 +1082,11 @@ getOrphanHashes hsc_env mods = do
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
- = Deps { dep_mods = sortBy (compare `on` (moduleNameFS . gwib_mod)) (dep_mods d),
+ = Deps { dep_mods = sortBy (lexicalCompareFS `on` (moduleNameFS . gwib_mod)) (dep_mods d),
dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d),
- dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }
+ dep_plgins = sortBy (lexicalCompareFS `on` moduleNameFS) (dep_plgins d) }
{-
************************************************************************
View Lorry Controller Status