diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,16 @@ +Copyright (c) 2022 Eric Torreborre + +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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* + +# 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/registry-options.cabal b/registry-options.cabal new file mode 100644 --- /dev/null +++ b/registry-options.cabal @@ -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 diff --git a/src/Data/Registry/Options.hs b/src/Data/Registry/Options.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options.hs @@ -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 diff --git a/src/Data/Registry/Options/Decoder.hs b/src/Data/Registry/Options/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Decoder.hs @@ -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) diff --git a/src/Data/Registry/Options/DefaultValues.hs b/src/Data/Registry/Options/DefaultValues.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/DefaultValues.hs @@ -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 diff --git a/src/Data/Registry/Options/Defaults.hs b/src/Data/Registry/Options/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Defaults.hs @@ -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 diff --git a/src/Data/Registry/Options/Display.hs b/src/Data/Registry/Options/Display.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Display.hs @@ -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) diff --git a/src/Data/Registry/Options/DisplayHelpBox.hs b/src/Data/Registry/Options/DisplayHelpBox.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/DisplayHelpBox.hs @@ -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) diff --git a/src/Data/Registry/Options/FieldConfiguration.hs b/src/Data/Registry/Options/FieldConfiguration.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/FieldConfiguration.hs @@ -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) diff --git a/src/Data/Registry/Options/Help.hs b/src/Data/Registry/Options/Help.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Help.hs @@ -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]} diff --git a/src/Data/Registry/Options/Lexemes.hs b/src/Data/Registry/Options/Lexemes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Lexemes.hs @@ -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 diff --git a/src/Data/Registry/Options/Main.hs b/src/Data/Registry/Options/Main.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Main.hs @@ -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 diff --git a/src/Data/Registry/Options/OptionDescription.hs b/src/Data/Registry/Options/OptionDescription.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/OptionDescription.hs @@ -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 @@ if no name has been defined yet +displayCliOptionName :: OptionDescription -> Text +displayCliOptionName o = + case getNames o of + n : _ -> camelCaseToHyphenated n + [] -> fromMaybe "" (_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 diff --git a/src/Data/Registry/Options/Parser.hs b/src/Data/Registry/Options/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Parser.hs @@ -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) diff --git a/src/Data/Registry/Options/Parsers.hs b/src/Data/Registry/Options/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Parsers.hs @@ -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 diff --git a/src/Data/Registry/Options/Sources.hs b/src/Data/Registry/Options/Sources.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Sources.hs @@ -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" diff --git a/src/Data/Registry/Options/TH.hs b/src/Data/Registry/Options/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/TH.hs @@ -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 diff --git a/src/Data/Registry/Options/Text.hs b/src/Data/Registry/Options/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Options/Text.hs @@ -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 "-" diff --git a/test/AutoDiscoveredSpecs.hs b/test/AutoDiscoveredSpecs.hs new file mode 100644 --- /dev/null +++ b/test/AutoDiscoveredSpecs.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=AutoDiscoveredSpecs #-} diff --git a/test/Test/Data/Registry/Options/Diffy.hs b/test/Test/Data/Registry/Options/Diffy.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/Diffy.hs @@ -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) diff --git a/test/Test/Data/Registry/Options/DiffySpec.hs b/test/Test/Data/Registry/Options/DiffySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/DiffySpec.hs @@ -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)) diff --git a/test/Test/Data/Registry/Options/DisplayHelpBoxSpec.hs b/test/Test/Data/Registry/Options/DisplayHelpBoxSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/DisplayHelpBoxSpec.hs @@ -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 diff --git a/test/Test/Data/Registry/Options/Fs.hs b/test/Test/Data/Registry/Options/Fs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/Fs.hs @@ -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 diff --git a/test/Test/Data/Registry/Options/GitSpec.hs b/test/Test/Data/Registry/Options/GitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/GitSpec.hs @@ -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 diff --git a/test/Test/Data/Registry/Options/HLint.hs b/test/Test/Data/Registry/Options/HLint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/HLint.hs @@ -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 + } diff --git a/test/Test/Data/Registry/Options/HLintSpec.hs b/test/Test/Data/Registry/Options/HLintSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/HLintSpec.hs @@ -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)) diff --git a/test/Test/Data/Registry/Options/HelpSpec.hs b/test/Test/Data/Registry/Options/HelpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/HelpSpec.hs @@ -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)) diff --git a/test/Test/Data/Registry/Options/LexemesSpec.hs b/test/Test/Data/Registry/Options/LexemesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/LexemesSpec.hs @@ -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") diff --git a/test/Test/Data/Registry/Options/Maker.hs b/test/Test/Data/Registry/Options/Maker.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/Maker.hs @@ -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" diff --git a/test/Test/Data/Registry/Options/MakerSpec.hs b/test/Test/Data/Registry/Options/MakerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/MakerSpec.hs @@ -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)) diff --git a/test/Test/Data/Registry/Options/ParserSpec.hs b/test/Test/Data/Registry/Options/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/ParserSpec.hs @@ -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" diff --git a/test/Test/Data/Registry/Options/SourcesSpec.hs b/test/Test/Data/Registry/Options/SourcesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/SourcesSpec.hs @@ -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 diff --git a/test/Test/Data/Registry/Options/TextSpec.hs b/test/Test/Data/Registry/Options/TextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Options/TextSpec.hs @@ -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" diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,5 @@ +import AutoDiscoveredSpecs (tests) +import Protolude +import Test.Tasty.Hedgehogx + +main = tests >>= defaultMain . groupByModuleName