mdoc 0.1.0.3 → 0.1.1.0
raw patch · 20 files changed
+771/−145 lines, 20 filesdep +autodocodecdep ~autodocodec-schema
Dependencies added: autodocodec
Dependency ranges changed: autodocodec-schema
Files
- mdoc.cabal +8/−2
- src/Autodocodec/Schema/Mdoc.hs +225/−0
- src/Env/Mdoc.hs +38/−4
- src/Mdoc/Dump/Diff.hs +1/−1
- src/Mdoc/Dump/Main.hs +3/−3
- src/Mdoc/Gen/Config.hs +12/−9
- src/Mdoc/Gen/Described.hs +40/−1
- src/Mdoc/Gen/Description.hs +6/−6
- src/Mdoc/Gen/Synopsis.hs +1/−1
- src/Mdoc/Optics.hs +2/−0
- src/Mdoc/Prelude.hs +4/−0
- src/Mdoc/Pretty/MdocLine.hs +2/−2
- src/OptEnvConf/Mdoc.hs +85/−65
- src/Options/Applicative/Mdoc.hs +57/−4
- test/Autodocodec/Schema/MdocSpec.hs +171/−0
- test/Mdoc/Gen/DescriptionSpec.hs +12/−18
- test/Mdoc/Gen/ExitStatusSpec.hs +17/−24
- test/Mdoc/GenSpec.hs +11/−5
- test/Mdoc/Test/Fixtures.hs +42/−0
- test/Mdoc/Test/Render.hs +34/−0
mdoc.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: mdoc-version: 0.1.0.3+version: 0.1.1.0 license: AGPL-3 maintainer: Pat Brisbin homepage: https://codeberg.org/pbrisbin/mdoc#readme@@ -42,6 +42,7 @@ library exposed-modules:+ Autodocodec.Schema.Mdoc Env.Mdoc Mdoc Mdoc.Detect@@ -116,7 +117,7 @@ build-depends: Diff >=0.5, aeson >=2.2.3.0,- autodocodec-schema >=0.2.0.1,+ autodocodec-schema >=0.2.0.1 && <0.2.0.2, base >=4.19.2.0 && <5, bytestring >=0.12.1.0, containers >=0.6.8,@@ -192,6 +193,7 @@ main-is: Spec.hs hs-source-dirs: test other-modules:+ Autodocodec.Schema.MdocSpec Mdoc.Gen.DescriptionSpec Mdoc.Gen.ExitStatusSpec Mdoc.Gen.FlagSpec@@ -202,6 +204,7 @@ Mdoc.Parse.TroffMacroSpec Mdoc.Test.Fixtures Mdoc.Test.Parse+ Mdoc.Test.Render Mdoc.UpdateMdocdateSpec MdocSpec Paths_mdoc@@ -224,6 +227,9 @@ -rtsopts -with-rtsopts=-N build-depends:+ aeson >=2.2.3.0,+ autodocodec >=0.4.2.2,+ autodocodec-schema >=0.2.0.1, base >=4.19.2.0 && <5, bytestring >=0.12.1.0, envparse >=0.6.0,
+ src/Autodocodec/Schema/Mdoc.hs view
@@ -0,0 +1,225 @@+-- |+--+-- Module : Autodocodec.Schema.Mdoc+-- Copyright : (c) 2026 Patrick Brisbin+-- License : AGPL-3+-- Maintainer : pbrisbin@gmail.com+-- Stability : experimental+-- Portability : POSIX+--+-- A small, semi-representative, not type-checked example:+--+-- @+-- data Person = Person+-- { name :: Text+-- , age :: Int+-- }+--+-- instance HasCodec Person where+-- codec = object "Person" $ Person+-- <$> requiredField "name" "Their name" .= (.name)+-- <*> requiredField "age" "Their age" .= (.age)+--+-- schema :: JSONSchema+-- schema = jsonSchemaViaCodec @Person+-- @+--+-- @+-- .\" Generates this mandoc source+-- .Sh DESCIPTION+-- .Bl ...+-- .It Cm name : string+-- Their name+-- .It Cm age : number+-- Their age+-- .El+-- @+--+-- Which renders something like:+--+-- @+-- DESCRIPTION+-- name : string Their name+--+-- age : object Their age+--+-- @+module Autodocodec.Schema.Mdoc+ ( addToMan5+ , getConfigs+ ) where++import Mdoc.Prelude++import Autodocodec.Schema (JSONSchema (..), ObjectSchema (..))+import Autodocodec.Schema qualified as JSONSchema+import Data.Aeson (Value)+import Data.Aeson qualified as Aeson+import Data.List (intercalate)+import Data.Text qualified as T+import Mdoc.Gen.Config+import Mdoc.Gen.Described+import Mdoc.Gen.Man5+import Mdoc.Gen.Optionality+import Mdoc.Optics++-- |+--+-- This uses 'getConfigs' without prefix, resulting in output like:+--+-- @+-- foo : string+-- A foo field that is string+--+-- bar : number+-- A bar field that is a number+-- @+--+-- for an object, or+--+-- @+-- : string+-- @+--+-- for a primitive+addToMan5 :: JSONSchema -> Man5 -> Man5+addToMan5 js m =+ m+ & field @"name" % field @"description" %~ getComment js+ & field @"configs" <>~ getConfigs Nothing js++getComment :: JSONSchema -> String -> String+getComment js existing = case js of+ CommentSchema comment _+ | null existing+ , not $ T.null comment ->+ unpack comment+ _ -> existing++getConfigs :: Maybe (NonEmpty String) -> JSONSchema -> [Described Config]+getConfigs mPrefix = uncurry (getConfigs1 mPrefix) . simplifyJSONSchema++getConfigs1+ :: Maybe (NonEmpty String)+ -> Described Schema+ -> [Described ObjectMember]+ -> [Described Config]+getConfigs1 mPrefix schema members =+ maybe id (:) mParent+ $ concatMap (describeObjectMember schema.item mPrefix) members+ where+ mParent = do+ -- This makes sure the no-prefix + complex case doesn't look like:+ --+ -- : object+ --+ -- bar : this+ -- baz : that+ --+ -- But instead is,+ --+ -- bar : this+ -- baz : that+ --+ guard $ isJust mPrefix || null members++ let config =+ Config+ { name = renderPrefix <$> mPrefix+ , schema = schema.item+ , exampleLines = Nothing+ }++ pure $ config <$ schema++data ObjectMember = ObjectMember+ { keys :: NonEmpty String+ , schema :: Schema+ , members :: [Described ObjectMember]+ }++describeObjectMember+ :: Schema+ -- ^ Parent schema+ -> Maybe (NonEmpty String)+ -> Described ObjectMember+ -> [Described Config]+describeObjectMember pschema mPrefix member =+ (config <$ member)+ : concatMap+ (describeObjectMember member.item.schema $ Just prefix)+ member.item.members+ where+ prefix = case (mPrefix, pschema) of+ (Nothing, ListOf {}) -> pure "[]" <> member.item.keys+ (Nothing, _) -> member.item.keys+ (Just p, ListOf {}) -> onLast (<> "[]") p <> member.item.keys+ (Just p, _) -> p <> member.item.keys++ config =+ Config+ { name = Just $ renderPrefix prefix+ , schema = member.item.schema+ , exampleLines = Nothing+ }++simplifyJSONSchema :: JSONSchema -> (Described Schema, [Described ObjectMember])+simplifyJSONSchema = \case+ AnySchema -> primitive "any"+ NullSchema -> primitive "null"+ BoolSchema -> primitive "boolean"+ StringSchema {} -> primitive "string"+ IntegerSchema {} -> primitive "number"+ NumberSchema {} -> primitive "number"+ MapSchema s -> simplifyJSONSchema s+ ArraySchema s -> first (fmap ListOf) $ simplifyJSONSchema s+ ObjectSchema ObjectAnySchema -> (required "any", [])+ ObjectSchema os -> (required "object", simplifyObjectSchema os)+ ValueSchema v -> primitive $ constSchema v+ AnyOfSchema ss -> anyOf ss+ OneOfSchema ss -> anyOf ss+ CommentSchema c s -> first (setHelpText c) $ simplifyJSONSchema s+ RefSchema t -> primitive $ Simple t+ WithDefSchema _ s -> simplifyJSONSchema s++simplifyObjectSchema :: ObjectSchema -> [Described ObjectMember]+simplifyObjectSchema = \case+ ObjectKeySchema k reqd s mcomment ->+ let (Described {item = schema}, members) = simplifyJSONSchema s+ in [ Described+ { item = ObjectMember {keys = pure $ unpack k, schema, members}+ , optionality = case reqd of+ JSONSchema.Required -> Required+ _ -> Optional+ , multiple = False+ , helpLines = nonEmpty . lines . unpack =<< mcomment+ }+ ]+ ObjectAllOfSchema os -> concatMap simplifyObjectSchema $ toList os+ ObjectAnyOfSchema os -> concatMap simplifyObjectSchema $ toList os+ ObjectOneOfSchema os -> concatMap simplifyObjectSchema $ toList os+ ObjectAnySchema -> error "panic! we should not have hit this case"++-- Work around bug in opt-env-conf where all configs are null|x+anyOf :: NonEmpty JSONSchema -> (Described Schema, [Described ObjectMember])+anyOf (NullSchema :| [s]) = simplifyJSONSchema s+anyOf ss = bimap (redescribe AnyOf) concat $ unzip $ map simplifyJSONSchema $ toList ss++primitive :: Schema -> (Described Schema, [a])+primitive schema = (required schema, [])++-- | 'ValueSchema' is only used for @const {value}@; e.g. it must match the+-- @Value@ literally. We don't render complex values, but rendering simple types+-- is how an enum, defined as @[{const:error, const:warning}]@, is correctly+-- rendered as @error|warning@.+constSchema :: Value -> Schema+constSchema = \case+ Aeson.Object {} -> "json"+ Aeson.Array {} -> "json"+ Aeson.String t -> Simple t+ Aeson.Number n -> Simple $ pack $ show n+ Aeson.Bool b -> Simple $ pack $ show b+ Aeson.Null -> "null"++renderPrefix :: NonEmpty String -> String+renderPrefix = intercalate "." . toList
src/Env/Mdoc.hs view
@@ -6,6 +6,42 @@ -- Maintainer : pbrisbin@gmail.com -- Stability : experimental -- Portability : POSIX+--+-- A small, semi-representative, not type-checked example:+--+-- @+-- -- This input parser+-- parser :: Parser Error Options+-- parser = Option+-- <$> var str "FOO" (help "Use foo")+-- <*> switch "DEBUG" (help "Log more verbosely")+-- @+--+-- @+-- .\" Generates this mandoc source+-- .Sh ENVIRONMENT+-- The following environment variables affect the execution of+-- .Nm+-- :+-- .Bl ...+-- .It Cm FOO+-- Use foo+-- .It Cm DEBUG+-- Log more verbosely+-- @+--+-- Which renders something like:+--+-- @+-- ENVIRONMENT+-- The following environment variable affect the execution of thing:+--+-- FOO Use foo+--+-- DEBUG Log more verbosely+-- @+--+-- For something more complete, see "Mdoc.GenSpec". module Env.Mdoc ( addToMan1 ) where@@ -18,12 +54,10 @@ import Mdoc.Gen.EnvVar import Mdoc.Gen.Man1 import Mdoc.Gen.Optionality+import Mdoc.Optics addToMan1 :: Parser e a -> Man1 -> Man1-addToMan1 p base =- base- { environment = base.environment <> envs- }+addToMan1 p m = m & field @"environment" <>~ envs where envs = foldAlt varToEnvVar $ unParser p
src/Mdoc/Dump/Diff.hs view
@@ -54,7 +54,7 @@ , annotate AnnFile $ "--- a" <> pretty (ensureSlash name) , annotate AnnFile $ "+++ b" <> pretty (ensureSlash name) ]- <> map prettyDiff (collapse diffs)+ <> map prettyDiff (collapse diffs) ensureSlash :: String -> String ensureSlash = \case
src/Mdoc/Dump/Main.hs view
@@ -40,9 +40,9 @@ when options.debug $ putDoc options.color stderr $ annotate AnnFile (pretty input.name)- <> ":"- <+> "refusing to parse"- <+> prettyUnparsable reason+ <> ":"+ <+> "refusing to parse"+ <+> prettyUnparsable reason ParseError err -> exitParseError err Parsed mdoc -> do mdoc' <- postProcess mdoc
src/Mdoc/Gen/Config.hs view
@@ -21,7 +21,7 @@ import Mdoc.MacroName data Config = Config- { name :: String+ { name :: Maybe String , schema :: Schema , exampleLines :: Maybe (NonEmpty String) }@@ -29,18 +29,22 @@ renderConfig :: Config -> [MacroArg] renderConfig c =- [ Callable Cm- , Bare $ esc $ pack c.name- , Callable Ns- , ":"- ]- <> schemaArgs c.schema+ nameArgs <> [":"] <> schemaArgs c.schema+ where+ nameArgs =+ maybe+ []+ ( \n ->+ [ Callable Cm+ , Bare $ esc $ pack n+ ]+ )+ c.name data Schema = Simple Text | AnyOf [Schema] | ListOf Schema- | Object Text Schema deriving stock (Eq, Show) instance IsString Schema where@@ -52,4 +56,3 @@ AnyOf ss -> intercalate [Callable Ns, "|", Callable Ns] $ map schemaArgs ss ListOf s@(AnyOf {}) -> ["("] <> schemaArgs s <> [")", Callable Ns, "[]"] ListOf s -> schemaArgs s <> [Callable Ns, "[]"]- Object k s -> ["{", Callable Ar, Bare $ esc k, ","] <> schemaArgs s <> ["}"]
src/Mdoc/Gen/Described.hs view
@@ -8,6 +8,11 @@ -- Portability : POSIX module Mdoc.Gen.Described ( Described (..)+ , required+ , redescribe+ , setHelpLines+ , setHelpText+ , partitionDescribed , renderDescribedItems , renderDescribedItem ) where@@ -19,6 +24,7 @@ import Mdoc.MacroArg import Mdoc.MacroName import Mdoc.MdocLine+import Mdoc.Optics data Described a = Described { item :: a@@ -28,6 +34,39 @@ } deriving stock (Eq, Functor, Generic, Show) +-- | Describe an item as 'Required', singular, without help+required :: a -> Described a+required item =+ Described+ { item+ , optionality = Required+ , multiple = False+ , helpLines = Nothing+ }++-- | Concat a described list into a single item+--+-- NB. The element descriptions are discarded and 'required' is used. We could+-- get clever (e.g. any required -> required, concatenat help, etc) but it's+-- just not useful in the project to do so.+redescribe :: ([a] -> b) -> [Described a] -> Described b+redescribe f = required . f . map (.item)++setHelpLines :: NonEmpty String -> Described a -> Described a+setHelpLines x = field @"helpLines" ?~ x++-- | Set a 'Described's 'helpLines' from a 'Text'+setHelpText :: Text -> Described a -> Described a+setHelpText = maybe id setHelpLines . nonEmpty . lines . unpack++partitionDescribed :: [Described (Either a b)] -> ([Described a], [Described b])+partitionDescribed = go ([], [])+ where+ go acc [] = acc+ go (as, bs) (d : ds) = case d.item of+ Left a -> go (as <> [a <$ d], bs) ds+ Right b -> go (as, bs <> [b <$ d]) ds+ renderDescribedItems :: Foldable t => (a -> [MacroArg])@@ -36,7 +75,7 @@ renderDescribedItems f = concatMap (renderDescribedItem f) . toList -- TODO: add "Default:" line--- TODO: add "This option may be specified multiple times line+-- TODO: add "This option may be specified multiple times" line renderDescribedItem :: (a -> [MacroArg]) -> Described a -> [MdocLine] renderDescribedItem f d = MacroLine It (f d.item) : descriptionLines where
src/Mdoc/Gen/Description.hs view
@@ -35,10 +35,10 @@ Just neItems -> sconcat $ pure (TextLine "The options are as follows:")- :| [ pure $ MacroLine Bl ["-tag", "-width", "indent"]- , neItems- , pure $ MacroLine El []- ]+ :| [ pure $ MacroLine Bl ["-tag", "-width", "indent"]+ , neItems+ , pure $ MacroLine El []+ ] where items = optionsLines m.switches m.options <> argumentsLines m.arguments @@ -49,14 +49,14 @@ Just neItems -> sconcat $ pure (MacroLine Bl ["-tag", "-width", "indent"])- :| [neItems, pure $ MacroLine El []]+ :| [neItems, pure $ MacroLine El []] optionsLines :: [Described Flag] -> [Described Option] -> [MdocLine] optionsLines switches options = concatMap snd $ sortOn fst $ map switchLines switches- <> map optionLines options+ <> map optionLines options switchLines :: Described Flag -> (Flag, [MdocLine]) switchLines d =
src/Mdoc/Gen/Synopsis.hs view
@@ -33,7 +33,7 @@ , map snd $ sortOn fst $ mapMaybe longSwitchLine m.switches- <> mapMaybe longOptionLine m.options+ <> mapMaybe longOptionLine m.options , map argLine m.arguments , [MacroLine Ek []] ]
src/Mdoc/Optics.hs view
@@ -34,3 +34,5 @@ (<>~) :: Semigroup b => Lens' a b -> b -> a -> a l <>~ w = l %~ (<> w)++infixr 4 <>~
src/Mdoc/Prelude.hs view
@@ -9,6 +9,7 @@ module Mdoc.Prelude ( module X , guarded+ , onLast , esc ) where @@ -38,6 +39,9 @@ guarded :: Alternative f => (a -> Bool) -> a -> f a guarded p a = a <$ guard (p a)++onLast :: (a -> a) -> NonEmpty a -> NonEmpty a+onLast f ne = init ne |: f (last ne) esc :: Text -> Text esc =
src/Mdoc/Pretty/MdocLine.hs view
@@ -26,8 +26,8 @@ MacroLine name args -> hsep $ annotate AnnComment "."- <> annotate AnnCommand (prettyMacroName name)- : map prettyMacroArg args+ <> annotate AnnCommand (prettyMacroName name)+ : map prettyMacroArg args TextLine x -> pretty x TableLines ls -> prettyTableLines ls TroffMacro m -> prettyTroffMacro m
src/OptEnvConf/Mdoc.hs view
@@ -6,6 +6,68 @@ -- Maintainer : pbrisbin@gmail.com -- Stability : experimental -- Portability : POSIX+--+-- A small, semi-representative, not type-checked example:+--+-- @+-- -- This input parser+-- parser :: Parser Options+-- parser = Option+-- <$> setting [short 'C', long "context", help "Include context" <> metavar "num"]+-- <*> setting [short 'v', long "debug", env "DEBUG", help "Log more verbosely"]+-- <*> some1 (setting [argument, metavar "file"])+-- @+--+-- @+-- .\" Generates this mandoc source+-- .Sh SYNOPSIS+-- .Nm+-- .Op Fl Ar Cv+-- .Op Fl Fl debug+-- .Ar file+-- .Op Ar file ...+-- .Sh DESCRIPTION+-- The options are as follows:+-- .Bl ...+-- .It Fl C Ar num+-- Include context+-- .It Fl v | Fl Fl verbose+-- Log more verbosely+-- .It Ar file+-- .El+-- .Sh ENVIRONMENT+-- The following environment variables affect the execution of+-- .It Cm DEBUG+-- Log more verbosely+-- .Sh EXIT STATUS+-- .Ex -std+-- @+--+-- Which renders something like:+--+-- @+-- SYNOPSIS+-- thing [-Cv] [--debug] file [file ...]+--+-- DESCRIPTION+-- The options are as follows:+--+-- -C Include context+--+-- -v | --debug Log more verbosely+--+-- file+--+-- ENVIRONMENT+-- The following environment variable affect the execution of thing:+--+-- DEBUG Log more verbosely+--+-- EXIT STATUS+-- The thing utility exits 0 for success, and >0 if an error occurs.+-- @+--+-- For something more complete, see "Mdoc.GenSpec". module OptEnvConf.Mdoc ( addToMan1 , addToMan5@@ -13,9 +75,7 @@ import Mdoc.Prelude -import Autodocodec.Schema (JSONSchema (..))-import Data.Aeson qualified as Aeson-import Data.List (intercalate)+import Autodocodec.Schema.Mdoc qualified as JSONSchema import Mdoc.Gen.Argument import Mdoc.Gen.Config import Mdoc.Gen.Described@@ -25,6 +85,7 @@ import Mdoc.Gen.Man5 import Mdoc.Gen.Option import Mdoc.Gen.Optionality+import Mdoc.Optics import OptEnvConf (ConfDoc (..), EnvDoc (..), OptDoc (..), Parser) import OptEnvConf.Args (Dashed (..)) import OptEnvConf.Doc@@ -35,29 +96,17 @@ ) addToMan1 :: Parser a -> Man1 -> Man1-addToMan1 p base =- base- { switches = base.switches <> switches- , options = base.options <> options- , arguments = base.arguments <> getParserArgs p- , environment = base.environment <> getParserEnvs p- }+addToMan1 p m =+ m+ & field @"switches" <>~ switches+ & field @"options" <>~ options+ & field @"arguments" <>~ getParserArgs p+ & field @"environment" <>~ getParserEnvs p where (switches, options) = partitionDescribed $ getParserOpts p -partitionDescribed :: [Described (Either a b)] -> ([Described a], [Described b])-partitionDescribed = go ([], [])- where- go acc [] = acc- go (as, bs) (d : ds) = case d.item of- Left a -> go (as <> [a <$ d], bs) ds- Right b -> go (as, bs <> [b <$ d]) ds- addToMan5 :: Parser a -> Man5 -> Man5-addToMan5 p base =- base- { configs = base.configs <> getParserConfs p- }+addToMan5 p m = m & field @"configs" <>~ getParserConfs p getParserOpts :: Parser a -> [Described (Either Flag Option)] getParserOpts = walkNonCommandDocs (maybe [] optDocToOpt) . parserOptDocs@@ -145,50 +194,21 @@ -- ] confToConfig :: ConfDoc -> [Described Config]-confToConfig doc = map (uncurry go . first toList) $ toList $ confDocKeys doc- where- go :: [String] -> JSONSchema -> Described Config- go keys jSchema =- Described- { item =- Config- { name = intercalate "." keys- , schema = simplifySchema jSchema- , exampleLines = nonEmpty $ confDocExamples doc- }- , optionality = maybe Required Defaulted $ confDocDefault doc- , multiple = False- , helpLines = nonEmpty . lines =<< confDocHelp doc- }--simplifySchema :: JSONSchema -> Schema-simplifySchema = \case- AnySchema -> "any"- NullSchema -> "null"- BoolSchema -> "boolean"- StringSchema {} -> "string"- IntegerSchema {} -> "number"- NumberSchema {} -> "number"- ArraySchema s -> ListOf $ simplifySchema s- MapSchema s -> simplifySchema s- ObjectSchema {} -> "object"- -- This is only used for `const`, it must match `Value` literally- ValueSchema v -> case v of- Aeson.Object {} -> "json"- Aeson.Array {} -> "json"- Aeson.String t -> Simple t- Aeson.Number n -> Simple $ pack $ show n- Aeson.Bool b -> Simple $ pack $ show b- Aeson.Null -> "null"- AnyOfSchema ss -> anyOf $ toList ss- OneOfSchema ss -> anyOf $ toList ss- CommentSchema c _ -> Simple c- RefSchema t -> Simple t- WithDefSchema _ s -> simplifySchema s+confToConfig doc =+ concatMap (\(keys, js) -> addMeta $ JSONSchema.getConfigs (Just keys) js)+ $ toList+ $ confDocKeys doc where- -- Work around bug in opt-env-conf where all configs are null|x- anyOf [NullSchema, s] = simplifySchema s- anyOf ss = AnyOf $ map simplifySchema ss+ addMeta :: [Described Config] -> [Described Config]+ addMeta = \case+ [] -> []+ (d : ds) ->+ d+ { optionality = maybe Required Defaulted $ confDocDefault doc+ , multiple = False+ , helpLines = nonEmpty . lines =<< confDocHelp doc+ }+ : ds dashedFlags :: [Dashed] -> Maybe Flag dashedFlags = fmap go . nonEmpty
src/Options/Applicative/Mdoc.hs view
@@ -8,6 +8,59 @@ -- Maintainer : pbrisbin@gmail.com -- Stability : experimental -- Portability : POSIX+--+-- A small, semi-representative, not type-checked example:+--+-- @+-- -- This input parser+-- parser :: Parser Options+-- parser = Option+-- <$> option str (short 'C' <> long "context" <> help "Include context" <> metavar "num"+-- <*> switch (short 'v' <> long "debug" <> help "Log more verbosely")+-- <*> some1 (argument (metavar "file"))+-- @+--+-- @+-- .\" Generates this mandoc source+-- .Sh SYNOPSIS+-- .Nm+-- .Op Fl Ar Cv+-- .Op Fl Fl debug+-- .Ar file+-- .Op Ar file ...+-- .Sh DESCRIPTION+-- The options are as follows:+-- .Bl ...+-- .It Fl C Ar num+-- Include context+-- .It Fl v | Fl Fl verbose+-- Log more verbosely+-- .It Ar file+-- .El+-- .Sh EXIT STATUS+-- .Ex -std+-- @+--+-- Which renders something like:+--+-- @+-- SYNOPSIS+-- thing [-Cv] [--debug] file [file ...]+--+-- DESCRIPTION+-- The options are as follows:+--+-- -C Include context+--+-- -v | --debug Log more verbosely+--+-- file+--+-- EXIT STATUS+-- The thing utility exits 0 for success, and >0 if an error occurs.+-- @+--+-- For something more complete, see "Mdoc.GenSpec". module Options.Applicative.Mdoc ( addToMan1 ) where@@ -21,6 +74,7 @@ import Mdoc.Gen.Man1 (Man1 (..)) import Mdoc.Gen.Option import Mdoc.Gen.Optionality+import Mdoc.Optics import Options.Applicative (Parser) import Options.Applicative.Common (treeMapParser) import Options.Applicative.Help.Chunk (Chunk (..), unChunk)@@ -48,10 +102,9 @@ fromSub :: Man1 -> SubMan1 -> Man1 fromSub m SubMan1 {switches, options, arguments} = m- { switches = m.switches <> switches- , options = m.options <> options- , arguments = m.arguments <> arguments- }+ & field @"switches" <>~ switches+ & field @"options" <>~ options+ & field @"arguments" <>~ arguments addToMan1 :: Parser a -> Man1 -> Man1 addToMan1 p base =
+ test/Autodocodec/Schema/MdocSpec.hs view
@@ -0,0 +1,171 @@+-- |+--+-- Module : Autodocodec.Schema.MdocSpec+-- Copyright : (c) 2026 Patrick Brisbin+-- License : AGPL-3+-- Maintainer : pbrisbin@gmail.com+-- Stability : experimental+-- Portability : POSIX+module Autodocodec.Schema.MdocSpec+ ( spec+ ) where++import Mdoc.Prelude++import Autodocodec.Schema+ ( JSONSchema (..)+ , KeyRequirement (..)+ , ObjectSchema (..)+ )+import Autodocodec.Schema.Mdoc+import Data.Aeson qualified as Aeson+import Data.List.NonEmpty qualified as NE+import Mdoc.Gen.Config+import Mdoc.Gen.Described+import Mdoc.MdocLine+import Mdoc.Test.Render+import Test.Hspec++spec :: Spec+spec = do+ describe "getConfigs" $ do+ let+ renderJSONSchema :: JSONSchema -> [MdocLine]+ renderJSONSchema =+ renderDescribedItems renderConfig . getConfigs Nothing++ renderJSONSchemaAt :: NonEmpty String -> JSONSchema -> [MdocLine]+ renderJSONSchemaAt keys =+ renderDescribedItems renderConfig . getConfigs (Just keys)++ it "primitive" $ do+ renderJSONSchema BoolSchema+ `shouldRender` [".It : Ar boolean"]++ it "array of primitive" $ do+ renderJSONSchema (ArraySchema BoolSchema)+ `shouldRender` [".It : Ar boolean Ns []"]++ it "array of any-of" $ do+ let+ js :: JSONSchema+ js = ArraySchema (AnyOfSchema $ StringSchema :| [BoolSchema])++ renderJSONSchema js+ `shouldRender` [".It : ( Ar string Ns | Ns Ar boolean ) Ns []"]++ it "any-of with array" $ do+ let+ js :: JSONSchema+ js = AnyOfSchema $ StringSchema :| [ArraySchema BoolSchema]++ renderJSONSchema js+ `shouldRender` [".It : Ar string Ns | Ns Ar boolean Ns []"]++ it "log-level example"+ $ do+ let+ keys :: NonEmpty String+ keys = "log" :| ["level"]++ js :: JSONSchema+ js =+ AnyOfSchema+ $ ValueSchema (Aeson.String "info")+ :| [ ValueSchema (Aeson.String "warn")+ , ValueSchema (Aeson.String "error")+ ]++ renderJSONSchemaAt keys js+ `shouldRender` [".It Cm log.level : Ar info Ns | Ns Ar warn Ns | Ns Ar error"]++ it "renders types with comments" $ do+ let+ keys :: NonEmpty String+ keys = pure "name"++ js :: JSONSchema+ js = CommentSchema "The person's name" StringSchema++ renderJSONSchemaAt keys js+ `shouldRender` [ ".It Cm name : Ar string"+ , "The person's name"+ ]++ context "objects" $ do+ let+ key :: Text -> JSONSchema -> ObjectSchema+ key k s = ObjectKeySchema k Required s Nothing++ keyComment :: Text -> Text -> JSONSchema -> ObjectSchema+ keyComment k d s = ObjectKeySchema k Required s $ Just d++ object :: [ObjectSchema] -> JSONSchema+ object = ObjectSchema . ObjectAllOfSchema . NE.fromList++ it "special case, any" $ do+ renderJSONSchema (ObjectSchema ObjectAnySchema)+ `shouldRender` [".It : Ar any"]++ it "one-level" $ do+ let+ js :: JSONSchema+ js =+ object+ [ key "foo" StringSchema+ , key "bar" BoolSchema+ , key "baz" (RefSchema "custom")+ ]++ renderJSONSchema js+ `shouldRender` [ ".It Cm foo : Ar string"+ , ".It Cm bar : Ar boolean"+ , ".It Cm baz : Ar custom"+ ]++ it "multi-level" $ do+ let+ js :: JSONSchema+ js = object [key "foo" (object [key "bar" (object [key "baz" StringSchema])])]++ renderJSONSchema js+ `shouldRender` [ ".It Cm foo : Ar object"+ , ".It Cm foo.bar : Ar object"+ , ".It Cm foo.bar.baz : Ar string"+ ]++ it "list of object at key" $ do+ let+ js :: JSONSchema+ js =+ ArraySchema+ $ object+ [ key "name" StringSchema+ , keyComment "admin" "Admin?" BoolSchema+ ]++ renderJSONSchema js+ `shouldRender` [ ".It Cm [].name : Ar string"+ , ".It Cm [].admin : Ar boolean"+ , "Admin?"+ ]++ it "list of object at key" $ do+ let+ keys :: NonEmpty String+ keys = pure "people"++ js :: JSONSchema+ js =+ ArraySchema+ $ object+ [ key "name" StringSchema+ , keyComment "admin" "Admin?" BoolSchema+ ]++ renderJSONSchemaAt keys js+ `shouldRender` [ ".It Cm people : Ar object Ns []"+ , ".It Cm people[].name : Ar string"+ , ".It Cm people[].admin : Ar boolean"+ , "Admin?"+ ]
test/Mdoc/Gen/DescriptionSpec.hs view
@@ -16,9 +16,7 @@ import Mdoc.Gen.Described import Mdoc.Gen.Description import Mdoc.Gen.Optionality-import Mdoc.MdocLine-import Mdoc.Pretty-import Mdoc.Pretty.MdocLine+import Mdoc.Test.Render import Test.Hspec spec :: Spec@@ -29,7 +27,7 @@ Described { item = Config- { name = "git.push"+ { name = Just "git.push" , schema = Simple "boolean" , exampleLines = Just $ "# disable pushing" :| ["git.push: false"] }@@ -38,17 +36,13 @@ , helpLines = Just $ pure "Push to git remote" } - render (configLines config)- `shouldBe` mconcat- [ ".It Cm git.push Ns : Ar boolean\n"- , "Push to git remote\n"- , ".Pp\n"- , "Example:\n"- , ".Bd -literal -offset indent\n"- , "# disable pushing\n"- , "git.push: false\n"- , ".Ed\n"- ]--render :: [MdocLine] -> Text-render = renderPlain . vsep . map prettyMdocLine+ configLines config+ `shouldRender` [ ".It Cm git.push : Ar boolean"+ , "Push to git remote"+ , ".Pp"+ , "Example:"+ , ".Bd -literal -offset indent"+ , "# disable pushing"+ , "git.push: false"+ , ".Ed"+ ]
test/Mdoc/Gen/ExitStatusSpec.hs view
@@ -13,9 +13,7 @@ import Mdoc.Prelude import Mdoc.Gen.ExitStatus-import Mdoc.MdocLine-import Mdoc.Pretty-import Mdoc.Pretty.MdocLine+import Mdoc.Test.Render import Test.Hspec spec :: Spec@@ -24,13 +22,12 @@ it "can re-create Ex -std format" $ do let nzs = pure $ NonZeroStatus ">0" "if an error occurs" - render (renderExitStatuses nzs)- `shouldBe` mconcat- [ "The\n"- , ".Nm\n"- , "utility exits 0 on success,\n"- , "and >0 if an error occurs.\n"- ]+ renderExitStatuses nzs+ `shouldRender` [ "The"+ , ".Nm"+ , "utility exits 0 on success,"+ , "and >0 if an error occurs."+ ] it "is flexible to more non-zero statuses" $ do -- https://github.com/ocharles/weeder#exit-codes@@ -42,17 +39,13 @@ , NonZeroStatus "4" "when no HIE files found" ] - render (renderExitStatuses nzs)- `shouldBe` mconcat- [ "The\n"- , ".Nm\n"- , "utility exits 0 on success,\n"- , "228 if one or more weeds found,\n"- , "1 for generic failing exit code,\n"- , "2 due to failure to read HIE file due to GHC version mismatch,\n"- , "3 due to failure to parse config file,\n"- , "and 4 when no HIE files found.\n"- ]--render :: NonEmpty MdocLine -> Text-render = renderPlain . vsep . map prettyMdocLine . toList+ renderExitStatuses nzs+ `shouldRender` [ "The"+ , ".Nm"+ , "utility exits 0 on success,"+ , "228 if one or more weeds found,"+ , "1 for generic failing exit code,"+ , "2 due to failure to read HIE file due to GHC version mismatch,"+ , "3 due to failure to parse config file,"+ , "and 4 when no HIE files found."+ ]
test/Mdoc/GenSpec.hs view
@@ -14,6 +14,7 @@ import Mdoc.Prelude +import Autodocodec.Schema.Mdoc qualified as JSONSchema import Data.ByteString.Lazy qualified as BSL import Data.Text.IO qualified as T import Data.Time (fromGregorian)@@ -40,24 +41,29 @@ it "grep.1" $ goldenMan1 $ grepBase- & OA.addToMan1 grepOpt- & Env.addToMan1 grepEnv+ & OA.addToMan1 grepOpt+ & Env.addToMan1 grepEnv it "example.1" $ goldenMan1 $ exampleBase1- & OptEnvConf.addToMan1 exampleOptEnvConf+ & OptEnvConf.addToMan1 exampleOptEnvConf describe "genMan5" $ do it "examplerc.5" $ goldenMan5 $ exampleBase5- & OptEnvConf.addToMan5 exampleOptEnvConf+ & OptEnvConf.addToMan5 exampleOptEnvConf it "conf.5" $ goldenMan5 $ confBase- & OptEnvConf.addToMan5 confConf+ & OptEnvConf.addToMan5 confConf++ it "person.5"+ $ goldenMan5+ $ personBase+ & JSONSchema.addToMan5 personJSONSchema goldenMan1 :: Man1 -> IO (Golden Mdoc) goldenMan1 man1 = goldenMan (man1.name.primary <.> "1") <$> genMan1 man1
test/Mdoc/Test/Fixtures.hs view
@@ -17,10 +17,14 @@ , exampleBase1 , exampleBase5 , exampleOptEnvConf+ , personBase+ , personJSONSchema ) where import Mdoc.Prelude +import Autodocodec (HasCodec (..), object, optionalField, requiredField, (.=))+import Autodocodec.Schema (JSONSchema, jsonSchemaViaCodec) import Env qualified import Mdoc.Gen.CrossRef import Mdoc.Gen.Man1@@ -129,3 +133,41 @@ <*> OptEnvConf.setting [OptEnvConf.conf "file", OptEnvConf.argument, OptEnvConf.reader OptEnvConf.str, OptEnvConf.metavar "FILE"] <*> OptEnvConf.many (OptEnvConf.setting [OptEnvConf.argument, OptEnvConf.reader OptEnvConf.str, OptEnvConf.metavar "FILE"]) {- FOURMOLU_ENABLE -}++data Person = Person+ { name :: Text+ , age :: Int+ , address :: Maybe Address+ , hobbies :: Maybe [Text]+ }++{- FOURMOLU_DISABLE -}+instance HasCodec Person where+ codec = object "Person" $ Person+ <$> requiredField "name" "Their name" .= (.name)+ <*> requiredField "age" "Their age" .= (.age)+ <*> optionalField "address" "Their address" .= (.address)+ <*> optionalField "hobbies" "Their hobbies" .= (.hobbies)+{- FOURMOLU_ENABLE -}++data Address = Address+ { street :: Text+ , city :: Text+ , state :: Text+ , postalCode :: Text+ }++{- FOURMOLU_DISABLE -}+instance HasCodec Address where+ codec = object "Address" $ Address+ <$> requiredField "street" "The street" .= (.street)+ <*> requiredField "city" "The city" .= (.city)+ <*> requiredField "state" "The state" .= (.state)+ <*> requiredField "postalCode" "The postal code" .= (.postalCode)+{- FOURMOLU_ENABLE -}++personBase :: Man5+personBase = baseMan5 "person" "person example via Codec" "person.schema.json"++personJSONSchema :: JSONSchema+personJSONSchema = jsonSchemaViaCodec @Person
+ test/Mdoc/Test/Render.hs view
@@ -0,0 +1,34 @@+module Mdoc.Test.Render+ ( IsMdoc (..)+ , shouldRender+ ) where++import Mdoc.Prelude++import Mdoc+import Mdoc.MdocLine+import Mdoc.Pretty+import Test.Hspec++class IsMdoc a where+ toMdoc :: a -> Mdoc++instance IsMdoc Mdoc where+ toMdoc = id++instance IsMdoc [MdocLine] where+ toMdoc = Mdoc++instance IsMdoc (NonEmpty MdocLine) where+ toMdoc = Mdoc . toList++instance IsMdoc MdocLine where+ toMdoc = Mdoc . pure++shouldRender :: IsMdoc a => a -> [Text] -> Expectation+shouldRender a lns = actual `shouldBe` expected+ where+ actual = renderPlain $ prettyMdoc $ toMdoc a+ expected = mconcat $ map (<> "\n") lns++infix 1 `shouldRender`