{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Refined JSON schema after converting
-- all JSON Value types to their specific sum types
module Swarm.Doc.Schema.Refined where

import Control.Applicative ((<|>))
import Data.Aeson
import Data.List.Extra (replace)
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import Swarm.Doc.Schema.SchemaType
import System.FilePath (takeBaseName)
import Text.Pandoc
import Text.Pandoc.Builder

-- * Basic

schemaJsonOptions :: Options
schemaJsonOptions :: Options
schemaJsonOptions =
  Options
defaultOptions
    { fieldLabelModifier :: [Char] -> [Char]
fieldLabelModifier = forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [Char]
"S" [Char]
"$" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 -- drops leading underscore
    }

-- | A single record that encompasses all possible objects
-- in a JSON schema. All fields are optional.
data SchemaRaw = SchemaRaw
  { SchemaRaw -> Maybe Text
_description :: Maybe Text
  , SchemaRaw -> Maybe Value
_default :: Maybe Value
  , SchemaRaw -> Maybe Text
_title :: Maybe Text
  , SchemaRaw -> Maybe (SingleOrList Text)
_type :: Maybe (SingleOrList Text)
  , SchemaRaw -> Maybe Text
_name :: Maybe Text
  , SchemaRaw -> Maybe (Map Text SwarmSchema)
_properties :: Maybe (Map Text SwarmSchema)
  , SchemaRaw -> Maybe (ItemDescription SwarmSchema)
_items :: Maybe (ItemDescription SwarmSchema)
  , SchemaRaw -> Maybe [Value]
_examples :: Maybe [Value]
  , SchemaRaw -> Maybe Text
_Sref :: Maybe Text
  , SchemaRaw -> Maybe [SchemaRaw]
_oneOf :: Maybe [SchemaRaw]
  , SchemaRaw -> Maybe [[Char]]
_footers :: Maybe [FilePath]
  , SchemaRaw -> Maybe Bool
_additionalProperties :: Maybe Bool
  }
  deriving (SchemaRaw -> SchemaRaw -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemaRaw -> SchemaRaw -> Bool
$c/= :: SchemaRaw -> SchemaRaw -> Bool
== :: SchemaRaw -> SchemaRaw -> Bool
$c== :: SchemaRaw -> SchemaRaw -> Bool
Eq, Eq SchemaRaw
SchemaRaw -> SchemaRaw -> Bool
SchemaRaw -> SchemaRaw -> Ordering
SchemaRaw -> SchemaRaw -> SchemaRaw
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SchemaRaw -> SchemaRaw -> SchemaRaw
$cmin :: SchemaRaw -> SchemaRaw -> SchemaRaw
max :: SchemaRaw -> SchemaRaw -> SchemaRaw
$cmax :: SchemaRaw -> SchemaRaw -> SchemaRaw
>= :: SchemaRaw -> SchemaRaw -> Bool
$c>= :: SchemaRaw -> SchemaRaw -> Bool
> :: SchemaRaw -> SchemaRaw -> Bool
$c> :: SchemaRaw -> SchemaRaw -> Bool
<= :: SchemaRaw -> SchemaRaw -> Bool
$c<= :: SchemaRaw -> SchemaRaw -> Bool
< :: SchemaRaw -> SchemaRaw -> Bool
$c< :: SchemaRaw -> SchemaRaw -> Bool
compare :: SchemaRaw -> SchemaRaw -> Ordering
$ccompare :: SchemaRaw -> SchemaRaw -> Ordering
Ord, Int -> SchemaRaw -> [Char] -> [Char]
[SchemaRaw] -> [Char] -> [Char]
SchemaRaw -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [SchemaRaw] -> [Char] -> [Char]
$cshowList :: [SchemaRaw] -> [Char] -> [Char]
show :: SchemaRaw -> [Char]
$cshow :: SchemaRaw -> [Char]
showsPrec :: Int -> SchemaRaw -> [Char] -> [Char]
$cshowsPrec :: Int -> SchemaRaw -> [Char] -> [Char]
Show, forall x. Rep SchemaRaw x -> SchemaRaw
forall x. SchemaRaw -> Rep SchemaRaw x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SchemaRaw x -> SchemaRaw
$cfrom :: forall x. SchemaRaw -> Rep SchemaRaw x
Generic)

instance FromJSON SchemaRaw where
  parseJSON :: Value -> Parser SchemaRaw
parseJSON = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
schemaJsonOptions

extractSchemaType :: SchemaRaw -> Maybe SchemaType
extractSchemaType :: SchemaRaw -> Maybe SchemaType
extractSchemaType SchemaRaw
rawSchema =
  Text -> SchemaType
mkReference forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaRaw -> Maybe Text
_Sref SchemaRaw
rawSchema
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe SchemaType
getTypeFromItems
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SingleOrList Text -> SchemaType
Simple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaRaw -> Maybe (SingleOrList Text)
_type SchemaRaw
rawSchema
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [SchemaType] -> SchemaType
Alternatives forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SchemaRaw -> Maybe SchemaType
extractSchemaType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaRaw -> Maybe [SchemaRaw]
_oneOf SchemaRaw
rawSchema
 where
  mkReference :: Text -> SchemaType
mkReference = SchemaIdReference -> SchemaType
Reference forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SchemaIdReference
SchemaIdReference forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
takeBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

  getTypeFromItems :: Maybe SchemaType
  getTypeFromItems :: Maybe SchemaType
getTypeFromItems = do
    ItemDescription SwarmSchema
itemsThing <- SchemaRaw -> Maybe (ItemDescription SwarmSchema)
_items SchemaRaw
rawSchema
    case ItemDescription SwarmSchema
itemsThing of
      ItemList [SwarmSchema]
_ -> forall a. Maybe a
Nothing
      ItemType SwarmSchema
x -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SchemaType -> SchemaType
ListOf forall a b. (a -> b) -> a -> b
$ SwarmSchema -> SchemaType
schemaType SwarmSchema
x

-- * Refined

data ItemDescription a
  = ItemList [a]
  | ItemType a
  deriving (ItemDescription a -> ItemDescription a -> Bool
forall a. Eq a => ItemDescription a -> ItemDescription a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ItemDescription a -> ItemDescription a -> Bool
$c/= :: forall a. Eq a => ItemDescription a -> ItemDescription a -> Bool
== :: ItemDescription a -> ItemDescription a -> Bool
$c== :: forall a. Eq a => ItemDescription a -> ItemDescription a -> Bool
Eq, ItemDescription a -> ItemDescription a -> Bool
ItemDescription a -> ItemDescription a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (ItemDescription a)
forall a. Ord a => ItemDescription a -> ItemDescription a -> Bool
forall a.
Ord a =>
ItemDescription a -> ItemDescription a -> Ordering
forall a.
Ord a =>
ItemDescription a -> ItemDescription a -> ItemDescription a
min :: ItemDescription a -> ItemDescription a -> ItemDescription a
$cmin :: forall a.
Ord a =>
ItemDescription a -> ItemDescription a -> ItemDescription a
max :: ItemDescription a -> ItemDescription a -> ItemDescription a
$cmax :: forall a.
Ord a =>
ItemDescription a -> ItemDescription a -> ItemDescription a
>= :: ItemDescription a -> ItemDescription a -> Bool
$c>= :: forall a. Ord a => ItemDescription a -> ItemDescription a -> Bool
> :: ItemDescription a -> ItemDescription a -> Bool
$c> :: forall a. Ord a => ItemDescription a -> ItemDescription a -> Bool
<= :: ItemDescription a -> ItemDescription a -> Bool
$c<= :: forall a. Ord a => ItemDescription a -> ItemDescription a -> Bool
< :: ItemDescription a -> ItemDescription a -> Bool
$c< :: forall a. Ord a => ItemDescription a -> ItemDescription a -> Bool
compare :: ItemDescription a -> ItemDescription a -> Ordering
$ccompare :: forall a.
Ord a =>
ItemDescription a -> ItemDescription a -> Ordering
Ord, Int -> ItemDescription a -> [Char] -> [Char]
forall a. Show a => Int -> ItemDescription a -> [Char] -> [Char]
forall a. Show a => [ItemDescription a] -> [Char] -> [Char]
forall a. Show a => ItemDescription a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ItemDescription a] -> [Char] -> [Char]
$cshowList :: forall a. Show a => [ItemDescription a] -> [Char] -> [Char]
show :: ItemDescription a -> [Char]
$cshow :: forall a. Show a => ItemDescription a -> [Char]
showsPrec :: Int -> ItemDescription a -> [Char] -> [Char]
$cshowsPrec :: forall a. Show a => Int -> ItemDescription a -> [Char] -> [Char]
Show)

