Provide a utility to check API Annotations

It is difficult for GHC developers to know if they have broken the API
Annotations.

This patch provides a utility that can be used as a test to show up
errors in the API Annotations.

It is based on the current tests for ghc-api/annotations which can parse
a file using the just-built GHC API, and check that no annotations are
disconnected from the ParsedSource in the output.

In addition, it should be able to dump the annotations to a file, so a
new feature developer can check that all changes to the parser do
provide annotations.

Trac ticket: #10917

Test Plan: ./validate

Reviewers: hvr, thomie, austin, bgamari

Reviewed By: bgamari

Differential Revision: https://phabricator.haskell.org/D1368

GHC Trac Issues: #10917

4 files changed, 173 insertions, 0 deletions

diff --git a/utils/check-api-annotations/Main.hs b/utils/check-api-annotations/Main.hs
new file mode 100644
index 0000000000..7dc2eb3f77
--- /dev/null
+++ b/utils/check-api-annotations/Main.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE RankNTypes #-}
+
+import Data.Data
+import Data.List
+import GHC
+import DynFlags
+import Outputable
+import ApiAnnotation
+import System.Environment( getArgs )
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+main::IO()
+main = do
+  args <- getArgs
+  case args of
+   [libdir,fileName] -> testOneFile libdir fileName
+   _ -> putStrLn "invoke with the libdir and a file to parse."
+
+testOneFile :: FilePath -> String -> IO ()
+testOneFile libdir fileName = do
+       ((anns,cs),p) <- runGhc (Just libdir) $ do
+                        dflags <- getSessionDynFlags
+                        _ <- setSessionDynFlags dflags
+                        let mn =mkModuleName fileName
+                        addTarget Target { targetId = TargetModule mn
+                                         , targetAllowObjCode = True
+                                         , targetContents = Nothing }
+                        _ <- load LoadAllTargets
+                        modSum <- getModSummary mn
+                        p <- parseModule modSum
+                        return (pm_annotations p,p)
+
+       let sspans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
+
+           problems = filter (\(s,_a) -> not (Set.member s sspans))
+                             $ getAnnSrcSpans (anns,cs)
+
+           exploded = [((kw,ss),[anchor])
+                      | ((anchor,kw),sss) <- Map.toList anns,ss <- sss]
+
+           exploded' = Map.toList $ Map.fromListWith (++) exploded
+
+           problems' = filter (\(_,anchors)
+                               -> not (any (\a -> Set.member a sspans) anchors))
+                              exploded'
+
+       putStrLn "---Problems---------------------"
+       putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems])
+       putStrLn "---Problems'--------------------"
+       putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems'])
+       putStrLn "--------------------------------"
+       putStrLn (intercalate "\n" [showAnns anns])
+
+    where
+      getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))]
+      getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns
+
+      getAllSrcSpans :: (Data t) => t -> [SrcSpan]
+      getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
+        where
+          getSrcSpan :: SrcSpan -> [SrcSpan]
+          getSrcSpan ss = [ss]
+
+
+showAnns :: Map.Map ApiAnnKey [SrcSpan] -> String
+showAnns anns = "[\n" ++ (intercalate "\n"
+   $ map (\((s,k),v)
+              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
+   $ Map.toList anns)
+    ++ "]\n"
+
+pp :: (Outputable a) => a -> String
+pp a = showPpr unsafeGlobalDynFlags a
+
+
+-- ---------------------------------------------------------------------
+
+-- Copied from syb for the test
+
+
+-- | Generic queries of type \"r\",
+--   i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+
+
+-- | Summarise all nodes in top-down, left-to-right order
+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
+
+-- Apply f to x to summarise top-level node;
+-- use gmapQ to recurse into immediate subterms;
+-- use ordinary foldl to reduce list of intermediate results
+
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
diff --git a/utils/check-api-annotations/README b/utils/check-api-annotations/README
new file mode 100644
index 0000000000..7c2815a403
--- /dev/null
+++ b/utils/check-api-annotations/README
@@ -0,0 +1,18 @@
+This programme is intended to be used by any GHC developers working on Parser.y
+or RdrHsSyn.hs, and who want to check that their changes do not break the API
+Annotations.
+
+It does a basic test that all annotations do make it to the final AST, and dumps
+a list of the annotations generated for a given file, so that they can be
+checked against the source being parsed for sanity.
+
+This utility is also intended to be used in tests, so that when new features are
+added the expected annotations are also captured.
+
+Usage
+
+In a test Makefile
+
+  $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" FileToParse.hs
+
+See examples in (REPO_HOME)/testsuite/tests/ghc-api/annotations/Makefile
diff --git a/utils/check-api-annotations/check-api-annotations.cabal b/utils/check-api-annotations/check-api-annotations.cabal
new file mode 100644
index 0000000000..38c3f184f1
--- /dev/null
+++ b/utils/check-api-annotations/check-api-annotations.cabal
@@ -0,0 +1,25 @@
+Name: check-api-annotations
+Version: 0.1
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: XXX
+Description: XXX
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Executable check-api-annotations
+    Default-Language: Haskell2010
+
+    Main-Is: Main.hs
+
+    Ghc-Options: -Wall
+
+    Build-Depends: base       >= 4   && < 5,
+                   containers,
+                   Cabal      >= 1.22 && <1.24,
+                   directory,
+                   ghc
diff --git a/utils/check-api-annotations/ghc.mk b/utils/check-api-annotations/ghc.mk
new file mode 100644
index 0000000000..61f896d3d7
--- /dev/null
+++ b/utils/check-api-annotations/ghc.mk
@@ -0,0 +1,18 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+utils/check-api-annotations_USES_CABAL                   = YES
+utils/check-api-annotations_PACKAGE                      = check-api-annotations
+utils/check-api-annotations_dist-install_PROGNAME        = check-api-annotations
+utils/check-api-annotations_dist-install_INSTALL         = NO
+utils/check-api-annotations_dist-install_INSTALL_INPLACE = YES
+$(eval $(call build-prog,utils/check-api-annotations,dist-install,2))