coot/multiple packages (ghc-9.2) (#1418)

2 files changed, 144 insertions, 0 deletions

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