packages feed

registry-options (empty) → 0.1.0.0

raw patch · 36 files changed

+3553/−0 lines, 36 filesdep +HsYAMLdep +basedep +boxessetup-changed

Dependencies added: HsYAML, base, boxes, bytestring, containers, directory, hedgehog, multimap, protolude, registry, registry-hedgehog, registry-options, tasty, template-haskell, text, th-lift, time, transformers, unordered-containers, vector

Files

+ LICENSE.txt view
@@ -0,0 +1,16 @@+Copyright (c) 2022 Eric Torreborre <etorreborre@yahoo.com>++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. Neither the name of specs nor the names of its contributors may be used to endorse or promote+products derived from this software without specific prior written permission.++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.
+ README.md view
@@ -0,0 +1,110 @@+# `registry-options`++[![Hackage](https://img.shields.io/hackage/v/registry-options.svg)](https://hackage.haskell.org/package/registry-options) [![Build Status](https://github.com/etorreborre/registry-options/workflows/ci/badge.svg)](https://github.com/etorreborre/registry-options/actions)+++##### *It's functions all the way down* <img src="https://raw.githubusercontent.com/etorreborre/registry-options/main/doc/images/unboxed-bottomup.jpg" border="0"/>++# Presentation++This library is an addition to the [`registry`](https://github.com/etorreborre/registry) library, supporting the parsing of options from the command line, environment variables or configuration files.++# A `copy` command-line parser++Here is a quick example showing how to create a parser for a simple command-line program. We want to be able to parse the following command-line arguments+```+copy -f secrets.txt .hidden+```+T+`copy` is the name of the command, `-f` is a flag, and `secrets.txt`, `.hidden` are arguments.++The purpose of command line parsing is to transform a list of input strings into a meaningful Haskell value:+```haskell+data Copy = Copy {+  copyForce :: Bool,+  copySource :: File,+  copyTarget :: File+}++newtype File = File { _file :: Text }+```++We can then use this Haskell value to drive the execution of a `copy` function.++# Define and use a Parser++In order to make a parser for the `Copy` data type we create a [registry](https://github.com/etorreborre/registry) containing several declarations+```haskell+import Data.Registry+import Data.Registry.Options++let parsers =+         $(makeCommand ''Copy [shortDescription "copy a file from SOURCE to TARGET"])+      <: argument @"source" @File [metavar "SOURCE", help "Source path"]+      <: argument @"target" @File [metavar "TARGET", help "Target path"]+      <: switch @"force" [help "Overwrite when a file with the same name already exists"]+      <: decoderOf File+      <: defaults+```+That registry allows us to make a parser capable of creating a `Copy` value from command-line arguments+```haskell+let copyParser = make @(Parser Command Copy) parsers++parse copyParser "copy -f secrets.txt .hidden" === Right (Copy True "secrets.txt" ".hidden")+```++# Display the help++We can also use the library to display the help of any Parser+```haskell+let copyParser = make @(Parser Command Copy) parsers+putStrLn $ displayHelp (parserHelp copyParser)+```++and the output is+```haskell+copy - copy a file from SOURCE to TARGET++USAGE++  copy [-f|--force] [SOURCE] [TARGET]++OPTIONS++  -f,--force BOOL           Force the action even if a file already exists with the same name+  SOURCE                    Source path+  TARGET                    Target path+```++_Note_: via the use of another registry it is possible to customize any part of the help.+See the documentation and functions in `Data.Registry.Options.DisplayHelpBox` on how to override various sections of the help text.++# Read option values++When we want to effectively run a parser and retrieve values we call the `run` function++```haskell+run @Command @Copy parsers :: IO (Either Text Copy)+```++The `run` function takes the `Copy` parser registry and uses some default sources to access option values.+By default the option values come from 3 different sources with the following priorities:++ 1. (highest priority) environment variables+ 2. "command line arguments+ 3. a YAML configuration file (off by default)++If you want to use a YAML configuration file, you can user the `runWith` function+```haskell+runWith @Command @Copy (setConfigFilePath ".configuration.yaml") parsers+```++# You want to know more?++  - fully developed [example][example]: we explain in detail all the declarations above and their role+  - [motivations][motivations]: why was this library created? How does it differ from similar libraries?+  - [sources][sources]: how to configure and extend sources++[example]: http://github.com/etorreborre/registry-options/blob/main/doc/example.md+[motivations]: http://github.com/etorreborre/registry-options/blob/main/doc/motivations.md+[sources]: http://github.com/etorreborre/registry-options/blob/main/doc/sources.md
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ registry-options.cabal view
@@ -0,0 +1,169 @@+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:           registry-options+version:        0.1.0.0+synopsis:       application options parsing+description:    This library provides various parsers for assembling application options+category:       Data+maintainer:     etorreborre@yahoo.com+license:        MIT+license-file:   LICENSE.txt+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/etorreborre/registry-options++library+  exposed-modules:+      Data.Registry.Options+      Data.Registry.Options.Decoder+      Data.Registry.Options.Defaults+      Data.Registry.Options.DefaultValues+      Data.Registry.Options.Display+      Data.Registry.Options.DisplayHelpBox+      Data.Registry.Options.FieldConfiguration+      Data.Registry.Options.Help+      Data.Registry.Options.Lexemes+      Data.Registry.Options.Main+      Data.Registry.Options.OptionDescription+      Data.Registry.Options.Parser+      Data.Registry.Options.Parsers+      Data.Registry.Options.Sources+      Data.Registry.Options.Text+      Data.Registry.Options.TH+  other-modules:+      Paths_registry_options+  hs-source-dirs:+      src+  default-extensions:+      BangPatterns+      DefaultSignatures+      EmptyCase+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      DerivingVia+      DerivingStrategies+      ImportQualifiedPost+      InstanceSigs+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NoImplicitPrelude+      OverloadedStrings+      PatternSynonyms+      Rank2Types+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns+  build-depends:+      HsYAML >=0.2 && <1+    , base >=4.7 && <5+    , boxes >=0.1 && <1+    , bytestring >=0.10 && <1+    , containers >=0.2 && <1+    , multimap >=1.2 && <2+    , protolude ==0.3.*+    , registry >=0.2 && <0.4+    , template-haskell >=2.13 && <3.0+    , text ==1.*+    , th-lift >=0.8 && <1+    , transformers >=0.5 && <2+    , unordered-containers >=0.2 && <1+    , vector >=0.1 && <1+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: test.hs+  other-modules:+      AutoDiscoveredSpecs+      Test.Data.Registry.Options.Diffy+      Test.Data.Registry.Options.DiffySpec+      Test.Data.Registry.Options.DisplayHelpBoxSpec+      Test.Data.Registry.Options.Fs+      Test.Data.Registry.Options.GitSpec+      Test.Data.Registry.Options.HelpSpec+      Test.Data.Registry.Options.HLint+      Test.Data.Registry.Options.HLintSpec+      Test.Data.Registry.Options.LexemesSpec+      Test.Data.Registry.Options.Maker+      Test.Data.Registry.Options.MakerSpec+      Test.Data.Registry.Options.ParserSpec+      Test.Data.Registry.Options.SourcesSpec+      Test.Data.Registry.Options.TextSpec+      Paths_registry_options+  hs-source-dirs:+      test+  default-extensions:+      BangPatterns+      DefaultSignatures+      EmptyCase+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      DerivingVia+      DerivingStrategies+      ImportQualifiedPost+      InstanceSigs+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NoImplicitPrelude+      OverloadedStrings+      PatternSynonyms+      Rank2Types+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-incomplete-uni-patterns -fno-warn-type-defaults -optP-Wno-nonportable-include-path+  build-depends:+      HsYAML >=0.2 && <1+    , base >=4.7 && <5+    , boxes >=0.1 && <1+    , bytestring >=0.10 && <1+    , containers >=0.2 && <1+    , directory+    , hedgehog+    , multimap >=1.2 && <2+    , protolude ==0.3.*+    , registry >=0.2 && <0.4+    , registry-hedgehog+    , registry-options+    , tasty+    , template-haskell >=2.13 && <3.0+    , text ==1.*+    , th-lift >=0.8 && <1+    , time+    , transformers >=0.5 && <2+    , unordered-containers >=0.2 && <1+    , vector >=0.1 && <1+  default-language: Haskell2010
+ src/Data/Registry/Options.hs view
@@ -0,0 +1,21 @@+-- | Full API for the Options library+module Data.Registry.Options+  ( module Options,+  )+where++import Data.Registry.Options.Decoder as Options+import Data.Registry.Options.DefaultValues as Options+import Data.Registry.Options.Defaults as Options+import Data.Registry.Options.Display as Options+import Data.Registry.Options.DisplayHelpBox as Options+import Data.Registry.Options.FieldConfiguration as Options+import Data.Registry.Options.Help as Options+import Data.Registry.Options.Lexemes as Options+import Data.Registry.Options.Main as Options+import Data.Registry.Options.OptionDescription as Options+import Data.Registry.Options.Parser as Options+import Data.Registry.Options.Parsers as Options+import Data.Registry.Options.Sources as Options+import Data.Registry.Options.TH as Options+import Data.Registry.Options.Text as Options
+ src/Data/Registry/Options/Decoder.hs view
@@ -0,0 +1,52 @@+-- | This module contains the definition of a 'Decoder'+--   and some default decoders+--+--   A 'Decoder' reads a string and return a Haskell value or a failure+module Data.Registry.Options.Decoder where++import Data.Registry (ApplyVariadic, Typed, fun, funTo)+import qualified Data.Text as T+import Protolude+import Prelude (String)++-- | Decode a value of type a from Text+newtype Decoder a = Decoder {decode :: Text -> Either Text a}+  deriving (Functor, Applicative, Monad) via (ReaderT Text (Either Text))++-- | Create a Decoder a for a given constructor of type a+decoderOf :: forall a b. (ApplyVariadic Decoder a b, Typeable a, Typeable b) => a -> Typed b+decoderOf = funTo @Decoder++-- | Add a Decoder to a registry+addDecoder :: forall a. (Typeable a) => (Text -> Either Text a) -> Typed (Decoder a)+addDecoder = fun . Decoder++-- * Common decoders++-- | Decoder for an Int+intDecoder :: Text -> Either Text Int+intDecoder t = maybe (Left $ "cannot read as an Int: " <> t) Right (readMaybe t)++-- | Decoder for a Bool+boolDecoder :: Text -> Either Text Bool+boolDecoder t = maybe (Left $ "cannot read as a Bool: " <> t) Right (readMaybe t)++-- | Decoder for some Text+textDecoder :: Text -> Either Text Text+textDecoder t = if T.null t then Left "empty text" else Right t++-- | Decoder for some String+stringDecoder :: Text -> Either Text String+stringDecoder t = if T.null t then Left "empty string" else Right (toS t)++-- | Create a Decoder for [a]+manyOf :: forall a. Typeable a => Typed (Decoder a -> Decoder [a])+manyOf = fun decodeMany++-- | Create a Decoder for [a] as a comma-separated string+decodeMany :: forall a. Typeable a => Decoder a -> Decoder [a]+decodeMany = decodeManySeparated ","++-- | Create a Decoder for [a] as a separated string+decodeManySeparated :: forall a. Typeable a => Text -> Decoder a -> Decoder [a]+decodeManySeparated separator d = Decoder $ \t -> for (T.strip <$> T.splitOn separator t) (decode d)
+ src/Data/Registry/Options/DefaultValues.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}++-- | Default and active values for options+--   They can be defined and / or overridden separately from the+--   option definition themselves+module Data.Registry.Options.DefaultValues where++import Data.Dynamic+import Data.Registry+import Protolude++-- | Contain an optional value to return when an option is missing+newtype DefaultValue (s :: Symbol) a = DefaultValue (Maybe Dynamic)++-- | Contain an optional value to return when an option is present+newtype ActiveValue (s :: Symbol) a = ActiveValue (Maybe Dynamic)++-- | Get the default value in DefaultValue if it exists and has the right type+getDefaultValue :: forall (a :: Type) s. (Typeable a, KnownSymbol s) => DefaultValue s a -> Maybe a+getDefaultValue (DefaultValue Nothing) = Nothing+getDefaultValue (DefaultValue (Just v)) = fromDynamic v++-- | Get the active value in ActiveValue if it exists and has the right type+getActiveValue :: forall (a :: Type) s. (Typeable a, KnownSymbol s) => ActiveValue s a -> Maybe a+getActiveValue (ActiveValue Nothing) = Nothing+getActiveValue (ActiveValue (Just v)) = fromDynamic v++-- | Allow to specify that a given field name and type has no default value+noDefaultValue :: forall s (a :: Type). (KnownSymbol s, Typeable a) => Typed (DefaultValue s a)+noDefaultValue = fun @(DefaultValue s a) (DefaultValue Nothing)++-- | Allow to specify that a given field name and type has no active value+noActiveValue :: forall s (a :: Type). (KnownSymbol s, Typeable a) => Typed (ActiveValue s a)+noActiveValue = fun (ActiveValue Nothing)++-- | Add a default value for a given field name and type+createDefaultValue :: forall s (a :: Type). (Typeable a, KnownSymbol s) => a -> DefaultValue s a+createDefaultValue = DefaultValue . Just . toDyn++-- | Add a default value for a given field name and type+createActiveValue :: forall s (a :: Type). (Typeable a, KnownSymbol s) => a -> ActiveValue s a+createActiveValue = ActiveValue . Just . toDyn
+ src/Data/Registry/Options/Defaults.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-- | This module provide a registry with default values for parsing options+module Data.Registry.Options.Defaults where++import Data.Registry+import Data.Registry.Options.Decoder+import Data.Registry.Options.FieldConfiguration++-- | Default registry+defaults =+  fun defaultFieldConfiguration+    <: decoders++-- | Default decoders+decoders =+  addDecoder boolDecoder+    <: addDecoder intDecoder+    <: addDecoder textDecoder+    <: addDecoder stringDecoder
+ src/Data/Registry/Options/Display.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Abstract data type for displaying the help+--   We are currently displaying the help as a Box from the boxes library+--   but we could as well use Text or Doc () from Prettyprinter+module Data.Registry.Options.Display where++import Protolude++-- | Data type for displaying elements as Text or Doc+--    - a represents a section of the final document+--    - b is the element to display (or part of that element)+--    - c is the output (Text or Doc)+newtype Display (a :: Symbol) b c = Display {display :: b -> c}+  deriving newtype (Functor, Applicative)++-- | noDisplay can be used as a placeholder while defining the structure of a display+noDisplay :: forall a b c. (Monoid c) => Display a b c+noDisplay = Display (const mempty)
+ src/Data/Registry/Options/DisplayHelpBox.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-- | Support for displaying a full help message as a Box (https://hackage.haskell.org/package/boxes)+--+--   The main display function uses a registry to register various+--   @Display "name" Data Box@ values which depend on each other+--+--   Display "name" Data Box is responsible for the display of "Data" in the section "name" as a Box,+--   which can then be rendered as Text with 'renderBox'.+--+--   For example there is a @Display "command-options" Help Box@ to display the options of a given command+--   (represented as a 'Help' value) in 2 columns: option flags / option help text.+--+--   This 'Display' value depends on 2 other 'Display' values:+--+--     - @Display "option-flag" OptionDescription Box@ to display the flag of an option+--     - @Display "option-help" OptionDescription Box@ to display the help of an option+--+--   It is possible to modify the display of the overall help of a command by adding a different display on top of+--   the registry of displays. For example+--   @+--   myDisplayBoxRegistry =+--     fun myDisplayOptionFlagBox <: displayBoxRegistry+--+--   myDisplayOptionFlagBox :: Display "option-flag" OptionDescription Box+--   myDisplayOptionFlagBox = Display $ fromMaybe "" . _name -- just use the option long name+--+--   myDisplayHelp :: Help -> Box+--   myDisplayHelp = renderBox . display (make @(Display "any" Help Box) myDisplayBoxRegistry)+--   @+module Data.Registry.Options.DisplayHelpBox where++import Data.Coerce (coerce)+import Data.Registry hiding ((<+>))+import Data.Registry.Options.Display+import Data.Registry.Options.Help+import Data.Registry.Options.OptionDescription hiding (help)+import Data.Text qualified as T+import Protolude hiding (Any, list)+import Text.PrettyPrint.Boxes hiding ((<>))++-- | Default display for a Help Text+displayHelp :: Help -> Text+displayHelp = renderBox . displayHelpBox++-- | Default display for a Help Box+displayHelpBox :: Help -> Box+displayHelpBox = display (make @(Display "any" Help Box) displayBoxRegistry)++-- | This registry provides overridable functions for displaying various parts of+--   a help text.+--+--   It can be overridden to display the help differently+displayBoxRegistry :: Registry _ _+displayBoxRegistry =+  fun displayAllBox+    <: fun displayHelpTitleBox+    <: fun displayUsageBox+    <: fun displayOptionsBox+    <: fun displayCommandsBox+    <: fun displayCommandSummaryBox+    <: fun displayCommandDetailBox+    <: fun displayCommandTitleBox+    <: fun displayCommandUsageBox+    <: fun displayCommandOptionsBox+    <: fun displayOptionBox+    <: fun displayOptionBoxes+    <: fun displayOptionUsageBox+    <: fun displayOptionFlagBox+    <: fun displayOptionHelpBox+    <: fun displayMetavarUsageBox+    <: fun displayMetavarBox+    <: val (TableParameters left top 10)+    <: val (ParagraphWidth 50)++-- | *Template*+--+--   Display "title" Help Box+--+--   Display "usage" Help Box+--+--   Display "commands" Help Box+--+--   *Example*+--+--   fs - a utility to copy and move files",+--+--   USAGE+--+--   fs [-h|--help] [-v|--version] [copy] [move]+--+--   OPTIONS+--+--     -h,--help BOOL             Display this help message+--     -v,--version BOOL          Display the version+--+--   COMMANDS+--+--     copy [OPTIONS]          copy a file from SOURCE to TARGET+--     move [OPTIONS]          move a file from SOURCE to TARGET+--+--   fs copy - copy a file from SOURCE to TARGET+--+--     fs copy [-h|--help] [-f|--force] [-r|--retries INT] [SOURCE] [TARGET]+--+--     -h,--help BOOL            Display this help message+--     -f,--force BOOL           Force the action even if a file already exists with the same name+--     -r,--retries INT          number of retries in case of an error+--     SOURCE                    Source path+--     TARGET                    Target path+--+--   fs move - move a file from SOURCE to TARGET+--+--    fs move [-h|--help] [-f|--force] [SOURCE] [TARGET]+--+--       -h,--help BOOL           Display this help message+--       -f,--force BOOL          Force the action even if a file already exists with the same name+--       SOURCE                   Source path+--       TARGET                   Target path+displayAllBox :: Display "title" Help Box -> Display "usage" Help Box -> Display "options" Help Box -> Display "commands" Help Box -> Display "any" Help Box+displayAllBox dt du dos dcs = Display $ \help ->+  vsepNonEmpty+    [ display dt help,+      display du help,+      display dos help,+      display dcs help+    ]++-- | Example+--+--   fs - a utility to copy and move files+--+--   We reused the display for a command title, which should work for either a top-level or a sub command+displayHelpTitleBox :: Display "command-title" Help Box -> Display "title" Help Box+displayHelpTitleBox = coerce++-- | Example+--+--   USAGE+--+--   fs [-h|--help] [-v|--version] [copy] [move]+displayUsageBox :: Display "option-usage" OptionDescription Box -> Display "usage" Help Box+displayUsageBox dou = Display $ \(Help n _ _ _ os cs _) -> do+  let options = display dou <$> os+  let commands = mText . helpCommandName <$> cs+  vsep+    1+    top+    [ "USAGE",+      moveRight 2 $ hsepNonEmpty (mText n : (options <> (brackets <$> commands)))+    ]++-- | Example+--+--   OPTIONS+--+--   -h,--help BOOL             Display this help message+--   -v,--version BOOL          Display the version+displayOptionsBox :: Display "command-options" [OptionDescription] Box -> Display "options" Help Box+displayOptionsBox dos = Display $ \help -> do+  let os = helpCommandFields help+  if null os+    then nullBox+    else+      vsepNonEmpty+        [ "OPTIONS",+          nullBox,+          moveRight 2 (display dos os)+        ]++-- | Example+--+--   COMMANDS+--+--   copy [OPTIONS]          copy a file from SOURCE to TARGET+--   move [OPTIONS]          move a file from SOURCE to TARGET+--+--   fs copy - copy a file from SOURCE to TARGET+--+--     fs copy [-h|--help] [-f|--force] [-r|--retries INT] [SOURCE] [TARGET]+--+--     -h,--help BOOL            Display this help message+--     -f,--force BOOL           Force the action even if a file already exists with the same name+--     -r,--retries INT          number of retries in case of an error+--     SOURCE                    Source path+--     TARGET                    Target path+--+--   fs move - move a file from SOURCE to TARGET+--+--     fs move [-h|--help] [-f|--force] [SOURCE] [TARGET]+--+--     -h,--help BOOL           Display this help message+--     -f,--force BOOL          Force the action even if a file already exists with the same name+--     SOURCE                   Source path+--     TARGET                   Target path+displayCommandsBox :: TableParameters -> Display "command-summary" Help [Box] -> Display "command-detail" Help Box -> Display "commands" Help Box+displayCommandsBox tps commandsSummary commandDetail = Display $ \help -> do+  let cs = helpCommands help+  if null cs+    then nullBox+    else+      vsepNonEmpty+        [ "COMMANDS",+          moveRight 2 $ table tps $ display commandsSummary <$> cs,+          vsepNonEmpty $ display commandDetail <$> cs+        ]++-- | Example+--+--   copy [OPTIONS]          copy a file from SOURCE to TARGET"+displayCommandSummaryBox :: Display "command-summary" Help [Box]+displayCommandSummaryBox = Display $ \(Help n _ s _ os _ isDefault) -> do+  let withOptions = if null os then nullBox else "[OPTIONS]"+  let withDefault = tText $ fromMaybe "" s <> if isDefault then " (default)" else ""+  [mText n <+> withOptions, withDefault]++-- | Example+--+--   fs move - move a file from SOURCE to TARGET+--+--   fs move [-h|--help] [-f|--force] [SOURCE] [TARGET]+--+--     -h,--help BOOL           Display this help message+--     -f,--force BOOL          Force the action even if a file already exists with the same name+--     SOURCE                   Source path+--     TARGET                   Target path+displayCommandDetailBox :: TableParameters -> Display "command-title" Help Box -> Display "command-usage" Help Box -> Display "option" OptionDescription [Box] -> Display "command-detail" Help Box+displayCommandDetailBox tp dct dcu dco = Display $ \h ->+  vsepNonEmpty $+    [ display dct h,+      moveRight 2 $ display dcu h+    ]+      <> [moveRight 2 $ table tp $ display dco <$> helpCommandFields h]++-- | Example+--+--   fs move - move a file from SOURCE to TARGET+--+--    - the parent command name is appended to the command name if the parent is defined+--    - if the command is a default subcommand the name is parenthesized+displayCommandTitleBox :: ParagraphWidth -> Display "command-title" Help Box+displayCommandTitleBox w = Display $ \(Help n p s l _ _ isDefault) -> do+  vsepNonEmpty+    [ hsepNonEmpty $+        catMaybes+          [ tText <$> p,+            (if isDefault then parens else identity) . tText <$> n,+            tText . ("- " <>) <$> s+          ],+      maybe nullBox (moveRight 2) $ paragraph w <$> l+    ]++-- | Example+--+--   fs move [-h|--help] [-f|--force] [SOURCE] [TARGET]+displayCommandUsageBox :: Display "option-usage" OptionDescription Box -> Display "command-usage" Help Box+displayCommandUsageBox dou = Display $ \(Help n p _ _ os _ isDefault) ->+  hsepNonEmpty $+    catMaybes+      [ tText <$> p,+        (if isDefault then parens else identity) . tText <$> n+      ]+      <> (display dou <$> os)++-- | Example+--+--   -h,--help BOOL           Display this help message+--   -f,--force BOOL          Force the action even if a file already exists with the same name+displayCommandOptionsBox :: TableParameters -> Display "option" OptionDescription [Box] -> Display "command-options" [OptionDescription] Box+displayCommandOptionsBox t d = Display $ \os -> table t (display d <$> os)++-- | Example+--+--   -h,--help BOOL           Display this help message+displayOptionBox :: TableParameters -> Display "option" OptionDescription [Box] -> Display "option" OptionDescription Box+displayOptionBox t dos = Display $ \o -> table t [filter (not . isEmpty) (display dos o)]++-- | Example+--+--   -h,--help BOOL           Display this help message+displayOptionBoxes :: Display "option-flag" OptionDescription Box -> Display "option-help" OptionDescription Box -> Display "option" OptionDescription [Box]+displayOptionBoxes df dh = Display $ \o -> [display df o, display dh o]++-- | Example+--+--   [-h|--help]+--   [-f|--file FILE]+displayOptionUsageBox :: Display "metavar-usage" OptionDescription Box -> Display "option-usage" OptionDescription Box+displayOptionUsageBox dmu = Display $ \case+  o@(OptionDescription (Just n) _ (Just s) _ _) ->+    brackets $ hsepNonEmpty [piped [tText $ "-" <> T.singleton s, tText $ "--" <> n], display dmu o]+  o@(OptionDescription _ _ (Just s) _ _) ->+    brackets $ hsepNonEmpty [tText $ "-" <> T.singleton s, display dmu o]+  o@(OptionDescription (Just n) _ _ _ _) ->+    brackets $ hsepNonEmpty [tText $ "--" <> n, display dmu o]+  o@(OptionDescription _ _ _ (Just _) _) ->+    brackets $ display dmu o+  _ -> nullBox++-- | Example+--+--   -h,--help BOOL+displayOptionFlagBox :: Display "metavar" OptionDescription Box -> Display "option-flag" OptionDescription Box+displayOptionFlagBox dm = Display $ \o@(OptionDescription n as s _ _) ->+  hsepNonEmpty+    [ commaed+        ( [ -- short flag+            mText $ ("-" <>) . T.singleton <$> s,+            -- long flag+            mText $ ("--" <>) <$> n+          ]+            -- aliases+            <> (text . ("--" <>) . toS <$> as)+        ),+      display dm o+    ]++-- | Example+--+--   Display this help message+displayOptionHelpBox :: ParagraphWidth -> Display "option-help" OptionDescription Box+displayOptionHelpBox w = Display (mParagraph w . _help)++-- | Display a metavar, except for a switch because it is obvious that it is a boolean+--   or for a String flag+--+--   Example+--+--   FILE+displayMetavarUsageBox :: Display "metavar-usage" OptionDescription Box+displayMetavarUsageBox = Display $ \(OptionDescription _ _ _ m _) ->+  case m of+    Nothing -> ""+    (Just "BOOL") -> ""+    (Just "[CHAR]") -> ""+    Just s -> tText $ s++-- | Display a metavar in a full help text+--+--   [Char] is transformed to String+displayMetavarBox :: Display "metavar" OptionDescription Box+displayMetavarBox = Display $ \(OptionDescription _ _ _ m _) ->+  case m of+    Nothing -> ""+    Just "[CHAR]" -> "STRING"+    Just s -> tText $ s++-- | Return True if a Box is Empty+--   The best we can do is to render the box and compare it to the empty text+isEmpty :: Box -> Bool+isEmpty b = renderBox b == ""++-- | Separate a list of Boxes with a separator+separate :: Box -> [Box] -> Box+separate _ [] = nullBox+separate s ds = punctuateH left s (filter (not . isEmpty) ds)++-- | Separate a list of boxes with a pipe+piped :: [Box] -> Box+piped = separate $ char '|'++-- | Separate a list of boxes with a comma+commaed :: [Box] -> Box+commaed = separate $ char ','++-- | Add brackets to a Box+brackets :: Box -> Box+brackets b = char '[' <:> b <:> char ']'++-- | Add parens to a Box+parens :: Box -> Box+parens b = char '(' <:> b <:> char ')'++-- | Remove empty docs and use hsep+hsepNonEmpty :: [Box] -> Box+hsepNonEmpty = hsep 1 left . filter (not . isEmpty)++-- | Remove empty docs and use hcat+hcatNonEmpty :: [Box] -> Box+hcatNonEmpty = hcat left . filter (not . isEmpty)++-- | Remove empty docs and use vsep+vsepNonEmpty :: [Box] -> Box+vsepNonEmpty = vsep 1 top . filter (not . isEmpty)++-- | Remove empty docs and use vcat+vcatNonEmpty :: [Box] -> Box+vcatNonEmpty = vcat top . filter (not . isEmpty)++-- | Create a box for non empty text+mText :: Maybe Text -> Box+mText Nothing = nullBox+mText (Just t) = text (toS t)++-- | Create a box for a Text value instead of a String+tText :: Text -> Box+tText = text . toS++-- | Non-clashing append operator for boxes+(<:>) :: Box -> Box -> Box+l <:> r = hcat left [l, r]++-- | Render a Box as Text+--   The render function for boxes adds one last newline which we want to avoid+renderBox :: Box -> Text+renderBox = T.intercalate "\n" . T.lines . toS . render++-- | Display a table given a list of rows containing boxes+table :: TableParameters -> [[Box]] -> Box+table _ [] = nullBox+table (TableParameters h v i) rs = do+  -- compute the max height of a row+  let maxCellRows cells = maximum (rows <$> cells)++  -- adjust all the rows so that they have the same height+  let rs' = (\row -> let m = maxCellRows row in alignVert v m <$> row) <$> rs++  -- transpose the rows to get the columns+  -- display them vertically then concatenate the columns horizontally+  hsep i h $ vcat v <$> transpose rs'++-- | Create a paragraph for some Text, wrapping the text at paragraph width+paragraph :: ParagraphWidth -> Text -> Box+paragraph (ParagraphWidth w) = para left w . toS++-- | Create a paragraph for an option piece of text+mParagraph :: ParagraphWidth -> Maybe Text -> Box+mParagraph _ Nothing = nullBox+mParagraph w (Just t) = paragraph w t++-- | Width of paragraph, used in conjunction with the 'paragraph' function+newtype ParagraphWidth = ParagraphWidth Int deriving (Eq, Show, Num)++-- | Those parameters are used when creating a table with the+--   'table' function+data TableParameters = TableParameters+  { horizontalAlignment :: Alignment,+    verticalAlignment :: Alignment,+    intercolumn :: Int+  }+  deriving (Eq, Show)
+ src/Data/Registry/Options/FieldConfiguration.hs view
@@ -0,0 +1,28 @@+-- | Configuration of fields from+--   field names given as singleton string types+--   For example in the `Parser "myField" MyType+--   @myField@ is used to create an option name like @--my-field@ (by default)+module Data.Registry.Options.FieldConfiguration where++import Data.Registry.Options.Text+import qualified Data.Text as T+import Protolude+import qualified Prelude++-- | These options are used at runtime to take a field name and build its short/long name + metavar+data FieldConfiguration = FieldConfiguration+  { -- | make a short name from a field name. For example @"force" -> \'f\'@+    makeShortName :: Text -> Char,+    -- | make a long name from a field name. For example @"forceCopy" -> 'force-copy'@+    makeLongName :: Text -> Text,+    -- | describe the type of a field from its name. For example @"sourceFile" -> "File"@+    makeMetavar :: Text -> Text+  }++-- | The default options are taking a Package1.Package2.camelCase name and+--    - creating a short name = "c"+--    - creating a long name = "camel-case"+--    - creating a metavar = "CAMELCASE"+defaultFieldConfiguration :: FieldConfiguration+defaultFieldConfiguration =+  FieldConfiguration (Prelude.head . toS . dropQualifier) (camelCaseToHyphenated . dropQualifier) (T.toUpper . dropQualifier)
+ src/Data/Registry/Options/Help.hs view
@@ -0,0 +1,82 @@+-- | Support for storing help messages associated to options+--   and for displaying a full help message+module Data.Registry.Options.Help where++import Data.Registry.Options.OptionDescription hiding (help)+import Protolude hiding (Any)++-- | This data type contains optional fields describing+--   either a full command or just a single option+--   A command refers to a list of command fields but can also contain subcommands+data Help = Help+  { -- | name of a command+    helpCommandName :: Maybe Text,+    -- | name of the parent command+    helpParentCommandName :: Maybe Text,+    -- | short description of a command+    helpCommandShortDescription :: Maybe Text,+    -- | long description of a command+    helpCommandLongDescription :: Maybe Text,+    -- | list of fields for a given command. Each option description contains some help text+    helpCommandFields :: [OptionDescription],+    -- | list of subcommands+    helpCommands :: [Help],+    -- | True if the command name is the default subcommand when not mentioned explicitly+    helpDefaultSubcommand :: Bool+  }+  deriving (Eq, Show)++-- | Function updating the help+type HelpUpdate = Help -> Help++-- | Create a Help from a list of updates+makeHelp :: [HelpUpdate] -> Help+makeHelp = foldl (\r u -> u r) mempty++-- | Empty Help description+noHelp :: Help+noHelp = Help mempty mempty mempty mempty mempty mempty False++-- | Create a Help value with a short command description+shortDescription :: Text -> HelpUpdate+shortDescription t h = h {helpCommandShortDescription = Just t}++-- | Create a Help value with a long command description+longDescription :: Text -> HelpUpdate+longDescription t h = h {helpCommandLongDescription = Just t}++-- | Create a Help value with a command name, a long and a short description+commandHelp :: Text -> Text -> Text -> Help+commandHelp n s l = Help (Just n) Nothing (Just s) (Just l) mempty mempty False++-- | Create a Help value with no command name+noCommandName :: Help -> Help+noCommandName h = h {helpCommandName = Nothing}++-- | Set the current subcommand as the default one+defaultSubcommand :: Help -> Help+defaultSubcommand h = h {helpDefaultSubcommand = True}++instance Semigroup Help where+  Help n1 p1 s1 l1 fs1 cs1 d1 <> Help n2 p2 s2 l2 fs2 cs2 d2 = do+    let subcommands = (\c -> c {helpParentCommandName = n1 <|> n2}) <$> (cs1 <> cs2)+    Help (n1 <|> n2) (p1 <|> p2) (s1 <|> s2) (l1 <|> l2) (fs1 <> fs2) subcommands (d1 || d2)++instance Monoid Help where+  mempty = noHelp+  mappend = (<>)++-- | Create a Help description for the alternative of 2 different help descriptions+--   This function is used for collecting the helps of 2 parsers when using the @<|>@ operator+--+--    - two commands end-up being the subcommands of the alternative+--    - a command alternated with some fields becomes a subcommand+alt :: Help -> Help -> Help+alt h1@(Help (Just _) _ _ _ _ _ _) h2@(Help (Just _) _ _ _ _ _ _) = noHelp {helpCommands = [h1, h2]}+alt (Help Nothing _ _ _ fs1 cs1 _) h2@(Help (Just _) _ _ _ _ _ _) = noHelp {helpCommandFields = fs1, helpCommands = cs1 <> [h2]}+alt h1@(Help (Just _) _ _ _ _ _ _) (Help Nothing _ _ _ fs2 cs2 _) = noHelp {helpCommandFields = fs2, helpCommands = h1 : cs2}+alt (Help Nothing _ _ _ fs1 cs1 _) (Help Nothing _ _ _ fs2 cs2 _) = noHelp {helpCommandFields = fs1 <> fs2, helpCommands = cs1 <> cs2}++-- | Create a Help value from the description of a simple option+fromCliOption :: OptionDescription -> Help+fromCliOption o = noHelp {helpCommandFields = [o]}
+ src/Data/Registry/Options/Lexemes.hs view
@@ -0,0 +1,295 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | This module parses strings coming from the command line+--   and tries to classify them as:+--+--     - option names + their associated values+--     - flag names+--     - arguments+--+--    It is however not always possible to know if a given list of string is:+--+--      - an option name + some values: find --files file1 file2+--      - a flag name + some arguments: copy --force source target+--+--    During lexing we leave this last case as "ambiguous".+--    This will be disambiguated during parsing where we know if+--    a given name is an option or a flag.+module Data.Registry.Options.Lexemes where++import Data.List qualified as L+import Data.Map.Strict qualified as Map+import Data.MultiMap (MultiMap)+import Data.MultiMap qualified as M+import Data.Text qualified as T+import Protolude as P+import Prelude (show)++-- | This data type helps pre-parsing option names and values+data Lexemes = Lexemes+  { -- | list of option names and associated values+    lexedOptions :: MultiMap Text Text,+    -- | list of flag names+    lexedFlags :: [Text],+    -- | list of argument values+    lexedArguments :: [Text],+    -- | possible ambiguous case: option + values or flag + arguments+    lexedAmbiguous :: Maybe (Text, [Text])+  }+  deriving (Eq, Show)++instance Semigroup Lexemes where+  (<>) = union++instance Monoid Lexemes where+  mempty = Lexemes M.empty mempty mempty Nothing+  mappend = (<>)++-- | Concatenate 2 lists of lexemes+union :: Lexemes -> Lexemes -> Lexemes+union (Lexemes m1 fs1 as1 am1) (Lexemes m2 fs2 as2 am2) =+  Lexemes+    (M.fromList $ M.toList m1 <> M.toList m2)+    (fs1 <> fs2)+    (as1 <> as2)+    (am1 <|> am2)++-- | Override the values from one Lexemes with the values from another+--   This is a bit tricky since ambiguous option/flags coming from the command can eventually+--   be detected to be valid options / flags when parsed as such in the environment or in a config file+override :: Lexemes -> Lexemes -> Lexemes+override (Lexemes m1 fs1 as1 am1) (Lexemes m2 fs2 as2 am2) =+  Lexemes+    mergeOptions+    (mergeMax fs1 fs2)+    (as1 <> as2)+    mergeAmbiguous+  where+    -- merge 2 lists so that every unique element of each list is present+    -- if there are duplicates in one list or the other, the max number of duplicates is kept+    mergeMax :: [Text] -> [Text] -> [Text]+    mergeMax vs1 vs2 = do+      let g1 = groupByEq vs1+      let g2 = groupByEq vs2+      join . Map.elems $ Map.unionWith (\v1 v2 -> if length v1 >= length v2 then v1 else v2) g1 g2++    groupByEq :: Ord a => [a] -> Map a [a]+    groupByEq = M.toMap . M.fromList . fmap (\a -> (a, a))++    mergeOptions = do+      let allOptions = M.fromMap . Map.fromList $ M.assocs m1 <> M.assocs m2+      case (am1, am2) of+        -- no ambiguous options+        (Nothing, Nothing) -> allOptions+        (Just _, Nothing) -> allOptions+        (_, Just (t2, v2)) ->+          if t2 `elem` M.keys allOptions then M.fromMap $ Map.fromList (M.assocs allOptions <> [(t2, v2)]) else allOptions++    mergeAmbiguous =+      case (am1, am2) of+        (Nothing, Nothing) -> Nothing+        (Just _, Just (t2, vs2)) -> Just (t2, vs2)+        (Just (t1, vs1), Nothing) ->+          if t1 `elem` M.keys m2 then Nothing else Just (t1, vs1)+        (Nothing, Just (t2, vs2)) ->+          if t2 `elem` M.keys m1 then Nothing else Just (t2, vs2)++-- * Create lexemes++-- | Lex some input arguments+--   They are first stripped of additional whitespace+--   and empty strings are removed (there shouldn't be any though, coming from the command line)+lexArgs :: [Text] -> Lexemes+lexArgs = mkLexemes . filter (not . T.null) . fmap T.strip++-- | Lex some input arguments+mkLexemes :: [Text] -> Lexemes+mkLexemes [] = mempty+mkLexemes ("--" : rest) = argsLexemes rest+mkLexemes [t] =+  -- this is either a single flag or an argument+  if isDashed t+    then -- if there is an = sign this an option++      if "=" `T.isInfixOf` t+        then makeEqualOptionLexeme t+        else makeFlagsLexeme t+    else argLexemes (dropDashed t)+mkLexemes (t : rest) =+  -- if we get an option name+  if isDashed t+    then -- if the option value is appended directly to the option name++      if "=" `T.isInfixOf` t+        then makeEqualOptionLexeme t <> mkLexemes rest+        else -- otherwise+        do+          let key = dropDashed t+          let (vs, others) = L.break isDashed rest+          -- if there are no values after the option name, we have a flag+          if null vs+            then makeFlagsLexeme t <> mkLexemes others+            else -- otherwise++            -- if there are additional options/flags, then we collect values for the+            -- current option and make lexemes for the rest++              if any isDashed others+                then optionsLexemes key vs <> mkLexemes others+                else -- this case is ambiguous, possibly the values are repeated values for an option+                -- or the option is a flag with no values and all the rest are arguments+                  ambiguousLexemes key rest+    else argLexemes t <> mkLexemes rest++-- | Create lexemes for an option name + an option value+optionLexemes :: Text -> Text -> Lexemes+optionLexemes k = optionsLexemes k . pure++-- | Create lexemes for an option name + a list of option values+optionsLexemes :: Text -> [Text] -> Lexemes+optionsLexemes k vs = Lexemes (M.fromList ((k,) <$> vs)) mempty mempty Nothing++-- | Create an option for --option=value or -o=value+--   Return mempty if no equal sign is present+makeEqualOptionLexeme :: Text -> Lexemes+makeEqualOptionLexeme t = do+  case T.splitOn "=" (dropDashed t) of+    [optionName, optionValue] -> optionLexemes optionName optionValue+    -- this case should not happen+    _ -> mempty++-- | Create lexemes for a list of potentially short flag names+--   e.g. makeFlagsLexeme "-opq" === flagsLexemes ["o", "p", "q"]+makeFlagsLexeme :: Text -> Lexemes+makeFlagsLexeme t =+  ( if isSingleDashed t+      then -- split the letters+        flagsLexemes . fmap T.singleton . T.unpack+      else flagLexemes+  )+    (dropDashed t)++-- | Create lexemes for a flag name+flagLexemes :: Text -> Lexemes+flagLexemes = flagsLexemes . pure++-- | Create lexemes for a list of flag names+flagsLexemes :: [Text] -> Lexemes+flagsLexemes fs = Lexemes M.empty fs mempty Nothing++-- | Create lexemes for an argument value+argLexemes :: Text -> Lexemes+argLexemes = argsLexemes . pure++-- | Create lexemes for several arguments+argsLexemes :: [Text] -> Lexemes+argsLexemes ts = Lexemes M.empty mempty ts Nothing++-- | Create lexemes an ambiguous flag an its values+--   Later parsing will indicate if the name is an option names and the values the option values+--   or if this is a flag + arguments+ambiguousLexemes :: Text -> [Text] -> Lexemes+ambiguousLexemes t ts = Lexemes M.empty mempty mempty (Just (t, ts))++-- | Return the possible list of argument values to parse from+--   Note that there can be ambiguous flags+getArguments :: Lexemes -> [Text]+getArguments (Lexemes _ _ as Nothing) = as+getArguments (Lexemes _ _ as1 (Just (_, as2))) = as1 <> as2++-- | Return option/flag names from lexed values+getFlagNames :: Lexemes -> [Text]+getFlagNames (Lexemes m fs _ am) = M.keys m <> fs <> (fst <$> toList am)++-- | Return a value for a given name+--   This can be a value associated to a given option+--   or just a flag name acting as a value to decode+--   (the value can also come from an ambiguous option value)+getValue :: Text -> Lexemes -> Maybe (Maybe Text)+getValue key (Lexemes options flags _ ambiguous) =+  case headMay (M.lookup key options) of+    Just v -> Just (Just v)+    Nothing ->+      case find (== key) flags of+        Just _ -> Just Nothing+        Nothing -> Just <$> getAmbiguousValue ambiguous+  where+    getAmbiguousValue Nothing = Nothing+    getAmbiguousValue (Just (k, vs)) =+      if k == key+        then headMay vs+        else Nothing++-- | Remove the value associated to an option name+--   The value might be:+--     - associated to an option name+--     - the name of a flag+--     - associated to an ambiguous flag name+popOptionValue :: Text -> Lexemes -> Lexemes+popOptionValue key ls =+  ls+    { lexedOptions = pop key $ lexedOptions ls,+      lexedFlags = filter (/= key) $ lexedFlags ls,+      lexedAmbiguous = case lexedAmbiguous ls of+        Just (k, []) | k == key -> Nothing+        Just (k, _ : as) | k == key -> Just (k, as)+        other -> other+    }++-- | Remove an argument value+--   first from the list of arguments if there are some`+--   otherwise remove a value in the list of values associated to an ambiguous flag+popArgumentValue :: Lexemes -> Lexemes+popArgumentValue ls =+  case lexedArguments ls of+    (_ : as) -> ls {lexedArguments = as}+    [] ->+      ls+        { lexedAmbiguous = case lexedAmbiguous ls of+            Nothing -> Nothing+            Just (_, []) -> Nothing+            Just (k, _ : as) -> Just (k, as)+        }++-- | Remove a flag+--   If the flag is actually an ambiguous flag with some associated values then+--   this means that those values were arguments and need to be treated as such+popFlag :: Text -> Lexemes -> Lexemes+popFlag f ls = do+  let (before, after) = L.break (== f) $ lexedFlags ls+  let (args, amb) =+        case lexedAmbiguous ls of+          Just (k, vs) | f == k -> (vs <> lexedArguments ls, Nothing)+          other -> (lexedArguments ls, other)++  ls+    { lexedFlags = before <> drop 1 after,+      lexedArguments = args,+      lexedAmbiguous = amb+    }++-- | Return True if some text starts with `-`+isDashed :: Text -> Bool+isDashed = T.isPrefixOf "-"++-- | Return True if some text starts with `-` but not with `--`+isSingleDashed :: Text -> Bool+isSingleDashed t = T.isPrefixOf "-" t && not (T.isPrefixOf "-" (T.drop 1 t))++-- | Drop dashes in front of a flag name+dropDashed :: Text -> Text+dropDashed = T.dropWhile (== '-')++-- * MultiMap functions++instance (Show k, Show v) => Show (MultiMap k v) where+  show = P.show . M.assocs++instance (Eq k, Eq v) => Eq (MultiMap k v) where+  m1 == m2 = M.assocs m1 == M.assocs m2++-- | Drop the first value associated to a key in the map+--   If a key has no more values drop the key+pop :: (Ord k) => k -> MultiMap k v -> MultiMap k v+pop key m =+  M.fromMap $ Map.fromList $ filter (not . null . snd) $ (\(k, vs) -> if k == key then (k, drop 1 vs) else (k, vs)) <$> M.assocs m
+ src/Data/Registry/Options/Main.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}++-- | This module provides top level functions to create a parser from+--   its definition and feed it values coming from various sources (command line, environment, configuration file)+--   to parse a command+module Data.Registry.Options.Main where++import Data.Registry+import Data.Registry.Options.Parser+import Data.Registry.Options.Sources+import Protolude++-- | Run a parser defined in a registry with values coming from default sources+run :: forall s a m. (KnownSymbol s, Typeable a, MonadIO m) => Registry _ _ -> m (Either Text a)+run = runWith @s @a @m (const sources)++-- | Run a parser defined in a registry with values coming from modified sources+--   using the setter functions defined in 'Data.Registry.Options.Sources'+runWith :: forall s a m. (KnownSymbol s, Typeable a, MonadIO m) => (Registry _ _ -> Registry _ _) -> Registry _ _ -> m (Either Text a)+runWith  sourcesModifications  parserRegistry = do+  let parser = make @(Parser s a) parserRegistry+  let os = getOptionNames parser+  lexemes <- getLexemesWith (sourcesModifications . setOptionNames os)+  pure $ fst <$> parseLexed parser lexemes
+ src/Data/Registry/Options/OptionDescription.hs view
@@ -0,0 +1,83 @@+-- | Description for options+--   A option has a long name (unless it's an argument), a short name, a metavar (its type), a help text+module Data.Registry.Options.OptionDescription where++import Data.Registry.Options.Text+import Data.Text qualified as T+import Protolude as P++-- | Optional values used to document a command line option+--+--     - 'name' is a "long" name, like @launch-missiles@+--     - 'short' is just a character, like @l@+--     - 'metavar' describes the type of value which is expected, like @BOOL@+--     - 'help' is a piece of text describing the usage of the option, like @"destroy everything"@+data OptionDescription = OptionDescription+  { _name :: Maybe Text,+    _aliases :: [Text],+    _shortName :: Maybe Char,+    _metavar :: Maybe Text,+    _help :: Maybe Text+  }+  deriving (Eq, Show)++-- | The Semigroup instance is used to collect several descriptions and+--   aggregate them together, for example name @"force" <> short \'f\'@+--+--   The second option always takes precedence on the first one+--   for example metavar @"m1" <> metavar "m2" == metavar "m2"@+instance Semigroup OptionDescription where+  OptionDescription n1 as1 s1 m1 h1 <> OptionDescription n2 as2 s2 m2 h2 =+    OptionDescription (n2 <|> n1) (as1 <> as2) (s2 <|> s1) (m2 <|> m1) (h2 <|> h1)++instance Monoid OptionDescription where+  mempty = OptionDescription Nothing mempty Nothing Nothing Nothing+  mappend = (<>)++-- | Function updating an OptionDescription+type OptionDescriptionUpdate = OptionDescription -> OptionDescription++-- | List of description updates+type OptionDescriptionUpdates = [OptionDescriptionUpdate]++-- | Apply a list of option description updates, from left to right,+--   to the empty description+makeOptionDescription :: OptionDescriptionUpdates -> OptionDescription+makeOptionDescription = foldl (\r u -> u r) mempty++-- | Create an 'OptionDescriptionUpdate' with a long hyphenated name, for example @name "collect-all"@+name :: Text -> OptionDescriptionUpdate+name t o = o {_name = Just t}++-- | Create an 'OptionDescriptionUpdate' with an alias for a given name+alias :: Text -> OptionDescriptionUpdate+alias t o = o {_aliases = [t]}++-- | Create an 'OptionDescriptionUpdate' with a short name, for example @short \'q\'@+short :: Char -> OptionDescriptionUpdate+short t o = o {_shortName = Just t}++-- | Create an 'OptionDescriptionUpdate' with specifying that there must be no short name+noShort :: OptionDescriptionUpdate+noShort o = o {_shortName = Nothing}++-- | Create an 'OptionDescriptionUpdate' with a metavar to indicate the type of an option, for example @metavar "FILE"@+metavar :: Text -> OptionDescriptionUpdate+metavar t o = o {_metavar = Just t}++-- | Create an 'OptionDescriptionUpdate' with some help text, for example @help "force the copy"@+help :: Text -> OptionDescriptionUpdate+help t o = o {_help = Just t}++-- | Display a 'OptionDescription' name+--   as a hyphenated name+--   return @<empty>@ if no name has been defined yet+displayCliOptionName :: OptionDescription -> Text+displayCliOptionName o =+  case getNames o of+    n : _ -> camelCaseToHyphenated n+    [] -> fromMaybe "<empty>" (_metavar o)++-- | Return the possible names for an 'OptionDescription' if they are defined+getNames :: OptionDescription -> [Text]+getNames o = catMaybes [_name o, T.singleton <$> _shortName o] <> _aliases o
+ src/Data/Registry/Options/Parser.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE PartialTypeSignatures #-}++-- | Main module for creating option parsers+module Data.Registry.Options.Parser where++import Data.Coerce+import Data.Dynamic+import Data.Registry (ApplyVariadic, Typed, funTo)+import Data.Registry.Options.Decoder+import Data.Registry.Options.DefaultValues+import Data.Registry.Options.FieldConfiguration+import Data.Registry.Options.Help+import Data.Registry.Options.Lexemes+import Data.Registry.Options.OptionDescription+import Data.Registry.Options.Text+import Data.Text qualified as T+import GHC.TypeLits+import Protolude+import Type.Reflection++-- | A Parser is responsible for parsing a value of type a+--   for to be used as "s" where s is a Symbol+--   For example "s" can be the name of a field, `force` in a data type+--+--   A Parser generally returns all the original lexemes values minus the option name and value just parsed+--   This is a bit different for positional arguments for example where the whole list of lexemes values is kept+data Parser (s :: Symbol) a = Parser+  { parserHelp :: Help,+    parseLexed :: Lexemes -> Either Text (a, Lexemes)+  }+  deriving (Functor)++instance Applicative (Parser s) where+  pure a = Parser noHelp (\ls -> Right (a, ls))++  Parser h1 f <*> Parser h2 fa = Parser (h1 <> h2) $ \ls -> do+    (l, ls1) <- f ls+    (a, ls2) <- fa ls1+    pure (l a, ls2)++instance Alternative (Parser s) where+  empty = Parser noHelp (const $ Left "nothing to parse")++  Parser h1 p1 <|> Parser h2 p2 = Parser (h1 `alt` h2) $ \lexemes ->+    case p1 lexemes of+      Right a -> Right a+      _ -> p2 lexemes++-- | This data type indicates if an argument must be parsed at a specific position+--   This changes the parsing since positional arguments do not consume lexemes+data Positional = Positional | NonPositional deriving (Eq, Show)++-- | This parser does not consume anything but always succeeds.+--   It is a unit for the @*>@ operator+unitParser :: Parser s ()+unitParser = Parser noHelp $ \ls -> Right ((), ls)++-- | Add some help description to a Parser+addParserHelp :: Help -> Parser s a -> Parser s a+addParserHelp h p = setParserHelp (parserHelp p <> h) p++-- | Set some help description on a Parser+setParserHelp :: Help -> Parser s a -> Parser s a+setParserHelp h p = p {parserHelp = h}++-- | Retrieve all the option names for this parser+--   by extracting the help and collecting option names for the top level command+--   and the subcommands+getOptionNames :: Parser s a -> [Text]+getOptionNames p =+  go (parserHelp p)+  where+    go (Help _ _ _ _ os cs _) =+      catMaybes (_name <$> os) <> concat (_aliases <$> os) <>+      (go =<< cs)++-- | The Command type can be used to create+--   parsers which are not given a specific role+type Command = "Command"++-- | All parsers can be used to parse a command+coerceParser :: Parser s a -> Parser t a+coerceParser = coerce++-- | Command line arguments can be parsed with a specific and either return an error+--   if there is nothing to parse, or if the parse is not successful+parseArgs :: Parser s a -> [Text] -> Either Text a+parseArgs p = fmap fst . parseLexed p . lexArgs++-- | Shortcut for parsing some text by splitting it on spaces+parse :: Parser s a -> Text -> Either Text a+parse p = parseArgs p . fmap T.strip . T.splitOn " "++-- | Create a Parser a for a given constructor of type a+--   by using the Applicative instance of a Parser+parserOf :: forall a b. (ApplyVariadic (Parser Command) a b, Typeable a, Typeable b) => a -> Typed b+parserOf = funTo @(Parser Command)++-- | Make a Parser for a @Maybe@ type.+--   If the original parser does not succeeds this parser+--   returns @Nothing@ and does not consume anything+maybeParser :: Parser s a -> Parser s (Maybe a)+maybeParser (Parser h p) = Parser h $ \lexemes ->+  case p lexemes of+    Right (a, ls) -> Right (Just a, ls)+    Left _ -> Right (Nothing, lexemes)++-- | Make a Parser for a @List@ type.+--   This works by repeatedly applying the original parser to+--   inputs (and appending results) until the parser fails in which case @[]@ is returned+listParser :: Parser s a -> Parser s [a]+listParser parser@(Parser h p) = Parser h $ \lexemes ->+  case p lexemes of+    Right (a, ls) ->+      case parseLexed (listParser parser) ls of+        Right (as, ls') -> Right (a : as, ls')+        Left e -> Left e+    Left _ -> Right ([], lexemes)++-- | Make a Parser for a @List@ type where at least one value is expected to be parsed+list1Parser :: Parser s a -> Parser s [a]+list1Parser = fmap toList . nonEmptyParser++-- | Make a Parser for a @NonEmpty@ type+--   (this means that least one value is expected to be parsed)+nonEmptyParser :: Parser s a -> Parser s (NonEmpty a)+nonEmptyParser parser@(Parser h p) = Parser h $ \lexemes ->+  case p lexemes of+    Right (a, ls) ->+      case parseLexed (listParser parser) ls of+        Right (as, ls') -> Right (a :| as, ls')+        Left e -> Left e+    Left e -> Left e++-- | Create a Parser for command-line field given:+--     - fieldOptions to derive long/short/metavar names from a field name+--     - a field name. If it is missing, then we can only parse arguments+--     - a field type. We use the type to make a METAVAR+--     - additional OptionDescription to either override the previous values, or to add the field help+--     - an optional default value for the field: the value to use if the field is missing+--     - an optional active value for the field: the value to use if the field is present+--     - a Decoder to read the value as text+parseField :: forall s a. (KnownSymbol s, Typeable a, Show a) => FieldConfiguration -> Positional -> Text -> OptionDescriptionUpdates -> DefaultValue s a -> ActiveValue s a -> Decoder a -> Parser s a+parseField fieldOptions pos fieldType os = do+  let fieldName = if pos == Positional then Nothing else Just $ getSymbol @s+  let shortName = maybe identity (\f -> short $ makeShortName fieldOptions f) fieldName+  let longName = maybe identity (name . toS . makeLongName fieldOptions) fieldName+  parseWith ([shortName, longName, metavar (makeMetavar fieldOptions fieldType)] <> os)++-- | Create a parser for a given field given:+--     - its name(s)+--     - an optional default value for the field: the value to use if the field is missing+--     - an optional active value for the field: the value to use if the field is present+--     - a Decoder to read the value as text+parseWith :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> DefaultValue s a -> ActiveValue s a -> Decoder a -> Parser s a+parseWith os defaultValue activeValue d = do+  Parser (fromCliOption cliOption) $ \ls ->+    case getNames cliOption of+      -- named option, flag or switch+      ns@(_:_) ->+        case takeOptionValue ns ls of+          Nothing ->+            (,ls) <$> returnDefaultValue+          Just (_, Nothing, ls') ->+            (,ls') <$> returnActiveValue+          Just (k, Just v, ls') ->+            -- if we have a flag, then the value v just retrieved is an argument+            -- in that case we move all the values for that flag to arguments+            case getActiveValue activeValue of+              Just active -> pure (active, popFlag k ls)+              Nothing -> (,ls') <$> decode d v+      -- arguments+      [] ->+        case takeArgumentValue ls of+          Nothing -> (,ls) <$> returnDefaultValue+          Just (a, ls') -> (,ls') <$> decode d a+  where+    cliOption = makeOptionDescription os++    returnActiveValue = case getActiveValue activeValue of+      Just def -> pure def+      Nothing -> Left $ "missing active value for argument: " <> displayCliOptionName cliOption++    returnDefaultValue = case getDefaultValue defaultValue of+      Just def -> pure def+      Nothing -> Left $ "missing default value for argument: " <> displayCliOptionName cliOption++-- | Find a value for a given option name+--   return Nothing if the name is not found+--   If the name is found return+--     - Nothing if there is no value+--     - the first value for that name if there is is one and remove the value associated to the flag+--   if there aren't any values left associated to a flag, remove it+takeOptionValue :: [Text] -> Lexemes -> Maybe (Text, Maybe Text, Lexemes)+takeOptionValue names lexemes = do+  headMay $ mapMaybe takeValue (camelCaseToHyphenated <$> names)+  where+    takeValue :: Text -> Maybe (Text, Maybe Text, Lexemes)+    takeValue key =+      case getValue key lexemes of+        Nothing -> Nothing+        Just v -> Just (key, v, popOptionValue key lexemes)++-- | Take the first argument value available and remove it from the list+--   of lexed arguments+takeArgumentValue :: Lexemes -> Maybe (Text, Lexemes)+takeArgumentValue lexemes = do+  case getArguments lexemes of+    [] -> Nothing+    (a : _) -> Just (a, popArgumentValue lexemes)++-- | Return the textual representation of a symbol (this is a fully qualified string)+getSymbol :: forall s. (KnownSymbol s) => Text+getSymbol = toS $ symbolVal @s Proxy++-- | Return the type of a value as Text+showType :: forall a. Typeable a => Text+showType = show $ someTypeRep (Proxy :: Proxy a)
+ src/Data/Registry/Options/Parsers.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}++-- | Common parsers for options+--+--    - 'option' specifies a named value on the command line+--    - 'flag' specifies a value derived from the presence of the flag+--    - 'named' specifies a value derived from the name of a flag+--    - 'switch' specifies a flag with a boolean value+--    - 'argument' specifies a value not delimited by an option name, the first string value is parsed+--    - 'positional' specifies an argument which is expected to be at a specific place in the list of arguments+module Data.Registry.Options.Parsers where++import Data.Dynamic+import Data.Either+import Data.Registry+import Data.Registry.Options.OptionDescription+import Data.Registry.Options.Decoder+import Data.Registry.Options.DefaultValues+import Data.Registry.Options.FieldConfiguration+import Data.Registry.Options.Help+import Data.Registry.Options.Lexemes+import Data.Registry.Options.Parser+import GHC.TypeLits+import Protolude++-- | Create an option:+--     - with a short/long name+--     - a metavar+--     - no active/default values+--+--   The OptionDescriptionUpdates list can be used to override values or provide a help+option :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _+option os = do+  let fieldType = showType @a+  fun (\fieldOptions -> parseField @s @a fieldOptions NonPositional fieldType os)+    <+ setNoDefaultValues @s @a++-- | Create a parser for a list of values+options :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _+options os = fun (listParser @s @a) <+ option @s @a os++-- | Create a parser for an optional value+optionMaybe :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _+optionMaybe os = fun (maybeParser @s @a) <+ option @s @a os++-- | Create a flag:+--     - with a short/long name+--     - a metavar+--     - an active value+--     - an optional default value+--+--   The OptionDescriptionUpdates list can be used to override values or provide a help+flag :: forall s a. (KnownSymbol s, Typeable a, Show a) => a -> Maybe a -> OptionDescriptionUpdates -> Registry _ _+flag activeValue defaultValue os = do+  let fieldType = showType @a+  fun (\fieldOptions -> parseField @s @a fieldOptions NonPositional fieldType os)+    <+ maybe noDefaultValue (setDefaultValue @s @a) defaultValue+    <+ setActiveValue @s @a activeValue++-- | Create a flag where the name of the flag can be decoded as a value:+--   The OptionDescriptionUpdates list can be used to override values or provide a help+named :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _+named os = do+  let fieldType = showType @a+  let p = \(decoder :: Decoder a) (defaultValue :: DefaultValue s a) -> Parser @s @a (fromCliOption $ makeOptionDescription os) $ \ls -> do+        case partitionEithers $ (\n -> (n,) <$> decode decoder n) <$> getFlagNames ls of+          (_, (f, a) : _) -> Right (a, popFlag f ls)+          _ -> case getDefaultValue defaultValue of+            Just def -> pure (def, ls)+            _ -> Left $ "Flag not found for data type `" <> fieldType <> "`"+  fun p+    <+ setNoDefaultValues @s @a++-- | Create a switch:+--     - with a short/long name+--     - a metavar+--     - an active value: True+--     - an default value: False+--+--   The OptionDescriptionUpdates list can be used to override values or provide a help+switch :: forall s. (KnownSymbol s) => OptionDescriptionUpdates -> Registry _ _+switch os = do+  let fieldType = showType @Bool+  fun (\fieldOptions -> parseField @s @Bool fieldOptions NonPositional fieldType os)+    <+ setDefaultValue @s False+    <+ setActiveValue @s True++-- | Create an argument:+--     - with no short/long names+--     - a metavar+--     - no active/default values+--+--   The OptionDescriptionUpdates list can be used to override values or provide a help+--+--   When the argument is read, its value is removed from the list of lexed values+argument :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _+argument os = do+  let fieldType = showType @a+  fun (\fieldOptions -> parseField @s @a fieldOptions Positional fieldType os)+    <+ setNoDefaultValues @s @a++-- | Create a parser for a list of arguments+arguments :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _+arguments os = fun (listParser @s @a) <+ argument @s @a os++-- | Create a positional argument, to parse the nth value (starting from 0):+--     - with no short/long names+--     - a metavar+--     - no active/default values+--+--   The OptionDescriptionUpdates list can be used to override values or provide a help+--+--   When the argument is read, its value is left in the list of lexed values+positional :: forall s a. (KnownSymbol s, Typeable a, Show a) => Int -> OptionDescriptionUpdates -> Registry _ _+positional n os = do+  let p fieldOptions = \d -> do+        let o = makeOptionDescription $ metavar (makeMetavar fieldOptions (showType @a)) : os+        Parser @s @a (fromCliOption o) $ \ls -> do+          -- take element at position n and make sure to keep all the other+          -- arguments intact because we need their position to parse them+          case headMay . drop n $ getArguments ls of+            Nothing -> Left $ "No argument to parse at position " <> show n+            Just arg ->+              case decode d arg of+                Left e -> Left e+                Right v -> Right (v, ls)++  fun p+    <+ setNoDefaultValues @s @a++-- | Set an active value for a given field name and field type+setActiveValue :: forall s a. (KnownSymbol s, Typeable a) => a -> Typed (ActiveValue s a)+setActiveValue = fun . createActiveValue @s @a++-- | Set a default value for a given field name and field type+setDefaultValue :: forall s a. (KnownSymbol s, Typeable a) => a -> Typed (DefaultValue s a)+setDefaultValue = fun . createDefaultValue @s @a++-- | Allow to specify that a given field name and type has some default/active values+setDefaultValues :: forall s a. (KnownSymbol s, Typeable a) => Maybe a -> Maybe a -> Registry _ _+setDefaultValues defaultValue activeValue =+  maybe (noDefaultValue @s) (setDefaultValue @s) defaultValue+    <+ maybe (noActiveValue @s) (setActiveValue @s) activeValue++-- | Allow to specify that a given field name and type has no default/active values+setNoDefaultValues :: forall s a. (KnownSymbol s, Typeable a) => Registry _ _+setNoDefaultValues =+  noDefaultValue @s @a+    <+ noActiveValue @s @a+    <+ val (mempty :: OptionDescription)++-- * Template Haskell++-- | This function is used by the TH module to parse a command name at the beginning+--   of a list of arguments+commandNameParser :: Text -> Parser Command ()+commandNameParser cn = Parser noHelp $ \ls ->+  case lexedArguments ls of+    [] -> Left $ "no arguments found, expected command: " <> cn+    n : _ ->+      if n == cn+        then Right ((), popArgumentValue ls)+        else Left $ "expected command: " <> cn <> ", found: " <> n
+ src/Data/Registry/Options/Sources.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | This module provides way to get option values from different sources:+--+--     - the command line+--     - the system environment variables+--     - a YAML configuration file+--+--   A registry is used to bring some extensibility:+--+--     - change the configuration file name+--     - change the mapping between option names and environment variable names+--     - change the mapping between options names and yaml names+--+--  Here is an example:+--+--  getLexemesWith (+--    -- restrict the env / config file search to the options of a given parser+--    setOptionNames (getOptionNames parser) .+--    -- change the config file path+--    setConfigFilePath "~/.config" .+--    -- change the config for retrieving environment variables based on option names+--    setEnvironmentNames env1 .+--    -- change the config for retrieving yaml values based on option names+--    setYamlNames yaml1 .+--    -- set command line arguments instead of taking them from getArgs+--    setArguments args .+--    -- set the priorities for the option values+--    setPriorities [commandLineSource, yamlSource])+module Data.Registry.Options.Sources where++import Data.ByteString qualified as BS+import Data.List qualified as L+import Data.Map qualified as M+import Data.Registry+import Data.Registry.Options.Lexemes hiding (getArguments)+import Data.Registry.Options.Text+import Data.Text qualified as T+import Data.YAML+import Protolude+import System.Environment (getEnvironment, lookupEnv)++-- | Get lexemes+getLexemes :: MonadIO m => m Lexemes+getLexemes = getLexemesWith (const sources)++-- | Get lexemes with a modified registry+getLexemesWith :: MonadIO m => (Registry _ _ -> Registry _ _) -> m  Lexemes+getLexemesWith f = liftIO $ make @(IO Lexemes) (f sources)++-- | Set option names on the registry+setOptionNames :: [Text] -> Registry _ _ -> Registry _ _+setOptionNames names r = valTo @IO (OptionNames names) +: r++-- | Set the config file path+setConfigFilePath :: Text -> Registry _ _ -> Registry _ _+setConfigFilePath path r = valTo @IO (Just $ YamlPath path) +: r++-- | Set the configuration for environment names+setEnvironmentNames :: EnvironmentNames -> Registry _ _ -> Registry _ _+setEnvironmentNames names r = funTo @IO names +: r++-- | Set the configuration for yaml names+setYamlNames :: YamlNames -> Registry _ _ -> Registry _ _+setYamlNames names r = funTo @IO names +: r++-- | Set arguments as if they were read from the command line+setArguments :: [Text] -> Registry _ _ -> Registry _ _+setArguments args r = valTo @IO (Arguments args) +: r++-- | Set source priorities+setPriorities :: [Source] -> Registry _ _ -> Registry _ _+setPriorities ps r = valTo @IO (Priorities ps) +: r++-- | Registry allowing the retrieval of Lexemes from various sources: command line, environment variable, configuration file+sources :: Registry _ _+sources =+  funTo @IO selectValues+    <: funTo @IO getValuesFromEnvironment+    <: funTo @IO getValuesFromYaml+    <: funTo @IO getValuesFromCommandLine+    <: funTo @IO defaultPriorities+    <: fun getCommandlineArguments+    <: funTo @IO defaultEnvironmentNames+    <: funTo @IO defaultYamlNames+    <: funTo @IO readYamlFile+    <: valTo @IO (mempty :: OptionNames)+    <: valTo @IO defaultYamlPath++-- | List of option names defined in a parser+--   It is used to restrict the names parsed in environment variables or in a configuration file+newtype OptionNames = OptionNames {_optionNames :: [Text]} deriving (Eq, Show, Semigroup, Monoid)++-- | Select lexed option names / values according to user defined priorities+selectValues :: Priorities -> Tag "environment" Lexemes -> Tag "yaml" Lexemes -> Tag "commandline" Lexemes -> Lexemes+selectValues priorities env yaml cl = do+  let bySource = [(environmentSource, unTag env), (yamlSource, unTag yaml), (commandLineSource, unTag cl)]+  foldr override mempty (reverse $ sortBySource priorities bySource)++-- * Command line++-- | Lex the arguments coming from the command line+getValuesFromCommandLine :: Arguments -> Tag "commandline" Lexemes+getValuesFromCommandLine = tag . lexArgs . _arguments++-- | By default arguments are retrieved from the base 'getArgs' function+getCommandlineArguments :: IO Arguments+getCommandlineArguments = Arguments . fmap toS <$> getArgs++-- | List of strings retrieved from the command line+newtype Arguments = Arguments {_arguments :: [Text]} deriving (Eq, Show, Semigroup, Monoid)++-- * Environment++-- | Get values from the environment+getValuesFromEnvironment :: OptionNames -> EnvironmentNames -> IO (Tag "environment" Lexemes)+getValuesFromEnvironment (OptionNames []) ens = do+  lexemes <- fmap (\(n, v) -> optionLexemes (fromEnvironmentName ens $ toS n) (toS v)) <$> getEnvironment+  pure . tag $ fold lexemes+getValuesFromEnvironment (OptionNames os) ens = do+  lexemes <- for os $ \o -> maybe mempty (optionLexemes o . toS) <$> lookupEnv (toS $ toEnvironmentName ens o)+  pure . tag $ fold lexemes++-- | Configuration for transforming an environment name into an option name+--   and for transforming an option name into an environment name+data EnvironmentNames = EnvironmentNames+  { fromEnvironmentName :: Text -> Text,+    toEnvironmentName :: Text -> Text+  }++-- | Default conversion functions for environment variables names to option names+--  @fromEnvironmentName "OPTION_NAME" == "optionName"@+--  @toEnvironmentName "optionName" == "OPTION_NAME"@+defaultEnvironmentNames :: EnvironmentNames+defaultEnvironmentNames =+  EnvironmentNames+    { fromEnvironmentName = underscoreToHyphenated . T.toLower,+      toEnvironmentName = T.toUpper . hyphenatedToUnderscore+    }++-- * Yaml++-- | Values can be retrieved from a Yaml file+getValuesFromYaml :: YamlNames -> OptionNames -> Maybe YamlByteString -> IO (Tag "yaml" Lexemes)+getValuesFromYaml _ _ Nothing = pure (tag (mempty :: Lexemes))+getValuesFromYaml yns optionNames (Just (YamlByteString bs)) = do+  case decodeNode (BS.fromStrict bs) of+    Left e -> throwIO ("cannot decode the YAML document: " <> show e :: Text)+    Right docs -> do+      let yamlOptions = collectYamlOptions . docRoot =<< docs+      let yos = case optionNames of+            OptionNames [] -> yamlOptions+            OptionNames os -> do+              let osNames = toYamlName yns <$> os+              filter (\(name, _) -> name `elem` osNames) yamlOptions+      pure . tag . fold $ (\(name, vs) -> optionsLexemes (fromYamlName yns name) vs) <$> yos++-- | Text needs to have an Exception instance in order to use throwIO+instance Exception Text++-- | Path for a YAML document+newtype YamlPath = YamlPath {yamlPath :: Text} deriving (Eq, Show, Semigroup, Monoid)++-- | ByteString representing a YAML document+newtype YamlByteString = YamlByteString {yamlByteString :: ByteString} deriving (Eq, Show, Semigroup, Monoid)++-- | Default path for a configuration file+--   By default we don't read from a configuration file+defaultYamlPath :: Maybe YamlPath+defaultYamlPath = Nothing++-- | Read yaml as a ByteString from a configuration file+readYamlFile :: Maybe YamlPath -> IO (Maybe YamlByteString)+readYamlFile Nothing = pure Nothing+readYamlFile (Just (YamlPath path)) = Just . YamlByteString <$> BS.readFile (toS path)++-- | Collect what looks like options in a YAML document i.e. any list of strings leading to a scalar+collectYamlOptions :: Node Pos -> [(YamlName, [Text])]+collectYamlOptions (Scalar _ (SStr t)) = [(YamlName [], [t])]+collectYamlOptions (Scalar _ (SBool b)) = [(YamlName [], [show b])]+collectYamlOptions (Scalar _ (SInt i)) = [(YamlName [], [show i])]+collectYamlOptions (Scalar _ _) = []+collectYamlOptions (Mapping _ _ m) =+  concat $ uncurry toKeysValue <$> M.assocs m+  where+    toKeysValue :: Node Pos -> Node Pos -> [(YamlName, [Text])]+    toKeysValue (Scalar _ (SStr k)) n =+      (\(YamlName ks, vs) -> (YamlName (k : ks), vs)) <$> collectYamlOptions n+    toKeysValue _ _ = []+collectYamlOptions (Sequence _ _ ns) = concat $ collectYamlOptions <$> ns+collectYamlOptions (Anchor _ _ n) = collectYamlOptions n++-- | A YAML name is represented by a list of keys+newtype YamlName = YamlName {yamlName :: [Text]} deriving (Eq, Show)++-- | Configuration for transforming a YAML name into an option name+--   and for transforming an option name into a YAML name+--   We consider that a YAML name is a sequence of string keys in a nested YAML document+data YamlNames = YamlNames+  { fromYamlName :: YamlName -> Text,+    toYamlName :: Text -> YamlName+  }++-- | Default conversion functions for YAML variables names to option names+--   We only keep in names on the leaves of the YAML tree+--+--  @fromYamlName ["section", "option_name"] == "option-name"@+--  @toYamlName "option-name" == ["option_name"]@+defaultYamlNames :: YamlNames+defaultYamlNames =+  YamlNames+    { fromYamlName = \(YamlName ts) ->+        case reverse ts of+          [] -> ""+          t : _ -> underscoreToHyphenated t,+      toYamlName = YamlName . pure . hyphenatedToUnderscore+    }++-- * Sources and priorities++-- | List of sources sorted by the highest priority to the lowest+newtype Priorities = Priorities [Source] deriving (Eq, Show)++-- | By default we take environment values, then command line values, then values coming from a configuration file+defaultPriorities :: Priorities+defaultPriorities = Priorities [environmentSource, commandLineSource, yamlSource]++-- | Sort a list of values associated with a source, using Priorities to determine the order+sortBySource :: Priorities -> [(Source, a)] -> [a]+sortBySource (Priorities ps) ss = do+  let compareSource source1 source2 = compare (L.elemIndex source1 ps) (L.elemIndex source2 ps)+  snd <$> sortBy (\(s1, _) (s2, _) -> compareSource s1 s2) ss++-- | Source of an option value+--   This is modelled as a simple newtype on Text in order to enable+--   the creation of new sources+newtype Source = Source Text deriving (Eq, Show)++-- | Source of options values coming from the environment+environmentSource :: Source+environmentSource = Source "environment"++-- | Source of options values coming from the command line+commandLineSource :: Source+commandLineSource = Source "commandline"++-- | Source of options values coming from a YAML configuration file+yamlSource :: Source+yamlSource = Source "yaml"
+ src/Data/Registry/Options/TH.hs view
@@ -0,0 +1,274 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | TemplateHaskell functions for creating commands+module Data.Registry.Options.TH where++import Control.Monad.Fail+import Data.List (elemIndex, foldr1)+import Data.Registry.Options.Help+import Data.Registry.Options.OptionDescription (OptionDescription)+import Data.Registry.Options.Text+import Data.String+import Data.Text qualified as T+import Language.Haskell.TH+import Language.Haskell.TH.Lift+import Language.Haskell.TH.Syntax+import Protolude hiding (Type)++deriveLift ''OptionDescription+deriveLift ''Help++-- | Make a command parser for a given data type+--    - the data type name is used to get the command name to parse+--    - each alternative in the data type defines an alternative parser+--+--   Usage: @$(makeCommand ''MyDataType [shortDescription "copy a file"]) <: otherParsers@+--   The type of the resulting parser is @Parser "dataType" MyDataType@+makeCommand :: Name -> [HelpUpdate] -> ExpQ+makeCommand = makeParserWith defaultParserConfiguration True++-- | Make a command parser with some specific parser options+makeCommandWith :: ParserConfiguration -> Name -> [HelpUpdate] -> ExpQ+makeCommandWith parserOptions = makeParserWith parserOptions True++-- | Make a Parser for a given data type, without using the data type as a command name+makeParser :: Name -> ExpQ+makeParser n = makeParserWith defaultParserConfiguration False n []++-- | Options for creating a command parser+data ParserConfiguration = ParserConfiguration+  { -- | make the name a the command from a qualified data type name+    makeCommandName :: Text -> Text,+    -- | make the type of a field from the command data type, and the qualified field type (if it exists)+    makeFieldType :: Text -> Maybe Text -> Text+  }++-- | Default parser configuration+--   if the data type is @mypackage.DataType { dataTypeFieldName :: FieldType }@ then+--     - @makeCommandName -> "type"@+--     - @makeFieldType -> "fieldName"@+defaultParserConfiguration :: ParserConfiguration+defaultParserConfiguration =+  ParserConfiguration+    { makeCommandName = T.toLower . dropPrefix . dropQualifier,+      makeFieldType = \typeName -> maybe "Command" (T.toLower . T.drop (T.length typeName) . dropQualifier)+    }++-- | Main TemplateHaskell function for creating a command parser+makeParserWith :: ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> ExpQ+makeParserWith parserOptions isCommand typeName help = do+  info <- reify typeName+  case info of+    -- newtype data constructor+    TyConI (NewtypeD _context _name _typeVars _kind c@(NormalC _ [(_, _)]) _deriving) ->+      makeSingleConstructor parserOptions isCommand typeName help c+    -- regular data constructor with just one field+    TyConI (NewtypeD _context _name _typeVars _kind c@(RecC _ [(_, _, _)]) _deriving) ->+      makeSingleConstructor parserOptions isCommand typeName help c+    -- list of data constructors+    TyConI (DataD _context _name _typeVars _kind constructors _deriving) -> do+      case constructors of+        [c] ->+          makeSingleConstructor parserOptions isCommand typeName help c+        c : cs -> do+          fs <- for (c : cs) fieldsOf+          addToRegistry $+            [funOf $ makeConstructorsParser parserOptions typeName (c : cs) $ makeHelp help]+              <> ( if isCommand+                     then []+                     else+                       (uncurry (makeFieldParser parserOptions typeName) <$> concat fs)+                         <> (uncurry (makeNoDefaultValues parserOptions typeName) <$> concat fs)+                 )+        [] -> do+          qReport True "can not make a Parser for a data type with no constructors"+          fail "parser creation failed: cannot create a parser for a data type with no constructors"+    other -> do+      qReport True ("cannot create a parser for: " <> show other)+      fail "parser creation failed"++-- | Make a parser for a single constructor, either a newtype with or without a field name+--   or a regular data constructor+makeSingleConstructor :: ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> Con -> ExpQ+makeSingleConstructor parserOptions isCommand typeName help c = do+  fs <- fieldsOf c+  cName <- nameOf c+  addToRegistry $+    [funOf $ makeConstructorParser parserOptions isCommand typeName c $ makeHelp help]+      <> ( if isCommand+             then []+             else+               (uncurry (makeFieldParser parserOptions cName) <$> fs)+                 <> (uncurry (makeNoDefaultValues parserOptions cName) <$> fs)+         )++-- | Add a list of parser functions to the registry+addToRegistry :: [ExpQ] -> ExpQ+addToRegistry [] = fail "parsers creation failed"+addToRegistry [g] = g+addToRegistry (g : gs) = g `append` addToRegistry gs++-- | Take an expression representing a function and apply @fun@ in front, in order+--   to add it to a registry+funOf :: ExpQ -> ExpQ+funOf = appE (varE (mkName "fun"))++-- | Make a Parser for a single Constructor, where each field of the constructor is parsed separately+--   \(os: FieldConfiguration) (p0::Parser fieldName0 Text) (p1::Parser fieldName1 Bool) -> Constructor <$> coerce p0 <*> coerce p1+makeConstructorParser :: ParserConfiguration -> Bool -> Name -> Con -> Help -> ExpQ+makeConstructorParser parserOptions isCommand typeName c help = do+  let isOptionalCommand = helpDefaultSubcommand help+  fs <- fieldsOf c+  cName <- nameOf c+  let parserParameters =+        ( \((mFieldName, t), n) -> do+            let fieldNameType = fieldNameTypeT parserOptions cName mFieldName+            sigP (varP (mkName $ "_p" <> show n)) (conT "Parser" `appT` fieldNameType `appT` pure t)+        )+          <$> zip fs [(0 :: Int) ..]+  let parserType = conT "Parser" `appT` fieldNameTypeT parserOptions cName Nothing `appT` conT typeName+  let commandName = makeCommandName parserOptions (show cName)+  let parserWithHelp =+        varE "addParserHelp"+          `appE` runQ [|help {helpCommandName = Just commandName}|]+          `appE` applyParser parserOptions isCommand isOptionalCommand cName [0 .. (length fs - 1)]+  lamE parserParameters (sigE parserWithHelp parserType)++-- | Make a Parser for a several Constructors, where each field of each the constructor is parsed separately+--   and an alternative is taken between all the parsers+--   \(os: FieldConfiguration) (p0::Parser fieldName1 Text) (p1::Parser fieldName1 Bool) (p2::Parser fieldName2 Bool) ->+--      (Constructor1 <$> coerce p0 <*> coerce p1) <|> (Constructor2 <$> coerce p1 <*> coerce p3)+makeConstructorsParser :: ParserConfiguration -> Name -> [Con] -> Help -> ExpQ+makeConstructorsParser parserOptions typeName cs help = do+  -- take the fields of all the constructors+  -- and make a parameter list with the corresponding parsers+  fs <- join <$> for cs fieldsOf+  let parserParameters =+        ( \((mFieldName, t), n) -> do+            let fieldNameType = fieldNameTypeT parserOptions typeName mFieldName+            sigP (varP (mkName $ "_p" <> show n)) (conT "Parser" `appT` fieldNameType `appT` pure t)+        )+          <$> zip fs [(0 :: Int) ..]++  let appliedParsers =+        ( \c -> do+            cName <- nameOf c+            cFields <- fieldsOf c+            constructorTypes <- indexConstructorTypes fs cFields+            applyParser parserOptions False False cName constructorTypes+        )+          <$> cs++  let commandName = makeCommandName parserOptions (show typeName)+  let commandNameParser = varE "commandNameParser" `appE` stringE (toS commandName)+  let parserAlternatives =+        varE "*>"+          `appE` commandNameParser+          `appE` (varE "addParserHelp" `appE` runQ [|help {helpCommandName = Just commandName}|] `appE` foldr1 (\p r -> varE "<|>" `appE` p `appE` r) appliedParsers)++  -- the string type for the final parser is entirely derived from the data type name+  let parserTypeName = fieldNameTypeT parserOptions typeName Nothing+  let parserType = conT "Parser" `appT` parserTypeName `appT` conT typeName+  lamE parserParameters (sigE parserAlternatives parserType)++-- | Apply a constructor to parsers for each of its fields+--   The resulting parser is a command parser @Parser "Command" DataType@ for a command+--   @ConstructorName <$> coerce p0 <*> coerce p1 ...@+applyParser :: ParserConfiguration -> Bool -> Bool -> Name -> [Int] -> ExpQ+applyParser parserOptions isCommand isOptionalCommand cName ns = do+  let commandName = makeCommandName parserOptions (show cName)+  let commandNameParser = if isCommand then varE "commandNameParser" `appE` stringE (toS commandName) else varE "unitParser"+  -- a default subcommand might be optional, in that case it is ok if the command name is not parsed+  let commandParser = varE "*>" `appE` (if isOptionalCommand then varE "<|>" `appE` commandNameParser `appE` varE "unitParser" else commandNameParser)+  let cons = commandParser `appE` (varE "pure" `appE` conE cName)+  case ns of+    [] -> cons+    (n : rest) ->+      foldr (\i r -> varE "<*>" `appE` r `appE` parseAt i) (varE "<*>" `appE` cons `appE` parseAt n) (reverse rest)+      where+        parseAt i = varE "coerceParser" `appE` varE (mkName $ "_p" <> show i)++-- | Get the types of all the fields of a constructor+typesOf :: Con -> Q [Type]+typesOf (NormalC _ types) = pure (snd <$> types)+typesOf (RecC _ types) = pure $ (\(_, _, t) -> t) <$> types+typesOf other = do+  qReport True ("we can only create a parser for normal constructors and records, got: " <> show other)+  fail "parser creation failed"++-- | Get the types of all the fields of a constructor+fieldsOf :: Con -> Q [(Maybe Name, Type)]+fieldsOf (NormalC _ types) = pure $ (\(_, t) -> (Nothing, t)) <$> types+fieldsOf (RecC _ types) = pure $ (\(n, _, t) -> (Just n, t)) <$> types+fieldsOf other = do+  qReport True ("we can only create a parser for normal constructors and records, got: " <> show other)+  fail "parser creation failed"++-- | Return the name of a constructor+nameOf :: Con -> Q Name+nameOf (NormalC n _) = pure n+nameOf (RecC n _) = pure n+nameOf other = do+  qReport True ("we can only create a parser for normal constructors and records, got: " <> show other)+  fail "parser creation failed"++-- | Given the list of all possible fields and their types, across all the alternatives of an ADT,+--   return the indices for a specific subset+indexConstructorTypes :: [(Maybe Name, Type)] -> [(Maybe Name, Type)] -> Q [Int]+indexConstructorTypes allFields constructorFields =+  for constructorFields $ \f ->+    case elemIndex f allFields of+      Just n -> pure n+      Nothing -> fail $ "the field " <> show f <> " cannot be found in the list of all the fields " <> show allFields++-- | Make a Parser for a given field+makeFieldParser :: ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ+makeFieldParser parserOptions constructorName mFieldName fieldType = do+  let fieldNameType = fieldNameTypeT parserOptions constructorName mFieldName+  let fieldName = maybe (conE "Positional") (const $ conE "NonPositional") mFieldName+  varE "fun"+    `appE` lamE+      [sigP (varP "ps") (conT "FieldConfiguration")]+      ( (varE "parseField" `appTypeE` fieldNameType `appTypeE` pure fieldType)+          `appE` varE "ps"+          `appE` fieldName+          `appE` stringE (toS $ displayType fieldType)+      )++-- | Add no default values for a given field name to the registry+makeNoDefaultValues :: ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ+makeNoDefaultValues parserOptions constructorName mFieldName fieldType =+  varE "setNoDefaultValues" `appTypeE` fieldNameTypeT parserOptions constructorName mFieldName `appTypeE` pure fieldType++-- | Return the singleton string type for a given field parser+fieldNameTypeT :: ParserConfiguration -> Name -> Maybe Name -> Q Type+fieldNameTypeT parserOptions constructorName mFieldName =+  litT . strTyLit . toS $ makeFieldType parserOptions (dropQualifier . show $ constructorName) (show <$> mFieldName)++-- | Append an expression to a registry+append :: ExpQ -> ExpQ -> ExpQ+append = appOf "<+"++-- | Apply an operator (described as Text) to 2 expressions+appOf :: Text -> ExpQ -> ExpQ -> ExpQ+appOf operator e1 e2 = infixE (Just e1) (varE (mkName $ toS operator)) (Just e2)++instance IsString Name where+  fromString = mkName++-- | Display a type name+displayType :: Type -> Text+displayType = show . getTypeName++-- | Return the name of a type in the most frequent cases+getTypeName :: Type -> Name+getTypeName (ForallT _ _ ty) = getTypeName ty+getTypeName (VarT name) = name+getTypeName (ConT name) = name+getTypeName (TupleT n) = tupleTypeName n+getTypeName ArrowT = ''(->)+getTypeName ListT = ''[]+getTypeName (AppT t1 t2) = mkName (show (getTypeName t1) <> " " <> show (getTypeName t2))+getTypeName (SigT t _) = getTypeName t+getTypeName (UnboxedTupleT n) = unboxedTupleTypeName n+getTypeName t = panic $ "getTypeName: Unknown type: " <> show t
+ src/Data/Registry/Options/Text.hs view
@@ -0,0 +1,99 @@+-- | Utility functions for working with text+module Data.Registry.Options.Text where++import qualified Data.Char as C+import qualified Data.List as L+import qualified Data.Text as T+import Protolude++-- | Hyphenate a camelCase Text into camel-case+camelCaseToHyphenated :: Text -> Text+camelCaseToHyphenated = T.intercalate "-" . fmap T.toLower . splitCamelCase++-- | camelCase some hyphenated Text+hyphenatedToCamelCase :: Text -> Text+hyphenatedToCamelCase t =+  case T.splitOn "-" t of+    [] -> ""+    t1:ts -> T.concat (t1: (T.toTitle <$> ts))++-- | Drop the leading names in a qualified name+--   dropQualifier "x.y.z" === "z"+dropQualifier :: Text -> Text+dropQualifier t = fromMaybe t . lastMay $ T.splitOn "." t++-- | Drop the prefix of a capitalized or uncapitalized name+--   dropPrefix Prefix = Prefix+--   dropPrefix PrefixName = Name+--   dropPrefix prefixName = Name+dropPrefix :: Text -> Text+dropPrefix t =+  case toS <$> splitCamelCase t of+    [] -> t+    [t1] -> t1+    (t1 : t2 : ts) ->+      T.concat $ if isCapitalized t1 then t2 : ts else T.toLower t2 : ts++-- | Split a camel cased word in several lower-cased strings+splitCamelCase :: Text -> [Text]+splitCamelCase = fmap toS . splitCamelCaseString . toS+  where+    splitCamelCaseString [] = []+    splitCamelCaseString (c : cs) = do+      let (lower, rest) = L.break C.isUpper cs+      [c : lower] <> splitCamelCaseString rest++-- | Return True if some text starts with a capital letter+isCapitalized :: Text -> Bool+isCapitalized t = T.null t || C.isUpper (T.head t)++-- | Display 2 columns of text so that the texts in the second column are aligned+displayColumns :: [Text] -> [Text] -> [Text]+displayColumns cs1 cs2 = do+  let maxSize = fromMaybe 0 $ maximumMay (T.length <$> cs1)+  (\(c1, c2) -> c1 <> T.replicate (maxSize - T.length c1) " " <> "          " <> c2) <$> zip cs1 cs2++-- | Surround some text with brackets+bracketText :: Text -> Text+bracketText = bracketTextWhen True++-- | Surround some text with brackets+bracketTextWhen :: Bool -> Text -> Text+bracketTextWhen False t = t+bracketTextWhen True t = "[" <> t <> "]"++-- | Surround some text with parentheses+parenthesizeText :: Text -> Text+parenthesizeText = parenthesizeTextWhen True++-- | Surround some text with parentheses+parenthesizeTextWhen :: Bool -> Text -> Text+parenthesizeTextWhen False t = t+parenthesizeTextWhen True t = "(" <> t <> ")"++-- | Indent some text with a fixed piece of text+indent :: Text -> Text -> Text+indent i t = T.intercalate "\n" $ (i <> ) <$> T.lines t++-- | Remove spaces on the right+trimRight :: Text -> Text+trimRight = T.pack . reverse . dropWhile isSpace . reverse. T.unpack++-- | Transform an underscore name to a camelcase one+underscoreToCamelCase :: Text -> Text+underscoreToCamelCase t =+  case T.splitOn "_" t of+    [] -> ""+    h:ts -> h <> T.concat (T.toTitle <$> ts)++-- | Transform a camelcase name to an underscore one+camelCaseToUnderscore :: Text -> Text+camelCaseToUnderscore t = T.intercalate "_" (T.toLower <$> splitCamelCase t)++-- | Transform an underscore name to a hyphenated one+underscoreToHyphenated :: Text -> Text+underscoreToHyphenated = T.intercalate "-" . T.splitOn "_"++-- | Transform a hyphenated name to an underscore one+hyphenatedToUnderscore :: Text -> Text+hyphenatedToUnderscore = T.intercalate "_" . T.splitOn "-"
+ test/AutoDiscoveredSpecs.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=AutoDiscoveredSpecs #-}
+ test/Test/Data/Registry/Options/Diffy.hs view
@@ -0,0 +1,23 @@+module Test.Data.Registry.Options.Diffy where++import Protolude++data Diffy+  = DiffyDiff Diff+  | DiffyCreate Create+  | DiffyHelp {diffyHelp :: Bool}+  | DiffyVersion {diffyVersion :: Bool}+  deriving (Eq, Show)++data Create = Create+  { createOut :: FilePath,+    createSrc :: Maybe FilePath+  }+  deriving (Eq, Show)++data Diff = Diff+  { diffOut :: FilePath,+    diffOld :: FilePath,+    diffNew :: FilePath+  }+  deriving (Eq, Show)
+ test/Test/Data/Registry/Options/DiffySpec.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Options.DiffySpec where++import Data.Registry+import Data.Registry.Options+import Data.Text qualified as T+import Protolude+import Test.Data.Registry.Options.Diffy+import Test.Tasty.Hedgehogx hiding (Command, OptionDescription, maybe)++test_diffy = test "create a parser for the diffy program" $ do+  let p = make @(Parser Command Diffy) $ parsers++  -- sanity check+  parse p "diffy create --out o.txt --src in" === Right (DiffyCreate $ Create "o.txt" (Just "in"))+  parse p "diffy diff --out o.txt old new" === Right (DiffyDiff $ Diff "o.txt" "old" "new")++  displayLines (parserHelp p)+    === [ "diffy - Diffy v1.0",+          "",+          "  Create and compare differences",+          "",+          "USAGE",+          "",+          "  diffy [-?|--help] [-V|--version] [diff] [create]",+          "",+          "OPTIONS",+          "",+          "  -?,--help BOOL             Display help message",+          "  -V,--version BOOL          Print version information",+          "",+          "COMMANDS",+          "",+          "  diff [OPTIONS]            Perform a diff",+          "  create [OPTIONS]          Create a fingerprint",+          "",+          "diffy diff - Perform a diff",+          "",+          "  diffy diff [-o|--out FILE] [FILE] [FILE]",+          "",+          "  -o,--out FILE          Output file",+          "  FILE                   Old file",+          "  FILE                   New file",+          "",+          "diffy create - Create a fingerprint",+          "",+          "  diffy create [-o|--out FILE] [-s|--src DIR]",+          "",+          "  -o,--out FILE          Output file",+          "  -s,--src DIR           Source directory"+        ]++parsers :: Registry _ _+parsers =+  $( makeCommand ''Diffy $+       [ shortDescription "Diffy v1.0",+         longDescription "Create and compare differences"+       ]+   )+    <: $(makeCommand ''Create [shortDescription "Create a fingerprint"])+    <: $(makeCommand ''Diff [shortDescription "Perform a diff"])+    <: optionMaybe @"src" @FilePath [help "Source directory", metavar "DIR"]+    <: option @"out" @FilePath [help "Output file", metavar "FILE"]+    <: positional @"old" @FilePath 0 [help "Old file", metavar "FILE"]+    <: positional @"new" @FilePath 1 [help "New file", metavar "FILE"]+    <: switch @"help" [short '?', help "Display help message"]+    <: switch @"version" [short 'V', help "Print version information"]+    <: defaults++-- * Helpers++displayLines h = fmap trimRight (T.lines (displayHelp h))
+ test/Test/Data/Registry/Options/DisplayHelpBoxSpec.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Test.Data.Registry.Options.DisplayHelpBoxSpec where++import Data.Registry+import Data.Registry.Options+import Data.Text qualified as T+import Protolude+import Test.Tasty.Hedgehogx hiding (OptionDescription, display)+import Text.PrettyPrint.Boxes hiding ((<>))++test_display_metavar_box = test "displayMetavarBox" $ do+  showB @"metavar" (metavar "FILE" mempty) === "FILE"+  showB @"metavar" (metavar "[CHAR]" mempty) === "STRING"++test_display_metavar_usage_box = test "displayMetavarUsageBox" $ do+  showB @"metavar-usage" (metavar "FILE" mempty) === "FILE"+  showB @"metavar-usage" (metavar "[CHAR]" mempty) === ""+  showB @"metavar-usage" (metavar "" mempty) === ""++test_display_option_help_box = test "displayOptionHelpBox" $ do+  showB @"option-help" noOption === ""+  showB @"option-help" (help "some help" mempty) === "some help"++test_display_option_flag_box = test "displayOptionFlagBox" $ do+  showB @"option-flag" noOption === ""+  showB @"option-flag" (name "name" <> short 'n' $ noOption) === "-n,--name"+  showB @"option-flag" (metavar "FILE" <> name "name" <> short 'n' $ noOption) === "-n,--name FILE"++test_display_option_usage_box = test "displayOptionUsageBox" $ do+  showB @"option-usage" noOption === ""+  showB @"option-usage" (name "name" <> short 'n' $ noOption) === "[-n|--name]"+  showB @"option-usage" (metavar "FILE" <> name "name" $ noOption) === "[--name FILE]"+  showB @"option-usage" (metavar "FILE" <> name "name" <> short 'n' $ noOption) === "[-n|--name FILE]"++test_display_option_box = test "displayOptionBox" $ do+  showB @"option" noOption === ""+  showB @"option" (name "name" <> short 'n' $ noOption) === "-n,--name"+  showB @"option" (name "name" <> short 'n' <> help "some help" $ noOption) === "-n,--name          some help"+  showB @"option" (metavar "FILE" <> name "name" <> short 'n' <> help "some help" $ noOption) === "-n,--name FILE          some help"++test_table = test "table" $ do+  let tps = TableParameters left top 10+  let width = 10++  -- when the help text fits on a single line+  renderBox+    ( table+        tps+        [ [paragraph width "o|option", paragraph 10 "long help"],+          [paragraph width "FILE", paragraph width "help"]+        ]+    )+    === T.intercalate+      "\n"+      [ "o|option          long help",+        "FILE              help     "+      ]++  -- when the help text fits on a single line needs to wrap+  renderBox+    ( table+        tps+        [ [paragraph width "o|option", paragraph width "long help very long help which doesn't fit a column"],+          [paragraph width "FILE", paragraph width "help"]+        ]+    )+    === T.intercalate+      "\n"+      [ "o|option          long help ",+        "                  very long ",+        "                  help which",+        "                  doesn't   ",+        "                  fit a     ",+        "                  column    ",+        "FILE              help      "+      ]++test_display_command_options_box = test "displayCommandOptionsBox" $ do+  showB @"command-options" [noOption] === ""+  showB @"command-options" [name "name" <> short 'n' $ noOption] === "-n,--name          "+  showB @"command-options" [name "name" <> short 'n' <> help "name help" $ noOption] === "-n,--name          name help"+  showB @"command-options" [metavar "FILE" <> name "name" <> short 'n' <> help "name help" $ noOption] === "-n,--name FILE          name help"++  showB @"command-options"+    [ name "name" <> short 'n' <> help "name help" $ noOption,+      name "force" <> short 'f' <> help "force help" $ noOption+    ]+    === T.intercalate+      "\n"+      [ "-n,--name           name help ",+        "-f,--force          force help"+      ]+++-- * Helpers++showB :: forall (t :: Symbol) a. (KnownSymbol t, Typeable a) => a -> Text+showB = renderBox . display (make @(Display t a Box) displayBoxRegistry)++noOption = mempty :: OptionDescription
+ test/Test/Data/Registry/Options/Fs.hs view
@@ -0,0 +1,35 @@+module Test.Data.Registry.Options.Fs where++import Data.String+import Protolude++data Copy+  = CopyHelp {copyHelp :: Bool}+  | Copy+      { copyForce :: Bool,+        copyRetries :: Maybe Int,+        copySource :: File,+        copyTarget :: File+      }+  deriving (Eq, Show)++data Move+  = MoveHelp {moveHelp :: Bool}+  | Move+      { moveForce :: Bool,+        moveSource :: File,+        moveTarget :: File+      }+  deriving (Eq, Show)++data Fs+  = FsCopy Copy+  | FsMove Move+  | FsHelp {fsHelp :: Bool}+  | FsVersion {fsVersion :: Bool}+  deriving (Eq, Show)++newtype File = File {_filePath :: Text} deriving (Eq, Show)++instance IsString File where+  fromString = File . toS
+ test/Test/Data/Registry/Options/GitSpec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DataKinds #-}+module Test.Data.Registry.Options.GitSpec where++-- import Data.Registry+-- import Data.Registry.Options as D+-- import Protolude hiding (Option, many, option, optional)+-- import Test.Tasty.Hedgehogx hiding (defaultValue)+-- import Data.Coerce++-- test_git = test "parse git commands" $ do+--   let p1 = make @(Parser AddCommand) parsers+--   parse p1 "-f -- name1 name2" === Right (AddCommand True False False False [File "name1", File "name2"])++--   let p2 = make @(Parser GitCommand) parsers+--   parse p2 "add -f -- name1 name2" === Right (Add $ AddCommand True False False False [File "name1", File "name2"])++-- -- * HELPERS++-- parsers =+--   fun (commands "add" "rm")+--     <: fun addCommand+--     <: fun rmCommand+--     <: decoders++-- decoders =+--   manyOf @File+--     <: decoderOf File+--     <: addDecoder D.intDecoder+--     <: addDecoder D.boolDecoder+--     <: addDecoder D.textDecoder++-- -- | Example inspired from https://github.com/markhibberd/pirate/blob/master/src/test/scala/pirate.example/GitExample.scala+-- data GitCommand+--   = Version+--   | HtmlPath+--   | ManPath+--   | Add AddCommand+--   | Rm RmCommand+--   deriving (Eq, Show)++-- newtype File = File Text deriving (Eq, Show)++-- data AddCommand = AddCommand+--   { forceAdd :: Bool,+--     interactive :: Bool,+--     patch :: Bool,+--     edit :: Bool,+--     addPaths :: [File]+--   }+--   deriving (Eq, Show)++-- data RmCommand = RmCommand+--   { forceRm :: Bool,+--     dryRun :: Bool,+--     recurse :: Bool,+--     cached :: Bool,+--     rmPaths :: [File]+--   }+--   deriving (Eq, Show)++-- addCommand :: Decoder Bool -> Decoder [File] -> Parser "Command" AddCommand+-- addCommand boolDecoder filesDecoder =+--   AddCommand+--     <$> parseWith [switch 'f', name "force"] boolDecoder+--     <*> parseWith [switch 'i', name "interactive"] boolDecoder+--     <*> parseWith [switch 'p', name "patch"] boolDecoder+--     <*> parseWith [switch 'e', name "edit"] boolDecoder+--     <*> parseWith [many (argument @File "paths")] filesDecoder++-- rmCommand :: Decoder Bool -> Decoder [File] -> Parser "Command" RmCommand+-- rmCommand boolDecoder filesDecoder =+--   RmCommand+--     <$> coerce (parseWith @"force" [switch, name "force"] boolDecoder)+--     <*> coerce (parseWith @"dry" [switch, name "dry"] boolDecoder)+--     <*> coerce (parseWith @"recurse" [switch, name "recurse"] boolDecoder)+--     <*> coerce (parseWith @"cached" [switch, name "cached"] boolDecoder)+--     <*> coerce (parseWith @"paths" [many (argument @File "paths")] filesDecoder)++-- commands :: Text -> Text -> Parser "Command" AddCommand -> Parser "Command" RmCommand -> Parser "Command" GitCommand+-- commands p1Name p2Name p1 p2 =+--   command p1Name Add p1+--     <|> command p2Name Rm p2
+ test/Test/Data/Registry/Options/HLint.hs view
@@ -0,0 +1,35 @@+module Test.Data.Registry.Options.HLint where++import Protolude+import qualified Data.Text as T+import Data.Registry.Options++data HLint = HLint+  { report :: [FilePath],+    hint :: [FilePath],+    color :: Bool,+    ignore :: [Text],+    showIgnored :: Bool,+    extension :: [Text],+    language :: [Text],+    utf8 :: Bool,+    encoding :: Text,+    find :: [FilePath],+    testMode :: Bool,+    datadir :: [FilePath],+    cppDefine :: [Text],+    cppInclude :: [FilePath],+    help :: Bool,+    version :: Bool,+    verbose :: Bool,+    quiet :: Bool,+    files :: [FilePath]+  }+  deriving (Eq, Show)++parserConfiguration :: ParserConfiguration+parserConfiguration =+  ParserConfiguration+    { makeCommandName = T.toLower . dropQualifier,+      makeFieldType = \_ -> maybe "Command" dropQualifier+    }
+ test/Test/Data/Registry/Options/HLintSpec.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Options.HLintSpec where++import Data.Registry+import Data.Registry.Options+import Data.Text qualified as T+import Protolude+import Test.Data.Registry.Options.HLint hiding (help)+import Test.Tasty.Hedgehogx hiding (Command, OptionDescription, maybe)++test_hlint = test "create a parser for the HLint program" $ do+  let p = make @(Parser Command HLint) $ parsers++  displayLines (parserHelp p)+    === [ "hlint - HLint v0.0.0, (C) Neil Mitchell",+          "",+          "  Hlint gives hints on how to improve Haskell code",+          "  To check all Haskell files in 'src' and generate a",+          "  report type: hlint src --report",+          "",+          "USAGE",+          "",+          "  hlint [-r|--report FILE] [-h|--hint FILE] [-c|--color] [-i|--ignore MESSAGE] [-s|--show] [--extension EXT] [-X|--language LANG] [-u|--utf8] [--encoding ENC] [-f|--find FILE] [-t|--test-mode] [-d|--datadir DIR] [--cpp-define NAME[=VALUE]] [--cpp-include DIR] [-?|--help] [-V|--version] [-v|--verbose] [-q|--quiet] [FILES/DIRS]",+          "",+          "OPTIONS",+          "",+          "  -r,--report FILE                   Generate a report in HTML",+          "  -h,--hint FILE                     Hint/ignore file to use",+          "  -c,--color,--colour BOOL           Color the output (requires ANSI terminal)",+          "  -i,--ignore MESSAGE                Ignore a particular hint",+          "  -s,--show BOOL                     Show all ignored ideas",+          "  --extension EXT                    Show all ignored ideas",+          "  -X,--language LANG                 Language extension (Arrows, NoCPP)",+          "  -u,--utf8 BOOL                     Use UTF-8 text encoding",+          "  --encoding ENC                     Choose the text encoding",+          "  -f,--find FILE                     Find hints in a Haskell file",+          "  -t,--test-mode BOOL                Run in test mode",+          "  -d,--datadir DIR                   Override the data directory",+          "  --cpp-define NAME[=VALUE]          CPP #define",+          "  --cpp-include DIR                  CPP include path",+          "  -?,--help BOOL                     Display help message",+          "  -V,--version BOOL                  Print version information",+          "  -v,--verbose BOOL                  Loud verbosity",+          "  -q,--quiet BOOL                    Quiet verbosity",+          "  FILES/DIRS"+        ]++parsers :: Registry _ _+parsers =+  $( makeCommandWith+       parserConfiguration+       ''HLint+       [ shortDescription "HLint v0.0.0, (C) Neil Mitchell",+         longDescription $+           T.unlines+             [ "Hlint gives hints on how to improve Haskell code",+               "",+               "To check all Haskell files in 'src' and generate a report type:",+               "  hlint src --report"+             ]+       ]+   )+    <: options @"report" @FilePath [help "Generate a report in HTML", metavar "FILE"]+    <: options @"hint" @FilePath [help "Hint/ignore file to use", metavar "FILE"]+    <: setDefaultValue @"report" @FilePath "report.html"+    <: switch @"color" [help "Color the output (requires ANSI terminal)", alias "colour"]+    <: options @"ignore" @Text [help "Ignore a particular hint", metavar "MESSAGE"]+    <: switch @"showIgnored" [name "show", help "Show all ignored ideas"]+    <: options @"extension" @Text [noShort, help "Show all ignored ideas", metavar "EXT"]+    <: options @"language" @Text [short 'X', help "Language extension (Arrows, NoCPP)", metavar "LANG"]+    <: switch @"utf8" [help "Use UTF-8 text encoding"]+    <: option @"encoding" @Text [noShort, help "Choose the text encoding", metavar "ENC"]+    <: options @"find" @FilePath [help "Find hints in a Haskell file", metavar "FILE"]+    <: switch @"testMode" [help "Run in test mode"]+    <: options @"datadir" @FilePath [help "Override the data directory", metavar "DIR"]+    <: options @"cppDefine" @Text [noShort, help "CPP #define", metavar "NAME[=VALUE]"]+    <: options @"cppInclude" @FilePath [noShort, help "CPP include path", metavar "DIR"]+    <: switch @"help" [short '?', help "Display help message"]+    <: switch @"version" [short 'V', help "Print version information"]+    <: switch @"verbose" [help "Loud verbosity"]+    <: switch @"quiet" [help "Quiet verbosity"]+    <: arguments @"files" @FilePath [metavar "FILES/DIRS"]+    <: defaults++-- * Helpers++displayLines h = fmap trimRight (T.lines (displayHelp h))
+ test/Test/Data/Registry/Options/HelpSpec.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Data.Registry.Options.HelpSpec where++import Data.Registry+import Data.Registry.Options+import Data.Text qualified as T+import Protolude+import Test.Data.Registry.Options.Fs+import Test.Tasty.Hedgehogx hiding (Command)++test_help_option = test "a parser can have help and version options" $ do+  let fsParser = make @(Parser Command Fs) $ parsers+  let copyParser = make @(Parser Command Copy) $ parsers++  parse copyParser "copy --help" === Right (CopyHelp True)++  parse fsParser "fs --help" === Right (FsHelp True)+  parse fsParser "fs --version" === Right (FsVersion True)+  parse fsParser "fs copy --help" === Right (FsCopy $ CopyHelp True)++  displayLines (parserHelp copyParser)+    === [ "copy - copy a file from SOURCE to TARGET",+          "",+          "USAGE",+          "",+          "  copy [-h|--help] [-f|--force] [-r|--retries INT] [SOURCE] [TARGET]",+          "",+          "OPTIONS",+          "",+          "  -h,--help BOOL            Display this help message",+          "  -f,--force BOOL           Force the action even if a file already exists",+          "                            with the same name",+          "  -r,--retries INT          number of retries in case of an error",+          "  SOURCE                    Source path",+          "  TARGET                    Target path"+        ]++  displayLines (parserHelp fsParser)+    === [ "fs - a utility to copy and move files",+          "",+          "USAGE",+          "",+          "  fs [-h|--help] [-v|--version] [copy] [move]",+          "",+          "OPTIONS",+          "",+          "  -h,--help BOOL             Display this help message",+          "  -v,--version BOOL          Display the version",+          "",+          "COMMANDS",+          "",+          "  copy [OPTIONS]          copy a file from SOURCE to TARGET",+          "  move [OPTIONS]          move a file from SOURCE to TARGET",+          "",+          "fs copy - copy a file from SOURCE to TARGET",+          "",+          "  fs copy [-h|--help] [-f|--force] [-r|--retries INT] [SOURCE] [TARGET]",+          "",+          "  -h,--help BOOL            Display this help message",+          "  -f,--force BOOL           Force the action even if a file already exists",+          "                            with the same name",+          "  -r,--retries INT          number of retries in case of an error",+          "  SOURCE                    Source path",+          "  TARGET                    Target path",+          "",+          "fs move - move a file from SOURCE to TARGET",+          "",+          "  fs move [-h|--help] [-f|--force] [SOURCE] [TARGET]",+          "",+          "  -h,--help BOOL           Display this help message",+          "  -f,--force BOOL          Force the action even if a file already exists",+          "                           with the same name",+          "  SOURCE                   Source path",+          "  TARGET                   Target path"+        ]++parsers =+  $(makeCommand ''Fs [shortDescription "a utility to copy and move files"])+    <: $(makeCommand ''Move [shortDescription "move a file from SOURCE to TARGET"])+    <: $(makeCommand ''Copy [shortDescription "copy a file from SOURCE to TARGET"])+    <: switch @"force" [help "Force the action even if a file already exists with the same name"]+    <: fun (maybeParser @"retries" @Int)+    <: option @"retries" @Int [help "number of retries in case of an error"]+    <: flag @"help" @Bool True Nothing [help "Display this help message"]+    <: flag @"version" @Bool True Nothing [help "Display the version"]+    <: argument @"source" @File [metavar "SOURCE", help "Source path"]+    <: argument @"target" @File [metavar "TARGET", help "Target path"]+    <: decoderOf File+    <: defaults++-- * Helpers++displayLines h = fmap trimRight (T.lines (displayHelp h))
+ test/Test/Data/Registry/Options/LexemesSpec.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Test.Data.Registry.Options.LexemesSpec where++import Data.MultiMap qualified as M+import Data.Registry.Options.Lexemes+import Protolude+import Test.Tasty.Hedgehogx++test_lexed = test "lex the command line" $ do+  mkLexemes ["a"] === argLexemes "a"+  mkLexemes ["a", "b"] === argsLexemes ["a", "b"]+  mkLexemes ["-o"] === flagLexemes "o"+  mkLexemes ["-opq"] === flagsLexemes ["o", "p", "q"]+  mkLexemes ["--o"] === flagLexemes "o"+  mkLexemes ["-o=v"] === optionLexemes "o" "v"+  mkLexemes ["--option=value"] === optionLexemes "option" "value"+  mkLexemes ["-o1=v1", "-o2", "v2"] === optionLexemes "o1" "v1" <> ambiguousLexemes "o2" ["v2"]+  mkLexemes ["--o", "v"] === ambiguousLexemes "o" ["v"]+  mkLexemes ["--o", "v1", "v2"] === ambiguousLexemes "o" ["v1", "v2"]+  mkLexemes ["-o", "--o", "v"] === flagsLexemes ["o"] <> ambiguousLexemes "o" ["v"]+  mkLexemes ["v1", "v2", "v3"] === argsLexemes ["v1", "v2", "v3"]+  mkLexemes ["--o1", "v1", "--o2", "v2"] === optionLexemes "o1" "v1" <> ambiguousLexemes "o2" ["v2"]++test_pop = test "pop a multimap value" $ do+  pop "k" (M.fromList [("k", "v1"), ("k", "v2")]) === M.fromList [("k", "v2")]+  pop "k" (pop "k" (M.fromList [("k", "v1"), ("k", "v2")])) === M.empty++test_override = test "override lexemes" $ do+  -- options+  optionLexemes "o1" "v1" `override` optionLexemes "o1" "v2" === optionLexemes "o1" "v2"+  optionsLexemes "o1" ["v1"] `override` optionsLexemes "o1" ["v2"] === optionsLexemes "o1" ["v2"]+  -- flags can be present several times in one source but we don't deduplicate across sources+  flagsLexemes ["o1", "o2"] `override` flagsLexemes ["o3"] === flagsLexemes ["o1", "o2", "o3"]+  flagsLexemes ["o1", "o2"] `override` flagsLexemes ["o1", "o3"] === flagsLexemes ["o1", "o2", "o3"]+  flagsLexemes ["o1", "o2", "o1"] `override` flagsLexemes ["o1", "o3"] === flagsLexemes ["o1", "o1", "o2", "o3"]+  flagsLexemes ["o1", "o2"] `override` flagsLexemes ["o1", "o3", "o1"] === flagsLexemes ["o1", "o1", "o2", "o3"]+  -- ambiguous values+  ambiguousLexemes "o1" ["v1"] `override` optionLexemes "o1" "v2" === optionLexemes "o1" "v2"+  optionLexemes "o1" "v2" `override` ambiguousLexemes "o1" ["v1"] === optionLexemes "o1" "v1"+  ambiguousLexemes "o1" ["v1"] `override` ambiguousLexemes "o1" ["v2"] === ambiguousLexemes "o1" ["v2"]++  ((optionLexemes "o1" "v1" <> ambiguousLexemes "o2" ["v2"]) `override` (optionLexemes "o1" "v3" <> ambiguousLexemes "o3" ["v4"]))+    === (optionLexemes "o1" "v3" <> ambiguousLexemes "o3" ["v4"])++  ((optionLexemes "o1" "v1" <> ambiguousLexemes "o2" ["v2"]) `override` optionLexemes "o2" "v3")+    === (optionLexemes "o1" "v1" <> optionLexemes "o2" "v3")++  (optionLexemes "o1" "v1" `override` (optionLexemes "o2" "v3" <> ambiguousLexemes "o1" ["v2"]))+    === (optionLexemes "o1" "v2" <> optionLexemes "o2" "v3")
+ test/Test/Data/Registry/Options/Maker.hs view
@@ -0,0 +1,35 @@+module Test.Data.Registry.Options.Maker where++import Protolude++data Method = Debug | Release | Profile+  deriving (Eq, Show)++data Maker+  = MakerWipe Wipe+  | MakerBuild Build+  | MakerTest Test+  | MakerMakerHelp {makerHelp :: Bool}+  | MakerMakerVersion {makerVersion :: Bool}+  deriving (Eq, Show)++data Wipe = Wipe deriving (Eq, Show)++data Build = Build+  { buildThreads :: Int,+    buildMethod :: Method,+    buildFiles :: [FilePath]+  }+  deriving (Eq, Show)++data Test = Test+  { testThreads :: Int,+    testExtra :: [Text]+  }+  deriving (Eq, Show)++methodDecoder :: Text -> Either Text Method+methodDecoder "release" = pure Release+methodDecoder "debug" = pure Debug+methodDecoder "profile" = pure Profile+methodDecoder _ = Left "expected release, debug, profile"
+ test/Test/Data/Registry/Options/MakerSpec.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Options.MakerSpec where++import Data.Coerce+import Data.Registry+import Data.Registry.Options+import Data.Text qualified as T+import Protolude+import Test.Data.Registry.Options.Maker+import Test.Tasty.Hedgehogx hiding (Command, OptionDescription, Test, maybe)++test_maker = test "create a parser for the maker program" $ do+  let p = make @(Parser Command Maker) $ parsers++  -- sanity check+  parse p "maker wipe" === Right (MakerWipe Wipe)+  parse p "maker build -j 3 --release f1 f2" === Right (MakerBuild $ Build 3 Release ["f1", "f2"])+  -- build is the default subcommand so it is optional+  parse p "maker -j 3 --release f1 f2" === Right (MakerBuild $ Build 3 Release ["f1", "f2"])+  parse p "maker test -j 3 f1 f2" === Right (MakerTest $ Test 3 ["f1", "f2"])++  displayLines (parserHelp p)+    === [ "maker - Maker v1.0",+          "Make it",+          "",+          "  Build helper program",+          "",+          "USAGE",+          "",+          "  maker [-?|--help] [-V|--version] [wipe] [build] [test]",+          "",+          "OPTIONS",+          "",+          "  -?,--help BOOL             Display help message",+          "  -V,--version BOOL          Print version information",+          "",+          "COMMANDS",+          "",+          "  wipe                     Clean all build objects",+          "  build [OPTIONS]          Build the project (default)",+          "  test [OPTIONS]           Run the test suite",+          "",+          "maker wipe - Clean all build objects",+          "",+          "  maker wipe",+          "",+          "maker (build) - Build the project",+          "",+          "  maker (build) [-j|--threads INT] [-d|--debug METHOD] [-r|--release METHOD] [-p|--profile METHOD] [FILE]",+          "",+          "  -j,--threads INT             Number of threads to use",+          "  -d,--debug METHOD            Debug",+          "  -r,--release METHOD          Release",+          "  -p,--profile METHOD          Profile",+          "  FILE",+          "",+          "maker test - Run the test suite",+          "",+          "  maker test [-j|--threads INT] [ANY]",+          "",+          "  -j,--threads INT          Number of threads to use",+          "  ANY"+        ]++parsers :: Registry _ _+parsers =+  $(makeCommand ''Maker [shortDescription "Maker v1.0\nMake it", longDescription "Build helper program"])+    <: $(makeCommand ''Build [shortDescription "Build the project", defaultSubcommand])+    <: $(makeCommand ''Wipe [shortDescription "Clean all build objects"])+    <: $(makeCommand ''Test [shortDescription "Run the test suite"])+    <: fun makeMethod+    <: flag @"debug" @Method Release Nothing [help "Debug"]+    <: flag @"release" @Method Release Nothing [help "Release"]+    <: flag @"profile" @Method Release Nothing [help "Profile"]+    <: option @"threads" @Int [short 'j', help "Number of threads to use", metavar "INT"]+    <: arguments @"extra" @Text [metavar "ANY"]+    <: arguments @"files" @FilePath [metavar "FILE"]+    <: switch @"help" [short '?', help "Display help message"]+    <: switch @"version" [short 'V', help "Print version information"]+    <: addDecoder methodDecoder+    <: defaults++makeMethod :: Parser "debug" Method -> Parser "release" Method -> Parser "profile" Method -> Parser "method" Method+makeMethod p1 p2 p3 = coerce p1 <|> coerce p2 <|> coerce p3++-- * Helpers++displayLines h = fmap trimRight (T.lines (displayHelp h))
+ test/Test/Data/Registry/Options/ParserSpec.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Test.Data.Registry.Options.ParserSpec where++import Data.Coerce+import Data.Registry+import Data.Registry.Options hiding (defaults)+import Data.Registry.Options qualified as Defaults+import Protolude+import Test.Data.Registry.Options.Fs+import Test.Tasty.Hedgehogx hiding (Command, defaultValue)++test_parse_option = test "parse an option" $ do+  let p = make @(Parser "text" Text) (option @"text" @Text [] <: defaults)+  parse p "--t eric" === Right "eric"+  parse p "--text eric" === Right "eric"+  parse p "--typo eric" === Left "missing default value for argument: text"++test_parse_flag = test "parse a flag" $ do+  -- with no default value+  let p = make @(Parser "int" Int) (flag @"int" @Int 10 Nothing [] <: defaults)++  annotate "a flag cannot work as an option, the active value is always taken"+  parse p "--int 1" === Right 10+  parse p "--i 1" === Right 10++  annotate "a flag has an active value"+  parse p "--int" === Right 10+  parse p "-i" === Right 10++  parse p "--typo" === Left "missing default value for argument: int"++  -- with a default value+  let p1 = make @(Parser "int" Int) (flag @"int" @Int 10 (Just 100) [] <: defaults)+  annotate "a flag cannot work as an option, the active value is always taken"+  parse p1 "--int 1" === Right 10+  parse p1 "-i 1" === Right 10++  annotate "a flag has an active value"+  parse p1 "--int" === Right 10+  parse p1 "-i" === Right 10++  parse p1 "--typo" === Right 100++test_parse_switch = test "parse a switch" $ do+  let p = make @(Parser "bool" Bool) (switch @"bool" [] <: defaults)+  parse p "-b" === Right True+  parse p "--bool" === Right True+  parse p "--typo" === Right False++test_parse_switches = test "parse several short switches" $ do+  let f (pa :: Parser "a" Bool) (pb :: Parser "b" Bool) (pc :: Parser "c" Bool) =+        (,,) <$> coerce pa <*> coerce pb <*> coerce pc :: Parser "abc" (Bool, Bool, Bool)+  let r =+        fun f+          <: switch @"a" []+          <: switch @"b" []+          <: switch @"c" []+          <: defaults++  let p = make @(Parser "abc" (Bool, Bool, Bool)) $ r+  parse p "-abc" === Right (True, True, True)++test_parse_argument = test "parse an argument" $ do+  let p = make @(Parser "argument" Text) (argument @"argument" @Text [] <: defaults)+  parse p "eric" === Right "eric"++test_parse_constructor = test "parse a constructor" $ do+  let parsers =+        fun constructor1+          <: option @"text" @Text []+          <: flag @"int" @Int 10 (Just 100) []+          <: switch @"bool" []+          <: argument @"file" @File []+          <: defaults++  let p = getParser @Constructor1 parsers++  -- the order of options does not matter+  -- but the convention is that options go before arguments+  parse p "-b --int --text eric file1" === Right (Constructor1 "eric" True 10 file1)+  parse p "-b --text eric --int file1" === Right (Constructor1 "eric" True 10 file1)+  parse p "-b --text eric file1" === Right (Constructor1 "eric" True 100 file1)++  annotateShow "-- can be used to separate arguments from options"+  parse p "-b --text eric --int -- file1" === Right (Constructor1 "eric" True 10 file1)++test_add_help = test "the help text can be specified for each option, and names can be changed" $ do+  let _parsers =+        fun constructor1+          <: option @"text" @Text [help "a text", metavar "SOME_TEXT", name "some-text"]+          <: flag @"int" @Int 10 (Just 100) [help "an int"]+          <: switch @"bool" [help "a bool"]+          <: argument @"file" @File [help "a file path"]+          <: defaults+  success++test_parse_repeated_options = test "parse options with repeated values" $ do+  let r =+        fun (nonEmptyParser @"filesNonEmpty" @File)+          <: fun (list1Parser @"files1" @File)+          <: fun (listParser @"files" @File)+          <: option @"filesNonEmpty" @File []+          <: option @"files1" @File []+          <: option @"files" @File []+          <: defaults++  let p = make @(Parser "files" [File]) r+  let p1 = make @(Parser "files1" [File]) r+  let pNonEmpty = make @(Parser "filesNonEmpty" (NonEmpty File)) r++  parse p "" === Right []+  parse p "--files" === Right []+  parse p "--files file1 file2 -- args" === Right [File "file1", File "file2"]++  parse p1 "" === Left "missing default value for argument: files1"+  parse p1 "--files1" === Left "missing active value for argument: files1"+  parse p1 "--files1 file1 file2 -- args" === Right [File "file1", File "file2"]++  parse pNonEmpty "" === Left "missing default value for argument: files-non-empty"+  parse pNonEmpty "--files-non-empty" === Left "missing active value for argument: files-non-empty"+  parse pNonEmpty "--files-non-empty file1 file2 -- args" === Right (File "file1" :| [File "file2"])++test_parse_repeated_arguments = test "parse arguments with repeated values" $ do+  let r =+        fun (nonEmptyParser @"filesNonEmpty" @File)+          <: fun (list1Parser @"files1" @File)+          <: fun (listParser @"files" @File)+          <: argument @"filesNonEmpty" @File []+          <: argument @"files1" @File []+          <: argument @"files" @File []+          <: defaults++  let p = make @(Parser "files" [File]) r+  let p1 = make @(Parser "files1" [File]) r+  let pNonEmpty = make @(Parser "filesNonEmpty" (NonEmpty File)) r++  parse p "" === Right []+  parse p "file1 file2" === Right [File "file1", File "file2"]++  parse p1 "" === Left "missing default value for argument: FILE"+  parse p1 "file1 file2" === Right [File "file1", File "file2"]++  parse pNonEmpty "" === Left "missing default value for argument: FILE"+  parse pNonEmpty "file1 file2" === Right (File "file1" :| [File "file2"])++test_parse_optional = test "parse optional options and arguments" $ do+  let parsers =+        fun constructor1+          <: setDefaultValue @"text" @Text "eric"+          <: setDefaultValue @"int" @Int 100+          <: setDefaultValue @"bool" True+          <: setDefaultValue @"file" (File "file1")+          --+          <: option @"text" @Text []+          <: flag @"int" @Int 10 Nothing []+          <: switch @"bool" []+          <: argument @"file" @File []+          <: defaults++  let p = getParser @Constructor1 parsers++  -- the order of options does not matter+  -- but the convention is that options go before arguments+  parse p "" === Right (Constructor1 "eric" True 100 file1)++test_parse_alternatives = test "parse alternative options and arguments" $ do+  let parsers =+        fun simpleAlternative+          <: flag @"bool" True Nothing []+          <: option @"text" @Text []+          <: option @"int" @Int []+          <: defaults++  let p = getParser @SimpleAlternative parsers+  parse p "" === Left "missing default value for argument: int"+  parse p "-b" === Right (SimpleAlternative1 True)+  parse p "--text hello" === Right (SimpleAlternative2 "hello")++  takeOptionValue ["repeat"] (optionLexemes "repeat" "10") === Just ("repeat", Just "10", mempty)+  parse p "--int 10" === Right (SimpleAlternative3 10)++test_parse_command = test "parse a command" $ do+  let p =+        make @(Parser Command Copy) $+          fun (copyCommand "copy")+            <: switch @"force" []+            <: setDefaultValue @"retries" @(Maybe Int) Nothing+            <: fun (maybeParser @"retries" @Int)+            <: option @"retries" @Int []+            <: positional @"source" @Text 0 []+            <: positional @"target" @Text 1 []+            <: defaults+  parse p "copy -f source target" === Right (Copy True Nothing "source" "target")++test_parse_named = test "parse a flag name" $ do+  let p =+        make @(Parser "language" Language) $+          named @"language" @Language []+            <: addDecoder languageDecoder+            <: defaults++  parse p "--haskell" === Right Haskell+  parse p "--idris" === Right Idris+  parse p "--other" === Left "Flag not found for data type `Language`"++  annotate "matched flags must be removed from the input strings"+  parseLexed p (lexArgs ["--haskell", "--other"]) === Right (Haskell, flagLexemes "other")++-- * HELPERS++getParser :: forall a. (Typeable a) => Registry _ _ -> Parser Command a+getParser = make @(Parser Command a)++constructor1 :: Parser "text" Text -> Parser "bool" Bool -> Parser "int" Int -> Parser "file" File -> Parser "Command" Constructor1+constructor1 p1 p2 p3 p4 = Constructor1 <$> coerce p1 <*> coerce p2 <*> coerce p3 <*> coerce p4++defaults = funTo @Decoder File <: Defaults.defaults++data Constructor1 = Constructor1 Text Bool Int File+  deriving (Eq, Show)++data SimpleAlternative+  = SimpleAlternative1 Bool+  | SimpleAlternative2 Text+  | SimpleAlternative3 Int+  deriving (Eq, Show)++simpleAlternative :: Parser "bool" Bool -> Parser "text" Text -> Parser "int" Int -> Parser Command SimpleAlternative+simpleAlternative p1 p2 p3 = (SimpleAlternative1 <$> coerce p1) <|> (SimpleAlternative2 <$> coerce p2) <|> (SimpleAlternative3 <$> coerce p3)++file1 :: File+file1 = File "file1"++-- COPY EXAMPLE for 2 arguments++copyCommand :: Text -> Parser "force" Bool -> Parser "retries" (Maybe Int) -> Parser "source" Text -> Parser "target" Text -> Parser Command Copy+copyCommand commandName p1 p2 p3 p4 = Parser noHelp $ \ls ->+  case lexedArguments ls of+    (n : _)+      | commandName == n ->+          parseLexed (Copy <$> coerce p1 <*> coerce p2 <*> coerce p3 <*> coerce p4) (popArgumentValue ls)+    _ ->+      Left $ "command not found, expected: " <> commandName++data Language = Haskell | Idris deriving (Eq, Show)++languageDecoder :: Text -> Either Text Language+languageDecoder "haskell" = Right Haskell+languageDecoder "idris" = Right Idris+languageDecoder _other = Left "wrong language, expected: Haskell or Idris"
+ test/Test/Data/Registry/Options/SourcesSpec.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Test.Data.Registry.Options.SourcesSpec where++import Data.ByteString.Lazy as BS+import Data.Registry+import Data.Registry.Options+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.YAML as Y (decode)+import Protolude as P+import System.Directory (removeFile)+import System.Environment+import Test.Tasty.Hedgehogx++-- | This is a large test but it avoid issues with concurrent execution when+--   writing down separate tests+test_sources = test "values can be retrieved from various sources" $ do+  -- from the environment+  lexemes1 <- withEnv "OPTION_NAME" "value" $ getLexemesWith (setOptionNames os)+  lexemes1 === optionLexemes "option-name" "value"++  -- from YAML+  lexemes2 <- withConfigFile (T.unlines ["option_name:", "  - value"]) $ \path -> getLexemesWith (setOptionNames os . setConfigFilePath path)+  lexemes2 === optionLexemes "option-name" "value"++  -- from the command line+  lexemes3 <- liftIO . withArgs ["--option-name", "value"] $ getLexemesWith (setOptionNames os)+  lexemes3 === ambiguousLexemes "option-name" ["value"]++  -- with priorities+  lexemes4 <-+    withConfigFile (T.unlines ["option_name:", "  - value1"]) $ \path ->+      withEnv "OPTION_NAME" "value3" $+        withArgs ["--option-name", "value2"] $+          getLexemesWith (setOptionNames os . setConfigFilePath path)++  lexemes4 === optionLexemes "option-name" "value3"++test_collect_yaml_options = test "all paths can be retrieved from a Yaml document" $ do+  checkOptionsFrom+    [ "option_name:",+      "  - value"+    ]+    [(YamlName ["option_name"], ["value"])]++  checkOptionsFrom+    [ "section:",+      "  - option_name:",+      "    - value"+    ]+    [(YamlName ["section", "option_name"], ["value"])]++  checkOptionsFrom+    [ "- option_name:",+      "  - 10"+    ]+    [(YamlName ["option_name"], ["10"])]++  checkOptionsFrom+    [ "- option_name:",+      "    - true"+    ]+    [(YamlName ["option_name"], ["True"])]++-- * Helpers++parsers = switch @"optionName" [] <: defaults++os = getOptionNames $ make @(Parser "optionName" Bool) parsers++-- | Execute an action after writing the config file+withConfigFile :: MonadIO m => Text -> (Text -> IO a) -> m a+withConfigFile t f = do+  let configFileName = "config.yaml"+  liftIO $ P.writeFile configFileName t+  a <- liftIO (f $ toS configFileName)+  liftIO $ removeFile configFileName+  pure a++-- | Execute an action with given key/value in the environment+withEnv :: MonadIO m => Text -> Text -> IO a -> m a+withEnv key value action = liftIO $ do+  setEnv (toS key) (toS value)+  a <- action+  unsetEnv (toS key)+  pure a++-- | Check that parsing some yaml returns the expected option name/values+checkOptionsFrom ts expected = do+  let Right [yamlDoc] = Y.decode . BS.fromStrict . T.encodeUtf8 $ T.unlines ts+  let collected = collectYamlOptions yamlDoc+  collected === expected
+ test/Test/Data/Registry/Options/TextSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Test.Data.Registry.Options.TextSpec where++import Data.Registry.Options.Text+import Protolude+import Test.Tasty.Hedgehogx++test_drop_prefix = test "drop the camel cased prefix of a name" $ do+  dropPrefix "name" === "name"+  dropPrefix "Name" === "Name"+  dropPrefix "prefixName" === "name"+  dropPrefix "PrefixName" === "Name"+  dropPrefix "prefixName1Name2" === "name1Name2"+  dropPrefix "PrefixName1Name2" === "Name1Name2"++test_hyphenate = test "camelCaseToHyphenated a camelCased string" $ do+  camelCaseToHyphenated "name" === "name"+  camelCaseToHyphenated "Name" === "name"+  camelCaseToHyphenated "aName" === "a-name"+  camelCaseToHyphenated "AName" === "a-name"+  camelCaseToHyphenated "aName1Name2" === "a-name1-name2"+  camelCaseToHyphenated "AName1Name2" === "a-name1-name2"++test_display_columns = test "display two list of strings in columns" $ do+  displayColumns ["12345678", "123", "12345"] ["12", "12345"]+    === [ "12345678          12",+          "123               12345"+        ]++  displayColumns ["123", "12345678", "12345"] ["12", "12345", "1234"]+    === [ "123               12",+          "12345678          12345",+          "12345             1234"+        ]++test_underscore_to_camel_case = test "underscore name to camel case name" $ do+  underscoreToCamelCase "option" === "option"+  underscoreToCamelCase "option_name" === "optionName"+  underscoreToCamelCase "prefixed_option_name" === "prefixedOptionName"++test_camel_case_to_underscore = test "underscore name to camel case name" $ do+  camelCaseToUnderscore "option" === "option"+  camelCaseToUnderscore "optionName" === "option_name"+  camelCaseToUnderscore "prefixedOptionName" === "prefixed_option_name"++test_underscore_to_hyphenated = test "underscore name to hyphenated case name" $ do+  underscoreToHyphenated "option" === "option"+  underscoreToHyphenated "option_name" === "option-name"+  underscoreToHyphenated "prefixed_option_name" === "prefixed-option-name"++test_hyphenated_to_underscore = test "hyphenated name to underscore name" $ do+  hyphenatedToUnderscore "option" === "option"+  hyphenatedToUnderscore "option-name" === "option_name"+  hyphenatedToUnderscore "prefixed-option-name" === "prefixed_option_name"
+ test/test.hs view
@@ -0,0 +1,5 @@+import AutoDiscoveredSpecs (tests)+import Protolude+import Test.Tasty.Hedgehogx++main = tests >>= defaultMain . groupByModuleName