diff options
author | Alec Theriault <alec.theriault@gmail.com> | 2018-12-11 13:47:35 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2018-12-11 14:23:22 -0500 |
commit | f582379de2c4ff7577235c926ad953debdae3cac (patch) | |
tree | df39b7a00d1730be04da120ca452517043478809 /compiler/hieFile/HieDebug.hs | |
parent | 21339c9f6bfb952a3a0b8de5ee649d46dfbf0d9b (diff) | |
download | haskell-f582379de2c4ff7577235c926ad953debdae3cac.tar.gz |
Support generating HIE files
Adds a `-fenable-ide-info` flag which instructs GHC to generate `.hie`
files (see the wiki page:
https://ghc.haskell.org/trac/ghc/wiki/HIEFiles).
This is a rebased version of Zubin Duggal's (@wz1000) GHC changes for
his GSOC project, as posted here:
https://gist.github.com/wz1000/5ed4ddd0d3e96d6bc75e095cef95363d.
Test Plan: ./validate
Reviewers: bgamari, gershomb, nomeata, alanz, sjakobi
Reviewed By: alanz, sjakobi
Subscribers: alanz, hvr, sjakobi, rwbarton, wz1000, carter
Differential Revision: https://phabricator.haskell.org/D5239
Diffstat (limited to 'compiler/hieFile/HieDebug.hs')
-rw-r--r-- | compiler/hieFile/HieDebug.hs | 143 |
1 files changed, 143 insertions, 0 deletions
diff --git a/compiler/hieFile/HieDebug.hs b/compiler/hieFile/HieDebug.hs new file mode 100644 index 0000000000..7896cf7720 --- /dev/null +++ b/compiler/hieFile/HieDebug.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module HieDebug where + +import GhcPrelude + +import SrcLoc +import Module +import FastString +import Outputable + +import HieTypes +import HieBin +import HieUtils + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Function ( on ) +import Data.List ( sortOn ) +import Data.Foldable ( toList ) + +ppHies :: Outputable a => (HieASTs a) -> SDoc +ppHies (HieASTs asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "File: " <> ppr k + , ppHie a + , rest + ] + +ppHie :: Outputable a => HieAST a -> SDoc +ppHie = go 0 + where + go n (Node inf sp children) = hang header n rest + where + rest = vcat $ map (go (n+2)) children + header = hsep + [ "Node" + , ppr sp + , ppInfo inf + ] + +ppInfo :: Outputable a => NodeInfo a -> SDoc +ppInfo ni = hsep + [ ppr $ toList $ nodeAnnotations ni + , ppr $ nodeType ni + , ppr $ M.toList $ nodeIdentifiers ni + ] + +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 f = diffList (diffAst f) `on` M.elems + +diffAst :: (Outputable a, Eq 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 + = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2 + ++ (diffList diffType `on` nodeType) info1 info2 + ++ (diffIdents `on` nodeIdentifiers) info1 info2 + diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b + diffIdent (a,b) (c,d) = diffName a c + ++ eqDiff b d + diffName (Right a) (Right b) = case (a,b) of + (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o') + (LocalName o _, ExternalName _ o' _) -> eqDiff o o' + _ -> eqDiff a b + diffName a b = eqDiff a b + +type DiffIdent = Either ModuleName HieName + +normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)] +normalizeIdents = sortOn fst . map (first toHieName) . M.toList + where + first f (a,b) = (fmap f a, b) + +diffList :: Diff a -> Diff [a] +diffList f xs ys + | length xs == length ys = concat $ zipWith f xs ys + | otherwise = ["length of lists doesn't match"] + +eqDiff :: (Outputable a, Eq a) => Diff a +eqDiff a b + | a == b = [] + | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]] + +validAst :: HieAST a -> Either SDoc () +validAst (Node _ span children) = do + checkContainment children + checkSorted children + mapM_ validAst children + where + checkSorted [] = return () + checkSorted [_] = return () + checkSorted (x:y:xs) + | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs) + | otherwise = Left $ hsep + [ ppr $ nodeSpan x + , "is not to the left of" + , ppr $ nodeSpan y + ] + checkContainment [] = return () + checkContainment (x:xs) + | span `containsSpan` (nodeSpan x) = checkContainment xs + | otherwise = Left $ hsep + [ ppr $ span + , "does not contain" + , ppr $ nodeSpan x + ] + +-- | 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 + where + refMap = generateReferencesMap asts + valid (Left _) _ = [] + valid (Right n) refs = concatMap inScope refs + where + mapRef = foldMap getScopeFromContext . identInfo . snd + scopes = case foldMap mapRef refs of + Just xs -> xs + Nothing -> [] + inScope (sp, dets) + | definedInAsts asts n + && any isOccurrence (identInfo dets) + = case scopes of + [] -> [] + _ -> if any (`scopeContainsSpan` sp) scopes + then [] + else return $ hsep $ + [ "Name", ppr n, "at position", ppr sp + , "doesn't occur in calculated scope", ppr scopes] + | otherwise = [] |