diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,11 +1,21 @@ # Changelog +## [0.3.0.0] - 2024-06-23 + +### Added + +* `jsonSchemaChunkLines` + +### Changed + +* Show number bounds in a nicer way. + ## [0.2.0.3] - 2023-01-01 ### Changed -Use the `ToYaml` instance instead of the `ToJSON` instance when encoding to Yaml. -This preserves the key order where `ToJSON` wouldn't. +* Use the `ToYaml` instance instead of the `ToJSON` instance when encoding to Yaml. + This preserves the key order where `ToJSON` wouldn't. ## [0.2.0.2] - 2022-07-21 diff --git a/autodocodec-yaml.cabal b/autodocodec-yaml.cabal --- a/autodocodec-yaml.cabal +++ b/autodocodec-yaml.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: autodocodec-yaml -version: 0.2.0.3 +version: 0.3.0.0 synopsis: Autodocodec interpreters for yaml homepage: https://github.com/NorfairKing/autodocodec#readme bug-reports: https://github.com/NorfairKing/autodocodec/issues @@ -34,17 +34,16 @@ hs-source-dirs: src build-depends: - autodocodec >=0.2.0.0 + autodocodec >=0.2.3.0 , autodocodec-schema >=0.1.0.0 , base >=4.7 && <5 , bytestring , containers , path , path-io - , safe-coloured-text >=0.2.0.0 + , safe-coloured-text >=0.3.0.1 , scientific , text - , unordered-containers , vector , yaml default-language: Haskell2010 diff --git a/src/Autodocodec/Yaml.hs b/src/Autodocodec/Yaml.hs --- a/src/Autodocodec/Yaml.hs +++ b/src/Autodocodec/Yaml.hs @@ -17,6 +17,7 @@ schemaChunksViaCodec, schemaChunksVia, jsonSchemaChunks, + jsonSchemaChunkLines, -- * Instantiating @ToYaml@ toYamlViaCodec, @@ -38,9 +39,9 @@ import qualified Data.Yaml.Builder as Yaml -- | Encode a value as a Yaml 'ByteString' via its type's 'codec'. -encodeYamlViaCodec :: HasCodec a => a -> ByteString +encodeYamlViaCodec :: (HasCodec a) => a -> ByteString encodeYamlViaCodec = Yaml.toByteString . Autodocodec -- | Parse a Yaml 'ByteString' using a type's 'codec'. -eitherDecodeYamlViaCodec :: HasCodec a => ByteString -> Either Yaml.ParseException a +eitherDecodeYamlViaCodec :: (HasCodec a) => ByteString -> Either Yaml.ParseException a eitherDecodeYamlViaCodec = fmap unAutodocodec . Yaml.decodeEither' diff --git a/src/Autodocodec/Yaml/Encode.hs b/src/Autodocodec/Yaml/Encode.hs --- a/src/Autodocodec/Yaml/Encode.hs +++ b/src/Autodocodec/Yaml/Encode.hs @@ -21,7 +21,7 @@ import Data.Yaml.Builder as Yaml -- | Implement 'Yaml.toYaml' using a type's codec -toYamlViaCodec :: HasCodec a => a -> YamlBuilder +toYamlViaCodec :: (HasCodec a) => a -> YamlBuilder toYamlViaCodec = toYamlVia codec -- | Implement 'Yaml.toYaml' using a given codec @@ -92,5 +92,5 @@ JSON.Object o -> yamlObject o JSON.Array v -> Yaml.array $ map yamlValue $ V.toList v -instance HasCodec a => ToYaml (Autodocodec a) where +instance (HasCodec a) => ToYaml (Autodocodec a) where toYaml = toYamlViaCodec . unAutodocodec diff --git a/src/Autodocodec/Yaml/IO.hs b/src/Autodocodec/Yaml/IO.hs --- a/src/Autodocodec/Yaml/IO.hs +++ b/src/Autodocodec/Yaml/IO.hs @@ -16,13 +16,13 @@ -- | Helper function to read a yaml file for a type in 'HasCodec' -- -- This will output a colourful yaml schema if parsing fails. -readYamlConfigFile :: HasCodec a => Path r File -> IO (Maybe a) +readYamlConfigFile :: (HasCodec a) => Path r File -> IO (Maybe a) readYamlConfigFile p = readFirstYamlConfigFile [p] -- | Helper function to read the first in a list of yaml files for a type is 'HasCodec' -- -- This will output a colourful yaml schema if parsing fails. -readFirstYamlConfigFile :: forall a r. HasCodec a => [Path r File] -> IO (Maybe a) +readFirstYamlConfigFile :: forall a r. (HasCodec a) => [Path r File] -> IO (Maybe a) readFirstYamlConfigFile files = go files where go :: [Path r File] -> IO (Maybe a) diff --git a/src/Autodocodec/Yaml/Schema.hs b/src/Autodocodec/Yaml/Schema.hs --- a/src/Autodocodec/Yaml/Schema.hs +++ b/src/Autodocodec/Yaml/Schema.hs @@ -1,11 +1,22 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Autodocodec.Yaml.Schema where +module Autodocodec.Yaml.Schema + ( renderColouredSchemaViaCodec, + renderColouredSchemaVia, + renderPlainSchemaViaCodec, + renderPlainSchemaVia, + schemaChunksViaCodec, + schemaChunksVia, + jsonSchemaChunks, + jsonSchemaChunkLines, + ) +where import Autodocodec import Autodocodec.Schema @@ -17,11 +28,12 @@ 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 = renderColouredSchemaVia (codec @a) -- | Render a human-readable schema for a given codec, in colour. @@ -29,7 +41,7 @@ renderColouredSchemaVia = renderChunksText With24BitColours . 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 = renderPlainSchemaVia (codec @a) -- | Render a human-readable schema for a given codec, without colour. @@ -37,7 +49,7 @@ renderPlainSchemaVia = renderChunksText WithoutColours . 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 = schemaChunksVia (codec @a) -- | Produce potentially-coloured 'Chunk's for a human-readable schema for a given codec. @@ -46,7 +58,11 @@ -- | Render a 'JSONSchema' as 'Chunk's jsonSchemaChunks :: JSONSchema -> [Chunk] -jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . go +jsonSchemaChunks = unlinesChunks . jsonSchemaChunkLines + +-- | Render a 'JSONSchema' as lines of 'Chunk's +jsonSchemaChunkLines :: JSONSchema -> [[Chunk]] +jsonSchemaChunkLines = go where indent :: [[Chunk]] -> [[Chunk]] indent = map (" " :) @@ -67,8 +83,9 @@ chunks :| [] -> addInFrontOfFirstInList ["[ "] chunks ++ [["]"]] (chunks :| restChunks) -> concat $ - addInFrontOfFirstInList ["[ "] chunks : - map (addInFrontOfFirstInList [", "]) restChunks ++ [[["]"]]] + addInFrontOfFirstInList ["[ "] chunks + : map (addInFrontOfFirstInList [", "]) restChunks + ++ [[["]"]]] anyOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]] anyOfChunks = (["# ", fore green "any of"] :) . choiceChunks @@ -87,18 +104,7 @@ StringSchema -> [[fore yellow ""]] NumberSchema mBounds -> case mBounds of Nothing -> [[fore yellow ""]] - Just NumberBounds {..} -> - let scientificChunk s = chunk $ - T.pack $ case floatingOrInteger s of - Left (_ :: Double) -> show (s :: Scientific) - Right i -> show (i :: Integer) - in [ [ fore yellow "", - " # between ", - fore green $ scientificChunk numberBoundsLower, - " and ", - fore green $ scientificChunk numberBoundsUpper - ] - ] + Just nb -> numberBoundsChunks nb ArraySchema s -> let addListMarker = addInFrontOfFirstInList ["- "] in addListMarker $ go s @@ -141,3 +147,66 @@ ObjectAllOfSchema ne -> concatMap goObject $ NE.toList ne ObjectAnyOfSchema ne -> anyOfChunks $ NE.map goObject ne ObjectOneOfSchema ne -> oneOfChunks $ NE.map goObject ne + + numberBoundsChunks :: NumberBounds -> [[Chunk]] + numberBoundsChunks nb = + [ [fore yellow "", " # "] ++ case guessNumberBoundsSymbolic nb of + BitUInt w -> + [ fore green $ chunk $ T.pack $ show w <> " bit unsigned integer" + ] + BitSInt w -> + [ fore green $ chunk $ T.pack $ show w <> " bit signed integer" + ] + OtherNumberBounds l u -> + [ "between ", + fore green $ scientificChunk l, + " and ", + fore green $ scientificChunk u + ] + ] + where + scientificChunk = \case + Zero -> "0" + PowerOf2 w -> chunk $ T.pack $ "2^" <> show w + PowerOf2MinusOne w -> chunk $ T.pack $ "2^" <> show w <> "-1" + MinusPowerOf2 w -> chunk $ T.pack $ "-2^" <> show w + MinusPowerOf2MinusOne w -> chunk $ T.pack $ "- (2^" <> show w <> "-1)" + OtherInteger i -> chunk $ T.pack $ show i + OtherDouble d -> chunk $ T.pack $ show d + +data NumberBoundsSymbolic + = BitUInt !Word8 -- w bit unsigned int + | BitSInt !Word8 -- w bit signed int + | OtherNumberBounds !ScientificSymbolic !ScientificSymbolic + +guessNumberBoundsSymbolic :: NumberBounds -> NumberBoundsSymbolic +guessNumberBoundsSymbolic NumberBounds {..} = + case (guessScientificSymbolic numberBoundsLower, guessScientificSymbolic numberBoundsUpper) of + (Zero, PowerOf2MinusOne w) -> BitUInt w + (MinusPowerOf2 w1, PowerOf2MinusOne w2) | w1 == w2 -> BitSInt (succ w1) + (l, u) -> OtherNumberBounds l 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 s = case floatingOrInteger s of + Left d -> OtherDouble d + Right i -> + let log2Rounded :: Word8 + log2Rounded = round (logBase 2 (fromInteger (abs i)) :: Double) + guess :: Integer + guess = 2 ^ log2Rounded + in if + | i == 0 -> Zero + | guess == i -> PowerOf2 log2Rounded + | (guess - 1) == i -> PowerOf2MinusOne log2Rounded + | -guess == i -> MinusPowerOf2 log2Rounded + | -(guess - 1) == i -> MinusPowerOf2MinusOne log2Rounded + | otherwise -> OtherInteger i