diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +0.2.0: + * Change the type of flag. + * Add the switch combinator (used to be “flag”). + * Add the “stop” combinator. + 0.1.1: * Printer fix for options consumer. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -74,9 +74,8 @@ ``` haskell λ> describe (many (char 'k') <> string "abc") mempty -(And (Bounded 0 UnlimitedBound (Unit "k")) - (Sequence [Unit "a",Sequence [Unit "b",Sequence [Unit "c",Sequence []]]]) -,"") +And (Bounded 0 UnlimitedBound (Unit "k")) + (Sequence [Unit "a",Sequence [Unit "b",Sequence [Unit "c",Sequence []]]]) λ> consume (many (char 'k') <> string "abc") "kkkabc" (Succeeded "kkkabc") λ> consume (many (char 'k') <> string "abc") "kkkab" diff --git a/descriptive.cabal b/descriptive.cabal --- a/descriptive.cabal +++ b/descriptive.cabal @@ -1,5 +1,5 @@ name: descriptive -version: 0.1.1 +version: 0.2.0 synopsis: Self-describing consumers/parsers; forms, cmd-line args, JSON, etc. description: Self-describing consumers/parsers. See the README.md for more information. It is currently EXPERIMENTAL. stability: Experimental diff --git a/src/Descriptive/Options.hs b/src/Descriptive/Options.hs --- a/src/Descriptive/Options.hs +++ b/src/Descriptive/Options.hs @@ -10,14 +10,18 @@ anyString ,constant ,flag + ,switch ,prefix ,arg + ,stop -- * Description ,Option(..) ,textDescription ,textOpt) where +import Control.Applicative +import Data.Bifunctor import Descriptive import Data.Char @@ -27,16 +31,38 @@ import qualified Data.Text as T -- | Description of a commandline option. -data Option +data Option a = AnyString !Text - | Constant !Text + | Constant !Text !Text | Flag !Text !Text | Arg !Text !Text | Prefix !Text !Text + | Stops + | Stopped !a deriving (Show,Eq) --- | Consume one argument from the argument list. -anyString :: Text -> Consumer [Text] Option Text +-- | If the consumer succeeds, stops the whole parser and returns +-- immediately. +stop :: Consumer [Text] (Option a) a + -- ^ A parser which, when it succeeds, causes the whole parser to stop. + -> Consumer [Text] (Option a) () +stop = + wrap (\s d -> + first (Wrap Stops) + (d s)) + (\s d p -> + case p s of + (Failed _,s') -> (Succeeded (),s') + (Continued e,s') -> (Continued e,s') + (Succeeded a,s') -> + (Failed (Wrap (Stopped a) + (fst (d s))) + ,s')) + +-- | Consume one argument from the argument list and pops it from the +-- start of the list. +anyString :: Text -- Help for the string. + -> Consumer [Text] (Option a) Text anyString help = consumer (d,) (\s -> @@ -45,27 +71,46 @@ (x:s') -> (Succeeded x,s')) where d = Unit (AnyString help) --- | Consume one argument from the argument list. -constant :: Text -> Consumer [Text] Option Text -constant x' = +-- | Consume one argument from the argument list which must match the +-- given string. +constant :: Text -- ^ String. + -> Text -- ^ Description. + -> Consumer [Text] (Option a) Text +constant x' desc = consumer (d,) (\s -> case s of (x:s') | x == x' -> (Succeeded x,s') _ -> (Failed d,s)) - where d = Unit (Constant x') + where d = Unit (Constant x' desc) --- | Find a short boolean flag. -flag :: Text -> Text -> Consumer [Text] Option Bool -flag name help = +-- | Find a value flag which must succeed. +flag :: Text -- ^ Name. + -> Text -- ^ Description. + -> v -- ^ Value returned when present. + -> Consumer [Text] (Option a) v +flag name help v = consumer (d,) (\s -> - (Succeeded (elem ("--" <> name) s),filter (/= "--" <> name) s)) + if elem ("--" <> name) s + then (Succeeded v,filter (/= "--" <> name) s) + else (Failed d,s) + ) where d = Unit (Flag name help) +-- | Find a boolean flag. Always succeeds. Omission counts as 'False'. +switch :: Text -- ^ Name. + -> Text -- ^ Description. + -> Consumer [Text] (Option a) Bool +switch name help = + flag name help True <|> + pure False + -- | Find an argument prefixed by -X. -prefix :: Text -> Text -> Consumer [Text] Option Text +prefix :: Text -- ^ Prefix string. + -> Text -- ^ Description. + -> Consumer [Text] (Option a) Text prefix pref help = consumer (d,) (\s -> @@ -74,8 +119,10 @@ Just a -> (Succeeded (T.drop (T.length pref + 1) a), delete a s)) where d = Unit (Prefix pref help) --- | Find a named argument. -arg :: Text -> Text -> Consumer [Text] Option Text +-- | Find a named argument e.g. @--name value@. +arg :: Text -- ^ Name. + -> Text -- ^ Description. + -> Consumer [Text] (Option a) Text arg name help = consumer (d,) (\s -> @@ -92,28 +139,27 @@ where d = Unit (Arg name help) -- | Make a text description of the command line options. -textDescription :: Description Option -> Text -textDescription = go False . clean - where clean (And None a) = clean a - clean (And a None) = clean a - clean (Or a None) = clean a - clean (Or None a) = clean a - clean (And a b) = - And (clean a) - (clean b) - clean (Or a b) = - Or (clean a) - (clean b) - clean a = a +textDescription :: Description (Option a) -> Text +textDescription = + go False . + clean + where go inor d = case d of + Or None a -> "[" <> go inor a <> "]" + Or a None -> "[" <> go inor a <> "]" Unit o -> textOpt o Bounded min' _ d' -> - "[" <> go inor d' <> "]" <> + "[" <> + go inor d' <> + "]" <> if min' == 0 then "*" else "+" - And a b -> go inor a <> " " <> go inor b + And a b -> + go inor a <> + " " <> + go inor b Or a b -> (if inor then "" @@ -127,13 +173,38 @@ Sequence xs -> T.intercalate " " (map (go inor) xs) - Wrap o d' -> textOpt o <> " " <> go inor d' + Wrap o d' -> + textOpt o <> + (if T.null (textOpt o) + then "" + else " ") <> + go inor d' None -> "" +-- | Clean up the condition tree for single-line presentation. +clean :: Description a -> Description a +clean (And None a) = clean a +clean (And a None) = clean a +clean (Or a (Or b None)) = Or (clean a) (clean b) +clean (Or a (Or None b)) = Or (clean a) (clean b) +clean (Or None (Or a b)) = Or (clean a) (clean b) +clean (Or (Or a b) None) = Or (clean a) (clean b) +clean (Or a None) = Or (clean a) None +clean (Or None b) = Or None (clean b) +clean (And a b) = + And (clean a) + (clean b) +clean (Or a b) = + Or (clean a) + (clean b) +clean a = a + -- | Make a text description of an option. -textOpt :: Option -> Text +textOpt :: (Option a) -> Text textOpt (AnyString t) = T.map toUpper t -textOpt (Constant t) = t -textOpt (Flag t _) = "[--" <> t <> "]" +textOpt (Constant t _) = t +textOpt (Flag t _) = "--" <> t textOpt (Arg t _) = "--" <> t <> " <...>" textOpt (Prefix t _) = "-" <> t <> "<...>" +textOpt Stops = "" +textOpt (Stopped _) = "" diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | Test suite for ACE. @@ -18,7 +18,6 @@ import qualified Descriptive.Formlet as Formlet import qualified Descriptive.JSON as JSON import qualified Descriptive.Options as Options -import Test.HUnit import Test.Hspec (Spec,it,hspec) import qualified Test.Hspec as Hspec @@ -135,9 +134,9 @@ options = do it "describe options" (describe server [] == - And (And (And (Unit (Options.Constant "start")) + And (And (And (Unit (Options.Constant "start" "cmd")) (Unit (Options.AnyString "SERVER_NAME"))) - (Unit (Options.Flag "dev" "Enable dev mode?"))) + (Or (Unit (Options.Flag "dev" "Enable dev mode?")) None)) (Unit (Options.Arg "port" "Port to listen on"))) it "succeeding options" (consume server ["start","any","--port","1234","--dev"] == @@ -150,9 +149,9 @@ Failed (Unit (Options.Arg "port" "Port to listen on"))) where server = ((,,,) <$> - Options.constant "start" <*> + Options.constant "start" "cmd" <*> Options.anyString "SERVER_NAME" <*> - Options.flag "dev" "Enable dev mode?" <*> + Options.switch "dev" "Enable dev mode?" <*> Options.arg "port" "Port to listen on") --------------------------------------------------------------------------------