aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
authorAlexander Biehl <alexbiehl@gmail.com>2017-08-06 13:18:02 +0200
committerGitHub <noreply@github.com>2017-08-06 13:18:02 +0200
commitf1d326b53fbed5d37f2a83c66e73dbbc94a4354f (patch)
treed798776c519fb21c4e26a6e604cd0d1cee6fa05d /haddock-api/src/Haddock
parenta677f1592d292a422b9a8d681b0b63a9af611722 (diff)
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.
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs109
-rw-r--r--haddock-api/src/Haddock/Options.hs6
2 files changed, 115 insertions, 0 deletions
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 ]