instance (FromJSON a) => FromJSON (ItemDescription a) where
  parseJSON :: Value -> Parser (ItemDescription a)
parseJSON Value
x =
    forall a. [a] -> ItemDescription a
ItemList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
x
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> ItemDescription a
ItemType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
x

getSchemaReferences :: SchemaType -> [SchemaIdReference]
getSchemaReferences :: SchemaType -> [SchemaIdReference]
getSchemaReferences = \case
  Simple SingleOrList Text
_ -> []
  Alternatives [SchemaType]
xs -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SchemaType -> [SchemaIdReference]
getSchemaReferences [SchemaType]
xs
  Reference SchemaIdReference
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SchemaIdReference
x
  ListOf SchemaType
x -> SchemaType -> [SchemaIdReference]
getSchemaReferences SchemaType
x

-- | A subset of all JSON schemas, conforming to internal Swarm conventions.
--
-- Conveniently, this extra representation layer
-- is able to enforce (via 'toSwarmSchema') that all "object"
-- definitions in the schema contain the @"additionalProperties": true@ attribute.
data SwarmSchema = SwarmSchema
  { SwarmSchema -> SchemaType
schemaType :: SchemaType
  , SwarmSchema -> Maybe Value
defaultValue :: Maybe Value
  , SwarmSchema -> Maybe Pandoc
objectDescription :: Maybe Pandoc
  , SwarmSchema -> Maybe (Map Text SwarmSchema)
properties :: Maybe (Map Text SwarmSchema)
  , SwarmSchema -> Maybe (ItemDescription SwarmSchema)
itemsDescription :: Maybe (ItemDescription SwarmSchema)
  , SwarmSchema -> [Value]
examples :: [Value]
  }
  deriving (SwarmSchema -> SwarmSchema -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SwarmSchema -> SwarmSchema -> Bool
$c/= :: SwarmSchema -> SwarmSchema -> Bool
== :: SwarmSchema -> SwarmSchema -> Bool
$c== :: SwarmSchema -> SwarmSchema -> Bool
Eq, Eq SwarmSchema
SwarmSchema -> SwarmSchema -> Bool
SwarmSchema -> SwarmSchema -> Ordering
SwarmSchema -> SwarmSchema -> SwarmSchema
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SwarmSchema -> SwarmSchema -> SwarmSchema
$cmin :: SwarmSchema -> SwarmSchema -> SwarmSchema
max :: SwarmSchema -> SwarmSchema -> SwarmSchema
$cmax :: SwarmSchema -> SwarmSchema -> SwarmSchema
>= :: SwarmSchema -> SwarmSchema -> Bool
$c>= :: SwarmSchema -> SwarmSchema -> Bool
> :: SwarmSchema -> SwarmSchema -> Bool
$c> :: SwarmSchema -> SwarmSchema -> Bool
<= :: SwarmSchema -> SwarmSchema -> Bool
$c<= :: SwarmSchema -> SwarmSchema -> Bool
< :: SwarmSchema -> SwarmSchema -> Bool
$c< :: SwarmSchema -> SwarmSchema -> Bool
compare :: SwarmSchema -> SwarmSchema -> Ordering
$ccompare :: SwarmSchema -> SwarmSchema -> Ordering
Ord, Int -> SwarmSchema -> [Char] -> [Char]
[SwarmSchema] -> [Char] -> [Char]
SwarmSchema -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [SwarmSchema] -> [Char] -> [Char]
$cshowList :: [SwarmSchema] -> [Char] -> [Char]
show :: SwarmSchema -> [Char]
$cshow :: SwarmSchema -> [Char]
showsPrec :: Int -> SwarmSchema -> [Char] -> [Char]
$cshowsPrec :: Int -> SwarmSchema -> [Char] -> [Char]
Show)

