Provide --show-interface option to dump interfaces (#645)

* WIP: Provide --show-interface option to dump interfaces

Like ghcs own --show-iface this flag dumps a binary interface file to
stdout in a human (and machine) readable fashion. Currently it uses
json as output format.

* Fill all the jsonNull stubs

* Rework Bifunctor instance of DocH, update changelog and documentation

* replace changelog, bring DocMarkupH doc back

* Update CHANGES.md

* Update CHANGES.md

* Move Control.Arrow up

It would result in unused import if the Bifunctor instance is not generated.

8 files changed, 167 insertions, 1 deletions

diff --git a/doc/invoking.rst b/doc/invoking.rst
index 83087bac..fc1e4410 100644
--- a/doc/invoking.rst
+++ b/doc/invoking.rst
@@ -88,6 +88,11 @@ The following options are available:
     :option:`--read-interface` option for more details. The interface file is
     in a binary format; don't try to read it.
 
+.. option:: --show-interface=<file>
+
+    Dumps a binary interface file to stdout in a human readable fashion.
+    Uses json as output format.
+
 .. [1]
    Haddock interface files are not the same as Haskell interface files,
    I just couldn't think of a better name.
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index ef4bb98c..d38e9149 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -73,6 +73,7 @@ library
     Haddock.Interface.Rename
     Haddock.Interface.Create
     Haddock.Interface.AttachInstances
+    Haddock.Interface.Json
     Haddock.Interface.LexParseRn
     Haddock.Interface.ParseModuleHeader
     Haddock.Interface.Specialize
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 57ea5fea..554cb416 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -32,6 +32,7 @@ import Haddock.Backends.LaTeX
 import Haddock.Backends.Hoogle
 import Haddock.Backends.Hyperlinker
 import Haddock.Interface
+import Haddock.Interface.Json
 import Haddock.Parser
 import Haddock.Types
 import Haddock.Version
@@ -68,6 +69,7 @@ import System.Directory (doesDirectoryExist)
 import GHC hiding (verbosity)
 import Config
 import DynFlags hiding (projectVersion, verbosity)
+import ErrUtils
 import Packages
 import Panic (handleGhcException)
 import Module
@@ -164,6 +166,11 @@ haddockWithGhc ghc args = handleTopExceptions $ do
 
     dflags <- getDynFlags
 
+    forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
+      mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)]
+      forM_ mIfaceFile $ \(_, ifaceFile) -> do
+        putMsg dflags (renderJson (jsonInterfaceFile ifaceFile))
+
     if not (null files) then do
       (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
 
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
new file mode 100644
index 00000000..9a569204
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE RecordWildCards #-}
+module Haddock.Interface.Json (
+    jsonInstalledInterface
+  , jsonInterfaceFile
+  , renderJson
+  ) where
+
+import BasicTypes
+import Json
+import Module
+import Name
+import Outputable
+
+import Control.Arrow
+import Data.Map (Map)
+import Data.Bifunctor
+import qualified Data.Map as Map
+
+import Haddock.Types
+import Haddock.InterfaceFile
+
+jsonInterfaceFile :: InterfaceFile -> JsonDoc
+jsonInterfaceFile InterfaceFile{..} =
+  jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv)
+             , ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces))
+             ]
+
+jsonInstalledInterface :: InstalledInterface -> JsonDoc
+jsonInstalledInterface InstalledInterface{..} = jsonObject properties
+  where
+    properties =
+      [ ("module"          , jsonModule instMod)
+      , ("is_sig"          , jsonBool instIsSig)
+      , ("info"            , jsonHaddockModInfo instInfo)
+      , ("doc_map"         , jsonMap nameStableString jsonMDoc instDocMap)
+      , ("arg_map"         , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap)
+      , ("exports"         , jsonArray (map jsonName instExports))
+      , ("visible_exports" , jsonArray (map jsonName instVisibleExports))
+      , ("options"         , jsonArray (map (jsonString . show) instOptions))
+      , ("sub_map"         , jsonMap nameStableString (jsonArray . map jsonName) instSubMap)
+      , ("bundled_patsyns" , jsonMap nameStableString (jsonArray . map jsonName) instBundledPatSynMap)
+      , ("fix_map"         , jsonMap nameStableString jsonFixity instFixMap)
+      ]
+
+jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc
+jsonHaddockModInfo HaddockModInfo{..} =
+  jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description)
+             , ("copyright"   , jsonMaybe jsonString hmi_copyright)
+             , ("maintainer"  , jsonMaybe jsonString hmi_maintainer)
+             , ("stability"   , jsonMaybe jsonString hmi_stability)
+             , ("protability" , jsonMaybe jsonString hmi_portability)
+             , ("safety"      , jsonMaybe jsonString hmi_safety)
+             , ("language"    , jsonMaybe (jsonString . show) hmi_language)
+             , ("extensions"  , jsonArray (map (jsonString . show) hmi_extensions))
+             ]
+
+jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc
+jsonMap f g = jsonObject . map (f *** g) . Map.toList
+
+jsonMDoc :: MDoc Name -> JsonDoc
+jsonMDoc MetaDoc{..} =
+  jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))])
+             , ("doc",  jsonDoc _doc)
+             ]
+
+jsonDoc :: Doc Name -> JsonDoc
+jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+
+jsonModule :: Module -> JsonDoc
+jsonModule = JSString . moduleStableString
+
+jsonName :: Name -> JsonDoc
+jsonName = JSString . nameStableString
+
+jsonFixity :: Fixity -> JsonDoc
+jsonFixity (Fixity _ prec dir) =
+  jsonObject [ ("prec"      , jsonInt prec)
+             , ("direction" , jsonFixityDirection dir)
+             ]
+
+jsonFixityDirection :: FixityDirection -> JsonDoc
+jsonFixityDirection InfixL = jsonString "infixl"
+jsonFixityDirection InfixR = jsonString "infixr"
+jsonFixityDirection InfixN = jsonString "infix"
+
+renderJson :: JsonDoc -> SDoc
+renderJson = renderJSON
+
+jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc
+jsonMaybe = maybe jsonNull
+
+jsonString :: String -> JsonDoc
+jsonString = JSString
+
+jsonObject :: [(String, JsonDoc)] -> JsonDoc
+jsonObject = JSObject
+
+jsonArray :: [JsonDoc] -> JsonDoc
+jsonArray = JSArray
+
+jsonNull :: JsonDoc
+jsonNull = JSNull
+
+jsonInt :: Int -> JsonDoc
+jsonInt = JSInt
+
+jsonBool :: Bool -> JsonDoc
+jsonBool = JSBool
+
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 0449c829..d73d1a79 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -25,6 +25,7 @@ module Haddock.Options (
   sourceUrls,
   wikiUrls,
   optDumpInterfaceFile,
+  optShowInterfaceFile,
   optLaTeXStyle,
   optMathjax,
   qualification,
@@ -53,6 +54,7 @@ data Flag
 --  | Flag_DocBook
   | Flag_ReadInterface String
   | Flag_DumpInterface String
+  | Flag_ShowInterface String
   | Flag_Heading String
   | Flag_Html
   | Flag_Hoogle
@@ -112,6 +114,8 @@ options backwardsCompat =
       "read an interface from FILE",
     Option ['D']  ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
       "write the resulting interface to FILE",
+    Option []     ["show-interface"] (ReqArg Flag_ShowInterface "FILE")
+      "print the interface in a human readable form",
 --    Option ['S']  ["docbook"]  (NoArg Flag_DocBook)
 --  "output in DocBook XML",
     Option ['h']  ["html"]     (NoArg Flag_Html)
@@ -270,6 +274,8 @@ wikiUrls flags =
 optDumpInterfaceFile :: [Flag] -> Maybe FilePath
 optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
 
+optShowInterfaceFile :: [Flag] -> Maybe FilePath
+optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ]
 
 optLaTeXStyle :: [Flag] -> Maybe String
 optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md
