{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Autodocodec.Yaml.Schema
  ( renderColouredSchemaViaCodec,
    renderColouredSchemaVia,
    renderPlainSchemaViaCodec,
    renderPlainSchemaVia,
    schemaChunksViaCodec,
    schemaChunksVia,
    jsonSchemaChunks,
    jsonSchemaChunkLines,
  )
where

import Autodocodec
import Autodocodec.Schema
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Scientific (Scientific, floatingOrInteger)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TE
import Data.Word
import Data.Yaml as Yaml
import Text.Colour

-- | Render a human-readable schema for a type's 'codec', in colour.
renderColouredSchemaViaCodec :: forall a. (HasCodec a) => Text
renderColouredSchemaViaCodec :: forall a. HasCodec a => Text
renderColouredSchemaViaCodec = ValueCodec a a -> Text
forall input output. ValueCodec input output -> Text
renderColouredSchemaVia (forall value. HasCodec value => JSONCodec value
codec @a)

-- | Render a human-readable schema for a given codec, in colour.
renderColouredSchemaVia :: ValueCodec input output -> Text
renderColouredSchemaVia :: forall input output. ValueCodec input output -> Text
renderColouredSchemaVia = TerminalCapabilities -> [Chunk] -> Text
forall (f :: * -> *).
Foldable f =>
TerminalCapabilities -> f Chunk -> Text
renderChunksText TerminalCapabilities
With24BitColours ([Chunk] -> Text)
-> (ValueCodec input output -> [Chunk])
-> ValueCodec input output
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueCodec input output -> [Chunk]
forall input output. ValueCodec input output -> [Chunk]
schemaChunksVia

-- | Render a human-readable schema for a type's 'codec', without colour.
renderPlainSchemaViaCodec :: forall a. (HasCodec a) => Text
renderPlainSchemaViaCodec :: forall a. HasCodec a => Text
renderPlainSchemaViaCodec = ValueCodec a a -> Text
forall input output. ValueCodec input output -> Text
renderPlainSchemaVia (forall value. HasCodec value => JSONCodec value
codec @a)

-- | Render a human-readable schema for a given codec, without colour.
renderPlainSchemaVia :: ValueCodec input output -> Text
renderPlainSchemaVia :: forall input output. ValueCodec input output -> Text
renderPlainSchemaVia = TerminalCapabilities -> [Chunk] -> Text
forall (f :: * -> *).
Foldable f =>
TerminalCapabilities -> f Chunk -> Text
renderChunksText TerminalCapabilities
WithoutColours ([Chunk] -> Text)
-> (ValueCodec input output -> [Chunk])
-> ValueCodec input output
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueCodec input output -> [Chunk]
forall input output. ValueCodec input output -> [Chunk]
schemaChunksVia

-- | Produce potentially-coloured 'Chunk's for a human-readable schema for a type's 'codec'.
schemaChunksViaCodec :: forall a. (HasCodec a) => [Chunk]
schemaChunksViaCodec :: forall a. HasCodec a => [Chunk]
schemaChunksViaCodec = ValueCodec a a -> [Chunk]
forall input output. ValueCodec input output -> [Chunk]
schemaChunksVia (forall value. HasCodec value => JSONCodec value
codec @a)

-- | Produce potentially-coloured 'Chunk's for a human-readable schema for a given codec.
schemaChunksVia :: ValueCodec input output -> [Chunk]
schemaChunksVia :: forall input output. ValueCodec input output -> [Chunk]
schemaChunksVia = JSONSchema -> [Chunk]
jsonSchemaChunks (JSONSchema -> [Chunk])
-> (ValueCodec input output -> JSONSchema)
-> ValueCodec input output
-> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueCodec input output -> JSONSchema
forall input output. ValueCodec input output -> JSONSchema
jsonSchemaVia

-- | Render a 'JSONSchema' as 'Chunk's
jsonSchemaChunks :: JSONSchema -> [Chunk]
jsonSchemaChunks :: JSONSchema -> [Chunk]
jsonSchemaChunks = [[Chunk]] -> [Chunk]
unlinesChunks ([[Chunk]] -> [Chunk])
-> (JSONSchema -> [[Chunk]]) -> JSONSchema -> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> [[Chunk]]
jsonSchemaChunkLines

-- | Render a 'JSONSchema' as lines of 'Chunk's
jsonSchemaChunkLines :: JSONSchema -> [[Chunk]]
jsonSchemaChunkLines :: JSONSchema -> [[Chunk]]
jsonSchemaChunkLines = JSONSchema -> [[Chunk]]
go
  where
    indent :: [[Chunk]] -> [[Chunk]]
    indent :: [[Chunk]] -> [[Chunk]]
indent = ([Chunk] -> [Chunk]) -> [[Chunk]] -> [[Chunk]]
forall a b. (a -> b) -> [a] -> [b]
map (Chunk
"  " Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
:)

    addInFrontOfFirstInList :: [Chunk] -> [[Chunk]] -> [[Chunk]]
    addInFrontOfFirstInList :: [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk]
cs = \case
      [] -> [[Chunk]
cs] -- Shouldn't happen, but fine if it doesn't
      ([Chunk]
l : [[Chunk]]
ls) -> ([Chunk]
cs [Chunk] -> [Chunk] -> [Chunk]
forall a. [a] -> [a] -> [a]
++ [Chunk]
l) [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: [[Chunk]] -> [[Chunk]]
indent [[Chunk]]
ls

    jsonValueChunks :: Yaml.Value -> [[Chunk]]
    jsonValueChunks :: Value -> [[Chunk]]
jsonValueChunks Value
v = (Text -> [Chunk]) -> [Text] -> [[Chunk]]
forall a b. (a -> b) -> [a] -> [b]
map ((Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
: []) (Chunk -> [Chunk]) -> (Text -> Chunk) -> Text -> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Chunk
chunk) ([Text] -> [[Chunk]]) -> [Text] -> [[Chunk]]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Value
v)

    docToLines :: Text -> [[Chunk]]
    docToLines :: Text -> [[Chunk]]
docToLines Text
doc = (Text -> [Chunk]) -> [Text] -> [[Chunk]]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
line -> [Text -> Chunk
chunk Text
"# ", Text -> Chunk
chunk Text
line]) (Text -> [Text]
T.lines Text
doc)

    choiceChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
    choiceChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
