Merge 'feature/gnu-styled-help' into development

felixSchl · Jul 12, 2016 · 005c826 · 005c826
2 parents 000368c + 71d761b
commit 005c826
Show file tree

Hide file tree

Showing 13 changed files with 261 additions and 188 deletions.
diff --git a/src/Docopt/Docopt.purs b/src/Docopt/Docopt.purs
@@ -32,7 +32,7 @@ import Data.Array as A
 import Data.Bifunctor (lmap)
 import Data.String.Yarn (lines, unlines)
 
-import Language.Docopt (Docopt, Specification(), parseDocopt, evalDocopt)
+import Language.Docopt (Docopt, parseDocopt, evalDocopt)
 import Language.Docopt.Value (Value())
 import Language.Docopt as D
 import Language.Docopt.Env (Env())
@@ -101,11 +101,11 @@ run input opts = do
   argv <- maybe (A.drop 2 <$> Process.argv) (pure <<< id) opts.argv
   env  <- maybe Process.getEnv              (pure <<< id) opts.env
   either onError pure do
-    { specification, shortHelp } <- case input of
+    { program, specification, shortHelp } <- case input of
       (Left spec)  -> pure spec
       (Right help) -> parseDocopt help opts
-    lmap ((help shortHelp) <> _) do
-      evalDocopt specification env argv opts
+    lmap (_ <> (help shortHelp)) do
+      evalDocopt program specification env argv opts
 
   where
     onError e = do
@@ -117,4 +117,4 @@ run input opts = do
           throwException $ error $ e
 
     help shortHelp
-      = dedent $ (unlines $ ("  " <> _) <$> lines (dedent shortHelp)) <> "\n"
+      = "\n" <> (dedent $ (unlines $ ("  " <> _) <$> lines (dedent shortHelp)))
diff --git a/src/Docopt/FFI.purs b/src/Docopt/FFI.purs
@@ -150,6 +150,7 @@ parse :: forall e.
             (Eff (Docopt.DocoptEff e) ({
               specification :: Array (Array (Array Foreign))
             , shortHelp     :: String
+            , program       :: String
             }))
 parse = mkFn2 go
   where
@@ -173,8 +174,9 @@ specToForeign
   :: Docopt
   -> { specification :: Array (Array (Array Foreign))
      , shortHelp     :: String
+     , program       :: String
      }
-specToForeign { shortHelp, specification } =
+specToForeign { shortHelp, specification, program } =
     let
       jsSpecification = toUnfoldable do
         specification <#> \branches -> do
@@ -183,6 +185,7 @@ specToForeign { shortHelp, specification } =
 
     in {
       shortHelp:     shortHelp
+    , program:       program
     , specification: jsSpecification
     }
 
@@ -224,6 +227,7 @@ specToForeign { shortHelp, specification } =
 readSpec :: Foreign -> F Docopt
 readSpec input = do
   shortHelp  <- F.readProp "shortHelp" input
+  program    <- F.readProp "program" input
   jsSpec     <- F.readProp "specification" input
   toplevel   <- F.readArray jsSpec
   spec       <- fromFoldable <$> do
@@ -235,7 +239,8 @@ readSpec input = do
           fromFoldable <$> do
             for args readArg
   pure {
-    shortHelp:     shortHelp
+    program:       program
+  , shortHelp:     shortHelp
   , specification: spec
   }
 

diff --git a/src/Language/Docopt.purs b/src/Language/Docopt.purs
@@ -25,22 +25,21 @@ import Text.Parsing.Parser as P
 import Text.Wrap (dedent)
 
 import Language.Docopt.Specification
-import Language.Docopt.Usage (Usage) as D
 import Language.Docopt.Errors (Argv, DocoptError(..), SolveError(..),
                               prettyPrintDocoptError
                               ) as D
 import Language.Docopt.Value (Value()) as D
 import Language.Docopt.ArgParser  as G
 import Language.Docopt.Trans.Flat as T
 
-import Language.Docopt.Argument     as Argument
-import Language.Docopt.Scanner      as Scanner
-import Language.Docopt.Solver       as Solver
-import Language.Docopt.SpecParser.Usage as Usage
-import Language.Docopt.SpecParser.Desc  as Desc
+import Language.Docopt.Argument   as Argument
+import Language.Docopt.Scanner    as Scanner
+import Language.Docopt.Solver     as Solver
+import Language.Docopt.SpecParser as SpecParser
 
 type Docopt = {
-  shortHelp     :: String
+  program       :: String
+, shortHelp     :: String
 , specification :: Specification
 }
 