index bebb9982..c52908e1 100644
--- a/haddock-library/CHANGES.md
+++ b/haddock-library/CHANGES.md
@@ -1,3 +1,9 @@
+## Changes in version 1.4.6
+
+ * to be released
+
+ * Bifunctor instance for DocH
+
 ## Changes in version 1.4.5
 
  * Move markup related data types to haddock-library
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 0ab6bb4c..22cab425 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -19,6 +19,11 @@ import Data.Foldable
 import Data.Traversable
 #endif
 
+#if MIN_VERSION_base(4,8,0)
+import Control.Arrow ((***))
+import Data.Bifunctor
+#endif
+
 -- | With the advent of 'Version', we may want to start attaching more
 -- meta-data to comments. We make a structure for this ahead of time
 -- so we don't have to gut half the core each time we want to add such
@@ -81,6 +86,33 @@ data DocH mod id
   | DocHeader (Header (DocH mod id))
   deriving (Eq, Show, Functor, Foldable, Traversable)
 
+#if MIN_VERSION_base(4,8,0)
+instance Bifunctor DocH where
+  bimap _ _ DocEmpty = DocEmpty
+  bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB)
+  bimap _ _ (DocString s) = DocString s
+  bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc)
+  bimap _ g (DocIdentifier i) = DocIdentifier (g i)
+  bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m)
+  bimap _ _ (DocModule s) = DocModule s
+  bimap f g (DocWarning doc) = DocWarning (bimap f g doc)
+  bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc)
+  bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc)
+  bimap f g (DocBold doc) = DocBold (bimap f g doc)
+  bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs)
+  bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs)
+  bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs)
+  bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc)
+  bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink
+  bimap _ _ (DocPic picture) = DocPic picture
+  bimap _ _ (DocMathInline s) = DocMathInline s
+  bimap _ _ (DocMathDisplay s) = DocMathDisplay s
+  bimap _ _ (DocAName s) = DocAName s
+  bimap _ _ (DocProperty s) = DocProperty s
+  bimap _ _ (DocExamples examples) = DocExamples examples
+  bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title))
+#endif
+
 -- | 'DocMarkupH' is a set of instructions for marking up documentation.
 -- In fact, it's really just a mapping from 'Doc' to some other
 -- type [a], where [a] is usually the type of the output (HTML, say).
@@ -114,4 +146,3 @@ data DocMarkupH mod id a = Markup
   , markupExample              :: [Example] -> a
   , markupHeader               :: Header a -> a
   }
-
diff --git a/haddock.cabal b/haddock.cabal
index 36c80f33..5ae3443c 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -106,6 +106,7 @@ executable haddock
       Documentation.Haddock
       Haddock
       Haddock.Interface
+      Haddock.Interface.Json
       Haddock.Interface.Rename
       Haddock.Interface.Create
       Haddock.Interface.AttachInstances