choiceChunks = \case
      [[Chunk]]
chunks :| [] -> [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk
"[ "] [[Chunk]]
chunks [[Chunk]] -> [[Chunk]] -> [[Chunk]]
forall a. [a] -> [a] -> [a]
++ [[Chunk
"]"]]
      ([[Chunk]]
chunks :| [[[Chunk]]]
restChunks) ->
        [[[Chunk]]] -> [[Chunk]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Chunk]]] -> [[Chunk]]) -> [[[Chunk]]] -> [[Chunk]]
forall a b. (a -> b) -> a -> b
$
          [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk
"[ "] [[Chunk]]
chunks
            [[Chunk]] -> [[[Chunk]]] -> [[[Chunk]]]
forall a. a -> [a] -> [a]
: ([[Chunk]] -> [[Chunk]]) -> [[[Chunk]]] -> [[[Chunk]]]
forall a b. (a -> b) -> [a] -> [b]
map ([Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk
", "]) [[[Chunk]]]
restChunks
            [[[Chunk]]] -> [[[Chunk]]] -> [[[Chunk]]]
forall a. [a] -> [a] -> [a]
++ [[[Chunk
"]"]]]

    anyOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
    anyOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
anyOfChunks = ([Chunk
"# ", Colour -> Chunk -> Chunk
fore Colour
green Chunk
"any of"] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
:) ([[Chunk]] -> [[Chunk]])
-> (NonEmpty [[Chunk]] -> [[Chunk]])
-> NonEmpty [[Chunk]]
-> [[Chunk]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [[Chunk]] -> [[Chunk]]
choiceChunks

    oneOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
    oneOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
oneOfChunks = ([Chunk
"# ", Colour -> Chunk -> Chunk
fore Colour
green Chunk
"one of"] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
:) ([[Chunk]] -> [[Chunk]])
-> (NonEmpty [[Chunk]] -> [[Chunk]])
-> NonEmpty [[Chunk]]
-> [[Chunk]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [[Chunk]] -> [[Chunk]]
choiceChunks

    orNullChunks :: JSONSchema -> [[Chunk]]
    orNullChunks :: JSONSchema -> [[Chunk]]
orNullChunks = ([Chunk
"# ", Colour -> Chunk -> Chunk
fore Colour
green Chunk
"or null"] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
:) ([[Chunk]] -> [[Chunk]])
-> (JSONSchema -> [[Chunk]]) -> JSONSchema -> [[Chunk]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> [[Chunk]]
go

    go :: JSONSchema -> [[Chunk]]
    go :: JSONSchema -> [[Chunk]]
go = \case
      JSONSchema
AnySchema -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<any>"]]
      JSONSchema
NullSchema -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"null"]]
      JSONSchema
BoolSchema -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<boolean>"]]
      JSONSchema
StringSchema -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<string>"]]
      NumberSchema Maybe NumberBounds
mBounds -> case Maybe NumberBounds
mBounds of
        Maybe NumberBounds
Nothing -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<number>"]]
        Just NumberBounds
nb -> NumberBounds -> [[Chunk]]
numberBoundsChunks NumberBounds
nb
      ArraySchema JSONSchema
s ->
        let addListMarker :: [[Chunk]] -> [[Chunk]]
addListMarker = [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk
"- "]
         in [[Chunk]] -> [[Chunk]]
addListMarker ([[Chunk]] -> [[Chunk]]) -> [[Chunk]] -> [[Chunk]]
forall a b. (a -> b) -> a -> b
$ JSONSchema -> [[Chunk]]
go JSONSchema
s
      MapSchema JSONSchema
s ->
        [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Colour -> Chunk -> Chunk
fore Colour
white Chunk
"<key>", Chunk
": "] ([[Chunk]] -> [[Chunk]]) -> [[Chunk]] -> [[Chunk]]
forall a b. (a -> b) -> a -> b
$ [] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: JSONSchema -> [[Chunk]]
go JSONSchema
s
      ObjectSchema ObjectSchema
os -> ObjectSchema -> [[Chunk]]
goObject ObjectSchema
os
      ValueSchema Value
v -> Value -> [[Chunk]]
jsonValueChunks Value
v
      AnyOfSchema NonEmpty JSONSchema
ne -> case NonEmpty JSONSchema
ne of
        (JSONSchema
NullSchema :| [JSONSchema
s]) -> JSONSchema -> [[Chunk]]
orNullChunks JSONSchema
s
        (JSONSchema
s :| [JSONSchema
NullSchema]) -> JSONSchema -> [[Chunk]]
orNullChunks JSONSchema
s
        NonEmpty JSONSchema
_ -> NonEmpty [[Chunk]] -> [[Chunk]]
anyOfChunks (NonEmpty [[Chunk]] -> [[Chunk]])
-> NonEmpty [[Chunk]] -> [[Chunk]]
forall a b. (a -> b) -> a -> b
$ (JSONSchema -> [[Chunk]])
-> NonEmpty JSONSchema -> NonEmpty [[Chunk]]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map JSONSchema -> [[Chunk]]
go NonEmpty JSONSchema
ne
      OneOfSchema NonEmpty JSONSchema
ne -> case NonEmpty JSONSchema
ne of
        (JSONSchema
NullSchema :| [JSONSchema
s]) -> JSONSchema -> [[Chunk]]
orNullChunks JSONSchema
s
        (JSONSchema
s :| [JSONSchema
NullSchema]) -> JSONSchema -> [[Chunk]]
orNullChunks JSONSchema
s
        NonEmpty JSONSchema
_ -> NonEmpty [[Chunk]] -> [[Chunk]]
oneOfChunks (NonEmpty [[Chunk]] -> [[Chunk]])
-> NonEmpty [[Chunk]] -> [[Chunk]]
forall a b. (a -> b) -> a -> b
$ (JSONSchema -> [[Chunk]])
-> NonEmpty JSONSchema -> NonEmpty [[Chunk]]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map JSONSchema -> [[Chunk]]
go NonEmpty JSONSchema
ne
      CommentSchema Text
comment JSONSchema
s -> Text -> [[Chunk]]
docToLines Text
comment [[Chunk]] -> [[Chunk]] -> [[Chunk]]
forall a. [a] -> [a] -> [a]
++ JSONSchema -> [[Chunk]]
go JSONSchema
s
      RefSchema Text
name -> [[Colour -> Chunk -> Chunk
fore Colour
cyan (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ Text
"ref: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name]]
      WithDefSchema Map Text JSONSchema
defs (RefSchema Text
_) -> ((Text, JSONSchema) -> [[Chunk]])
-> [(Text, JSONSchema)] -> [[Chunk]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Text
name, JSONSchema
s') -> [Colour -> Chunk -> Chunk
fore Colour
cyan (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ Text
"def: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: JSONSchema -> [[Chunk]]
go JSONSchema
s') (Map Text JSONSchema -> [(Text, JSONSchema)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text JSONSchema
defs)
      WithDefSchema Map Text JSONSchema
defs JSONSchema
s -> ((Text, JSONSchema) -> [[Chunk]])
-> [(Text, JSONSchema)] -> [[Chunk]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Text
name, JSONSchema
s') -> [Colour -> Chunk -> Chunk
fore Colour
cyan (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ Text
"def: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: JSONSchema -> [[Chunk]]
go JSONSchema
s') (Map Text JSONSchema -> [(Text, JSONSchema)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text JSONSchema
defs) [[Chunk]] -> [[Chunk]] -> [[Chunk]]
forall a. [a] -> [a] -> [a]
++ JSONSchema -> [[Chunk]]
go JSONSchema
s

    goObject :: ObjectSchema -> [[Chunk]]
    goObject :: ObjectSchema -> [[Chunk]]
goObject = \case
      ObjectSchema
ObjectAnySchema -> [[Chunk
"<object>"]]
      ObjectKeySchema Text
k KeyRequirement
kr JSONSchema
ks Maybe Text
mdoc ->
        let requirementComment :: KeyRequirement -> Chunk
requirementComment = \case
              KeyRequirement
Required -> Colour -> Chunk -> Chunk
fore Colour
red Chunk
"required"
              Optional Maybe Value
_ -> Colour -> Chunk -> Chunk
fore Colour
blue Chunk
"optional"
            mDefaultValue :: KeyRequirement -> Maybe Value
mDefaultValue = \case
              KeyRequirement
Required -> Maybe Value
forall a. Maybe a
Nothing
              Optional Maybe Value
mdv -> Maybe Value
mdv
         in let keySchemaChunks :: [[Chunk]]
keySchemaChunks = JSONSchema -> [[Chunk]]
go JSONSchema
ks
                defaultValueLine :: [[Chunk]]
defaultValueLine = case KeyRequirement -> Maybe Value
mDefaultValue KeyRequirement
kr of
                  Maybe Value
Nothing -> []
                  Just Value
defaultValue ->
                    case Value -> [[Chunk]]
jsonValueChunks Value
defaultValue of
                      [[Chunk]
c] -> [Text -> Chunk
chunk Text
"# default: " Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
: (Chunk -> Chunk) -> [Chunk] -> [Chunk]
forall a b. (a -> b) -> [a] -> [b]
map (Colour -> Chunk -> Chunk
fore Colour
magenta) [Chunk]
c]
                      [[Chunk]]
cs -> [Text -> Chunk
chunk Text
"# default: "] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: ([Chunk] -> [Chunk]) -> [[Chunk]] -> [[Chunk]]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Chunk
chunk Text
"#   " Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
:) ([Chunk] -> [Chunk]) -> ([Chunk] -> [Chunk]) -> [Chunk] -> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk -> Chunk) -> [Chunk] -> [Chunk]
forall a b. (a -> b) -> [a] -> [b]
map (Colour -> Chunk -> Chunk
fore Colour
magenta)) [[Chunk]]
cs
                prefixLines :: [[Chunk]]
prefixLines = [Chunk
"# ", KeyRequirement -> Chunk
requirementComment KeyRequirement
kr] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: [[Chunk]]
defaultValueLine [[Chunk]] -> [[Chunk]] -> [[Chunk]]
forall a. [a] -> [a] -> [a]
++ [[Chunk]] -> (Text -> [[Chunk]]) -> Maybe Text -> [[Chunk]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> [[Chunk]]
docToLines Maybe Text
mdoc
             in [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Colour -> Chunk -> Chunk
fore Colour
white (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk Text
k, Chunk
": "] ([[Chunk]]
prefixLines [[Chunk]] -> [[Chunk]] -> [[Chunk]]
forall a. [a] -> [a] -> [a]
++ [[Chunk]]
keySchemaChunks)
      ObjectAllOfSchema NonEmpty ObjectSchema
ne -> (ObjectSchema -> [[Chunk]]) -> [ObjectSchema] -> [[Chunk]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjectSchema -> [[Chunk]]
goObject ([ObjectSchema] -> [[Chunk]]) -> [ObjectSchema] -> [[Chunk]]
forall a b. (a -> b) -> a -> b
$ NonEmpty ObjectSchema -> [ObjectSchema]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ObjectSchema
ne
      ObjectAnyOfSchema NonEmpty ObjectSchema
ne -> NonEmpty [[Chunk]] -> [[Chunk]]
anyOfChunks (NonEmpty [[Chunk]] -> [[Chunk]])
-> NonEmpty [[Chunk]] -> [[Chunk]]
forall a b. (a -> b) -> a -> b
$ (ObjectSchema -> [[Chunk]])
-> NonEmpty ObjectSchema -> NonEmpty [[Chunk]]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ObjectSchema -> [[Chunk]]
goObject NonEmpty ObjectSchema
ne
      ObjectOneOfSchema NonEmpty ObjectSchema
ne -> NonEmpty [[Chunk]] -> [[Chunk]]
oneOfChunks (NonEmpty [[Chunk]] -> [[Chunk]])
-> NonEmpty [[Chunk]] -> [[Chunk]]
forall a b. (a -> b) -> a -> b
$ (ObjectSchema -> [[Chunk]])
-> NonEmpty ObjectSchema -> NonEmpty [[Chunk]]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ObjectSchema -> [[Chunk]]
goObject NonEmpty ObjectSchema
ne

    numberBoundsChunks :: NumberBounds -> [[Chunk]]
    numberBoundsChunks :: NumberBounds -> [[Chunk]]
numberBoundsChunks NumberBounds
nb =
      [ [Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<number>", Chunk
" # "] [Chunk] -> [Chunk] -> [Chunk]
forall a. [a] -> [a] -> [a]
++ case NumberBounds -> NumberBoundsSymbolic
guessNumberBoundsSymbolic NumberBounds
nb of
          BitUInt Word8
w ->
            [ Colour -> Chunk -> Chunk
fore Colour
green (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word8 -> String
forall a. Show a => a -> String
show Word8
w String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" bit unsigned integer"
            ]
          BitSInt Word8
w ->
            [ Colour -> Chunk -> Chunk
fore Colour
green (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word8 -> String
forall a. Show a => a -> String
show Word8
w String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" bit signed integer"
            ]
          OtherNumberBounds ScientificSymbolic
l ScientificSymbolic
u ->
            [ Chunk
"between ",
              Colour -> Chunk -> Chunk
fore Colour
green (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ ScientificSymbolic -> Chunk
scientificChunk ScientificSymbolic
l,
              Chunk
" and ",
              Colour -> Chunk -> Chunk
fore Colour
green (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ ScientificSymbolic -> Chunk
scientificChunk ScientificSymbolic
u
            ]
      ]
      where
        scientificChunk :: ScientificSymbolic -> Chunk
scientificChunk = \case
          ScientificSymbolic
Zero -> Chunk
"0"
          PowerOf2 Word8
w -> Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"2^" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
w
          PowerOf2MinusOne Word8
w -> Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"2^" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
w String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-1"
          MinusPowerOf2 Word8
w -> Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"-2^" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
w
          MinusPowerOf2MinusOne Word8
w -> Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"- (2^" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
w String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-1)"
          OtherInteger Integer
i -> Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i
          OtherDouble Double
d -> Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show Double
d

data NumberBoundsSymbolic
  = BitUInt !Word8 -- w bit unsigned int
  | BitSInt !Word8 -- w bit signed int
  | OtherNumberBounds !ScientificSymbolic !ScientificSymbolic

guessNumberBoundsSymbolic :: NumberBounds -> NumberBoundsSymbolic
guessNumberBoundsSymbolic :: NumberBounds -> NumberBoundsSymbolic
guessNumberBoundsSymbolic NumberBounds {Scientific
numberBoundsLower :: Scientific
numberBoundsUpper :: Scientific
numberBoundsLower :: NumberBounds -> Scientific
numberBoundsUpper :: NumberBounds -> Scientific
..} =
  case (Scientific -> ScientificSymbolic
guessScientificSymbolic Scientific
numberBoundsLower, Scientific -> ScientificSymbolic
guessScientificSymbolic Scientific
numberBoundsUpper) of
    (ScientificSymbolic
Zero, PowerOf2MinusOne Word8
w) -> Word8 -> NumberBoundsSymbolic
BitUInt Word8
w
    (MinusPowerOf2 Word8
w1, PowerOf2MinusOne Word8
w2) | Word8
w1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w2 -> Word8 -> NumberBoundsSymbolic
BitSInt (Word8 -> Word8
forall a. Enum a => a -> a
succ Word8
w1)
    (ScientificSymbolic
l, ScientificSymbolic
u) -> ScientificSymbolic -> ScientificSymbolic -> NumberBoundsSymbolic
OtherNumberBounds ScientificSymbolic
l ScientificSymbolic
u

data ScientificSymbolic
  = Zero
  | PowerOf2 !Word8 -- 2^w
  | PowerOf2MinusOne !Word8 -- 2^w -1
  | MinusPowerOf2 !Word8 -- - 2^w
  | MinusPowerOf2MinusOne !Word8 -- - (2^w -1)
  | OtherInteger !Integer
  | OtherDouble !Double

guessScientificSymbolic :: Scientific -> ScientificSymbolic
guessScientificSymbolic :: Scientific -> ScientificSymbolic
guessScientificSymbolic Scientific
s = case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
s of
  Left Double
d -> Double -> ScientificSymbolic
OtherDouble Double
d
  Right Integer
i ->
    let log2Rounded :: Word8
        log2Rounded :: Word8
log2Rounded = Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer
forall a. Num a => a -> a
abs Integer
i)) :: Double)
        guess :: Integer
        guess :: Integer
guess = Integer
2 Integer -> Word8 -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Word8
log2Rounded
     in if
          | Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> ScientificSymbolic
Zero
          | Integer
guess Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i -> Word8 -> ScientificSymbolic
PowerOf2 Word8
log2Rounded
          | (Integer
guess Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i -> Word8 -> ScientificSymbolic
PowerOf2MinusOne Word8
log2Rounded
          | -Integer
guess Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i -> Word8 -> ScientificSymbolic
MinusPowerOf2 Word8
log2Rounded
          | -(Integer
guess Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i -> Word8 -> ScientificSymbolic
MinusPowerOf2MinusOne Word8
log2Rounded
          | Bool
otherwise -> Integer -> ScientificSymbolic
OtherInteger Integer
i