Generate an index for package content search (#662)

Generate an index for package content search

4 files changed, 285 insertions, 4 deletions

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index d38e9149..d4132cea 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -79,6 +79,7 @@ library
     Haddock.Interface.Specialize
     Haddock.Parser
     Haddock.Utils
+    Haddock.Utils.Json
     Haddock.Backends.Xhtml
     Haddock.Backends.Xhtml.Decl
     Haddock.Backends.Xhtml.DocMarkup
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 249389b9..78bd0262 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -11,7 +11,7 @@
 -- Stability   :  experimental
 -- Portability :  portable
 -----------------------------------------------------------------------------
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, NamedFieldPuns #-}
 module Haddock.Backends.Xhtml (
   ppHtml, copyHtmlBits,
   ppHtmlIndex, ppHtmlContents,
@@ -31,6 +31,7 @@ import Haddock.ModuleTree
 import Haddock.Types
 import Haddock.Version
 import Haddock.Utils
+import Haddock.Utils.Json
 import Text.XHtml hiding ( name, title, p, quote )
 import Haddock.GhcUtils
 
@@ -87,10 +88,12 @@ ppHtml dflags doctitle maybe_package ifaces odir prologue
         False -- we don't want to display the packages in a single-package contents
         prologue debug (makeContentsQual qual)
 
-  when (isNothing maybe_index_url) $
+  when (isNothing maybe_index_url) $ do
     ppHtmlIndex odir doctitle maybe_package
       themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url
       (map toInstalledIface visible_ifaces) debug
+    ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual
+      visible_ifaces
 
   mapM_ (ppHtmlModule odir doctitle themes
            maybe_mathjax_url maybe_source_url maybe_wiki_url
@@ -340,6 +343,57 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) =
 -- * Generate the index
 --------------------------------------------------------------------------------
 
+ppJsonIndex :: FilePath
+           -> SourceURLs                   -- ^ The source URL (--source)
+           -> WikiURLs                     -- ^ The wiki URL (--wiki)
+           -> Bool
+           -> QualOption
+           -> [Interface]
+           -> IO ()
+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do
+  createDirectoryIfMissing True odir
+  writeFile (joinPath [odir, indexJsonFile])
+            (encodeToString modules)
+
+  where
+    modules :: Value
+    modules = Array (concatMap goInterface ifaces)
+
+    goInterface :: Interface -> [Value]
+    goInterface iface =
+        concatMap (goExport mdl qual) (ifaceRnExportItems iface)
+      where
+        aliases = ifaceModuleAliases iface
+        qual    = makeModuleQual qual_opt aliases mdl
+        mdl     = ifaceMod iface
+
+    goExport :: Module -> Qualification -> ExportItem DocName -> [Value]
+    goExport mdl qual item =
+      case processExport True links_info unicode qual item of
+        Nothing -> []
+        Just html ->
+          [ Object
+            [ "display_html" .= String (showHtmlFragment html)
+            , "name"         .= String (intercalate " " (map nameString names))
+            , "module"       .= String (moduleString mdl)
+            , "link"         .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))
+            ]
+          ]
+      where 
+        names = exportName item
+    
+    exportName :: ExportItem DocName -> [DocName]
+    exportName ExportDecl { expItemDecl } = getMainDeclBinder $ unLoc expItemDecl
+    exportName ExportNoDecl { expItemName } = [expItemName]
+    exportName _ = []
+
+    nameString :: NamedThing name => name -> String
+    nameString = occNameString . nameOccName . getName
+
+    nameLink :: NamedThing name => Module -> name -> String
+    nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName
+
+    links_info = (maybe_source_url, maybe_wiki_url)
 
 ppHtmlIndex :: FilePath
             -> String
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 7a9d65a4..200cd00a 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -20,7 +20,7 @@ module Haddock.Utils (
 
   -- * Filename utilities
   moduleHtmlFile, moduleHtmlFile',
-  contentsHtmlFile, indexHtmlFile,
+  contentsHtmlFile, indexHtmlFile, indexJsonFile,
   moduleIndexFrameName, mainFrameName, synopsisFrameName,
   subIndexHtmlFile,
   jsFile,
@@ -254,9 +254,10 @@ moduleHtmlFile' mdl =
     Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"]
 
 
-contentsHtmlFile, indexHtmlFile :: String
+contentsHtmlFile, indexHtmlFile, indexJsonFile :: String
 contentsHtmlFile = "index.html"
 indexHtmlFile = "doc-index.html"
+indexJsonFile = "doc-index.json"
 
 
 
diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs
new file mode 100644
index 00000000..e3c3dddc
--- /dev/null
+++ b/haddock-api/src/Haddock/Utils/Json.hs
@@ -0,0 +1,225 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Minimal JSON / RFC 7159 support
+--
+-- The API is heavily inspired by @aeson@'s API but puts emphasis on
+-- simplicity rather than performance. The 'ToJSON' instances are
+-- intended to have an encoding compatible with @aeson@'s encoding.
+--
+module Haddock.Utils.Json
+    ( Value(..)
+    , Object, object, Pair, (.=)
+    , encodeToString
+    , encodeToBuilder
+    , ToJSON(toJSON)
+    )
+    where
+
+import Data.Char
+import Data.Int
+import Data.String
+import Data.Word
+import Data.List
+import Data.Monoid
+
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as BB
+
+-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'
+
+-- | A JSON value represented as a Haskell value.
+data Value = Object !Object
+           | Array  [Value]
+           | String  String
+           | Number !Double
+           | Bool   !Bool
+           | Null
+           deriving (Eq, Read, Show)
+
+-- | A key\/value pair for an 'Object'
+type Pair = (String, Value)
+
+-- | A JSON \"object\" (key/value map).
+type Object = [Pair]
+
+infixr 8 .=
+
+-- | A key-value pair for encoding a JSON object.
+(.=) :: ToJSON v => String -> v -> Pair
+k .= v  = (k, toJSON v)
+
+-- | Create a 'Value' from a list of name\/value 'Pair's.
+object :: [Pair] -> Value
+object = Object
+
+instance IsString Value where
+  fromString = String
+
+
+-- | A type that can be converted to JSON.
+class ToJSON a where
+  -- | Convert a Haskell value to a JSON-friendly intermediate type.
+  toJSON :: a -> Value
+
+instance ToJSON () where
+  toJSON () = Array []
+
+instance ToJSON Value where
+  toJSON = id
+
+instance ToJSON Bool where
+  toJSON = Bool
+
+instance ToJSON a => ToJSON [a] where
+  toJSON = Array . map toJSON
+
+instance ToJSON a => ToJSON (Maybe a) where
+  toJSON Nothing  = Null
+  toJSON (Just a) = toJSON a
+
+instance (ToJSON a,ToJSON b) => ToJSON (a,b) where
+  toJSON (a,b) = Array [toJSON a, toJSON b]
+
+instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where
+  toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]
+
+instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
+  toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]
+
+instance ToJSON Float where
+  toJSON = Number . realToFrac
+
+instance ToJSON Double where
+  toJSON = Number
+
+instance ToJSON Int    where  toJSON = Number . realToFrac
+instance ToJSON Int8   where  toJSON = Number . realToFrac
+instance ToJSON Int16  where  toJSON = Number . realToFrac
+instance ToJSON Int32  where  toJSON = Number . realToFrac
+
+instance ToJSON Word   where  toJSON = Number . realToFrac
+instance ToJSON Word8  where  toJSON = Number . realToFrac
+instance ToJSON Word16 where  toJSON = Number . realToFrac
+instance ToJSON Word32 where  toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Int64  where  toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Word64 where  toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Integer where toJSON = Number . fromInteger
+
+------------------------------------------------------------------------------
+-- 'BB.Builder'-based encoding
+
+-- | Serialise value as JSON/UTF8-encoded 'Builder'
+encodeToBuilder :: ToJSON a => a -> Builder
+encodeToBuilder = encodeValueBB . toJSON
+
+encodeValueBB :: Value -> Builder
+encodeValueBB jv = case jv of
+  Bool True  -> "true"
+  Bool False -> "false"
+  Null       -> "null"
+  Number n
+    | isNaN n || isInfinite n   -> encodeValueBB Null
+    | Just i <- doubleToInt64 n -> BB.int64Dec i
+    | otherwise                 -> BB.doubleDec n
+  Array a  -> encodeArrayBB a
+  String s -> encodeStringBB s
+  Object o -> encodeObjectBB o
+
+encodeArrayBB :: [Value] -> Builder
+encodeArrayBB [] = "[]"
+encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'
+  where
+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB
+
+encodeObjectBB :: Object -> Builder
+encodeObjectBB [] = "{}"
+encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'
+  where
+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair
+    encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x
+
+encodeStringBB :: String -> Builder
+encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'
+  where
+    go = BB.stringUtf8 . escapeString
+
+------------------------------------------------------------------------------
+-- 'String'-based encoding
+
+-- | Serialise value as JSON-encoded Unicode 'String'
+encodeToString :: ToJSON a => a -> String
+encodeToString jv = encodeValue (toJSON jv) []
+
+encodeValue :: Value -> ShowS
+encodeValue jv = case jv of
+  Bool b   -> showString (if b then "true" else "false")
+  Null     -> showString "null"
+  Number n
+    | isNaN n || isInfinite n    -> encodeValue Null
+    | Just i <- doubleToInt64 n -> shows i
+    | otherwise                 -> shows n
+  Array a -> encodeArray a
+  String s -> encodeString s
+  Object o -> encodeObject o
+
+encodeArray :: [Value] -> ShowS
+encodeArray [] = showString "[]"
+encodeArray jvs = ('[':) . go jvs . (']':)
+  where
+    go []     = id
+    go [x]    = encodeValue x
+    go (x:xs) = encodeValue x . (',':) . go xs
+
+encodeObject :: Object -> ShowS
+encodeObject [] = showString "{}"
+encodeObject jvs = ('{':) . go jvs . ('}':)
+  where
+    go []          = id
+    go [(l,x)]     = encodeString l . (':':) . encodeValue x
+    go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs
+
+encodeString :: String -> ShowS
+encodeString str = ('"':) . showString (escapeString str) . ('"':)
+
+------------------------------------------------------------------------------
+-- helpers
+
+-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not
+-- representable loss-free as integral 'Int64' value.
+doubleToInt64 :: Double -> Maybe Int64
+doubleToInt64 x
+  | fromInteger x' == x
+  , x' <= toInteger (maxBound :: Int64)
+  , x' >= toInteger (minBound :: Int64)
+    = Just (fromIntegral x')
+  | otherwise = Nothing
+  where
+    x' = round x
+
+-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"
+escapeString :: String -> String
+escapeString s
+  | not (any needsEscape s) = s
+  | otherwise               = escape s
+  where
+    escape [] = []
+    escape (x:xs) = case x of
+      '\\' -> '\\':'\\':escape xs
+      '"'  -> '\\':'"':escape xs
+      '\b' -> '\\':'b':escape xs
+      '\f' -> '\\':'f':escape xs
+      '\n' -> '\\':'n':escape xs
+      '\r' -> '\\':'r':escape xs
+      '\t' -> '\\':'t':escape xs
+      c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs
+        | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs
+        | otherwise    -> c : escape xs
+
+    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF
+    needsEscape c = ord c < 0x20 || c `elem` ['\\','"']