instance FromJSON SwarmSchema where
  parseJSON :: Value -> Parser SwarmSchema
parseJSON Value
x = do
    SchemaRaw
rawSchema :: rawSchema <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
x
    forall (m :: * -> *). MonadFail m => SchemaRaw -> m SwarmSchema
toSwarmSchema SchemaRaw
rawSchema

getMarkdown :: MonadFail m => Text -> m Pandoc
getMarkdown :: forall (m :: * -> *). MonadFail m => Text -> m Pandoc
getMarkdown Text
desc = case forall a. PandocPure a -> Either PandocError a
runPure (forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown forall a. Default a => a
def Text
desc) of
  Right Pandoc
d -> forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
d
  Left PandocError
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ PandocError -> Text
renderError PandocError
err

toSwarmSchema :: MonadFail m => SchemaRaw -> m SwarmSchema
toSwarmSchema :: forall (m :: * -> *). MonadFail m => SchemaRaw -> m SwarmSchema
toSwarmSchema SchemaRaw
rawSchema = do
  SchemaType
theType <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unspecified sub-schema type") forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SchemaType
maybeType
  Maybe Pandoc
markdownDescription <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadFail m => Text -> m Pandoc
getMarkdown forall a b. (a -> b) -> a -> b
$ SchemaRaw -> Maybe Text
_description SchemaRaw
rawSchema

  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SchemaRaw -> Maybe (Map Text SwarmSchema)