@@ -75,14 +74,15 @@ preparseDocopt
   :: forall r
    .  String           -- ^ The docopt text
   -> ParseOptionsObj r -- ^ Parse options
-  -> Either String { usages       :: List Usage.Usage
-                   , descriptions :: List Desc.Desc
+  -> Either String { program      :: String
+                   , usages       :: List SpecParser.Usage
+                   , descriptions :: List SpecParser.Desc
                    }
 preparseDocopt docopt options = do
   doc <- toScanErr       $ Scanner.scan $ dedent docopt
-  us  <- toUsageParseErr $ Usage.run doc.usage options.smartOptions
-  ds  <- toDescParseErr  $ concat <$> Desc.run `traverse` doc.options
-  pure { descriptions: ds, usages: us }
+  u   <- toUsageParseErr $ SpecParser.parseUsage doc.usage options.smartOptions
+  ds  <- toDescParseErr  $ concat <$> SpecParser.parseDesc `traverse` doc.options
+  pure { descriptions: ds, usages: u.usages, program: u.program }
 
 -- |
 -- | Parse the docopt text and produce a parser that can be applied to user
@@ -95,25 +95,27 @@ parseDocopt
   -> Either String Docopt
 parseDocopt helpText options = do
   doc <- toScanErr       $ Scanner.scan $ dedent helpText
-  us  <- toUsageParseErr $ Usage.run doc.usage options.smartOptions
-  ds  <- toDescParseErr  $ concat <$> Desc.run `traverse` doc.options
-  prg <- toSolveErr      $ Solver.solve us ds
+  u   <- toUsageParseErr $ SpecParser.parseUsage doc.usage options.smartOptions
+  ds  <- toDescParseErr  $ concat <$> SpecParser.parseDesc `traverse` doc.options
+  prg <- toSolveErr      $ Solver.solve u.usages ds
   pure $ { specification: prg
          , shortHelp:     doc.originalUsage
+         , program:       u.program
          }
 
 -- |
 -- | Apply the neodoc parser to user input.
 -- |
 evalDocopt
   :: forall r
-   . Specification    -- ^ The program specification
+   . String           -- ^ The program name
+  -> Specification    -- ^ The program specification
   -> StrMap String    -- ^ The environment
   -> Array String     -- ^ The user input
   -> EvalOptionsObj r -- ^ The eval opts
   -> Either String (StrMap D.Value)
-evalDocopt spec env argv options = do
-  vs <- toUserParseErr argv $ G.run spec env argv options
+evalDocopt prog spec env argv options = do
+  vs <- toUserParseErr prog argv $ G.run spec env argv options
   pure $ uncurry (T.reduce spec env) vs
 
 -- |
@@ -127,8 +129,8 @@ runDocopt
   -> Options r      -- ^ Parse and eval options
   -> Either String (StrMap D.Value)
 runDocopt docopt env argv options = do
-  { specification } <- parseDocopt docopt options
-  evalDocopt specification env argv options
+  { program, specification } <- parseDocopt docopt options
+  evalDocopt program specification env argv options
 
 toScanErr :: forall a. Either P.ParseError a -> Either String a
 toScanErr  = lmap (D.prettyPrintDocoptError <<< D.DocoptScanError)
@@ -139,8 +141,8 @@ toUsageParseErr = lmap (D.prettyPrintDocoptError <<< D.DocoptUsageParseError)
 toDescParseErr :: forall a. Either P.ParseError a -> Either String a
 toDescParseErr = lmap (D.prettyPrintDocoptError <<< D.DocoptDescParseError)
 
-toUserParseErr :: forall a. Array String -> Either P.ParseError a -> Either String a
-toUserParseErr argv = lmap (D.prettyPrintDocoptError <<< D.DocoptUserParseError argv)
+toUserParseErr :: forall a. String -> Array String -> Either P.ParseError a -> Either String a
+toUserParseErr prog argv = lmap (D.prettyPrintDocoptError <<< D.DocoptUserParseError prog argv)
 
 toSolveErr :: forall a. Either D.SolveError a -> Either String a
 toSolveErr = lmap (D.prettyPrintDocoptError <<< D.DocoptSolveError)
diff --git a/src/Language/Docopt/ArgParser/Parser.purs b/src/Language/Docopt/ArgParser/Parser.purs
@@ -57,8 +57,8 @@ import Language.Docopt.Argument (Argument(..), Branch, isFree,
                                 isRepeatable, OptionArgumentObj(),
                                 setRequired, isOptional, isGroup
                                 ) as D
-import Language.Docopt.Usage (Usage) as D
 import Language.Docopt.Env (Env ())
+import Language.Docopt.Specification (Specification())
 import Language.Docopt.Env as Env
 import Language.Docopt.Origin as Origin
 import Language.Docopt.Origin (Origin())
@@ -398,8 +398,8 @@ eof branches = P.ParserT $ \(P.PState s pos) ->
 -- | Parse user input against a program specification.
 spec
   :: forall r
-   . List D.Usage -- ^ the list of usage branches
-  -> Options r    -- ^ generator options
+   . Specification -- ^ the list of usage branches
+  -> Options r     -- ^ generator options
   -> Parser (Tuple D.Branch (List ValueMapping))
 spec xs options = do
   let

diff --git a/src/Language/Docopt/Solver/Solver.purs b/src/Language/Docopt/Solver/Solver.purs
@@ -30,12 +30,10 @@ import Data.String as Str
 
 import Language.Docopt.Argument
 import Language.Docopt.Argument (isFree) as Arg
-import Language.Docopt.SpecParser.Desc as DE
-import Language.Docopt.SpecParser.Usage.Option as UO
+import Language.Docopt.SpecParser.Desc as Desc
 import Language.Docopt.Argument (Argument(..), Branch)
 import Language.Docopt.Errors (SolveError(..))
-import Language.Docopt.SpecParser.Desc (Desc)
-import Language.Docopt.SpecParser.Usage (Usage(..)) as U
+import Language.Docopt.SpecParser (Desc(), Usage()) as SpecParser
 import Language.Docopt.SpecParser.Usage.Argument (Branch, Argument(..)) as U
 import Language.Docopt.Usage (Usage)
 import Partial.Unsafe (unsafePartial)
@@ -70,9 +68,10 @@ instance showResolveTo :: (Show a, Show b) => Show (ResolveTo a b) where
 fail :: forall a. String -> Either SolveError a
 fail = Left <<< SolveError
 
-solveBranch :: U.Branch                 -- ^ the usage branch
-            -> List Desc                -- ^ the option descriptions
-            -> Either SolveError Branch -- ^ the canonical usage branch
+solveBranch
+  :: U.Branch                 -- ^ the usage branch
+  -> List SpecParser.Desc     -- ^ the option descriptions
+  -> Either SolveError Branch -- ^ the canonical usage branch
 solveBranch as ds = go as
   where
     go :: U.Branch -> Either SolveError (List Argument)
@@ -108,12 +107,12 @@ solveBranch as ds = go as
                           )
 
         expand
