From 7f4e0335035888cc6eda4b974199f46d9f3c1b33 Mon Sep 17 00:00:00 2001 From: Damien Pollet Date: Mon, 18 Feb 2019 18:58:08 +0100 Subject: [PATCH] Integrate Clap --- src/BaselineOfClap/BaselineOfClap.class.st | 21 ++ src/BaselineOfClap/package.st | 1 + .../ClapCommandLineHandler.class.st | 38 +++ src/Clap-CommandLine/package.st | 1 + .../ClapCodeEvaluator.class.st | 68 ++++ .../ClapPharoVersion.class.st | 91 ++++++ src/Clap-Commands-Pharo/package.st | 1 + src/Clap-Core/ClapCommand.class.st | 132 ++++++++ src/Clap-Core/ClapCompositeMatch.class.st | 174 +++++++++++ src/Clap-Core/ClapContext.class.st | 291 ++++++++++++++++++ .../ClapDocumentationFormatter.class.st | 95 ++++++ src/Clap-Core/ClapDocumenter.class.st | 118 +++++++ src/Clap-Core/ClapExplicit.class.st | 60 ++++ src/Clap-Core/ClapExpression.class.st | 112 +++++++ src/Clap-Core/ClapFlag.class.st | 70 +++++ src/Clap-Core/ClapImplicit.class.st | 43 +++ .../ClapLeftoversValidation.class.st | 15 + src/Clap-Core/ClapMismatch.class.st | 42 +++ src/Clap-Core/ClapNamedMatch.class.st | 20 ++ src/Clap-Core/ClapParameter.class.st | 212 +++++++++++++ src/Clap-Core/ClapParameterized.class.st | 84 +++++ src/Clap-Core/ClapPositional.class.st | 37 +++ src/Clap-Core/ClapRoot.class.st | 19 ++ src/Clap-Core/ClapSubExpression.class.st | 58 ++++ src/Clap-Core/ClapValidation.class.st | 29 ++ .../ClapValidationDiagnostic.class.st | 45 +++ src/Clap-Core/ClapValidationReport.class.st | 47 +++ src/Clap-Core/ClapWordMatch.class.st | 24 ++ src/Clap-Core/ManifestClapCore.class.st | 21 ++ src/Clap-Core/package.st | 1 + .../ClapCommandLineExamples.class.st | 136 ++++++++ src/Clap-Examples/package.st | 1 + src/Clap-Tests/ClapCommandTest.class.st | 115 +++++++ src/Clap-Tests/ClapContextTest.class.st | 53 ++++ src/Clap-Tests/ClapDocumentationTest.class.st | 22 ++ src/Clap-Tests/ClapFlagTest.class.st | 74 +++++ src/Clap-Tests/ClapHelloWorldTest.class.st | 96 ++++++ src/Clap-Tests/ClapMatchesTest.class.st | 172 +++++++++++ src/Clap-Tests/ClapMeaningsTest.class.st | 57 ++++ src/Clap-Tests/ClapParameterTest.class.st | 48 +++ src/Clap-Tests/ClapParameterizedTest.class.st | 19 ++ src/Clap-Tests/ClapPositionalTest.class.st | 25 ++ src/Clap-Tests/package.st | 1 + 43 files changed, 2789 insertions(+) create mode 100644 src/BaselineOfClap/BaselineOfClap.class.st create mode 100644 src/BaselineOfClap/package.st create mode 100644 src/Clap-CommandLine/ClapCommandLineHandler.class.st create mode 100644 src/Clap-CommandLine/package.st create mode 100644 src/Clap-Commands-Pharo/ClapCodeEvaluator.class.st create mode 100644 src/Clap-Commands-Pharo/ClapPharoVersion.class.st create mode 100644 src/Clap-Commands-Pharo/package.st create mode 100644 src/Clap-Core/ClapCommand.class.st create mode 100644 src/Clap-Core/ClapCompositeMatch.class.st create mode 100644 src/Clap-Core/ClapContext.class.st create mode 100644 src/Clap-Core/ClapDocumentationFormatter.class.st create mode 100644 src/Clap-Core/ClapDocumenter.class.st create mode 100644 src/Clap-Core/ClapExplicit.class.st create mode 100644 src/Clap-Core/ClapExpression.class.st create mode 100644 src/Clap-Core/ClapFlag.class.st create mode 100644 src/Clap-Core/ClapImplicit.class.st create mode 100644 src/Clap-Core/ClapLeftoversValidation.class.st create mode 100644 src/Clap-Core/ClapMismatch.class.st create mode 100644 src/Clap-Core/ClapNamedMatch.class.st create mode 100644 src/Clap-Core/ClapParameter.class.st create mode 100644 src/Clap-Core/ClapParameterized.class.st create mode 100644 src/Clap-Core/ClapPositional.class.st create mode 100644 src/Clap-Core/ClapRoot.class.st create mode 100644 src/Clap-Core/ClapSubExpression.class.st create mode 100644 src/Clap-Core/ClapValidation.class.st create mode 100644 src/Clap-Core/ClapValidationDiagnostic.class.st create mode 100644 src/Clap-Core/ClapValidationReport.class.st create mode 100644 src/Clap-Core/ClapWordMatch.class.st create mode 100644 src/Clap-Core/ManifestClapCore.class.st create mode 100644 src/Clap-Core/package.st create mode 100644 src/Clap-Examples/ClapCommandLineExamples.class.st create mode 100644 src/Clap-Examples/package.st create mode 100644 src/Clap-Tests/ClapCommandTest.class.st create mode 100644 src/Clap-Tests/ClapContextTest.class.st create mode 100644 src/Clap-Tests/ClapDocumentationTest.class.st create mode 100644 src/Clap-Tests/ClapFlagTest.class.st create mode 100644 src/Clap-Tests/ClapHelloWorldTest.class.st create mode 100644 src/Clap-Tests/ClapMatchesTest.class.st create mode 100644 src/Clap-Tests/ClapMeaningsTest.class.st create mode 100644 src/Clap-Tests/ClapParameterTest.class.st create mode 100644 src/Clap-Tests/ClapParameterizedTest.class.st create mode 100644 src/Clap-Tests/ClapPositionalTest.class.st create mode 100644 src/Clap-Tests/package.st diff --git a/src/BaselineOfClap/BaselineOfClap.class.st b/src/BaselineOfClap/BaselineOfClap.class.st new file mode 100644 index 00000000000..35c4fc70e61 --- /dev/null +++ b/src/BaselineOfClap/BaselineOfClap.class.st @@ -0,0 +1,21 @@ +Class { + #name : #BaselineOfClap, + #superclass : #BaselineOf, + #category : #BaselineOfClap +} + +{ #category : #baseline } +BaselineOfClap >> baseline: spec [ + + spec for: #common do: [ spec + package: 'Clap-Core'; + package: 'Clap-CommandLine' with: [ spec requires: #('Clap-Core') ]; + package: 'Clap-Tests' with: [ spec requires: #('Clap-Core' 'Clap-Examples') ]; + package: 'Clap-Examples' with: [ spec requires: #('Clap-CommandLine') ]; + package: 'Clap-Commands-Pharo' with: [ spec requires: #('Clap-CommandLine') ]; + + group: 'default' with: #(core development); + group: 'core' with: #('Clap-Core' 'Clap-CommandLine'); + group: 'pharo' with: #('Clap-Commands-Pharo'); + group: 'development' with: #('Clap-Tests' 'Clap-Examples' 'Clap-Commands-Pharo') ] +] diff --git a/src/BaselineOfClap/package.st b/src/BaselineOfClap/package.st new file mode 100644 index 00000000000..1b905ef7f8c --- /dev/null +++ b/src/BaselineOfClap/package.st @@ -0,0 +1 @@ +Package { #name : #BaselineOfClap } diff --git a/src/Clap-CommandLine/ClapCommandLineHandler.class.st b/src/Clap-CommandLine/ClapCommandLineHandler.class.st new file mode 100644 index 00000000000..982b3c6a444 --- /dev/null +++ b/src/Clap-CommandLine/ClapCommandLineHandler.class.st @@ -0,0 +1,38 @@ +" +A thin layer to hook Clap into the existing command-line system +" +Class { + #name : #ClapCommandLineHandler, + #superclass : #CommandLineHandler, + #category : #'Clap-CommandLine' +} + +{ #category : #accessing } +ClapCommandLineHandler class >> commandName [ + ^ 'clap' +] + +{ #category : #activation } +ClapCommandLineHandler >> activate [ + [ + ClapContext withPragmaCommands beObeyingExits + activateWith: self arguments + onExit: [ :exit | self handleExit: exit ] + ] + forkAt: Processor userSchedulingPriority + named: 'Clap commandline handler process' +] + +{ #category : #activation } +ClapCommandLineHandler >> handleExit: exit [ + Smalltalk isInteractive + ifFalse: [ ^ exit pass ]. + + exit isSuccess + ifFalse: [ ^ exit resignalAs: (Error new messageText: exit messageText) ] +] + +{ #category : #activation } +ClapCommandLineHandler >> noneMatched [ + self exitFailure: 'Unknown command' +] diff --git a/src/Clap-CommandLine/package.st b/src/Clap-CommandLine/package.st new file mode 100644 index 00000000000..8d8520bd286 --- /dev/null +++ b/src/Clap-CommandLine/package.st @@ -0,0 +1 @@ +Package { #name : #'Clap-CommandLine' } diff --git a/src/Clap-Commands-Pharo/ClapCodeEvaluator.class.st b/src/Clap-Commands-Pharo/ClapCodeEvaluator.class.st new file mode 100644 index 00000000000..37cbe1eb080 --- /dev/null +++ b/src/Clap-Commands-Pharo/ClapCodeEvaluator.class.st @@ -0,0 +1,68 @@ +Class { + #name : #ClapCodeEvaluator, + #superclass : #Object, + #instVars : [ + 'arguments' + ], + #category : #'Clap-Commands-Pharo' +} + +{ #category : #'command line' } +ClapCodeEvaluator class >> evaluate [ + + ^ (ClapCommand withName: 'evaluate') + aliases: #('eval'); + description: 'Print the result of a Pharo expression'; + add: ClapFlag forHelp; + add: ((ClapFlag withName: 'save') + description: 'Save the image after evaluation'); + add: ((ClapFlag withName: 'no-quit') + description: 'Keep image running'); + add: ((ClapPositional withName: 'EXPR') + description: 'The expression to evaluate, joining successive arguments with spaces (if omitted, read the expression from stdin)'; + multiple: true; + meaning: [ :match | "let's copy all the bytes, twice, because the VM assumes some 8-bit encoding…" + String space join: (match allOccurrencesCollect: #word) ]; + defaultMeaning: [ :match | "in the absence of an explicit argument, read from standard input" + match context stdin upToEnd ]); + meaning: [ :args | + args atName: 'help' ifFound: [ :help | help value; exitSuccess ]. + (self with: args) execute ] +] + +{ #category : #'instance creation' } +ClapCodeEvaluator class >> with: arguments [ + ^ self new + setArguments: arguments; + yourself +] + +{ #category : #execution } +ClapCodeEvaluator >> context [ + ^ arguments context +] + +{ #category : #execution } +ClapCodeEvaluator >> execute [ + | result | + result := Smalltalk compiler evaluate: self source. + + self context hasSessionChanged "we might be waking up after a #save:andQuit:" + ifFalse: [ self outputStreamDo: [ :out | out print: result; lf ] ] + +] + +{ #category : #execution } +ClapCodeEvaluator >> outputStreamDo: aBlock [ + aBlock value: self context stdout +] + +{ #category : #initialization } +ClapCodeEvaluator >> setArguments: args [ + arguments := args +] + +{ #category : #initialization } +ClapCodeEvaluator >> source [ + ^ (arguments atName: 'EXPR') value +] diff --git a/src/Clap-Commands-Pharo/ClapPharoVersion.class.st b/src/Clap-Commands-Pharo/ClapPharoVersion.class.st new file mode 100644 index 00000000000..b7d75760c3c --- /dev/null +++ b/src/Clap-Commands-Pharo/ClapPharoVersion.class.st @@ -0,0 +1,91 @@ +Class { + #name : #ClapPharoVersion, + #superclass : #Object, + #instVars : [ + 'stream', + 'formats' + ], + #category : #'Clap-Commands-Pharo' +} + +{ #category : #'command line' } +ClapPharoVersion class >> version [ + + ^ (ClapCommand withName: 'version') + description: 'Displays version information, in various formats'; + add: ClapFlag forHelp; + add: ((ClapFlag withName: 'full') description: 'Full image version (default format)'); + add: ((ClapFlag withName: 'release') description: 'Major.minor alpha/stable'); + add: ((ClapFlag withName: 'numeric') description: '5-digit sequential integration number'); + add: ((ClapFlag withName: 'hash') description: 'Integration commit hash'); + add: ((ClapFlag withName: 'vm') description: 'VM build and version'); + add: ((ClapFlag withName: 'license') description: 'Licensing and copyright'); + meaning: [ :args | + args atName: 'help' ifFound: [ :help | + help value; exitSuccess ]. + args validateAll. + + (self with: args) execute ] +] + +{ #category : #'instance creation' } +ClapPharoVersion class >> with: arguments [ + ^ self new + setArguments: arguments; + yourself +] + +{ #category : #execution } +ClapPharoVersion >> execute [ + self formats do: [ :each | + stream + nextPutAll: (self perform: each); + lf ]. + stream flush +] + +{ #category : #accessing } +ClapPharoVersion >> formats [ + ^ formats ifEmpty: [ #(full) ] +] + +{ #category : #formats } +ClapPharoVersion >> full [ + ^ SystemVersion current imageVersionString +] + +{ #category : #formats } +ClapPharoVersion >> hash [ + ^ SystemVersion current commitHash +] + +{ #category : #initialization } +ClapPharoVersion >> initialize [ + stream := VTermOutputDriver stdout +] + +{ #category : #formats } +ClapPharoVersion >> license [ + ^ Smalltalk licenseString +] + +{ #category : #formats } +ClapPharoVersion >> numeric [ + ^ SystemVersion current highestUpdate printString +] + +{ #category : #formats } +ClapPharoVersion >> release [ + ^ SystemVersion current shortVersionString +] + +{ #category : #initialization } +ClapPharoVersion >> setArguments: arguments [ + formats := arguments flags collect: [ :each | + each specification canonicalName asSymbol ] +] + +{ #category : #formats } +ClapPharoVersion >> vm [ + ^ Smalltalk vm version +] diff --git a/src/Clap-Commands-Pharo/package.st b/src/Clap-Commands-Pharo/package.st new file mode 100644 index 00000000000..d41feffc681 --- /dev/null +++ b/src/Clap-Commands-Pharo/package.st @@ -0,0 +1 @@ +Package { #name : #'Clap-Commands-Pharo' } diff --git a/src/Clap-Core/ClapCommand.class.st b/src/Clap-Core/ClapCommand.class.st new file mode 100644 index 00000000000..14910d92c3c --- /dev/null +++ b/src/Clap-Core/ClapCommand.class.st @@ -0,0 +1,132 @@ +" +I represent a command or subcommand. + +Commands are recognized by a keyword, possibly with aliases for convenience. Besides positionals, commands can have flags, as well as nested (sub)commands. + +Subcommands work like a trie, to organize and select the various behaviors of a complex program. At each level in a given invocation, at most one subcommand will be recognized, most often as the last parameter of its parent command. + + +To create a new instance of this class, you must write this: + ClapCommand withName: + +And after, if you want to add a flag: + addFlag: ClapFlag withName: + +If you want to add a positional: + addPositional: ClapPositional withName: + +If you want to add a subcommand: + addSubCommand: + +Example for the eval command: + (ClapCommand withName: 'eval') + addFlag: ClapFlag withName: 'help'; + addPositional: ClapPositionnal withName: 'smalltalk expression'. +" +Class { + #name : #ClapCommand, + #superclass : #ClapParameterized, + #instVars : [ + 'flags', + 'subcommands' + ], + #category : #'Clap-Core-Specification' +} + +{ #category : #'predefined commands' } +ClapCommand class >> forHelp [ + ^ (self withName: 'help') + description: 'Prints command documentation'; + + add: ((ClapPositional withName: 'topic') + description: 'The subcommand to document (defaults to the current one)'; + meaning: [ :pos :cmd | cmd subcommandNamed: pos word ifNone: nil ]; + defaultMeaning: [ :pos :cmd | cmd ]); + + meaning: [ :match | | doc parent query topic | + doc := ClapDocumenter on: match context stdout. + parent := match parent specification. + query := match atName: 'topic'. + topic := query value: parent. + topic + ifNil: [ match context exitFailure: 'Unknown subcommand: ' , query word ] + ifNotNil: [ doc explain: topic ] ] + +] + +{ #category : #adding } +ClapCommand >> addFlag: aFlag [ + flags add: aFlag +] + +{ #category : #adding } +ClapCommand >> addSubcommand: aCommand [ + subcommands add: aCommand +] + +{ #category : #adding } +ClapCommand >> addTo: parentParameter [ + ^ parentParameter addSubcommand: self +] + +{ #category : #accessing } +ClapCommand >> atName: specName [ + ^ self subcommandNamed: specName ifNone: + [ self flagNamed: specName ifNone: + [ super atName: specName ] ] +] + +{ #category : #'matching - testing' } +ClapCommand >> canMatchWith: word [ + ^ self hasAlias: word +] + +{ #category : #accessing } +ClapCommand >> flagNamed: specName ifNone: aBlock [ + ^ flags + detect: [ :flag | flag hasAlias: specName ] + ifNone: aBlock +] + +{ #category : #accessing } +ClapCommand >> flags [ + ^ flags +] + +{ #category : #initialization } +ClapCommand >> initialize [ + super initialize. + subcommands := OrderedCollection new. + flags := OrderedCollection new. +] + +{ #category : #enumerating } +ClapCommand >> parametersDo: aBlock [ + super parametersDo: aBlock. + self flags do: aBlock. + self subcommands do: aBlock +] + +{ #category : #accessing } +ClapCommand >> subcommandNamed: specName ifNone: aBlock [ + ^ subcommands + detect: [ :cmd | cmd hasAlias: specName ] + ifNone: aBlock +] + +{ #category : #accessing } +ClapCommand >> subcommands [ + ^ subcommands +] + +{ #category : #documenting } +ClapCommand >> synopsisOn: aStream [ + aStream nextPutAll: self canonicalName +] + +{ #category : #accessing } +ClapCommand >> valueFor: aMatch with: arg [ + ^ aMatch + matchedSubcommand: [ :sub | sub value: arg ] + ifNone: [ super valueFor: aMatch with: arg ] +] diff --git a/src/Clap-Core/ClapCompositeMatch.class.st b/src/Clap-Core/ClapCompositeMatch.class.st new file mode 100644 index 00000000000..1b9210d8d6f --- /dev/null +++ b/src/Clap-Core/ClapCompositeMatch.class.st @@ -0,0 +1,174 @@ +Class { + #name : #ClapCompositeMatch, + #superclass : #ClapExplicit, + #instVars : [ + 'children' + ], + #category : #'Clap-Core-Activation' +} + +{ #category : #matching } +ClapCompositeMatch >> addChild: aSubExpression [ + children add: aSubExpression +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> at: aSpec [ + ^ self + at: aSpec + ifAbsent: [ ClapImplicit of: aSpec in: self ] +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> at: aSpec ifAbsent: absentBlock [ + ^ children + detect: [ :child | child specification = aSpec ] + ifNone: absentBlock +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> at: aSpec ifFound: foundBlock [ + ^ children + detect: [ :child | child specification = aSpec ] + ifFound: foundBlock +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> at: aSpec ifFound: foundBlock ifAbsent: absentBlock [ + ^ children + detect: [ :child | child specification = aSpec ] + ifFound: foundBlock + ifNone: absentBlock +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> atName: canonicalName [ + ^ self at: (specification atName: canonicalName) +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> atName: canonicalName ifFound: foundBlock [ + ^ self + at: (specification atName: canonicalName) + ifFound: foundBlock +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> atName: canonicalName ifFound: foundBlock ifAbsent: absentBlock [ + ^ self + at: (specification atName: canonicalName) + ifFound: foundBlock + ifAbsent: absentBlock +] + +{ #category : #matching } +ClapCompositeMatch >> completeMatchOn: aStream [ + startIndex := aStream position + 1. + self matchChildrenOn: aStream +] + +{ #category : #matching } +ClapCompositeMatch >> detectMatchOn: aStream ifFound: foundBlock ifNone: noneBlock [ + self specification parametersDo: [ :param | + (param isMultiple or: (self includesMatchOf: param) not) + ifTrue: [ | sub | + sub := param matchOn: aStream. + sub isMismatch + ifFalse: [ ^ foundBlock cull: sub ] ] ]. + ^ noneBlock value +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> flags [ + ^ children select: [ :each | specification flags includes: each specification ] +] + +{ #category : #testing } +ClapCompositeMatch >> includesMatchNamed: canonicalName [ + ^ children anySatisfy: [ :arg | arg specification canonicalName = canonicalName ] +] + +{ #category : #testing } +ClapCompositeMatch >> includesMatchOf: aSpec [ + ^ children anySatisfy: [ :arg | arg specification = aSpec ] +] + +{ #category : #initialization } +ClapCompositeMatch >> initialize [ + children := OrderedCollection new +] + +{ #category : #matching } +ClapCompositeMatch >> matchChildrenOn: aStream [ + [ self + detectMatchOn: aStream + ifFound: [ :arg | arg recordIn: self ] + ifNone: [ ^ self ] + ] repeat +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> matchedSubcommand: foundBlock ifNone: noneBlock [ + ^ children + detect: [ :child | specification subcommands includes: child specification ] + ifFound: [ :cmdMatch | foundBlock cull: cmdMatch ] + ifNone: noneBlock +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> occurrencesNamed: canonicalName [ + ^ self occurrencesOf: (specification atName: canonicalName) +] + +{ #category : #enumerating } +ClapCompositeMatch >> occurrencesNamed: canonicalName collect: aBlock [ + ^ self + occurrencesOf: (specification atName: canonicalName) + collect: aBlock +] + +{ #category : #enumerating } +ClapCompositeMatch >> occurrencesNamed: canonicalName do: aBlock [ + ^ self + occurrencesOf: (specification atName: canonicalName) + do: aBlock +] + +{ #category : #'accessing - children' } +ClapCompositeMatch >> occurrencesOf: aSpec [ + ^ children select: [ :child | child specification = aSpec ] +] + +{ #category : #enumerating } +ClapCompositeMatch >> occurrencesOf: aSpec collect: aBlock [ + ^ children + select: [ :child | child specification = aSpec ] + thenCollect: aBlock +] + +{ #category : #enumerating } +ClapCompositeMatch >> occurrencesOf: aSpec do: aBlock [ + ^ children + select: [ :child | child specification = aSpec ] + thenDo: aBlock +] + +{ #category : #evaluating } +ClapCompositeMatch >> positionalValues [ + ^ specification positionals + collect: [ :each | (self at: each) value ] +] + +{ #category : #accessing } +ClapCompositeMatch >> stop [ + ^ children + ifEmpty: [ self start - 1 ] + ifNotEmpty: [ children last stop ] + +] + +{ #category : #validation } +ClapCompositeMatch >> validateOn: aReport [ + super validateOn: aReport. + children do: [ :each | each validateOn: aReport ] +] diff --git a/src/Clap-Core/ClapContext.class.st b/src/Clap-Core/ClapContext.class.st new file mode 100644 index 00000000000..f996dcd12f6 --- /dev/null +++ b/src/Clap-Core/ClapContext.class.st @@ -0,0 +1,291 @@ +" +I represent the (stateful) context in which command parsing happens. +Most importantly I own a stream over the sequence of arguments to parse. + +For example, the command ""eval '1 + 2' "" is represented by this: + ClapContext on: #('eval' '1 + 2') +" +Class { + #name : #ClapContext, + #superclass : #ClapExpression, + #instVars : [ + 'arguments', + 'obeyingExits', + 'stdio', + 'match', + 'leftovers', + 'session' + ], + #category : #'Clap-Core-Activation' +} + +{ #category : #accessing } +ClapContext class >> defaultRoot [ + ^ (ClapRoot withName: 'clap') + description: 'Entry point for commands implemented with Clap'; + add: ClapFlag forHelp; + add: ClapCommand forHelp; + meaning: [ :args | + args atName: 'help' ifFound: [ :help | + help value; exitSuccess ]. + args validateAll ]; + yourself + "setup default flags, omnipresent subcommands & basic meanings here" +] + +{ #category : #accessing } +ClapContext class >> pragmaCommands [ + ^ (PragmaCollector filter: [:prg | prg keyword = 'commandline']) reset + collect: [ :pragma | + | theClass theSelector | + theClass := pragma method methodClass. + theSelector := pragma method selector. + self assert: [ theSelector isUnary ]. + + theClass instanceSide + perform: theSelector ] +] + +{ #category : #'instance creation' } +ClapContext class >> withAll: commandCandidates [ + ^ self specification: (self defaultRoot addAll: commandCandidates; yourself) +] + +{ #category : #'instance creation' } +ClapContext class >> withPragmaCommands [ + ^ self withAll: self pragmaCommands +] + +{ #category : #activation } +ClapContext >> activateWith: args [ + ^ self + activateWith: args + onExit: [ :exit | self handleExit: exit ] +] + +{ #category : #activation } +ClapContext >> activateWith: args onExit: exitBlock [ + ^ [ self + rememberSession; + interpret: args + ] + on: Exit + do: exitBlock +] + +{ #category : #validation } +ClapContext >> allValidations [ + ^ self validateOn: ClapValidationReport success. + +] + +{ #category : #accessing } +ClapContext >> arguments [ + ^ arguments +] + +{ #category : #initialization } +ClapContext >> arguments: aCollection [ + arguments := aCollection +] + +{ #category : #initialization } +ClapContext >> beObeyingExits [ + obeyingExits := true +] + +{ #category : #streams } +ClapContext >> binaryStderr [ + ^ self stdio stderr +] + +{ #category : #streams } +ClapContext >> binaryStdin [ + ^ self stdio stdin +] + +{ #category : #streams } +ClapContext >> binaryStdout [ + ^ self stdio stdout +] + +{ #category : #accessing } +ClapContext >> context [ + ^ self +] + +{ #category : #matching } +ClapContext >> doMatch [ + | args | + args := self arguments readStream. + match := self specification matchOn: args. + match parent: self. + leftovers := args upToEnd. + ^ match +] + +{ #category : #accessing } +ClapContext >> documenter [ + ^ ClapDocumenter on: self stdout +] + +{ #category : #running } +ClapContext >> exit: status [ + ^ (Exit status: status) signal +] + +{ #category : #running } +ClapContext >> exit: status message: message [ + ^ (Exit status: status) signal: message +] + +{ #category : #running } +ClapContext >> exitFailure [ + ^ Exit signalFailure +] + +{ #category : #running } +ClapContext >> exitFailure: message [ + ^ Exit signalFailure: message +] + +{ #category : #running } +ClapContext >> exitSuccess [ + ^ Exit signalSuccess +] + +{ #category : #running } +ClapContext >> exitSuccess: message [ + ^ Exit signalSuccess: message +] + +{ #category : #activation } +ClapContext >> handleExit: exit [ + self hasSessionChanged ifTrue: [ ^ self ]. + + self shouldObeyExit + ifTrue: [ exit pass ] + ifFalse: [ + exit isSuccess + ifFalse: [ exit resignalAs: (Error new messageText: exit messageText) ] ] +] + +{ #category : #activation } +ClapContext >> hasSessionChanged [ + ^ session ~~ Smalltalk session +] + +{ #category : #testing } +ClapContext >> ifMatch: matchBlock ifMismatch: failBlock [ + ^ self match + ifMatch: matchBlock + ifMismatch: failBlock + +] + +{ #category : #initialization } +ClapContext >> initialize [ + arguments := #(). + obeyingExits := false +] + +{ #category : #activation } +ClapContext >> interpret: argumentsSequence [ + ^ self arguments: argumentsSequence; + ifMatch: [ :match | + match value: self. + self exitSuccess ] + ifMismatch: [ self noneMatched ] +] + +{ #category : #accessing } +ClapContext >> leftovers [ + ^ leftovers +] + +{ #category : #accessing } +ClapContext >> match [ + ^ match ifNil: [ self doMatch ] + +] + +{ #category : #activation } +ClapContext >> noneMatched [ + ^ self exitFailure: 'Unknown command' +] + +{ #category : #printing } +ClapContext >> printOn: aStream [ + super printOn: aStream. + aStream + nextPut: $(; + print: arguments; + nextPut: $) +] + +{ #category : #activation } +ClapContext >> rememberSession [ + session := Smalltalk session +] + +{ #category : #testing } +ClapContext >> shouldObeyExit [ + ^ obeyingExits and: [ Smalltalk isInteractive not ] +] + +{ #category : #streams } +ClapContext >> stderr [ + ^ self stderrEncoded: 'utf8' +] + +{ #category : #streams } +ClapContext >> stderrEncoded: anEncoding [ + ^ ZnNewLineWriterStream on: + (ZnCharacterWriteStream on: self binaryStderr encoding: anEncoding) +] + +{ #category : #streams } +ClapContext >> stdin [ + ^ self stdinEncoded: 'utf8' +] + +{ #category : #streams } +ClapContext >> stdinEncoded: anEncoding [ + ^ ZnCharacterReadStream + on: self binaryStdin + encoding: anEncoding +] + +{ #category : #streams } +ClapContext >> stdio [ + ^ stdio ifNil: [ Stdio ] +] + +{ #category : #streams } +ClapContext >> stdout [ + ^ self stdoutEncoded: 'utf8' +] + +{ #category : #streams } +ClapContext >> stdoutEncoded: anEncoding [ + ^ ZnNewLineWriterStream on: + (ZnCharacterWriteStream on: self binaryStdout encoding: anEncoding) +] + +{ #category : #validation } +ClapContext >> validateAll [ + | report | + report := self allValidations. + report isSuccess ifTrue: [ ^ self ]. + + self stderr print: report; flush. + self exitFailure +] + +{ #category : #validation } +ClapContext >> validateOn: aReport [ + match validateOn: aReport. + aReport add: (ClapLeftoversValidation new validate: self). + + ^ aReport +] diff --git a/src/Clap-Core/ClapDocumentationFormatter.class.st b/src/Clap-Core/ClapDocumentationFormatter.class.st new file mode 100644 index 00000000000..8239b619b94 --- /dev/null +++ b/src/Clap-Core/ClapDocumentationFormatter.class.st @@ -0,0 +1,95 @@ +Class { + #name : #ClapDocumentationFormatter, + #superclass : #Object, + #instVars : [ + 'stream', + 'newLineString' + ], + #category : #'Clap-Core-Documentation' +} + +{ #category : #'instance creation' } +ClapDocumentationFormatter class >> on: aCharacterWriteStream [ + ^ self new + stream: aCharacterWriteStream; + yourself +] + +{ #category : #accessing } +ClapDocumentationFormatter >> columnIndent [ + ^ 16 +] + +{ #category : #accessing } +ClapDocumentationFormatter >> columnSeparation [ + ^ 3 +] + +{ #category : #accessing } +ClapDocumentationFormatter >> contents [ + ^ stream contents +] + +{ #category : #flushing } +ClapDocumentationFormatter >> flush [ + stream flush +] + +{ #category : #accessing } +ClapDocumentationFormatter >> listIndent [ + ^ 4 +] + +{ #category : #formattting } +ClapDocumentationFormatter >> newLine [ + ^ stream newLine +] + +{ #category : #formattting } +ClapDocumentationFormatter >> section: titleString with: contentsBlock [ + | contents | + contents := self class new. + contentsBlock value: contents. + + contents isEmpty ifFalse: [ + stream + nextPutAll: titleString; nextPut: $:; + newLine; + nextPutAll: contents contents ] +] + +{ #category : #accessing } +ClapDocumentationFormatter >> space [ + ^ stream space +] + +{ #category : #formattting } +ClapDocumentationFormatter >> space: anInteger [ + anInteger timesRepeat: [ stream space ] +] + +{ #category : #initialization } +ClapDocumentationFormatter >> stream: aStream [ + stream := (aStream respondsTo: #newLine) + ifTrue: [ aStream ] + ifFalse: [ ZnNewLineWriterStream on: aStream ] +] + +{ #category : #formattting } +ClapDocumentationFormatter >> tabularize: associations [ + associations do: [ :each | + | keyWidth | + keyWidth := each key size + self listIndent. + self space: self listIndent. + stream nextPutAll: each key. + keyWidth + self columnSeparation > self columnIndent + ifTrue: [ self newLine; space: self columnIndent ] + ifFalse: [ self space: self columnIndent - keyWidth ]. + stream nextPutAll: each value. + self newLine ] +] + +{ #category : #formattting } +ClapDocumentationFormatter >> text: aString [ + stream nextPutAll: aString +] diff --git a/src/Clap-Core/ClapDocumenter.class.st b/src/Clap-Core/ClapDocumenter.class.st new file mode 100644 index 00000000000..1e4f98de9ed --- /dev/null +++ b/src/Clap-Core/ClapDocumenter.class.st @@ -0,0 +1,118 @@ +Class { + #name : #ClapDocumenter, + #superclass : #Object, + #instVars : [ + 'formatter' + ], + #category : #'Clap-Core-Documentation' +} + +{ #category : #convenience } +ClapDocumenter class >> explain: aClapParameter [ + ^ self stringFrom: [ :doc | doc explain: aClapParameter ] +] + +{ #category : #private } +ClapDocumenter class >> new [ + "use #on: instead" + ^ self shouldNotImplement +] + +{ #category : #'instance creation' } +ClapDocumenter class >> on: aCharacterWriteStream [ + ^ self onFormatter: (ClapDocumentationFormatter on: aCharacterWriteStream) +] + +{ #category : #'instance creation' } +ClapDocumenter class >> onFormatter: aFormatter [ + ^ self basicNew + initializeOn: aFormatter +] + +{ #category : #convenience } +ClapDocumenter class >> stringFrom: documenterBlock [ + ^ String streamContents: [ :stream | + documenterBlock value: (self on: stream) + ] +] + +{ #category : #accessing } +ClapDocumenter >> contents [ + ^ formatter contents +] + +{ #category : #documenting } +ClapDocumenter >> descriptionSummary: aCommand [ + formatter + text: aCommand description; + newLine +] + +{ #category : #documenting } +ClapDocumenter >> explain: aCommand [ + self descriptionSummary: aCommand. + formatter newLine. + self usage: aCommand. + self parameterDescriptions: aCommand. + formatter flush +] + +{ #category : #documenting } +ClapDocumenter >> flagSynopsis: each [ + ^ formatter + text: '['; + text: '--'; + text: each canonicalName; + text: ']' +] + +{ #category : #initialization } +ClapDocumenter >> initializeOn: aFormatter [ + self initialize. + formatter := aFormatter +] + +{ #category : #documenting } +ClapDocumenter >> parameterDescriptions: aCommand [ + self section: 'Parameters:' listing: aCommand positionals. + self section: 'Options:' listing: aCommand flags. + self section: 'Commands:' listing: aCommand subcommands +] + +{ #category : #documenting } +ClapDocumenter >> positional: each [ + ^ formatter + text: '[<'; + text: each canonicalName; + text: '>]' +] + +{ #category : #documenting } +ClapDocumenter >> section: titleString listing: parameters [ + parameters ifEmpty: [ ^ self ]. + + formatter + newLine; + text: titleString; + newLine; + tabularize: (parameters collect: + [ :each | each synopsis -> each description ]) +] + +{ #category : #documenting } +ClapDocumenter >> usage: aCommand [ + formatter + text: 'Usage: '; + text: aCommand canonicalName. + aCommand flags ifNotEmpty: [ :flags | + formatter space. + flags + do: [ :each | self flagSynopsis: each ] + separatedBy: [ formatter space ] ]. + aCommand positionals ifNotEmpty: [ :positionals | + formatter space. + positionals + do: [ :each | self positional: each ] + separatedBy: [ formatter space ] ]. + formatter newLine +] diff --git a/src/Clap-Core/ClapExplicit.class.st b/src/Clap-Core/ClapExplicit.class.st new file mode 100644 index 00000000000..690191f411a --- /dev/null +++ b/src/Clap-Core/ClapExplicit.class.st @@ -0,0 +1,60 @@ +Class { + #name : #ClapExplicit, + #superclass : #ClapSubExpression, + #instVars : [ + 'startIndex' + ], + #category : #'Clap-Core-Activation' +} + +{ #category : #testing } +ClapExplicit class >> isAbstract [ + ^ self == ClapExplicit +] + +{ #category : #matching } +ClapExplicit >> completeMatchOn: aStream [ + self subclassResponsibility +] + +{ #category : #testing } +ClapExplicit >> isExplicit [ + ^ true +] + +{ #category : #adding } +ClapExplicit >> recordIn: parentMatch [ + self parent: parentMatch. + self parent addChild: self +] + +{ #category : #accessing } +ClapExplicit >> span [ + ^ self start to: self stop +] + +{ #category : #accessing } +ClapExplicit >> start [ + ^ startIndex +] + +{ #category : #accessing } +ClapExplicit >> stop [ + ^ self subclassResponsibility +] + +{ #category : #evaluating } +ClapExplicit >> words [ + ^ self context arguments + collect: [ :str | str asByteArray utf8Decoded ] + from: self start + to: self stop +] + +{ #category : #evaluating } +ClapExplicit >> wordsDo: aBlock [ + ^ self context arguments + from: self start + to: self stop + do: [ :str | aBlock value: str asByteArray utf8Decoded ] +] diff --git a/src/Clap-Core/ClapExpression.class.st b/src/Clap-Core/ClapExpression.class.st new file mode 100644 index 00000000000..a17de605571 --- /dev/null +++ b/src/Clap-Core/ClapExpression.class.st @@ -0,0 +1,112 @@ +" +I represent the concrete manifestation of a formal parameter during a command activation. +" +Class { + #name : #ClapExpression, + #superclass : #Object, + #instVars : [ + 'specification' + ], + #category : #'Clap-Core-Activation' +} + +{ #category : #testing } +ClapExpression class >> isAbstract [ + ^ self == ClapExpression +] + +{ #category : #'instance creation' } +ClapExpression class >> specification: aParameter [ + ^ self new + specification: aParameter; + yourself +] + +{ #category : #validation } +ClapExpression >> allValidations [ + ^ self context allValidations +] + +{ #category : #accessing } +ClapExpression >> context [ + ^ self subclassResponsibility +] + +{ #category : #evaluating } +ClapExpression >> exitSuccess [ + ^ self context exitSuccess +] + +{ #category : #testing } +ClapExpression >> ifMatch: aBlock [ + ^ self + ifMatch: aBlock + ifMismatch: [ self ] +] + +{ #category : #testing } +ClapExpression >> ifMatch: matchBlock ifMismatch: mismatchBlock [ + ^ self subclassResponsibility +] + +{ #category : #testing } +ClapExpression >> ifMismatch: aBlock [ + ^ self + ifMatch: [ self ] + ifMismatch: aBlock +] + +{ #category : #testing } +ClapExpression >> isMatch [ + ^ self + ifMatch: [ true ] + ifMismatch: [ false ] +] + +{ #category : #testing } +ClapExpression >> isMismatch [ + ^ self + ifMatch: [ false ] + ifMismatch: [ true ] +] + +{ #category : #testing } +ClapExpression >> isValid [ + "Semantic validation, post-parse" + self flag: 'obsolete?'. + ^ self allValidations isSuccess +] + +{ #category : #accessing } +ClapExpression >> specification [ + ^ specification +] + +{ #category : #initialization } +ClapExpression >> specification: anArgumentSpec [ + specification := anArgumentSpec +] + +{ #category : #validation } +ClapExpression >> validateAll [ + "Validate the activation as a whole, or report and exit." + self context validateAll +] + +{ #category : #validation } +ClapExpression >> validateOn: aReport [ + "Recursively validate the receiver and any subexpressions, enriching aReport" + + self specification + validate: self on: aReport +] + +{ #category : #evaluating } +ClapExpression >> value [ + ^ self value: nil +] + +{ #category : #evaluating } +ClapExpression >> value: arg [ + ^ specification valueFor: self with: arg +] diff --git a/src/Clap-Core/ClapFlag.class.st b/src/Clap-Core/ClapFlag.class.st new file mode 100644 index 00000000000..a1389f373fa --- /dev/null +++ b/src/Clap-Core/ClapFlag.class.st @@ -0,0 +1,70 @@ +" +I represent a flag (also called option). + +A flag is recognized by its form, starting with dashes (e.g. `--foo` in long form or `-f` in short form). Often, flags are optional and take a boolean meaning representing their presence or absence, but they can also be used as named parameters or to accept complex values in the form of positionals. +" +Class { + #name : #ClapFlag, + #superclass : #ClapParameterized, + #category : #'Clap-Core-Specification' +} + +{ #category : #evaluating } +ClapFlag class >> basicMeaning [ + ^ [ :match | + match isExplicit and: [ match isMatch ] ] +] + +{ #category : #'predefined flags' } +ClapFlag class >> forHelp [ + ^ (self withName: 'help') + description: 'Prints this documentation'; + meaning: [ :match | + (ClapDocumenter on: (ZnCharacterWriteStream on: match context stdout)) + explain: match parent specification. + true ] +] + +{ #category : #adding } +ClapFlag >> addTo: parentParameter [ + ^ parentParameter addFlag: self +] + +{ #category : #matching } +ClapFlag >> canMatchWith: word [ + ^ word = self shortForm + or: [ word = self longForm ] +] + +{ #category : #accessing } +ClapFlag >> longForm [ + ^ '--' , self canonicalName +] + +{ #category : #initialization } +ClapFlag >> meaningCollection [ + self meaning: [ :match | match positionalValues ] +] + +{ #category : #initialization } +ClapFlag >> meaningScalar [ + "Should only be allowed when there's a single positional" + self meaning: [ :match | (match at: self positionals first) value ] +] + +{ #category : #accessing } +ClapFlag >> shortForm [ + ^ '-' , self shortName +] + +{ #category : #accessing } +ClapFlag >> shortName [ + ^ self canonicalName copyFrom: 1 to: 1 +] + +{ #category : #documenting } +ClapFlag >> synopsisOn: aStream [ + aStream + nextPutAll: '--'; + nextPutAll: self canonicalName +] diff --git a/src/Clap-Core/ClapImplicit.class.st b/src/Clap-Core/ClapImplicit.class.st new file mode 100644 index 00000000000..a15d51e4449 --- /dev/null +++ b/src/Clap-Core/ClapImplicit.class.st @@ -0,0 +1,43 @@ +Class { + #name : #ClapImplicit, + #superclass : #ClapSubExpression, + #category : #'Clap-Core-Activation' +} + +{ #category : #'instance creation' } +ClapImplicit class >> of: aParameter in: parentMatch [ + ^ (self specification: aParameter) + parent: parentMatch; + yourself +] + +{ #category : #enumerating } +ClapImplicit >> allOccurrences [ + ^ Array with: self +] + +{ #category : #enumerating } +ClapImplicit >> allOccurrencesCollect: aBlock [ + ^ Array with: (aBlock value: self) +] + +{ #category : #enumerating } +ClapImplicit >> allOccurrencesDo: aBlock [ + aBlock value: self +] + +{ #category : #testing } +ClapImplicit >> isExplicit [ + ^ false +] + +{ #category : #testing } +ClapImplicit >> isValid [ + self flag: 'could be false if resulted from wrong access...'. + ^ true +] + +{ #category : #evaluating } +ClapImplicit >> value: arg [ + ^ specification valueForImplicit: self with: arg +] diff --git a/src/Clap-Core/ClapLeftoversValidation.class.st b/src/Clap-Core/ClapLeftoversValidation.class.st new file mode 100644 index 00000000000..eef9cf0778d --- /dev/null +++ b/src/Clap-Core/ClapLeftoversValidation.class.st @@ -0,0 +1,15 @@ +Class { + #name : #ClapLeftoversValidation, + #superclass : #ClapValidation, + #category : #'Clap-Core-Validation' +} + +{ #category : #validation } +ClapLeftoversValidation >> description [ + ^ 'Unrecognized arguments' +] + +{ #category : #validation } +ClapLeftoversValidation >> matches: aClapExpression [ + ^ aClapExpression context leftovers isEmpty +] diff --git a/src/Clap-Core/ClapMismatch.class.st b/src/Clap-Core/ClapMismatch.class.st new file mode 100644 index 00000000000..e6380fb5c6f --- /dev/null +++ b/src/Clap-Core/ClapMismatch.class.st @@ -0,0 +1,42 @@ +" +I represent a class which represents a failed match. +" +Class { + #name : #ClapMismatch, + #superclass : #ClapWordMatch, + #category : #'Clap-Core-Activation' +} + +{ #category : #accessing } +ClapMismatch >> at: aSpec [ + ^ ClapImplicit of: aSpec in: self +] + +{ #category : #matching } +ClapMismatch >> completeMatchOn: aStream [ + word:= aStream peek. + startIndex := aStream position + 1. +] + +{ #category : #testing } +ClapMismatch >> ifMatch: matchingBlock ifMismatch: mismatchBlock [ + ^ mismatchBlock cull: self +] + +{ #category : #testing } +ClapMismatch >> isValid [ + ^ false +] + +{ #category : #printing } +ClapMismatch >> printDetailsOn: aStream [ + aStream + nextPutAll: word; + nextPutAll: ' ≠ '; + print: specification +] + +{ #category : #adding } +ClapMismatch >> recordIn: parentMatch [ + "this match failed, so do nothing" +] diff --git a/src/Clap-Core/ClapNamedMatch.class.st b/src/Clap-Core/ClapNamedMatch.class.st new file mode 100644 index 00000000000..a91a26e0756 --- /dev/null +++ b/src/Clap-Core/ClapNamedMatch.class.st @@ -0,0 +1,20 @@ +Class { + #name : #ClapNamedMatch, + #superclass : #ClapCompositeMatch, + #instVars : [ + 'keyword' + ], + #category : #'Clap-Core-Activation' +} + +{ #category : #matching } +ClapNamedMatch >> completeMatchOn: aStream [ + keyword := aStream next. + startIndex := aStream position. + self matchChildrenOn: aStream +] + +{ #category : #matching } +ClapNamedMatch >> word [ + ^ keyword +] diff --git a/src/Clap-Core/ClapParameter.class.st b/src/Clap-Core/ClapParameter.class.st new file mode 100644 index 00000000000..326b7023af7 --- /dev/null +++ b/src/Clap-Core/ClapParameter.class.st @@ -0,0 +1,212 @@ +" +My instances represent formal parameters in command-line invocations. + +My subclasses implement the various conventional kinds of command-line parameters, and their instances are composed to specify the syntax of a given command. +" +Class { + #name : #ClapParameter, + #superclass : #Object, + #instVars : [ + 'canonicalName', + 'description', + 'multiple', + 'meaningBlock', + 'validationBlock', + 'implicitMeaningBlock' + ], + #category : #'Clap-Core-Specification' +} + +{ #category : #evaluating } +ClapParameter class >> basicMeaning [ + ^ [ :match | match ] +] + +{ #category : #testing } +ClapParameter class >> isAbstract [ + ^ self == ClapParameter +] + +{ #category : #'instance creation' } +ClapParameter class >> withName: aString [ + ^ self new + canonicalName: aString; + yourself +] + +{ #category : #activating } +ClapParameter >> activateWith: arguments [ + "Convenience method for activating in an interactive context" + ^ (ClapContext specification: self) + activateWith: arguments +] + +{ #category : #adding } +ClapParameter >> addTo: parentParameter [ + ^ self subclassResponsibility +] + +{ #category : #accessing } +ClapParameter >> basicMeaning [ + ^ self class basicMeaning +] + +{ #category : #'matching - testing' } +ClapParameter >> canMatchAt: aStream [ + ^ aStream atEnd not + and: [ self canMatchWith: aStream peek ] +] + +{ #category : #'matching - testing' } +ClapParameter >> canMatchWith: word [ + ^ self subclassResponsibility +] + +{ #category : #accessing } +ClapParameter >> canonicalName [ + ^ canonicalName +] + +{ #category : #initialization } +ClapParameter >> canonicalName: aString [ + canonicalName := aString +] + +{ #category : #accessing } +ClapParameter >> defaultMeaning [ + self + deprecated: 'Renamed to #implicitMeaning' + transformWith: '`@receiver defaultMeaning' -> '`@receiver implicitMeaning'. + + ^ self implicitMeaning +] + +{ #category : #initialization } +ClapParameter >> defaultMeaning: aBlock [ + self + deprecated: 'Renamed to #implicitMeaning:' + transformWith: '`@receiver defaultMeaning: `@block' -> '`@receiver implicitMeaning: `@block'. + + self implicitMeaning: aBlock +] + +{ #category : #accessing } +ClapParameter >> description [ + ^ description +] + +{ #category : #initialization } +ClapParameter >> description: aString [ + description := aString +] + +{ #category : #accessing } +ClapParameter >> implicitMeaning [ + ^ implicitMeaningBlock +] + +{ #category : #initialization } +ClapParameter >> implicitMeaning: aBlock [ + implicitMeaningBlock := aBlock +] + +{ #category : #initialization } +ClapParameter >> initialize [ + description := ''. + multiple := false. + meaningBlock := self basicMeaning. + implicitMeaningBlock := meaningBlock +] + +{ #category : #testing } +ClapParameter >> isMultiple [ + ^ multiple +] + +{ #category : #matching } +ClapParameter >> match: aStreamOrSequenceable [ + ^ self matchOn: aStreamOrSequenceable readStream +] + +{ #category : #accessing } +ClapParameter >> matchClass [ + ^ self subclassResponsibility +] + +{ #category : #matching } +ClapParameter >> matchOn: aStream [ + ^ (self newMatchAt: aStream) + completeMatchOn: aStream; + yourself +] + +{ #category : #accessing } +ClapParameter >> meaning [ + ^ meaningBlock +] + +{ #category : #initialization } +ClapParameter >> meaning: aBlock [ + meaningBlock := aBlock +] + +{ #category : #initialization } +ClapParameter >> multiple: aBoolean [ + multiple := aBoolean +] + +{ #category : #matching } +ClapParameter >> newMatchAt: aStream [ + ^ ((self canMatchAt: aStream) + ifTrue: [ self matchClass ] + ifFalse: [ ClapMismatch ]) + specification: self +] + +{ #category : #printing } +ClapParameter >> printOn: aStream [ + super printOn: aStream. + aStream + nextPut: $(; + nextPutAll: self canonicalName; + nextPut: $) +] + +{ #category : #documenting } +ClapParameter >> synopsis [ + ^ String streamContents: [ :aStream | self synopsisOn: aStream ] +] + +{ #category : #documenting } +ClapParameter >> synopsisOn: aStream [ + ^ self subclassResponsibility +] + +{ #category : #validation } +ClapParameter >> validate: aMatch on: aReport [ + aReport addAll: (self validationDiagnosticsFor: aMatch) +] + +{ #category : #validation } +ClapParameter >> validationDiagnosticsFor: aMatch [ + ^ validationBlock + ifNil: [ #() ] + ifNotNil: [ validationBlock value: aMatch ] +] + +{ #category : #initialization } +ClapParameter >> validations: aBlock [ + validationBlock := aBlock +] + +{ #category : #accessing } +ClapParameter >> valueFor: aMatch with: arg [ + ^ self meaning + cull: aMatch + cull: arg +] + +{ #category : #accessing } +ClapParameter >> valueForImplicit: aMatch with: arg [ + ^ self implicitMeaning cull: aMatch cull: arg +] diff --git a/src/Clap-Core/ClapParameterized.class.st b/src/Clap-Core/ClapParameterized.class.st new file mode 100644 index 00000000000..efef8c51211 --- /dev/null +++ b/src/Clap-Core/ClapParameterized.class.st @@ -0,0 +1,84 @@ +" +I am an abstract class specifying a parameter with nested positional parameters. +" +Class { + #name : #ClapParameterized, + #superclass : #ClapParameter, + #instVars : [ + 'positionals', + 'aliases' + ], + #category : #'Clap-Core-Specification' +} + +{ #category : #testing } +ClapParameterized class >> isAbstract [ + ^ self == ClapParameterized +] + +{ #category : #adding } +ClapParameterized >> add: aParameter [ + ^ aParameter addTo: self +] + +{ #category : #adding } +ClapParameterized >> addAll: parameters [ + parameters do: [ :each | each addTo: self ] +] + +{ #category : #adding } +ClapParameterized >> addPositional: aPositional [ + positionals add: aPositional +] + +{ #category : #accessing } +ClapParameterized >> aliases [ + ^ aliases +] + +{ #category : #initialization } +ClapParameterized >> aliases: aCollection [ + aliases := aCollection +] + +{ #category : #accessing } +ClapParameterized >> atName: specName [ + ^ self + positionalNamed: specName + ifNone: [ nil ] +] + +{ #category : #testing } +ClapParameterized >> hasAlias: aString [ + ^ aString = self canonicalName or: [ self aliases includes: aString ] + +] + +{ #category : #initialization } +ClapParameterized >> initialize [ + super initialize. + positionals := OrderedCollection new. + aliases := #() +] + +{ #category : #accessing } +ClapParameterized >> matchClass [ + ^ ClapNamedMatch +] + +{ #category : #enumerating } +ClapParameterized >> parametersDo: aBlock [ + positionals do: aBlock +] + +{ #category : #accessing } +ClapParameterized >> positionalNamed: specName ifNone: aBlock [ + ^ positionals + detect: [ :arg | arg canonicalName = specName ] + ifNone: aBlock +] + +{ #category : #accessing } +ClapParameterized >> positionals [ + ^ positionals +] diff --git a/src/Clap-Core/ClapPositional.class.st b/src/Clap-Core/ClapPositional.class.st new file mode 100644 index 00000000000..674a25d6084 --- /dev/null +++ b/src/Clap-Core/ClapPositional.class.st @@ -0,0 +1,37 @@ +" +I represent a free-form parameter which is passed as a single shell word and recognized based on its position in the input. + +" +Class { + #name : #ClapPositional, + #superclass : #ClapParameter, + #category : #'Clap-Core-Specification' +} + +{ #category : #evaluating } +ClapPositional class >> basicMeaning [ + ^ [ :match | match word ] +] + +{ #category : #adding } +ClapPositional >> addTo: parentParameter [ + ^ parentParameter addPositional: self +] + +{ #category : #'matching - testing' } +ClapPositional >> canMatchWith: word [ + ^ (word beginsWith: '-') not +] + +{ #category : #accessing } +ClapPositional >> matchClass [ + ^ ClapWordMatch +] + +{ #category : #documenting } +ClapPositional >> synopsisOn: aStream [ + ^ aStream + nextPut: $<; + nextPutAll: self canonicalName; + nextPut: $> +] diff --git a/src/Clap-Core/ClapRoot.class.st b/src/Clap-Core/ClapRoot.class.st new file mode 100644 index 00000000000..806f7f3aca4 --- /dev/null +++ b/src/Clap-Core/ClapRoot.class.st @@ -0,0 +1,19 @@ +" +I represent a nameless command, serving as the root of the command hierarchy and providing default behavior and error handling. +My subcommands are effectively the main commands available to the user. +" +Class { + #name : #ClapRoot, + #superclass : #ClapCommand, + #category : #'Clap-Core-Specification' +} + +{ #category : #'matching - testing' } +ClapRoot >> canMatchWith: word [ + ^ true +] + +{ #category : #accessing } +ClapRoot >> matchClass [ + ^ ClapCompositeMatch +] diff --git a/src/Clap-Core/ClapSubExpression.class.st b/src/Clap-Core/ClapSubExpression.class.st new file mode 100644 index 00000000000..50649d39167 --- /dev/null +++ b/src/Clap-Core/ClapSubExpression.class.st @@ -0,0 +1,58 @@ +Class { + #name : #ClapSubExpression, + #superclass : #ClapExpression, + #instVars : [ + 'parent' + ], + #category : #'Clap-Core-Activation' +} + +{ #category : #testing } +ClapSubExpression class >> isAbstract [ + ^ self == ClapSubExpression +] + +{ #category : #enumerating } +ClapSubExpression >> allOccurrences [ + ^ self parent + occurrencesOf: self specification +] + +{ #category : #enumerating } +ClapSubExpression >> allOccurrencesCollect: aBlock [ + ^ self parent + occurrencesOf: self specification + collect: aBlock +] + +{ #category : #enumerating } +ClapSubExpression >> allOccurrencesDo: aBlock [ + ^ self parent + occurrencesOf: self specification + do: aBlock +] + +{ #category : #accessing } +ClapSubExpression >> context [ + ^ parent context +] + +{ #category : #testing } +ClapSubExpression >> ifMatch: matchBlock ifMismatch: mismatchBlock [ + ^ matchBlock cull: self +] + +{ #category : #testing } +ClapSubExpression >> isExplicit [ + ^ self subclassResponsibility +] + +{ #category : #accessing } +ClapSubExpression >> parent [ + ^ parent +] + +{ #category : #accessing } +ClapSubExpression >> parent: aMatch [ + parent := aMatch +] diff --git a/src/Clap-Core/ClapValidation.class.st b/src/Clap-Core/ClapValidation.class.st new file mode 100644 index 00000000000..7fe6123e60e --- /dev/null +++ b/src/Clap-Core/ClapValidation.class.st @@ -0,0 +1,29 @@ +Class { + #name : #ClapValidation, + #superclass : #Object, + #category : #'Clap-Core-Validation' +} + +{ #category : #validation } +ClapValidation >> description [ + ^ self subclassResponsibility +] + +{ #category : #validation } +ClapValidation >> failureDescriptionFor: anObject [ + ^ String streamContents: [ :str | + str nextPutAll: 'Unrecognized arguments: '. + anObject context leftovers + do: [ :each | str nextPutAll: each ] + separatedBy: [ str nextPutAll: ', ' ] ] +] + +{ #category : #validation } +ClapValidation >> matches: aClapExpression [ + ^ self subclassResponsibility +] + +{ #category : #validation } +ClapValidation >> validate: anObject [ + ^ ClapValidationDiagnostic of: self subject: anObject +] diff --git a/src/Clap-Core/ClapValidationDiagnostic.class.st b/src/Clap-Core/ClapValidationDiagnostic.class.st new file mode 100644 index 00000000000..d8d04ad1b61 --- /dev/null +++ b/src/Clap-Core/ClapValidationDiagnostic.class.st @@ -0,0 +1,45 @@ +Class { + #name : #ClapValidationDiagnostic, + #superclass : #Object, + #instVars : [ + 'validation', + 'subject', + 'success' + ], + #category : #'Clap-Core-Validation' +} + +{ #category : #'instance creation' } +ClapValidationDiagnostic class >> of: aValidation subject: anExpression [ + ^ self new + validation: aValidation subject: anExpression; + yourself +] + +{ #category : #'as yet unclassified' } +ClapValidationDiagnostic >> description [ + ^ validation failureDescriptionFor: subject +] + +{ #category : #testing } +ClapValidationDiagnostic >> isFailure [ + ^ success not +] + +{ #category : #testing } +ClapValidationDiagnostic >> isSuccess [ + ^ success +] + +{ #category : #printing } +ClapValidationDiagnostic >> printOn: aStream [ + aStream nextPutAll: self description +] + +{ #category : #initialization } +ClapValidationDiagnostic >> validation: aValidation subject: anExpression [ + validation := aValidation. + subject := anExpression. + success := validation matches: subject + +] diff --git a/src/Clap-Core/ClapValidationReport.class.st b/src/Clap-Core/ClapValidationReport.class.st new file mode 100644 index 00000000000..f74eff4cad5 --- /dev/null +++ b/src/Clap-Core/ClapValidationReport.class.st @@ -0,0 +1,47 @@ +Class { + #name : #ClapValidationReport, + #superclass : #Object, + #instVars : [ + 'problems' + ], + #category : #'Clap-Core-Validation' +} + +{ #category : #'instance creation' } +ClapValidationReport class >> success [ + ^ self new +] + +{ #category : #controlling } +ClapValidationReport >> add: aDiagnostic [ + aDiagnostic isFailure ifTrue: [ problems add: aDiagnostic ]. + +] + +{ #category : #controlling } +ClapValidationReport >> addAll: diagnostics [ + diagnostics do: [ :each | self add: each ] +] + +{ #category : #initialization } +ClapValidationReport >> initialize [ + problems := OrderedCollection new +] + +{ #category : #testing } +ClapValidationReport >> isFailure [ + ^ self isSuccess not +] + +{ #category : #testing } +ClapValidationReport >> isSuccess [ + ^ problems isEmpty +] + +{ #category : #printing } +ClapValidationReport >> printOn: aStream [ + problems do: [ :each | + aStream + nextPutAll: each printString; + cr ] +] diff --git a/src/Clap-Core/ClapWordMatch.class.st b/src/Clap-Core/ClapWordMatch.class.st new file mode 100644 index 00000000000..494d99cd273 --- /dev/null +++ b/src/Clap-Core/ClapWordMatch.class.st @@ -0,0 +1,24 @@ +Class { + #name : #ClapWordMatch, + #superclass : #ClapExplicit, + #instVars : [ + 'word' + ], + #category : #'Clap-Core-Activation' +} + +{ #category : #matching } +ClapWordMatch >> completeMatchOn: aStream [ + word := aStream next. + startIndex := aStream position. +] + +{ #category : #accessing } +ClapWordMatch >> stop [ + ^ self start +] + +{ #category : #accessing } +ClapWordMatch >> word [ + ^ word +] diff --git a/src/Clap-Core/ManifestClapCore.class.st b/src/Clap-Core/ManifestClapCore.class.st new file mode 100644 index 00000000000..1f515c25fe2 --- /dev/null +++ b/src/Clap-Core/ManifestClapCore.class.st @@ -0,0 +1,21 @@ +" +Clap is a parser for command-line arguments. + +The general process in Clap has three steps: + +1. We start from a static specification of a command, its parameters, and their behavior. + + The command specification is recursively composed from instances of ClapCommand (a named command or sub-command with flags and positional parameters), ClapFlag (a keyword representing an option or naming a parameter) and ClapPositional (a value passed in sequence). + +2. At invocation time, we build a context to match the specification against an actual sequence of arguments coming from the shell. + +3. The resulting context is an activation of the command, which can be evaluated. + + The activation is a structured record of the parameters that matched the invocation and how; at its root, the context provides access to external resources such as the standard I/O streams. + +" +Class { + #name : #ManifestClapCore, + #superclass : #PackageManifest, + #category : #'Clap-Core-Manifest' +} diff --git a/src/Clap-Core/package.st b/src/Clap-Core/package.st new file mode 100644 index 00000000000..e63d1125082 --- /dev/null +++ b/src/Clap-Core/package.st @@ -0,0 +1 @@ +Package { #name : #'Clap-Core' } diff --git a/src/Clap-Examples/ClapCommandLineExamples.class.st b/src/Clap-Examples/ClapCommandLineExamples.class.st new file mode 100644 index 00000000000..206ea220e02 --- /dev/null +++ b/src/Clap-Examples/ClapCommandLineExamples.class.st @@ -0,0 +1,136 @@ +" +Examples and demos of Clap commands (see class side, protocol commandline). Each of those methods builds and returns a command specification, which you can then run or just match against an actual invocation (an array of strings, as would be passed by a shell). + +Arbitrary command instances can be run as do-its, e.g.: + ClapCommandLineExamples hello runWith: #('hello' 'Pharo'). + ClapCommandLineExamples git runWith: #('git' 'help' 'remote'). + +To inspect the matches without activating the commands, replace #runWith: with #match: + ClapCommandLineExamples hello match: #('hello' 'Pharo'). + ClapCommandLineExamples git match: #('git' 'help' 'remote'). + +Commands registered in the system (returned from a class-side method with the pragma) can also be invoked from the host system's command line: + $PHARO_VM $IMAGE clap hello Pharo + +" +Class { + #name : #ClapCommandLineExamples, + #superclass : #Object, + #instVars : [ + 'arguments', + 'outStream' + ], + #category : #'Clap-Examples' +} + +{ #category : #'command line' } +ClapCommandLineExamples class >> git [ + "A dummy command (no behavior besides help) to demonstrate nested subcommand and as a test subject for the documenter. + pragma omitted, because doesn't really make sense to make it available outside the image." + ^ (ClapCommand withName: 'git') + description: 'The stupid content tracker'; + add: ClapCommand forHelp; + add: ((ClapCommand withName: 'add') + description: 'Add file contents to the index'); + add: ((ClapCommand withName: 'branch') + description: 'List, create, or delete branches'); + add: ((ClapCommand withName: 'clone') + description: 'Clone a repository into a new directory'); + add: ((ClapCommand withName: 'commit') + description: 'Record changes to the repository'); + add: ((ClapCommand withName: 'init') + description: 'Create an empty Git repository or reinitialize an existing one'); + add: ((ClapCommand withName: 'remote') + description: 'Manage set of tracked repositories'; + add: (ClapCommand withName: 'add'); + add: (ClapCommand withName: 'remove'); + add: (ClapCommand withName: 'set-url'); + yourself); + add: ((ClapCommand withName: 'status') + description: 'Show the working tree status'); + yourself +] + +{ #category : #'command line' } +ClapCommandLineExamples class >> hello [ + "The usual Hello-World example, demonstrating a Clap command with a couple options." + + + ^ (ClapCommand withName: 'hello') + description: 'Provides greetings'; + add: ClapFlag forHelp; + add: ((ClapFlag withName: 'whisper') description: 'Greet discretely'); + add: ((ClapFlag withName: 'shout') description: 'Greet loudly'); + add: + ((ClapPositional withName: 'who') + description: 'Recipient of the greetings'; + multiple: true; + implicitMeaning: [ 'world' ]); + meaning: [ :args | + args + atName: 'help' + ifFound: [ :help | + help + value; + exitSuccess ]. + (self with: args) sayHello ] +] + +{ #category : #'instance creation' } +ClapCommandLineExamples class >> with: arguments [ + ^ self new + setArguments: arguments; + yourself +] + +{ #category : #'accessing - private' } +ClapCommandLineExamples >> argumentAt: argumentName [ + ^ (arguments atName: argumentName) value +] + +{ #category : #'accessing - private' } +ClapCommandLineExamples >> outStream [ + ^ outStream ifNil: [ outStream := VTermOutputDriver on: arguments context stdout ] +] + +{ #category : #accessing } +ClapCommandLineExamples >> recipients [ + ^ (arguments atName: 'who') allOccurrencesCollect: #value +] + +{ #category : #running } +ClapCommandLineExamples >> sayHello [ + arguments validateAll. + self sayHelloOn: self outStream +] + +{ #category : #running } +ClapCommandLineExamples >> sayHelloOn: aStream [ + self recipients do: [ :each | + aStream + << (self voice: 'hello, ' , each); + lf ] +] + +{ #category : #initialization } +ClapCommandLineExamples >> setArguments: args [ + arguments := args +] + +{ #category : #accessing } +ClapCommandLineExamples >> shouting [ + ^ self argumentAt: 'shout' +] + +{ #category : #running } +ClapCommandLineExamples >> voice: aString [ + self shouting ifTrue: [ ^ aString asUppercase , '!' ]. + self whispering ifTrue: [ ^ '(' , aString asLowercase , ')' ]. + ^ aString , '.' + +] + +{ #category : #accessing } +ClapCommandLineExamples >> whispering [ + ^ self argumentAt: 'whisper' +] diff --git a/src/Clap-Examples/package.st b/src/Clap-Examples/package.st new file mode 100644 index 00000000000..925390e3d01 --- /dev/null +++ b/src/Clap-Examples/package.st @@ -0,0 +1 @@ +Package { #name : #'Clap-Examples' } diff --git a/src/Clap-Tests/ClapCommandTest.class.st b/src/Clap-Tests/ClapCommandTest.class.st new file mode 100644 index 00000000000..4002b20a0b6 --- /dev/null +++ b/src/Clap-Tests/ClapCommandTest.class.st @@ -0,0 +1,115 @@ +Class { + #name : #ClapCommandTest, + #superclass : #ClapParameterizedTest, + #category : #'Clap-Tests-Unit' +} + +{ #category : #accessing } +ClapCommandTest >> classToTest [ + ^ ClapCommand +] + +{ #category : #tests } +ClapCommandTest >> testAddFlag [ + | flag | + flag := ClapFlag withName: 'flag'. + subject add: flag. + + self assert: (subject flags includes: flag) +] + +{ #category : #tests } +ClapCommandTest >> testAddSubcommand [ + | cmd | + cmd := ClapCommand withName: 'cmd'. + subject add: cmd. + + self assert: (subject subcommands includes: cmd) +] + +{ #category : #tests } +ClapCommandTest >> testMatches [ + | arg argv match | + arg := self subjectName copy. + argv := { arg. #remainder } readStream. + + match := subject matchOn: argv. + + self deny: match isMismatch. + self assert: match word equals: arg. + self assert: argv next equals: #remainder +] + +{ #category : #tests } +ClapCommandTest >> testMatchesWithSingleFlag [ + | argv match | + subject add: (ClapFlag withName: 'bar'). + argv := { self subjectName . '--bar' . #remainder } readStream. + + match := subject matchOn: argv. + + self deny: match isMismatch. + self assert: (match includesMatchNamed: 'bar'). + self assert: argv next equals: #remainder +] + +{ #category : #tests } +ClapCommandTest >> testMatchesWithSinglePositional [ + | argv match | + subject add: (ClapPositional withName: 'bar'). + argv := { self subjectName copy. 'valueforbar'. #remainder } readStream. + + match := subject matchOn: argv. + + self deny: match isMismatch. + self + assert: match word + equals: self subjectName. + self assert: (match includesMatchNamed: 'bar'). + self + assert: (match atName: 'bar') word + equals: 'valueforbar'. + self assert: argv next equals: #remainder +] + +{ #category : #tests } +ClapCommandTest >> testMatchesWithSingleSubcommand [ + | argv match | + subject add: (ClapCommand withName: 'bar'). + argv := { self subjectName. 'bar'. #remainder } readStream. + + match := subject matchOn: argv. + + self deny: match isMismatch. + self assert: (match includesMatchNamed: 'bar'). + self assert: argv next equals: #remainder +] + +{ #category : #tests } +ClapCommandTest >> testMatchingStopsAtWrongFlag [ + | argv badFlag match | + subject add: (ClapFlag withName: 'bar'). + badFlag := '--notbar'. + argv := { self subjectName. badFlag } readStream. + + match := subject matchOn: argv. + + self assert: match isMatch. + self + assert: argv next + identicalTo: badFlag +] + +{ #category : #tests } +ClapCommandTest >> testMismatchesDifferentAlias [ + | argv badCommand match | + badCommand := self subjectName , 'NOT'. + argv := { badCommand } readStream. + + match := subject matchOn: argv. + + self assert: match isMismatch. + self + assert: argv next + identicalTo: badCommand +] diff --git a/src/Clap-Tests/ClapContextTest.class.st b/src/Clap-Tests/ClapContextTest.class.st new file mode 100644 index 00000000000..abcb6d07cdf --- /dev/null +++ b/src/Clap-Tests/ClapContextTest.class.st @@ -0,0 +1,53 @@ +Class { + #name : #ClapContextTest, + #superclass : #TestCase, + #instVars : [ + 'context', + 'hello' + ], + #category : #'Clap-Tests-Integration' +} + +{ #category : #running } +ClapContextTest >> setUp [ + hello := ClapCommandLineExamples hello. + context := ClapContext specification: hello +] + +{ #category : #running } +ClapContextTest >> testMatch [ + context + arguments: #('hello' 'world'); + match. + + self assert: context isMatch. + self assert: context isValid. + self assert: context leftovers isEmpty +] + +{ #category : #running } +ClapContextTest >> testRootPositionalAfterSubcommand [ + context + arguments: #('hello' 'world' '--directory' 'foo/bar/baz'); + match. + + self assert: context isMatch. + self deny: context isValid. + self + assert: context leftovers + equals: #('--directory' 'foo/bar/baz') + +] + +{ #category : #running } +ClapContextTest >> testWrongFlagMatchingButInvalid [ + context + arguments: #('hello' '--inexistent'); + match. + + self assert: context isMatch. + self deny: context isValid. + self + assert: context leftovers + equals: #('--inexistent') +] diff --git a/src/Clap-Tests/ClapDocumentationTest.class.st b/src/Clap-Tests/ClapDocumentationTest.class.st new file mode 100644 index 00000000000..7af95c9391e --- /dev/null +++ b/src/Clap-Tests/ClapDocumentationTest.class.st @@ -0,0 +1,22 @@ +Class { + #name : #ClapDocumentationTest, + #superclass : #TestCase, + #category : #'Clap-Tests-Integration' +} + +{ #category : #tests } +ClapDocumentationTest >> testHelloShortUsage [ + | command doc | + command := ClapCommandLineExamples hello. + + doc := ClapDocumenter stringFrom: [ :documenter | documenter explain: command ]. + + self assert: (doc endsWith: OSPlatform current lineEnding). + self + assert: (doc lines first: 3) + equals: #( + 'Provides greetings' + '' + 'Usage: hello [--help] [--whisper] [--shout] []' + ) +] diff --git a/src/Clap-Tests/ClapFlagTest.class.st b/src/Clap-Tests/ClapFlagTest.class.st new file mode 100644 index 00000000000..a8007ed5711 --- /dev/null +++ b/src/Clap-Tests/ClapFlagTest.class.st @@ -0,0 +1,74 @@ +Class { + #name : #ClapFlagTest, + #superclass : #ClapParameterizedTest, + #category : #'Clap-Tests-Unit' +} + +{ #category : #accessing } +ClapFlagTest >> classToTest [ + ^ ClapFlag +] + +{ #category : #tests } +ClapFlagTest >> testMatchesLongForm [ + | argv flagName match | + flagName := '--' , self subjectName. + argv := { flagName. #remainder } readStream. + + match := subject matchOn: argv. + + self deny: match isMismatch. + self + assert: match specification + identicalTo: subject. + self assert: match word equals: '--foo'. + self assert: argv next equals: #remainder +] + +{ #category : #tests } +ClapFlagTest >> testMatchesShortForm [ + | argv flagName match | + flagName := '-' , (self subjectName first: 1). + argv := { flagName. #remainder } readStream. + + match := subject matchOn: argv. + + self deny: match isMismatch. + self + assert: match specification + identicalTo: subject. + self assert: match word equals: flagName. + self assert: argv next equals: #remainder +] + +{ #category : #tests } +ClapFlagTest >> testMismatchesWrongLongForm [ + | argv badFlag match | + badFlag := '--' , self subjectName , 'NOT'. + argv := { badFlag } readStream. + + match := subject matchOn: argv. + + self assert: match isMismatch. + self + assert: match specification + identicalTo: subject. + self assert: match word equals: badFlag. + self assert: argv next identicalTo: badFlag +] + +{ #category : #tests } +ClapFlagTest >> testMismatchesWrongShortForm [ + | argv badFlag match | + badFlag := '-' , (self subjectName first: 1) asUppercase. + argv := { badFlag } readStream. + + match := subject matchOn: argv. + + self assert: match isMismatch. + self + assert: match specification + identicalTo: subject. + self assert: match word equals: badFlag. + self assert: argv next identicalTo: badFlag +] diff --git a/src/Clap-Tests/ClapHelloWorldTest.class.st b/src/Clap-Tests/ClapHelloWorldTest.class.st new file mode 100644 index 00000000000..f923698fe22 --- /dev/null +++ b/src/Clap-Tests/ClapHelloWorldTest.class.st @@ -0,0 +1,96 @@ +Class { + #name : #ClapHelloWorldTest, + #superclass : #TestCase, + #instVars : [ + 'hello' + ], + #category : 'Clap-Tests-Integration' +} + +{ #category : #running } +ClapHelloWorldTest >> setUp [ + hello := (ClapCommand withName: 'hello') + add: (ClapFlag withName: 'shout'); + add: (ClapPositional withName: 'who') + +] + +{ #category : #'tests - matching' } +ClapHelloWorldTest >> testHello [ + | match | + match := hello match: #('hello'). + + self deny: match isMismatch. + self deny: (match includesMatchNamed: 'shout'). + self deny: (match includesMatchNamed: 'who') +] + +{ #category : #'tests - matching' } +ClapHelloWorldTest >> testHelloWorld [ + | match | + match := hello match: #('hello' 'world'). + + self deny: match isMismatch. + self deny: (match includesMatchNamed: 'shout'). + self assert: (match includesMatchNamed: 'who'). + self + assert: (match atName: 'who') word + equals: 'world'. + self + assert: (match atName: 'who') parent + identicalTo: match +] + +{ #category : #'tests - matching' } +ClapHelloWorldTest >> testLanguageFlag [ + | match lang | + lang := ClapPositional withName: 'language'. + hello add: ((ClapFlag withName: 'lang') + add: lang; + meaning: [ :flag | (flag at: lang) value]). + + match := hello match: #('hello' 'monde' '--lang' 'fr' '--shout'). + + self deny: match isMismatch. + self assert: (match includesMatchNamed: 'shout'). + self assert: (match includesMatchNamed: 'who'). + self + assert: (match atName: 'who') word + equals: 'monde'. + self assert: (match includesMatchNamed: 'lang'). + self assert: ((match atName: 'lang') includesMatchNamed: 'language'). + self + assert: (match atName: 'lang') value + equals: 'fr'. + self flag: 'needs a context'. "((match atName: 'lang') at: lang) context should be: match." +] + +{ #category : #'tests - matching' } +ClapHelloWorldTest >> testShouting [ + | match | + match := hello match: #('hello' '--shout'). + + self deny: match isMismatch. + self assert: (match includesMatchNamed: 'shout'). + self deny: (match includesMatchNamed: 'who') +] + +{ #category : #'tests - matching' } +ClapHelloWorldTest >> testShoutingAfterthought [ + | match | + match := hello match: #('hello' 'world' '-s'). + + self deny: match isMismatch. + self assert: (match includesMatchNamed: 'shout'). + self assert: (match includesMatchNamed: 'who') +] + +{ #category : #'tests - matching' } +ClapHelloWorldTest >> testShoutingWorld [ + | match | + match := hello match: #('hello' '--shout' 'world'). + + self deny: match isMismatch. + self assert: (match includesMatchNamed: 'shout'). + self assert: (match includesMatchNamed: 'who') +] diff --git a/src/Clap-Tests/ClapMatchesTest.class.st b/src/Clap-Tests/ClapMatchesTest.class.st new file mode 100644 index 00000000000..5e4940cd109 --- /dev/null +++ b/src/Clap-Tests/ClapMatchesTest.class.st @@ -0,0 +1,172 @@ +" +Tests around matching non-trivial commands and parameters. + +In the absence of a parent context however, we can't test invalid or extra arguments; see ClapContextTest for this. +" +Class { + #name : #ClapMatchesTest, + #superclass : #TestCase, + #instVars : [ + 'clap', + 'dirFlag', + 'slowFlag' + ], + #category : #'Clap-Tests-Integration' +} + +{ #category : #running } +ClapMatchesTest >> setUp [ + dirFlag := (ClapFlag withName: 'directory') + add: (ClapPositional withName: 'DIR'). + slowFlag := ClapFlag withName: 'slow'. + + clap := (ClapCommand withName: 'clap') + add: dirFlag; + add: ((ClapCommand withName: 'this') + add: slowFlag); + add: ((ClapCommand withName: 'that') + add: (ClapFlag withName: 'encore'); + add: (ClapPositional withName: 'clappee')) +] + +{ #category : #running } +ClapMatchesTest >> testFlagAbsentValue [ + | match flagMatch | + slowFlag meaning: [ :flag | flag isMismatch not ]. + + match := clap matchOn: #('clap' 'this') readStream. + flagMatch := (match atName: 'this') at: slowFlag. + + self deny: flagMatch isExplicit. + self + assert: flagMatch parent parent + identicalTo: match. + self deny: flagMatch value + +] + +{ #category : #running } +ClapMatchesTest >> testFlagOmittedValue [ + | match flagMatch | + clap add: slowFlag. "we need another flag to follow the incomplete one" + + match := clap match: #('clap' '--directory' '--slow'). + flagMatch := match at: dirFlag. + + self assert: flagMatch isExplicit. + self + deny: flagMatch value + identicalTo: '--slow'. + self deny: (flagMatch atName: 'DIR') isExplicit. + self assert: (match at: slowFlag) isExplicit. + +] + +{ #category : #running } +ClapMatchesTest >> testFlagValue [ + | match flagMatch | + slowFlag meaning: [ :flag | flag isMismatch not ]. + + match := clap match: #('clap' 'this' '--slow'). + flagMatch := ((match atName: 'this') at: slowFlag). + + self assert: flagMatch isExplicit. + self + assert: flagMatch parent parent + identicalTo: match. + self assert: flagMatch value + +] + +{ #category : #running } +ClapMatchesTest >> testMultiplePositional [ + | match | + clap add: ((ClapPositional withName: 'list') multiple: true). + + match := clap match: #('clap' 'foo' 'bar' 'baz' '-d' 'a/b/c'). + + self deny: match isMismatch. + self assert: (match includesMatchNamed: 'directory'). + self assert: (match includesMatchNamed: 'list'). + self + assertCollection: (match occurrencesNamed: 'list' collect: #value) asArray + equals: #('foo' 'bar' 'baz'). + self + assertCollection: ((match atName: 'list') allOccurrencesCollect: #value) asArray + equals: #('foo' 'bar' 'baz'). +] + +{ #category : #running } +ClapMatchesTest >> testParameterizedFlagValue [ + | match | + dirFlag meaning: [ :flag | Path from: (flag atName: 'DIR') value ]. + + match := clap match: #('clap' '--directory' 'foo/bar/baz'). + + self + assert: (match at: dirFlag) value + equals: (Path * 'foo' / 'bar' / 'baz'). + +] + +{ #category : #running } +ClapMatchesTest >> testRootPositionalBeforeSubcommand [ + | match | + match := clap match: #('clap' '--directory' 'foo/bar/baz' 'this'). + + self deny: match isMismatch. + self assert: (match includesMatchNamed: 'directory'). + self assert: (match includesMatchNamed: 'this'). + self deny: (match includesMatchNamed: 'that'). + self + assert: ((match atName: 'directory') atName: 'DIR') value + equals: 'foo/bar/baz'. + self + assert: (match at: dirFlag) positionalValues asArray + equals: #( 'foo/bar/baz' ) + +] + +{ #category : #running } +ClapMatchesTest >> testSubcommandAccessing [ + | match found | + match := clap match: #('clap' 'this'). + + self deny: match isMismatch. + self deny: (match includesMatchNamed: 'directory'). + self assert: (match includesMatchNamed: 'this'). + self deny: (match includesMatchNamed: 'that'). + self deny: (match atName: 'this') isMismatch. + self deny: ((match atName: 'this') includesMatchNamed: 'slow'). + + self + should: [ match atName: 'this' ifFound: [ Notification signal ] ] + raise: Notification. + self + should: [ match atName: 'this' ifFound: [ Notification signal ] ifAbsent: [ self fail ] ] + raise: Notification. +] + +{ #category : #running } +ClapMatchesTest >> testThis [ + | match | + match := clap match: #('clap' 'this'). + + self deny: match isMismatch. + self deny: (match includesMatchNamed: 'directory'). + self assert: (match includesMatchNamed: 'this'). + self deny: (match includesMatchNamed: 'that'). + self deny: (match atName: 'this') isMismatch. + self deny: ((match atName: 'this') includesMatchNamed: 'slow') +] + +{ #category : #running } +ClapMatchesTest >> testWrongCommandMismatches [ + | match | + match := clap match: #('foo' '-d' 'bar/baz/qux' 'this'). + + self assert: match isMismatch. + self + assert: match word + equals: 'foo' +] diff --git a/src/Clap-Tests/ClapMeaningsTest.class.st b/src/Clap-Tests/ClapMeaningsTest.class.st new file mode 100644 index 00000000000..37f622aec2f --- /dev/null +++ b/src/Clap-Tests/ClapMeaningsTest.class.st @@ -0,0 +1,57 @@ +Class { + #name : #ClapMeaningsTest, + #superclass : #TestCase, + #category : #'Clap-Tests-Integration' +} + +{ #category : #tests } +ClapMeaningsTest >> testArgFlagBasicMeaning [ + | flag match | + flag := (ClapFlag withName: 'foo') + add: (ClapPositional withName: 'bar'). + + match := flag match: #('--foo' 'whatever'). + + self assert: match value. + self deny: (flag match: #()) value +] + +{ #category : #tests } +ClapMeaningsTest >> testArgFlagCollectionMeaning [ + | flag match | + flag := (ClapFlag withName: 'foo') + add: ((ClapPositional withName: 'bar') implicitMeaning: [ #nobar ]); + add: ((ClapPositional withName: 'baz') implicitMeaning: [ #nobaz ]); + meaningCollection. + match := flag match: #('--foo' 'whatever 1' 'whatever 2'). + self assert: match value asArray equals: #('whatever 1' 'whatever 2'). + match := flag match: #('--foo' 'whatever'). + self assert: match value asArray equals: #('whatever' nobaz). + match := flag match: #('--foo'). + self assert: match value asArray equals: #(nobar nobaz) +] + +{ #category : #tests } +ClapMeaningsTest >> testArgFlagScalarMeaning [ + | flag match | + flag := (ClapFlag withName: 'foo') + add: ((ClapPositional withName: 'bar') implicitMeaning: [ 'oops' ]); + meaningScalar. + match := flag match: #('--foo' 'whatever'). + self assert: match value equals: 'whatever'. + match := flag match: #('--foo'). + self assert: match value equals: 'oops'. + match := flag match: #(). "might be wrong, since this is really a mismatch" + self assert: match value equals: 'oops' +] + +{ #category : #tests } +ClapMeaningsTest >> testSimpleFlagBasicMeaning [ + | flag match | + flag := ClapFlag withName: 'foo'. + + match := flag match: #('--foo'). + + self assert: match value. + self deny: (flag match: #()) value +] diff --git a/src/Clap-Tests/ClapParameterTest.class.st b/src/Clap-Tests/ClapParameterTest.class.st new file mode 100644 index 00000000000..435202405f4 --- /dev/null +++ b/src/Clap-Tests/ClapParameterTest.class.st @@ -0,0 +1,48 @@ +Class { + #name : #ClapParameterTest, + #superclass : #TestCase, + #instVars : [ + 'subject' + ], + #category : #'Clap-Tests-Unit' +} + +{ #category : #testing } +ClapParameterTest class >> isAbstract [ + ^ self == ClapParameterTest +] + +{ #category : #accessing } +ClapParameterTest >> classToTest [ + ^ self subclassResponsibility +] + +{ #category : #running } +ClapParameterTest >> setUp [ + subject := self classToTest withName: self subjectName +] + +{ #category : #running } +ClapParameterTest >> subjectName [ + ^ 'foo' +] + +{ #category : #tests } +ClapParameterTest >> testCanonicalName [ + self + assert: subject canonicalName + equals: self subjectName +] + +{ #category : #tests } +ClapParameterTest >> testMismatchesAtEnd [ + | argv match | + argv := #() readStream. + + match := subject matchOn: argv. + + self assert: match isMismatch. + self + assert: match specification + identicalTo: subject +] diff --git a/src/Clap-Tests/ClapParameterizedTest.class.st b/src/Clap-Tests/ClapParameterizedTest.class.st new file mode 100644 index 00000000000..576a7afafce --- /dev/null +++ b/src/Clap-Tests/ClapParameterizedTest.class.st @@ -0,0 +1,19 @@ +Class { + #name : #ClapParameterizedTest, + #superclass : #ClapParameterTest, + #category : #'Clap-Tests-Unit' +} + +{ #category : #testing } +ClapParameterizedTest class >> isAbstract [ + ^ self == ClapParameterizedTest +] + +{ #category : #tests } +ClapParameterizedTest >> testAddPositional [ + | pos | + pos := ClapPositional withName: 'pos'. + subject add: pos. + + self assert: (subject positionals includes: pos) +] diff --git a/src/Clap-Tests/ClapPositionalTest.class.st b/src/Clap-Tests/ClapPositionalTest.class.st new file mode 100644 index 00000000000..d6e33278ee0 --- /dev/null +++ b/src/Clap-Tests/ClapPositionalTest.class.st @@ -0,0 +1,25 @@ +Class { + #name : #ClapPositionalTest, + #superclass : #ClapParameterTest, + #category : 'Clap-Tests-Unit' +} + +{ #category : #accessing } +ClapPositionalTest >> classToTest [ + ^ ClapPositional +] + +{ #category : #tests } +ClapPositionalTest >> testMatches [ + | argv match | + argv := { 'bar'. #remainder } readStream. + + match := subject matchOn: argv. + + self deny: match isMismatch. + self + assert: match specification + identicalTo: subject. + self assert: match word equals: 'bar'. + self assert: argv next equals: #remainder +] diff --git a/src/Clap-Tests/package.st b/src/Clap-Tests/package.st new file mode 100644 index 00000000000..6567123a75e --- /dev/null +++ b/src/Clap-Tests/package.st @@ -0,0 +1 @@ +Package { #name : #'Clap-Tests' }