packages feed

descriptive (empty) → 0.0.0

raw patch · 10 files changed

+869/−0 lines, 10 filesdep +aesondep +basedep +bifunctorssetup-changed

Dependencies added: aeson, base, bifunctors, containers, mtl, text, transformers

Files

+ LICENSE view
@@ -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 <COPYRIGHT HOLDER> 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.
+ README.md view
@@ -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 "<distrans-verb> a <noun> <prep> a <noun>" ==+Right (ComplVDisV (DistransitiveV "<distrans-verb>")+                  (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))+                  (ComplPP (PP (Preposition "<prep>")+                               (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))))+```++Which I can then further parse with `descriptive` to yield+descriptions like:++    <verb-phrase> [<noun-phrase> ..]++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ descriptive.cabal view
@@ -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
+ src/Descriptive.hs view
@@ -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
+ src/Descriptive/Char.hs view
@@ -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
+ src/Descriptive/Form.hs view
@@ -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'))
+ src/Descriptive/Formlet.hs view
@@ -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})
+ src/Descriptive/JSON.hs view
@@ -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)
+ src/Descriptive/Options.hs view
@@ -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)