diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2015, descriptive +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of descriptive nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,307 @@ +descriptive +===== + +Self-describing consumers/parsers + +[Haddocks](http://chrisdone.com/descriptive/) + +There are a variety of Haskell libraries which are implementable +through a common interface: self-describing parsers: + +* A formlet is a self-describing parser. +* A regular old text parser can be self-describing. +* A command-line options parser is a self-describing parser. +* A MUD command set is a self-describing parser. +* A JSON API can be a self-describing parser. + +Consumption is done in this data type: + +``` haskell +data Consumer s d a +``` + +To make a consumer, this combinator is used: + +``` haskell +consumer :: (s -> (Description d,s)) + -> (s -> (Either (Description d) a,s)) + -> Consumer s d a +``` + +The first argument generates a description based on some state. The +state is determined by whatever use-case you have. The second argument +parses from the state, which could be a stream of bytes, a list of +strings, a Map, a Vector, etc. You may or may not decide to modify the +state during generation of the description and during parsing. + +To use a consumer or describe what it does, these are used: + +``` haskell +consume :: Consumer s d a -> s -> (Either (Description d) a,s) +describe :: Consumer s d a -> s -> (Description d,s) +``` + +A description is like this: + +``` haskell +data Description a + = Unit !a + | Bounded !Integer !Bound !(Description a) + | And !(Description a) !(Description a) + | Sequence [Description a] + | Wrap a (Description a) + | None + deriving (Show) +``` + +You configure the `a` for your use-case, but the rest is generatable +by the library. Afterwards, you can make your own pretty printing +function, which may be to generate an HTML form, to generate a +commandline `--help` screen, a man page, API docs for your JSON +parser, a text parsing grammar, etc. For example: + +``` haskell +describeParser :: Consumer [Char] Text Demo -> Text +describeForm :: Consumer (Map Text Text) (Html ()) Login -> Html () +describeArgs :: Consumer [Text] CmdArgs MyApp -> CmdArgs +``` + +See below for some examples of this library. + +## Parsing characters + +See `Descriptive.Char`. + +``` haskell +λ> describe (many (char 'k') <> string "abc") mempty +(And (Bounded 0 UnlimitedBound (Unit "k")) + (Sequence [Unit "a",Sequence [Unit "b",Sequence [Unit "c",Sequence []]]]) +,"") +λ> consume (many (char 'k') <> string "abc") "kkkabc" +(Right "kkkabc","") +λ> consume (many (char 'k') <> string "abc") "kkkab" +(Left (Unit "a character"),"") +λ> consume (many (char 'k') <> string "abc") "kkkabj" +(Left (Unit "c"),"") +``` + +## Validating forms with named inputs + +See `Descriptive.Form`. + +``` haskell +λ> describe ((,) <$> input "username" <*> input "password") mempty +(And (Unit (Input "username")) (Unit (Input "password")),fromList []) + +λ> consume ((,) <$> + input "username" <*> + input "password") + (M.fromList [("username","chrisdone"),("password","god")]) +(Right ("chrisdone","god") +,fromList [("password","god"),("username","chrisdone")]) +``` + +Conditions on two inputs: + +``` haskell +login = validate "confirmed password (entered the same twice)" + (\(x,y) -> + if x == y + then Just y + else Nothing) + ((,) <$> + input "password" <*> + input "password2") +``` + +``` haskell +λ> describe login mempty +(Wrap (Constraint "confirmed password (entered the same twice)") + (And (Unit (Input "password")) + (Unit (Input "password2"))) +,fromList []) + +λ> consume login (M.fromList [("password2","gob"),("password","gob")]) +(Right "gob",fromList [("password","gob"),("password2","gob")]) +``` + +## Validating forms with auto-generated input indexes + +See `Descriptive.Formlet`. + +``` haskell +λ> describe ((,) <$> indexed <*> indexed) + (FormletState mempty 0) +(And (Unit (Index 0)) + (Unit (Index 1)) +,FormletState {formletMap = fromList [] + ,formletIndex = 2}) +λ> consume ((,) <$> indexed <*> indexed) + (FormletState (M.fromList [(0,"chrisdone"),(1,"god")]) 0) +(Right ("chrisdone","god") +,FormletState {formletMap = + fromList [(0,"chrisdone"),(1,"god")] + ,formletIndex = 2}) +λ> consume ((,) <$> indexed <*> indexed) + (FormletState (M.fromList [(0,"chrisdone")]) 0) +(Left (Unit (Index 1)) +,FormletState {formletMap = + fromList [(0,"chrisdone")] + ,formletIndex = 2}) +``` + +## Parsing command-line options + +See `Descriptive.Options`. + +``` haskell +server = + ((,,,) <$> + constant "start" <*> + anyString "SERVER_NAME" <*> + flag "dev" "Enable dev mode?" <*> + arg "port" "Port to listen on") +``` + +``` haskell +λ> describe server [] +(And (And (And (Unit (Constant "start")) + (Unit (AnyString "SERVER_NAME"))) + (Unit (Flag "dev" "Enable dev mode?"))) + (Unit (Arg "port" "Port to listen on")) +,[]) +λ> consume server ["start","any","--port","1234","-fdev"] +(Right ("start","any",True,"1234"),[]) +λ> consume server ["start","any","--port","1234"] +(Right ("start","any",False,"1234"),[]) +λ> consume server ["start","any"] +(Left (Unit (Arg "port" "Port to listen on")),[]) +``` + +## Self-documenting JSON parser + +See `Descriptive.JSON`. + +``` haskell +-- | Submit a URL to reddit. +data Submission = + Submission {submissionToken :: !Integer + ,submissionTitle :: !Text + ,submissionComment :: !Text + ,submissionSubreddit :: !Integer} + deriving (Show) + +submission :: Consumer Value Doc Submission +submission = + obj "Submission" + (Submission + <$> key "token" (integer "Submission token; see the API docs") + <*> key "title" (string "Submission title") + <*> key "comment" (string "Submission comment") + <*> key "subreddit" (integer "The ID of the subreddit")) + +sample :: Value +sample = + toJSON (object + ["token" .= 123 + ,"title" .= "Some title" + ,"comment" .= "This is good" + ,"subreddit" .= 234214]) + +badsample :: Value +badsample = + toJSON (object + ["token" .= 123 + ,"title" .= "Some title" + ,"comment" .= 123 + ,"subreddit" .= 234214]) +``` + +``` haskell +λ> describe submission (toJSON ()) +(Wrap (Struct "Submission") + (And (And (And (Wrap (Key "token") + (Unit (Integer "Submission token; see the API docs"))) + (Wrap (Key "title") + (Unit (Text "Submission title")))) + (Wrap (Key "comment") + (Unit (Text "Submission comment")))) + (Wrap (Key "subreddit") + (Unit (Integer "The ID of the subreddit")))) +,Array (fromList [])) + +λ> consume submission sample +(Right (Submission {submissionToken = 123 + ,submissionTitle = "Some title" + ,submissionComment = "This is good" + ,submissionSubreddit = 234214}) +,Object (fromList [("token",Number 123.0) + ,("subreddit",Number 234214.0) + ,("title",String "Some title") + ,("comment",String "This is good")])) + +λ> consume submission badsample +(Left (Wrap (Struct "Submission") + (Wrap (Key "comment") + (Unit (Text "Submission comment")))) +,Object (fromList [("token",Number 123.0) + ,("subreddit",Number 234214.0) + ,("title",String "Some title") + ,("comment",Number 123.0)])) +``` + +The bad sample yields an informative message that: + +* The error is in the Submission object. +* The key "comment". +* The type of that key should be a String and it should be a + Submission comment (or whatever invariants you'd like to mention). + +## Parsing Attempto Controlled English for MUD commands + +TBA. Will use +[this package](http://chrisdone.com/posts/attempto-controlled-english). + +With ACE you can parse into: + +``` haskell +parsed complV " a a " == +Right (ComplVDisV (DistransitiveV "") + (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))) + (ComplPP (PP (Preposition "") + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) +``` + +Which I can then further parse with `descriptive` to yield +descriptions like: + + [ ..] + +Or similar. Which would be handy for a MUD so that a user can write: + +> Put the sword on the table. + +## Producing questions and consuming the answers in Haskell + +TBA. Will be a generalization of +[this type](https://github.com/chrisdone/exercise/blob/master/src/Exercise/Types.hs#L20). + +It is a library which I am working on in parallel which will ask the +user questions and then validate the answers. Current output is like +this: + +``` haskell +λ> describe (greaterThan 4 (integerExpr (parse id expr exercise))) +an integer greater than 4 +λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "x = 1") +Left expected an expression, but got a declaration +λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "x") +Left expected an integer, but got an expression +λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "3") +Left expected an integer greater than 4 +λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "5") +Right 5 +``` + +This is also couples description with validation, but I will probably +rewrite it with this `descriptive` library. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/descriptive.cabal b/descriptive.cabal new file mode 100644 --- /dev/null +++ b/descriptive.cabal @@ -0,0 +1,27 @@ +name: descriptive +version: 0.0.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 +homepage: https://github.com/chrisdone/descriptive +license: BSD3 +license-file: LICENSE +author: Chris Done +maintainer: chrisdone@gmail.com +copyright: 2015 Chris Done +category: Parsing +build-type: Simple +cabal-version: >=1.8 +extra-source-files: README.md + +library + hs-source-dirs: src/ + ghc-options: -Wall -O2 + exposed-modules: Descriptive + Descriptive.Char + Descriptive.Form + Descriptive.Formlet + Descriptive.Options + Descriptive.JSON + build-depends: base >= 4 && <5, + transformers, containers, text, mtl, aeson, bifunctors diff --git a/src/Descriptive.hs b/src/Descriptive.hs new file mode 100644 --- /dev/null +++ b/src/Descriptive.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Descriptive parsers. + +module Descriptive + (Description(..) + ,Bound(..) + ,Consumer(..) + ,consumer + ,wrap + ,sequencing + ,consume + ,describe) + where + +import Control.Applicative +import Control.Arrow +import Data.Function +import Data.Monoid + +-------------------------------------------------------------------------------- +-- Types + +-- | Description of a consumable thing. +data Description a + = Unit !a + | Bounded !Integer !Bound !(Description a) + | And !(Description a) !(Description a) + | Or !(Description a) !(Description a) + | Sequence [Description a] + | Wrap a (Description a) + | None + deriving (Show) + +instance Monoid (Description d) where + mempty = None + mappend = And + +-- | The bounds of a many-consumable thing. +data Bound + = NaturalBound !Integer + | UnlimitedBound + deriving (Show) + +-- | A consumer. +data Consumer s d a = + Consumer {consumerDesc :: s -> (Description d,s) + ,consumerParse :: s -> (Either (Description d) a,s)} + +instance Functor (Consumer s d) where + fmap f (Consumer d p) = + Consumer d + (\s -> + case p s of + (Left e,s') -> (Left e,s') + (Right a,s') -> + (Right (f a),s')) + +instance Applicative (Consumer s d) where + pure a = + consumer (\s -> (mempty,s)) + (\s -> (Right a,s)) + Consumer d pf <*> Consumer d' p' = + consumer (\s -> + let !(e,s') = d s + !(e',s'') = d' s' + in (e <> e',s'')) + (\s -> + let !(mf,s') = pf s + !(ma,s'') = p' s' + in case mf of + Left e -> (Left e,s') + Right f -> + case ma of + Left e -> (Left e,s'') + Right a -> + (Right (f a),s'')) + +instance Alternative (Consumer s d) where + empty = + Consumer (\s -> (mempty,s)) + (\s -> (Left mempty,s)) + a <|> b = + Consumer (\s -> + let !(d1,s') = consumerDesc a s + !(d2,s'') = consumerDesc b s' + in (Or d1 d2,s'')) + (\s -> + case consumerParse a s of + (Left e1,s') -> + case consumerParse b s' of + (Left e2,s'') -> + (Left (Or e1 e2),s'') + (Right a2,s'') -> + (Right a2,s'') + (Right a1,s') -> (Right a1,s')) + some = sequenceHelper 1 + many = sequenceHelper 0 + +-- | An internal sequence maker which describes itself better than +-- regular Alternative, and is strict, not lazy. +sequenceHelper :: Integer -> Consumer t d a -> Consumer t d [a] +sequenceHelper minb = + wrap (\s d -> first redescribe (d s)) + (\s _ r -> + fix (\go !i s' as -> + case r s' of + (Right a,s'') -> + go (i + 1) + s'' + (a : as) + (Left e,s'') + | i >= minb -> + (Right (reverse as),s') + | otherwise -> + (Left (redescribe e),s'')) + 0 + s + []) + where redescribe = + Bounded minb UnlimitedBound + +instance (Monoid a) => Monoid (Either (Description d) a) where + mempty = Right mempty + mappend x y = + case x of + Left e -> Left e + Right a -> + case y of + Left e -> Left e + Right b -> Right (a <> b) + +instance (Monoid a) => Monoid (Consumer s d a) where + mempty = Consumer (\s -> (mempty,s)) (\s -> (mempty,s)) + mappend x y = (<>) <$> x <*> y + +-------------------------------------------------------------------------------- +-- Combinators + +-- | Make a consumer. +consumer :: (s -> (Description d,s)) -> (s -> (Either (Description d) a,s)) -> Consumer s d a +consumer d p = + Consumer d p + +-- | Wrap a consumer with another consumer. +wrap :: (s -> (t -> (Description d,t)) -> (Description d,s)) + -> (s -> (t -> (Description d,t)) -> (t -> (Either (Description d) a,t)) -> (Either (Description d) b,s)) + -> Consumer t d a + -> Consumer s d b +wrap redescribe reparse (Consumer d p) = + Consumer (\s -> redescribe s d) + (\s -> reparse s d p) + +-- | Compose contiguous items into one sequence. +sequencing :: [Consumer d s a] -> Consumer d s [a] +sequencing = + wrap (\s d -> + first (Sequence . se) + (d s)) + (\s _ p -> p s) . + go + where se (And x y) = x : se y + se None = [] + se x = [x] + go (x:xs) = (:) <$> x <*> sequencing xs + go [] = mempty + +-------------------------------------------------------------------------------- +-- Running + +-- | Run a consumer. +consume :: Consumer s d a -> s -> (Either (Description d) a,s) +consume (Consumer _ m) = m + +-- | Describe a consumer. +describe :: Consumer s d a -> s -> (Description d,s) +describe (Consumer desc _) = desc diff --git a/src/Descriptive/Char.hs b/src/Descriptive/Char.hs new file mode 100644 --- /dev/null +++ b/src/Descriptive/Char.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Consuming form a list of characters. +-- +-- Examples: +-- +-- λ> describe (zeroOrMore (char 'k') <> string "abc") [] +-- (And (Bounded 0 UnlimitedBound (Unit "k")) (And (Unit "a") (And (Unit "b") (And (Unit "c") None))),"") +-- +-- λ> consumer (zeroOrMore (char 'k') <> string "abc") "kkkabc" +-- (Right "kkkabc","") +-- +-- λ> consumer (zeroOrMore (char 'k') <> string "abc") "kkkabq" +-- (Left (Unit "c"),"") +-- +-- λ> consumer (zeroOrMore (char 'k') <> string "abc") "kkkab" +-- (Left (Unit "a character"),"") + +module Descriptive.Char where + +import Descriptive + +import Data.Text (Text) +import qualified Data.Text as T + +-- | Consume any character. +anyChar :: Consumer [Char] Text Char +anyChar = + consumer (d,) + (\s -> + case s of + (c':cs') -> (Right c',cs') + [] -> (Left d,s)) + where d = Unit "a character" + +-- | A character consumer. +char :: Char -> Consumer [Char] Text Char +char c = + wrap (const . + (d,)) + (\s _ p -> + case p s of + (Left e,s') -> (Left e,s') + (Right c',s') + | c' == c -> (Right c,s') + | otherwise -> (Left d,s')) + anyChar + where d = Unit (T.singleton c) + +-- | A string consumer. +string :: [Char] -> Consumer [Char] Text [Char] +string = sequencing . map char diff --git a/src/Descriptive/Form.hs b/src/Descriptive/Form.hs new file mode 100644 --- /dev/null +++ b/src/Descriptive/Form.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Validating form with named inputs. + +module Descriptive.Form where + +import Descriptive + +import Control.Arrow +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) + +-- | Form descriptor. +data Form + = Input !Text + | Constraint !Text + deriving (Show) + +-- | Consume any character. +input :: Text -> Consumer (Map Text Text) Form Text +input name = + consumer (d,) + (\s -> + (case M.lookup name s of + Nothing -> Left d + Just a -> Right a + ,s)) + where d = Unit (Input name) + +-- | Validate a form input with a description of what's required. +validate :: Text + -> (a -> Maybe b) + -> Consumer (Map Text Text) Form a + -> Consumer (Map Text Text) Form b +validate d' check = + wrap (\s d -> redescribe (d s)) + (\s d p -> + case p s of + (Left e,s') -> (Left e,s') + (Right a,s') -> + case check a of + Nothing -> + (Left (fst (redescribe (d s))),s') + Just a' -> (Right a',s')) + where redescribe = first (Wrap (Constraint d')) diff --git a/src/Descriptive/Formlet.hs b/src/Descriptive/Formlet.hs new file mode 100644 --- /dev/null +++ b/src/Descriptive/Formlet.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Validating indexed formlet with auto-generated input names. + +module Descriptive.Formlet where + +import Descriptive + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) + +data Formlet + = Index !Integer + | Constrained !Text + deriving (Show) + +data FormletState = + FormletState {formletMap :: (Map Integer Text) + ,formletIndex :: !Integer} + deriving (Show) + +-- | Consume any character. +indexed :: Consumer FormletState Formlet Text +indexed = + consumer (\(nextIndex -> (i,s)) -> (d i,s)) + (\(nextIndex -> (i,s)) -> + case M.lookup i (formletMap s) of + Nothing -> (Left (d i),s) + Just a -> (Right a,s)) + where d = Unit . Index + nextIndex s = + (formletIndex s,s {formletIndex = formletIndex s + 1}) diff --git a/src/Descriptive/JSON.hs b/src/Descriptive/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Descriptive/JSON.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- | A JSON API which describes itself. + +module Descriptive.JSON where + +import Data.Bifunctor +import Data.Monoid +import Descriptive + +import Data.Aeson +import Data.Aeson.Types +import Data.Text (Text) + +-- | Description of parseable things. +data Doc + = Integer !Text + | Text !Text + | Struct !Text + | Key !Text + deriving (Show) + +-- | Consume an object. +obj :: Text -> Consumer Object Doc a -> Consumer Value Doc a +obj desc = + wrap (\v d -> (Wrap doc (fst (d mempty)),v)) + (\v _ p -> + case fromJSON v of + Error{} -> (Left (Unit doc),v) + Success o -> + (case p o of + (Left e,_) -> Left (Wrap doc e) + (Right a,_) -> Right a + ,toJSON o)) + where doc = Struct desc + +-- | Consume from object at the given key. +key :: Text -> Consumer Value Doc a -> Consumer Object Doc a +key k = + wrap (\o d -> + first (Wrap doc) + (second (const o) + (d (toJSON o)))) + (\o _ p -> + case parseMaybe (const (o .: k)) + () of + Nothing -> (Left (Unit doc),o) + Just (v :: Value) -> + first (bimap (Wrap doc) id) + (second (const o) + (p v))) + where doc = Key k + +-- | Consume a string. +string :: Text -> Consumer Value Doc Text +string doc = + consumer (d,) + (\s -> + case fromJSON s of + Error{} -> (Left d,s) + Success a -> (Right a,s)) + where d = Unit (Text doc) + +-- | Consume an integer. +integer :: Text -> Consumer Value Doc Integer +integer doc = + consumer (d,) + (\s -> + case fromJSON s of + Error{} -> (Left d,s) + Success a -> (Right a,s)) + where d = Unit (Integer doc) diff --git a/src/Descriptive/Options.hs b/src/Descriptive/Options.hs new file mode 100644 --- /dev/null +++ b/src/Descriptive/Options.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Command-line options parser. + +module Descriptive.Options where + +import Descriptive + +import Data.Char +import Data.List +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T + +-- | Description of a commandline option. +data Option + = AnyString !Text + | Constant !Text + | Flag !Text !Text + | Arg !Text !Text + | Prefix !Text !Text + deriving (Show) + +-- | Make a text description of the command line options. +textDescription :: Description Option -> Text +textDescription = go . 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 + go d = + case d of + Unit o -> textOpt o + Bounded min' _ d' -> + "[" <> go d' <> "]" <> + if min' == 0 + then "*" + else "+" + And a b -> go a <> " " <> go b + Or a b -> "(" <> go a <> "|" <> go b <> ")" + Sequence xs -> + T.intercalate " " + (map go xs) + Wrap o d' -> textOpt o <> " " <> go d' + None -> "" + +-- | Make a text description of an option. +textOpt :: Option -> Text +textOpt (AnyString t) = T.map toUpper t +textOpt (Constant t) = t +textOpt (Flag t _) = "-f" <> t +textOpt (Arg t _) = "-" <> t <> " <...>" +textOpt (Prefix t _) = "-" <> t <> "<...>" + +-- | Consume one argument from the argument list. +anyString :: Text -> Consumer [Text] Option Text +anyString help = + consumer (d,) + (\s -> + case s of + [] -> (Left d,s) + (x:s') -> (Right x,s')) + where d = Unit (AnyString help) + +-- | Consume one argument from the argument list. +constant :: Text -> Consumer [Text] Option Text +constant x' = + consumer (d,) + (\s -> + case s of + (x:s') | x == x' -> + (Right x,s') + _ -> (Left d,s)) + where d = Unit (Constant x') + +-- | Find a short boolean flag. +flag :: Text -> Text -> Consumer [Text] Option Bool +flag name help = + consumer (d,) + (\s -> + (Right (elem ("-f" <> name) s),filter (/= "-f" <> name) s)) + where d = Unit (Flag name help) + +-- | Find an argument prefixed by -X. +prefix :: Text -> Text -> Consumer [Text] Option Text +prefix pref help = + consumer (d,) + (\s -> + case find (T.isPrefixOf ("-" <> pref)) s of + Nothing -> (Left d,s) + Just a -> (Right (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 +arg name help = + consumer (d,) + (\s -> + let indexedArgs = + zip [0 :: Integer ..] s + in case find ((== "--" <> name) . snd) indexedArgs of + Nothing -> (Left d,s) + Just (i,_) -> + case lookup (i + 1) indexedArgs of + Nothing -> (Left d,s) + Just text -> + (Right text + ,map snd (filter (\(j,_) -> j /= i && j /= i + 1) indexedArgs))) + where d = Unit (Arg name help)