{-# LANGUAGE OverloadedStrings #-}
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
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
}
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]
, :: 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
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
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
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
extractReferences :: SwarmSchema -> Set SchemaIdReference
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