autodocodec-yaml (empty) → 0.0.0.0
raw patch · 7 files changed
+398/−0 lines, 7 filesdep +autodocodecdep +autodocodec-schemadep +base
Dependencies added: autodocodec, autodocodec-schema, base, bytestring, containers, path, path-io, safe-coloured-text, scientific, text, unordered-containers, vector, yaml
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- autodocodec-yaml.cabal +50/−0
- src/Autodocodec/Yaml.hs +45/−0
- src/Autodocodec/Yaml/Encode.hs +91/−0
- src/Autodocodec/Yaml/IO.hs +62/−0
- src/Autodocodec/Yaml/Schema.hs +124/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## [0.0.0.0] - 2021-11-19++First release.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2021 Tom Sydney Kerckhove++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ autodocodec-yaml.cabal view
@@ -0,0 +1,50 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: autodocodec-yaml+version: 0.0.0.0+synopsis: Autodocodec interpreters for yaml+homepage: https://github.com/NorfairKing/autodocodec#readme+bug-reports: https://github.com/NorfairKing/autodocodec/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: 2021 Tom Sydney Kerckhove+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ LICENSE+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/NorfairKing/autodocodec++library+ exposed-modules:+ Autodocodec.Yaml+ Autodocodec.Yaml.Encode+ Autodocodec.Yaml.IO+ Autodocodec.Yaml.Schema+ other-modules:+ Paths_autodocodec_yaml+ hs-source-dirs:+ src+ build-depends:+ autodocodec+ , autodocodec-schema+ , base >=4.7 && <5+ , bytestring+ , containers+ , path+ , path-io+ , safe-coloured-text+ , scientific+ , text+ , unordered-containers+ , vector+ , yaml+ default-language: Haskell2010
+ src/Autodocodec/Yaml.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-dodgy-exports -fno-warn-duplicate-exports #-}++module Autodocodec.Yaml+ ( -- * Encoding and decoding Yaml+ encodeYamlViaCodec,+ eitherDecodeYamlViaCodec,++ -- * Reading Yaml Files+ readYamlConfigFile,+ readFirstYamlConfigFile,++ -- * Producing a Yaml schema+ renderColouredSchemaViaCodec,+ renderColouredSchemaVia,+ renderPlainSchemaViaCodec,+ renderPlainSchemaVia,+ schemaChunksViaCodec,+ schemaChunksVia,+ jsonSchemaChunks,++ -- * Instantiating @ToYaml@+ toYamlViaCodec,+ toYamlVia,++ -- * To makes sure we definitely export everything.+ module Autodocodec.Yaml.Schema,+ module Autodocodec.Yaml.IO,+ module Autodocodec.Yaml.Encode,+ )+where++import Autodocodec+import Autodocodec.Yaml.Encode+import Autodocodec.Yaml.IO+import Autodocodec.Yaml.Schema+import Data.ByteString+import qualified Data.Yaml as Yaml++-- | Encode a value as a Yaml 'ByteString' via its type's 'codec'.+encodeYamlViaCodec :: HasCodec a => a -> ByteString+encodeYamlViaCodec = Yaml.encode . Autodocodec++-- | Parse a Yaml 'ByteString' using a type's 'codec'.+eitherDecodeYamlViaCodec :: HasCodec a => ByteString -> Either Yaml.ParseException a+eitherDecodeYamlViaCodec = fmap unAutodocodec . Yaml.decodeEither'
+ src/Autodocodec/Yaml/Encode.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures -fno-warn-orphans #-}++module Autodocodec.Yaml.Encode where++import Autodocodec.Aeson.Encode+import Autodocodec.Class+import Autodocodec.Codec+import Autodocodec.DerivingVia+import qualified Data.HashMap.Strict as HM+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector (Vector)+import qualified Data.Vector as V+import qualified Data.Yaml as JSON+import Data.Yaml.Builder as Yaml++-- | Implement 'Yaml.toYaml' using a type's codec+toYamlViaCodec :: HasCodec a => a -> YamlBuilder+toYamlViaCodec = toYamlVia codec++-- | Implement 'Yaml.toYaml' using a given codec+toYamlVia :: ValueCodec a void -> a -> YamlBuilder+toYamlVia = flip go+ where+ -- We use type-annotations here for readability of type information that is+ -- gathered to case-matching on GADTs, they aren't strictly necessary.+ go :: a -> ValueCodec a void -> YamlBuilder+ go a = \case+ NullCodec -> Yaml.null+ BoolCodec _ -> Yaml.bool (a :: Bool)+ StringCodec _ -> Yaml.string (a :: Text)+ NumberCodec _ _ -> yamlNumber (a :: Scientific)+ ArrayOfCodec _ c -> Yaml.array (map (`go` c) (V.toList (a :: Vector _)))+ ObjectOfCodec _ oc -> Yaml.mapping (goObject a oc)+ HashMapCodec c -> go (toJSONVia (HashMapCodec c) a) ValueCodec -- This may be optimisable?+ MapCodec c -> go (toJSONVia (MapCodec c) a) ValueCodec -- This may be optimisable?+ ValueCodec -> yamlValue (a :: JSON.Value)+ EqCodec value c -> go value c+ BimapCodec _ g c -> go (g a) c+ EitherCodec c1 c2 -> case (a :: Either _ _) of+ Left a1 -> go a1 c1+ Right a2 -> go a2 c2+ CommentCodec _ c -> go a c+ ReferenceCodec _ c -> go a c++ goObject :: a -> ObjectCodec a void -> [(Text, YamlBuilder)]+ goObject a = \case+ RequiredKeyCodec k c _ -> [(k, go a c)]+ OptionalKeyCodec k c _ -> case (a :: Maybe _) of+ Nothing -> []+ Just b -> [k Yaml..= go b c]+ OptionalKeyWithDefaultCodec k c _ mDoc -> goObject (Just a) (OptionalKeyCodec k c mDoc)+ OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc ->+ if a == defaultValue+ then []+ else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mDoc)+ BimapCodec _ g c -> goObject (g a) c+ EitherCodec c1 c2 -> case (a :: Either _ _) of+ Left a1 -> goObject a1 c1+ Right a2 -> goObject a2 c2+ PureCodec _ -> []+ ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2++ -- Encode a 'Scientific' value 'safely' by refusing to encode values that would be enormous.+ yamlNumber :: Scientific -> YamlBuilder+ yamlNumber s =+ if s > 1E1024 || s < -1E1024+ then Yaml.string $ "Cannot encode super duper large numbers with toYaml: " <> T.pack (show s)+ else Yaml.scientific s++ -- Encode a 'JSON.Object'+ yamlObject :: JSON.Object -> YamlBuilder+ yamlObject a = Yaml.mapping $ HM.toList (HM.map yamlValue (a :: JSON.Object))++ -- Encode a 'JSON.Value'+ yamlValue :: JSON.Value -> YamlBuilder+ yamlValue = \case+ JSON.Null -> Yaml.null+ JSON.Bool b -> Yaml.bool b+ JSON.String s -> Yaml.string s+ JSON.Number s -> yamlNumber s+ JSON.Object o -> yamlObject o+ JSON.Array v -> Yaml.array $ map yamlValue $ V.toList v++instance HasCodec a => ToYaml (Autodocodec a) where+ toYaml = toYamlViaCodec . unAutodocodec
+ src/Autodocodec/Yaml/IO.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Autodocodec.Yaml.IO where++import Autodocodec+import Autodocodec.Yaml.Schema+import qualified Data.ByteString as SB+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TE+import qualified Data.Yaml as Yaml+import Path+import Path.IO+import System.Exit++-- | 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 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 files = go files+ where+ go :: [Path r File] -> IO (Maybe a)+ go =+ \case+ [] -> pure Nothing+ (p : ps) -> do+ mc <- forgivingAbsence $ SB.readFile $ toFilePath p+ case mc of+ Nothing -> go ps+ Just contents ->+ case Yaml.decodeEither' contents of+ Left err -> do+ let failedMsgs =+ [ "Failed to parse yaml file",+ toFilePath p,+ "with error:",+ Yaml.prettyPrintParseException err+ ]+ triedFilesMsgs = case files of+ [] -> []+ [f] -> ["While parsing file: " <> toFilePath f]+ fs -> "While parsing files:" : map (("* " <>) . toFilePath) fs+ referenceMsgs =+ [ "Reference: ",+ T.unpack $ TE.decodeUtf8With TE.lenientDecode (renderColouredSchemaViaCodec @a)+ ]+ die $+ unlines $+ concat+ [ failedMsgs,+ triedFilesMsgs,+ referenceMsgs+ ]+ Right (Autodocodec conf) -> pure $ Just conf
+ src/Autodocodec/Yaml/Schema.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Autodocodec.Yaml.Schema where++import Autodocodec+import Autodocodec.Schema+import Data.ByteString (ByteString)+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.Yaml as Yaml+import Text.Colour++-- | Render a human-readable schema for a type's 'codec', in colour.+renderColouredSchemaViaCodec :: forall a. HasCodec a => ByteString+renderColouredSchemaViaCodec = renderColouredSchemaVia (codec @a)++-- | Render a human-readable schema for a given codec, in colour.+renderColouredSchemaVia :: ValueCodec input output -> ByteString+renderColouredSchemaVia = renderChunksBS With24BitColours . schemaChunksVia++-- | Render a human-readable schema for a type's 'codec', without colour.+renderPlainSchemaViaCodec :: forall a. HasCodec a => ByteString+renderPlainSchemaViaCodec = renderPlainSchemaVia (codec @a)++-- | Render a human-readable schema for a given codec, without colour.+renderPlainSchemaVia :: ValueCodec input output -> ByteString+renderPlainSchemaVia = renderChunksBS WithoutColours . schemaChunksVia++-- | Produce potentially-coloured 'Chunk's for a human-readable schema for a type's 'codec'.+schemaChunksViaCodec :: forall a. HasCodec a => [Chunk]+schemaChunksViaCodec = schemaChunksVia (codec @a)++-- | Produce potentially-coloured 'Chunk's for a human-readable schema for a given codec.+schemaChunksVia :: ValueCodec input output -> [Chunk]+schemaChunksVia = jsonSchemaChunks . jsonSchemaVia++-- | Render a 'JSONSchema' as 'Chunk's+jsonSchemaChunks :: JSONSchema -> [Chunk]+jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . go+ where+ indent :: [[Chunk]] -> [[Chunk]]+ indent = map (" " :)++ addInFrontOfFirstInList :: [Chunk] -> [[Chunk]] -> [[Chunk]]+ addInFrontOfFirstInList cs = \case+ [] -> [cs] -- Shouldn't happen, but fine if it doesn't+ (l : ls) -> (cs ++ l) : indent ls++ jsonValueChunk :: Yaml.Value -> Chunk+ jsonValueChunk v = chunk $ T.strip $ TE.decodeUtf8With TE.lenientDecode (Yaml.encode v)++ docToLines :: Text -> [[Chunk]]+ docToLines doc = map (\line -> [chunk "# ", chunk line]) (T.lines doc)++ go :: JSONSchema -> [[Chunk]]+ go = \case+ AnySchema -> [[fore yellow "<any>"]]+ NullSchema -> [[fore yellow "null"]]+ BoolSchema -> [[fore yellow "<boolean>"]]+ 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+ ]+ ]+ ArraySchema s ->+ let addListMarker = addInFrontOfFirstInList ["- "]+ in addListMarker $ go s+ MapSchema s ->+ addInFrontOfFirstInList [fore white "<key>", ": "] $ [] : go s+ ObjectSchema os -> goObject os+ ValueSchema v -> [[jsonValueChunk v]]+ ChoiceSchema ne -> choiceChunks $ NE.map go ne+ CommentSchema comment s -> docToLines comment ++ go s+ RefSchema name -> [[fore cyan $ chunk $ "ref: " <> name]]+ WithDefSchema defs (RefSchema _) -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : go s') (M.toList defs)+ WithDefSchema defs s -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : go s') (M.toList defs) ++ go s++ choiceChunks :: NonEmpty [[Chunk]] -> [[Chunk]]+ choiceChunks = \case+ chunks :| [] -> addInFrontOfFirstInList ["[ "] chunks ++ [["]"]]+ (chunks :| restChunks) ->+ concat $+ addInFrontOfFirstInList ["[ "] chunks :+ map (addInFrontOfFirstInList [", "]) restChunks ++ [[["]"]]]++ goObject :: ObjectSchema -> [[Chunk]]+ goObject = \case+ ObjectAnySchema -> [["<object>"]]+ ObjectKeySchema k kr ks mdoc ->+ let requirementComment = \case+ Required -> fore red "required"+ Optional _ -> fore blue "optional"+ mDefaultValue = \case+ Required -> Nothing+ Optional mdv -> mdv+ in let keySchemaChunks = go ks+ defaultValueLine = case mDefaultValue kr of+ Nothing -> []+ Just defaultValue -> [[chunk "# default: ", fore magenta $ jsonValueChunk defaultValue]]+ prefixLines = ["# ", requirementComment kr] : defaultValueLine ++ maybe [] docToLines mdoc+ in addInFrontOfFirstInList [fore white $ chunk k, ": "] (prefixLines ++ keySchemaChunks)+ ObjectAllOfSchema ne -> concatMap goObject $ NE.toList ne+ ObjectChoiceSchema ne -> choiceChunks $ NE.map goObject ne