From 1b63771dee5a7fac0696505d0b335908bd12835d Mon Sep 17 00:00:00 2001
From: Marcin Szamotulski <profunctor@pm.me>
Date: Mon, 16 Aug 2021 08:46:03 +0200
Subject: coot/multiple package (ghc-head) (#1419)

* FromJSON class

Aeson style FromJSON class with Parsec based json parser.

* doc-index.json file for multiple packages

When creating haddock summary page for multiple packages render
doc-index.json file using contents of all found 'doc-index.json' files.

* Render doc-index.json

When rendering html, render doc-index.json file independently of
maybe_index_url option.  doc-index.json file is useful now even if
maybe_index_url is not `Nothing`.

* base url option

New `Flag_BaseURL` which configures from where static files are loaded
(--base-url).  If given and not equal "." static files are not coppied,
as this indicates that they are not read from the the directory where
we'd copy them.  The default value is ".".
---
 haddock-api/src/Haddock/Utils/Json/Parser.hs | 102 +++++++++++++++++++++++++++
 haddock-api/src/Haddock/Utils/Json/Types.hs  |  42 +++++++++++
 2 files changed, 144 insertions(+)
 create mode 100644 haddock-api/src/Haddock/Utils/Json/Parser.hs
 create mode 100644 haddock-api/src/Haddock/Utils/Json/Types.hs

(limited to 'haddock-api/src/Haddock/Utils/Json')

diff --git a/haddock-api/src/Haddock/Utils/Json/Parser.hs b/haddock-api/src/Haddock/Utils/Json/Parser.hs
new file mode 100644
index 00000000..018e27d3
--- /dev/null
+++ b/haddock-api/src/Haddock/Utils/Json/Parser.hs
@@ -0,0 +1,102 @@
+-- | Json "Parsec" parser, based on
+-- [json](https://hackage.haskell.org/package/json) package.
+--
+module Haddock.Utils.Json.Parser
+  ( parseJSONValue
+  ) where
+
+import Prelude hiding (null)
+
+import Control.Applicative (Alternative (..))
+import Control.Monad (MonadPlus (..))
+import Data.Char (isHexDigit)
+import Data.Functor (($>))
+import qualified Data.ByteString.Lazy.Char8 as BSCL
+import Numeric
+import Text.Parsec.ByteString.Lazy (Parser)
+import Text.ParserCombinators.Parsec ((<?>))
+import qualified Text.ParserCombinators.Parsec as Parsec
+
+import Haddock.Utils.Json.Types hiding (object)
+
+parseJSONValue :: Parser Value
+parseJSONValue = Parsec.spaces *> parseValue
+
+tok :: Parser a -> Parser a
+tok p = p <* Parsec.spaces
+
+parseValue :: Parser Value
+parseValue =
+         parseNull
+     <|> Bool   <$> parseBoolean
+     <|> Array  <$> parseArray
+     <|> String <$> parseString
+     <|> Object <$> parseObject
+     <|> Number <$> parseNumber
+     <?> "JSON value"
+
+parseNull :: Parser Value
+parseNull = tok
+     $  Parsec.string "null"
+     $> Null
+
+parseBoolean :: Parser Bool
+parseBoolean = tok
+     $  Parsec.string "true"  $> True
+    <|> Parsec.string "false" $> False
+
+parseArray :: Parser [Value]
+parseArray =
+    Parsec.between
+      (tok (Parsec.char '['))
+      (tok (Parsec.char ']'))
+      (parseValue `Parsec.sepBy` tok (Parsec.char ','))
+
+parseString :: Parser String
+parseString =
+    Parsec.between
+      (tok (Parsec.char '"'))
+      (tok (Parsec.char '"'))
+      (many char)
+  where
+    char = (Parsec.char '\\' >> escapedChar)
+       <|> Parsec.satisfy (\x -> x /= '"' && x /= '\\')
+
+    escapedChar =
+          Parsec.char '"'  $> '"'
+      <|> Parsec.char '\\' $> '\\'
+      <|> Parsec.char '/'  $> '/'
+      <|> Parsec.char 'b'  $> '\b'
+      <|> Parsec.char 'f'  $> '\f'
+      <|> Parsec.char 'n'  $> '\n'
+      <|> Parsec.char 'r'  $> '\r'
+      <|> Parsec.char 't'  $> '\t'
+      <|> Parsec.char 'u'  *> uni
+      <?> "escape character"
+
+    uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit)
+      where
+        check x | code <= max_char = return (toEnum code)
+                | otherwise        = mzero
+          where code      = fst $ head $ readHex x
+                max_char  = fromEnum (maxBound :: Char)
+
+parseObject :: Parser Object
+parseObject =
+      Parsec.between
+        (tok (Parsec.char '{'))
+        (tok (Parsec.char '}'))
+        (field `Parsec.sepBy` tok (Parsec.char ','))
+  where
+    field :: Parser (String, Value)
+    field = (,)
+        <$> parseString
+        <*  tok (Parsec.char ':')
+        <*> parseValue
+
+parseNumber :: Parser Double
+parseNumber = tok $ do
+  s <- BSCL.unpack <$> Parsec.getInput
+  case readSigned readFloat s of
+    [(n,s')] -> Parsec.setInput (BSCL.pack s') $> n
+    _        -> mzero
diff --git a/haddock-api/src/Haddock/Utils/Json/Types.hs b/haddock-api/src/Haddock/Utils/Json/Types.hs
new file mode 100644
index 00000000..1174329c
--- /dev/null
+++ b/haddock-api/src/Haddock/Utils/Json/Types.hs
@@ -0,0 +1,42 @@
+module Haddock.Utils.Json.Types
+  ( Value(..)
+  , typeOf
+  , Pair
+  , Object
+  , object
+  ) where
+
+import Data.String
+
+-- 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)
+
+typeOf :: Value -> String
+typeOf v = case v of
+    Object _ -> "Object"
+    Array _  -> "Array"
+    String _ -> "String"
+    Number _ -> "Number"
+    Bool _   -> "Boolean"
+    Null     -> "Null"
+
+-- | A key\/value pair for an 'Object'
+type Pair = (String, Value)
+
+-- | A JSON \"object\" (key/value map).
+type Object = [Pair]
+
+-- | Create a 'Value' from a list of name\/value 'Pair's.
+object :: [Pair] -> Value
+object = Object
+
+instance IsString Value where
+  fromString = String
-- 
cgit v1.2.3