-          :: List Desc
+          :: List SpecParser.Desc
           -> List Argument
           -> List Argument
         expand ds surroundingArgs = reverse $ go ds surroundingArgs Nil
           where
-          go (Cons (x@(DE.OptionDesc opt)) xs) surroundingArgs acc = do
+          go (Cons (x@(Desc.OptionDesc opt)) xs) surroundingArgs acc = do
             -- Assuming description and usage have already been merged,
             -- find all options that are not present in the surrounding
             -- "free" area and add them.
@@ -123,8 +122,8 @@ solveBranch as ds = go as
                   let z = Group {
                           optional: true
                         , branches: (singleton $ singleton $ Option $
-                              { flag:       DE.getFlag opt.name
-                              , name:       DE.getName opt.name
+                              { flag:       Desc.getFlag opt.name
+                              , name:       Desc.getName opt.name
                               , arg:        opt.arg
                               , env:        opt.env
                               , repeatable: false
@@ -135,15 +134,15 @@ solveBranch as ds = go as
                   in go xs (z:surroundingArgs) (z:acc)
             where
               isMatch (Option o)
-                = if isJust (DE.getFlag opt.name) &&
+                = if isJust (Desc.getFlag opt.name) &&
                       isJust (o.flag)
                       then fromMaybe false do
-                            eq <$> (DE.getFlag opt.name)
+                            eq <$> (Desc.getFlag opt.name)
                                 <*> o.flag
-                      else if isJust (DE.getName opt.name) &&
+                      else if isJust (Desc.getName opt.name) &&
                               isJust (o.name)
                               then fromMaybe false do
-                                    (^=) <$> (DE.getName opt.name)
+                                    (^=) <$> (Desc.getName opt.name)
                                           <*> o.name
                               else false
               isMatch (Group grp) = any isMatch (concat grp.branches)
@@ -282,10 +281,10 @@ solveBranch as ds = go as
           case filter isMatch ds of
             xs | length xs > 1 -> fail
               $ "Multiple option descriptions for option --" <> n
-            (Cons (DE.OptionDesc desc) Nil) -> do
+            (Cons (Desc.OptionDesc desc) Nil) -> do
               arg <- resolveOptArg o.arg desc.arg
-              pure  { flag:       DE.getFlag desc.name
-                    , name:       DE.getName desc.name
+              pure  { flag:       Desc.getFlag desc.name
+                    , name:       Desc.getName desc.name
                     , arg:        arg
                     , env:        desc.env
                     , repeatable: o.repeatable
@@ -299,8 +298,8 @@ solveBranch as ds = go as
                     , repeatable: o.repeatable
                     }
           where
-            isMatch (DE.OptionDesc { name: DE.Long n'   }) = n == n'
-            isMatch (DE.OptionDesc { name: DE.Full _ n' }) = n == n'
+            isMatch (Desc.OptionDesc { name: Desc.Long n'   }) = n == n'
+            isMatch (Desc.OptionDesc { name: Desc.Full _ n' }) = n == n'
             isMatch _ = false
 
 
@@ -350,10 +349,13 @@ solveBranch as ds = go as
                 (head $ catMaybes $ subsume fs <$> ds)
 
           where
-            subsume :: String -> Desc -> Maybe (ResolveTo (Slurp Argument)
-                                                          Reference)
-            subsume fs (DE.OptionDesc d) = do
-              f <- DE.getFlag d.name
+            subsume
+              :: String
+              -> SpecParser.Desc
+              -> Maybe (ResolveTo (Slurp Argument)
+                       Reference)
+            subsume fs (Desc.OptionDesc d) = do
+              f <- Desc.getFlag d.name
               a <- d.arg
 
               -- the haystack needs to be modified, such that the
@@ -376,7 +378,7 @@ solveBranch as ds = go as
                                     )
                                   )
                                   { flag:       pure f
-                                  , name:       DE.getName d.name
+                                  , name:       Desc.getName d.name
                                   , arg:        pure a
                                   , env:        d.env
                                   , repeatable: o.repeatable
@@ -513,7 +515,7 @@ solveBranch as ds = go as
                     $ "Multiple option descriptions for option -"
                         <> String.singleton f
 
-            (Cons (DE.OptionDesc desc) Nil) -> do
+            (Cons (Desc.OptionDesc desc) Nil) -> do
               arg <- if isTrailing
                           then resolveOptArg o.arg desc.arg
                           else if isNothing desc.arg
@@ -522,8 +524,8 @@ solveBranch as ds = go as
                               $ "Stacked option -" <> String.singleton f
                                   <> " may not specify arguments"
 
-              pure  { flag:       DE.getFlag desc.name
-                    , name:       DE.getName desc.name
+              pure  { flag:       Desc.getFlag desc.name
+                    , name:       Desc.getName desc.name
                     , arg:        arg
                     , env:        desc.env
                     , repeatable: o.repeatable
@@ -541,14 +543,14 @@ solveBranch as ds = go as
                     }
 
           where
-            isMatch (DE.OptionDesc { name: DE.Flag f'   }) = f == f'
-            isMatch (DE.OptionDesc { name: DE.Full f' _ }) = f == f'
+            isMatch (Desc.OptionDesc { name: Desc.Flag f'   }) = f == f'
+            isMatch (Desc.OptionDesc { name: Desc.Full f' _ }) = f == f'
             isMatch _ = false
 
     -- | Resolve an option's argument name against that given in the
     -- | description, pureing the most complete argument known.
     resolveOptArg :: Maybe { name :: String, optional :: Boolean }
-                  -> Maybe DE.OptionArgumentObj
+                  -> Maybe Desc.OptionArgumentObj
                   -> Either SolveError (Maybe OptionArgumentObj)
 
     resolveOptArg (Just a) Nothing = do
@@ -578,10 +580,14 @@ solveBranch as ds = go as
             , optional: a.optional
             , default:  Nothing }
 
-solveUsage :: U.Usage -> List Desc -> Either SolveError Usage
-solveUsage (U.Usage _ bs) ds = traverse (flip solveBranch ds) bs
+solveUsage
+  :: SpecParser.Usage
+  -> List SpecParser.Desc
+  -> Either SolveError Usage
+solveUsage bs ds = traverse (flip solveBranch ds) bs
 
-solve :: List U.Usage
-      -> List Desc
-      -> Either SolveError (List Usage)
+solve
+  :: List SpecParser.Usage
+  -> List SpecParser.Desc
+  -> Either SolveError (List Usage)
 solve us ds = traverse (flip solveUsage ds) us