_properties SchemaRaw
rawSchema) Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. a -> Maybe a -> a
fromMaybe Bool
True (SchemaRaw -> Maybe Bool
_additionalProperties SchemaRaw
rawSchema))
    then forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"All objects must specify '\"additionalProperties\": true'"

  forall (m :: * -> *) a. Monad m => a -> m a
return
    SwarmSchema
      { schemaType :: SchemaType
schemaType = SchemaType
theType
      , defaultValue :: Maybe Value
defaultValue = SchemaRaw -> Maybe Value
_default SchemaRaw
rawSchema
      , objectDescription :: Maybe Pandoc
objectDescription = Maybe Pandoc
markdownDescription forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Blocks -> Pandoc
doc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Blocks
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inlines
text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaRaw -> Maybe Text
_name SchemaRaw
rawSchema
      , examples :: [Value]
examples = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ SchemaRaw -> Maybe [Value]
_examples SchemaRaw
rawSchema
      , properties :: Maybe (Map Text SwarmSchema)
properties = SchemaRaw -> Maybe (Map Text SwarmSchema)
_properties SchemaRaw
rawSchema
      , itemsDescription :: Maybe (ItemDescription SwarmSchema)
itemsDescription = SchemaRaw -> Maybe (ItemDescription SwarmSchema)
_items SchemaRaw
rawSchema
      }
 where
  maybeType :: Maybe SchemaType
maybeType = SchemaRaw -> Maybe SchemaType
extractSchemaType SchemaRaw
rawSchema

-- * Utilities

-- | Recursively extract references to other schemas
extractReferences :: SwarmSchema -> Set SchemaIdReference
extractReferences :: SwarmSchema -> Set SchemaIdReference
extractReferences SwarmSchema
s = Set SchemaIdReference
thisRefList forall a. Semigroup a => a -> a -> a
<> Set SchemaIdReference
otherRefLists
 where
  thisRefList :: Set SchemaIdReference
thisRefList = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaType -> [SchemaIdReference]
getSchemaReferences forall a b. (a -> b) -> a -> b
$ SwarmSchema -> SchemaType
schemaType SwarmSchema
s

  otherSchemas :: [SwarmSchema]
otherSchemas = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ SwarmSchema -> Maybe (Map Text SwarmSchema)
properties SwarmSchema
s
  otherRefLists :: Set SchemaIdReference
otherRefLists = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map SwarmSchema -> Set SchemaIdReference
extractReferences [SwarmSchema]
otherSchemas