Integrate Clap

src/BaselineOfClap/BaselineOfClap.class.st

@@ -0,0 +1,21 @@
+Class {
+	#name : #BaselineOfClap,
+	#superclass : #BaselineOf,
+	#category : #BaselineOfClap
+}
+
+{ #category : #baseline }
+BaselineOfClap >> baseline: spec [
+	<baseline>
+	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') ]
+]

src/BaselineOfClap/package.st

@@ -0,0 +1 @@
+Package { #name : #BaselineOfClap }

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'
+]

src/Clap-CommandLine/package.st

@@ -0,0 +1 @@
+Package { #name : #'Clap-CommandLine' }

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 [
+	<commandline>
+	^ (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
+]

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 [
+	<commandline>
+	^ (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
+]

src/Clap-Commands-Pharo/package.st

@@ -0,0 +1 @@
+Package { #name : #'Clap-Commands-Pharo' }

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: <CommandName>
+	
+And after, if you want to add a flag:
+	addFlag: ClapFlag withName: <FlagName>
+	
+If you want to add a positional:
+	addPositional: ClapPositional withName: <PositionalName>
+	
+If you want to add a subcommand:
+	addSubCommand: <subCommand>
+	
+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 ]
+]