content: {-# LANGUAGE LambdaCase #-}
  {-# 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 Control.Monad (unless)
  import Data.Aeson
  import Data.List.Extra (replace)
  import Data.List.NonEmpty (NonEmpty)
  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 =
    defaultOptions
      { fieldLabelModifier = replace "S" "$" . drop 1 -- drops leading underscore
      }
  
  -- | A single record that encompasses all possible objects
  -- in a JSON schema. All fields are optional.
  data SchemaRaw = SchemaRaw
    { _description :: Maybe Text
    , _default :: Maybe Value
    , _title :: Maybe Text
    , _type :: Maybe (SingleOrList Text)
    , _name :: Maybe Text
    , _properties :: Maybe (Map Text SwarmSchema)
    , _items :: Maybe (ItemDescription SwarmSchema)
    , _examples :: Maybe [Value]
    , _Sref :: Maybe Text
    , _oneOf :: Maybe [SchemaRaw]
    , _footers :: Maybe [FilePath]
    , _additionalProperties :: Maybe Bool
    , _enum :: Maybe (NonEmpty Text)
    }
    deriving (Eq, Ord, Show, Generic)
  
  instance FromJSON SchemaRaw where
    parseJSON = genericParseJSON schemaJsonOptions
  
  extractSchemaType :: SchemaRaw -> Maybe SchemaType
  extractSchemaType rawSchema =
    mkReference <$> _Sref rawSchema
      <|> getTypeFromItems
      <|> Simple <$> _type rawSchema
      <|> Alternatives . mapMaybe extractSchemaType <$> _oneOf rawSchema
      <|> EnumList <$> _enum rawSchema
   where
    mkReference = Reference . SchemaIdReference . T.pack . takeBaseName . T.unpack
  
    getTypeFromItems :: Maybe SchemaType
    getTypeFromItems = do
      itemsThing <- _items rawSchema
      case itemsThing of
        ItemList _ -> Nothing
        ItemType x -> Just $ ListOf $ schemaType x
  
  -- * Refined
  
  data ItemDescription a
    = ItemList [a]
    | ItemType a
    deriving (Eq, Ord, Show)
  
  instance (FromJSON a) => FromJSON (ItemDescription a) where
    parseJSON x =
      ItemList <$> parseJSON x
        <|> ItemType <$> parseJSON x
  
  getSchemaReferences :: SchemaType -> [SchemaIdReference]
  getSchemaReferences = \case
    Simple _ -> []
    Alternatives xs -> concatMap getSchemaReferences xs
    Reference x -> pure x
    ListOf x -> getSchemaReferences x
    EnumList _ -> []
  
  -- | 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
    { schemaType :: SchemaType
    , defaultValue :: Maybe Value
    , objectDescription :: Maybe Pandoc
    , properties :: Maybe (Map Text SwarmSchema)
    , itemsDescription :: Maybe (ItemDescription SwarmSchema)
    , examples :: [Value]
    }
    deriving (Eq, Ord, Show)
  
  instance FromJSON SwarmSchema where
    parseJSON x = do
      rawSchema :: rawSchema <- parseJSON x
      toSwarmSchema rawSchema
  
  getMarkdown :: MonadFail m => Text -> m Pandoc
  getMarkdown desc = case runPure (readMarkdown def desc) of
    Right d -> return d
    Left err -> fail $ T.unpack $ renderError err
  
  toSwarmSchema :: MonadFail m => SchemaRaw -> m SwarmSchema
  toSwarmSchema rawSchema = do
    theType <- maybe (fail "Unspecified sub-schema type") return maybeType
    markdownDescription <- mapM getMarkdown $ _description rawSchema
  
    unless (null (_properties rawSchema) || not (fromMaybe True (_additionalProperties rawSchema))) $
      fail "All objects must specify '\"additionalProperties\": true'"
  
    return
      SwarmSchema
        { schemaType = theType
        , defaultValue = _default rawSchema
        , objectDescription = markdownDescription <|> doc . plain . text <$> _name rawSchema
        , examples = fromMaybe [] $ _examples rawSchema
        , properties = _properties rawSchema
        , itemsDescription = _items rawSchema
        }
   where
    maybeType = extractSchemaType rawSchema
  
  -- * Utilities
  
  -- | Recursively extract references to other schemas
  extractReferences :: SwarmSchema -> Set SchemaIdReference
  extractReferences s = thisRefList <> otherRefLists
   where
    thisRefList = Set.fromList . getSchemaReferences $ schemaType s
  
    otherSchemas = maybe [] M.elems $ properties s
    otherRefLists = Set.unions $ map extractReferences otherSchemas
  