autodocodec-yaml 0.2.0.3 → 0.3.0.0
raw patch · 6 files changed
+111/−32 lines, 6 filesdep −unordered-containersdep ~autodocodecdep ~safe-coloured-textPVP ok
version bump matches the API change (PVP)
Dependencies removed: unordered-containers
Dependency ranges changed: autodocodec, safe-coloured-text
API changes (from Hackage documentation)
+ Autodocodec.Yaml: jsonSchemaChunkLines :: JSONSchema -> [[Chunk]]
+ Autodocodec.Yaml.Schema: jsonSchemaChunkLines :: JSONSchema -> [[Chunk]]
Files
- CHANGELOG.md +12/−2
- autodocodec-yaml.cabal +4/−5
- src/Autodocodec/Yaml.hs +3/−2
- src/Autodocodec/Yaml/Encode.hs +2/−2
- src/Autodocodec/Yaml/IO.hs +2/−2
- src/Autodocodec/Yaml/Schema.hs +88/−19
CHANGELOG.md view
@@ -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
autodocodec-yaml.cabal view
@@ -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
src/Autodocodec/Yaml.hs view
@@ -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'
src/Autodocodec/Yaml/Encode.hs view
@@ -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
src/Autodocodec/Yaml/IO.hs view
@@ -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)
src/Autodocodec/Yaml/Schema.hs view
@@ -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 "<string>"]] NumberSchema mBounds -> case mBounds of Nothing -> [[fore yellow "<number>"]]- 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 "<number>",- " # 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 "<number>", " # "] ++ 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