yamlparse-applicative 0.1.0.1 → 0.1.0.2
raw patch · 6 files changed
+77/−30 lines, 6 files
Files
- src/YamlParse/Applicative.hs +4/−0
- src/YamlParse/Applicative/IO.hs +1/−1
- src/YamlParse/Applicative/OptParse.hs +1/−1
- src/YamlParse/Applicative/Parser.hs +1/−1
- src/YamlParse/Applicative/Pretty.hs +67/−24
- yamlparse-applicative.cabal +3/−3
src/YamlParse/Applicative.hs view
@@ -115,6 +115,8 @@ -- * Documentation for a 'Parser' prettySchemaDoc, prettyParserDoc,+ prettyColourisedSchemaDoc,+ prettyColourisedParserDoc, -- ** Parser schemas explainParser,@@ -122,9 +124,11 @@ -- ** Showing the schema to the user prettySchema,+ prettyColourisedSchema, -- * Interface with 'optparse-applicative' confDesc,+ confDescWith, -- * Parsing a file readConfigFile,
src/YamlParse/Applicative/IO.hs view
@@ -49,7 +49,7 @@ fs -> "While parsing files:" : map (("* " <>) . toFilePath) fs referenceMsgs = [ "Reference: ",- T.unpack $ prettySchema $ explainParser (yamlSchema :: YamlParser a)+ T.unpack $ prettyColourisedSchema $ explainParser (yamlSchema :: YamlParser a) ] die $ unlines
src/YamlParse/Applicative/OptParse.hs view
@@ -20,4 +20,4 @@ -- | Helper function to add the schema documentation for a given parser to the optparse applicative help output confDescWith :: Parser i o -> OptParse.InfoMod a-confDescWith p = OptParse.footerDoc $ Just $ OptParse.string . T.unpack . prettySchema $ explainParser p+confDescWith p = OptParse.footerDoc $ Just $ OptParse.string . T.unpack . prettyColourisedSchema $ explainParser p
src/YamlParse/Applicative/Parser.hs view
@@ -152,7 +152,7 @@ -- > instance YamlSchema Fruit where -- > yamlSchema = Apple <$ literalString "Apple" <|> Banana <$ literalString "Banana" literalString :: Text -> YamlParser Text-literalString t = ParseString Nothing $ ParseEq t t ParseAny+literalString t = ParseString Nothing $ ParseEq t (T.pack $ show t) ParseAny -- | Declare a parser for a value using its show instance --
src/YamlParse/Applicative/Pretty.hs view
@@ -9,20 +9,24 @@ module YamlParse.Applicative.Pretty where +import Data.Maybe import qualified Data.Text as T import Data.Text (Text) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Text+import Data.Text.Prettyprint.Doc.Render.Util.StackMachine import YamlParse.Applicative.Class import YamlParse.Applicative.Explain import YamlParse.Applicative.Parser +data Colour = Yellow | Gray | Red | Blue | White+ -- | Render pretty documentation about the 'yamlSchema' of a type -- -- This is meant for humans. -- The output may look like YAML but it is not.-prettySchemaDoc :: forall o i. YamlSchema o => Text-prettySchemaDoc = prettyParserDoc (yamlSchema @o)+prettySchemaDoc :: forall a. YamlSchema a => Text+prettySchemaDoc = prettyParserDoc (yamlSchema @a) -- | Render pretty documentation about a parser --@@ -31,6 +35,20 @@ prettyParserDoc :: Parser i o -> Text prettyParserDoc = prettySchema . explainParser +-- | Render pretty colourised documentation about the 'yamlSchema' of a type+--+-- This is meant for humans.+-- The output may look like YAML but it is not.+prettyColourisedSchemaDoc :: forall a. YamlSchema a => Text+prettyColourisedSchemaDoc = prettyColourisedParserDoc (yamlSchema @a)++-- | Render pretty colourised documentation about a parser+--+-- This is meant for humans.+-- The output may look like YAML but it is not.+prettyColourisedParserDoc :: Parser i o -> Text+prettyColourisedParserDoc = prettyColourisedSchema . explainParser+ -- | Render a schema as pretty text. -- -- This is meant for humans.@@ -38,8 +56,25 @@ prettySchema :: Schema -> Text prettySchema = renderStrict . layoutPretty defaultLayoutOptions . schemaDoc +-- | Render a schema as pretty and colourised text.+--+-- This is meant for humans.+-- The output may look like YAML but it is not.+prettyColourisedSchema :: Schema -> Text+prettyColourisedSchema = renderSimplyDecorated id startColour resetColour . layoutPretty defaultLayoutOptions . schemaDoc+ where+ startColour :: Colour -> Text+ startColour = \case+ Yellow -> "\x1b[33m"+ Gray -> "\x1b[2m"+ Red -> "\x1b[31m"+ Blue -> "\x1b[34m"+ White -> "\x1b[37m"+ resetColour :: Colour -> Text+ resetColour _ = "\x1b[0m"+ -- | A list of comments-newtype Comments = Comments {commentsList :: [Doc ()]}+newtype Comments = Comments {commentsList :: [Doc Colour]} deriving (Show) instance Semigroup Comments where@@ -58,63 +93,71 @@ comment t = Comments $ map pretty $ T.lines t -- | Prettyprint a 'Schema'-schemaDoc :: Schema -> Doc ()+schemaDoc :: Schema -> Doc Colour schemaDoc = go emptyComments where- go :: Comments -> Schema -> Doc ()+ go :: Comments -> Schema -> Doc Colour go cs = let g = go cs ge = go emptyComments- mkComment :: Doc () -> Doc ()+ mkComment :: Doc Colour -> Doc Colour mkComment = ("# " <>)- mkCommentsMDoc :: Comments -> Maybe (Doc ())+ mkCommentsMDoc :: Comments -> Maybe (Doc Colour) mkCommentsMDoc = \case Comments [] -> Nothing- Comments l -> Just $ align $ vsep $ map mkComment l+ Comments l -> Just $ align $ vsep $ map (annotate Gray . mkComment) l addMComment :: Comments -> Maybe Text -> Comments addMComment c = \case Nothing -> c Just t -> c <> comment t- e :: Doc () -> Comments -> Doc ()+ e :: Doc Colour -> Comments -> Doc Colour e s cs' = case mkCommentsMDoc cs' of- Nothing -> s- Just cd -> vsep [cd, s]+ Nothing -> annotate Yellow s+ Just cd -> vsep [cd, annotate Yellow s] in \case- EmptySchema -> e "# Nothing to parse" cs+ EmptySchema -> e emptyDoc $ addMComment cs $ Just "Nothing to parse" AnySchema -> e "<any>" cs- ExactSchema t -> e (pretty t) cs+ ExactSchema t -> e (pretty t) cs <+> fromJust (mkCommentsMDoc $ comment "(exact)") NullSchema -> e "null" cs MaybeSchema s -> go (cs <> comment "or <null>") s- BoolSchema t -> e "<bool>" $ addMComment cs t+ BoolSchema t -> e "<boolean>" $ addMComment cs t NumberSchema t -> e "<number>" $ addMComment cs t StringSchema t -> e "<string>" $ addMComment cs t ArraySchema t s -> "-" <+> align (go (addMComment cs t) s) -- The comments really only work on the object level -- so they are erased when going down+ ObjectSchema t AnySchema -> e "<object>" (addMComment cs t) ObjectSchema t s -> e (ge s) (addMComment cs t) FieldSchema k r md s ->- let keyDoc :: Doc a+ let keyDoc :: Doc Colour keyDoc = pretty k- requiredDoc :: Doc a+ requiredDoc :: Doc Colour requiredDoc = if r- then "required"+ then annotate Red "required" else case md of- Nothing -> "optional"- Just d -> "optional, default:" <+> pretty d+ Nothing -> blueOptional+ Just d -> blueOptional <+> ", default:" <+> pretty d+ where+ blueOptional = annotate Blue "optional" in vsep- [ keyDoc <> ":" <+> mkComment requiredDoc,+ [ annotate White keyDoc <> ":" <+> mkComment requiredDoc, indent 2 $ g s ] ListSchema s -> g s- MapSchema s -> e ("<key>: " <> nest 2 (g s)) cs+ MapSchema s -> e (annotate White "<key>: " <> nest 2 (g s)) cs MapKeysSchema s -> g s ApSchema s1 s2 -> align $ vsep [g s1, g s2] AltSchema ss ->- let listDoc :: [Doc a] -> Doc a+ let listDoc :: [Doc Colour] -> Doc Colour listDoc = \case [] -> "[]"- (d : ds) -> vsep ["[" <+> nest 2 d, vsep $ map (("," <+>) . nest 2) ds, "]"]- in e (listDoc $ map ge ss) cs+ (d : ds) ->+ vsep+ [ "[" <+> nest 2 d,+ vsep $ map (("," <+>) . nest 2) ds,+ "]"+ ]+ in listDoc $ map ge ss CommentSchema t s -> go (cs <> comment t) s
yamlparse-applicative.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack ----- hash: 63f792362464bdaad4d56636d97966fab17cacd6884f9f3f049a8617543a6cb8+-- hash: ded1b4f5ee3db66fbcd6e3f4573306cbe3dd7edae1f55ae9ab6de42b25805e58 name: yamlparse-applicative-version: 0.1.0.1+version: 0.1.0.2 synopsis: Declaritive configuration parsing with free docs description: See https://github.com/NorfairKing/yamlparse-applicative homepage: https://github.com/NorfairKing/yamlparse-applicative#readme