Add Fn to type signature explainer

carp/src/bridge/carp.py

@@ -8,6 +8,7 @@ class CarpProc:
         self.proc = diplomat.Diplomat('carp')
         self._version_info = None
         self.adornment_re = re.compile(".\[33m.*?\[0m")
+        self.warning_re = re.compile("\[WARNING\] (.*)\n?")
 
     def wait_for_boot(self):
         while not self.proc.output():
@@ -23,11 +24,13 @@ class CarpProc:
         while self.proc.output() == old_output:
             time.sleep(0.5)
         res = self.adornment_re.sub("", self.proc.output()[len(old_output):]).strip()
+        warnings = self.warning_re.findall(res)
+        res = self.warning_re.sub("", res)
         if res.startswith("=> "):
-            return {'result': 'success', 'value': res[3:]}
+            return {'result': 'success', 'value': res[3:], 'warnings': warnings}
         if not res:
-            return {'result': 'success', 'value': '()'}
+            return {'result': 'success', 'value': '()', 'warnings': warnings}
-        return {'result': 'error', 'value': res}
+        return {'result': 'error', 'value': res, 'warnings': warnings}
 
     def evaluate(self, statements):
         assert self.proc.is_running(), "carp process has died"

src/Carp-AST/CarpExpressionNode.class.st

@@ -16,6 +16,11 @@ CarpExpressionNode >> acceptVisitor: anExpressionVisitor [
 	^ anExpressionVisitor visitExpression: self
 ]
 
+{ #category : #accessing }
+CarpExpressionNode >> isDefinition [
+	^ false
+]
+
 { #category : #accessing }
 CarpExpressionNode >> isQuoted [
 	^ parent ifNil: [ false ] ifNotNil: [ parent isQuoted ]

src/Carp-AST/CarpVariableNode.class.st

@@ -13,6 +13,15 @@ CarpVariableNode >> acceptVisitor: anExpressionVisitor [
 	^ anExpressionVisitor visitVariable: self
 ]
 
+{ #category : #accessing }
+CarpVariableNode >> isDefinitionPredicate [
+	^ {'defdynamic'.
+		'defndynamic'.
+		'defmacro'.
+		'defn'.
+		'def'} includes: self value source
+]
+
 { #category : #accessing }
 CarpVariableNode >> toPharo [
 	^ value source asSymbol

src/Carp-Parser/CarpListNode.class.st

@@ -21,6 +21,14 @@ CarpListNode >> compositeNodeVariables [
 	^ #( #expressions )
 ]
 
+{ #category : #accessing }
+CarpListNode >> definitionVariable [
+	^ (self expressions size > 1
+		and: [ self expressions first isDefinitionPredicate ])
+		ifTrue: [ self expressions second ]
+		ifFalse: [ nil ]
+]
+
 { #category : #generated }
 CarpListNode >> expressions [
 
@@ -41,6 +49,11 @@ CarpListNode >> initialize [
 	expressions := OrderedCollection new: 2.
 ]
 
+{ #category : #accessing }
+CarpListNode >> isDefinition [
+	^ self definitionVariable isNotNil
+]
+
 { #category : #generated }
 CarpListNode >> leftParen [
 

src/Carp/CarpCliOutput.class.st

@@ -0,0 +1,51 @@
+Class {
+	#name : #CarpCliOutput,
+	#superclass : #Object,
+	#instVars : [
+		'text'
+	],
+	#category : #'Carp-Core'
+}
+
+{ #category : #accessing }
+CarpCliOutput class >> text: aString [
+	^ self new text: aString
+]
+
+{ #category : #accessing }
+CarpCliOutput >> gtExitCodeFor: aView [
+	<gtView>
+	^ aView forward
+		title: 'Exit Code';
+		priority: 2;
+		object: [ self text lines last asInteger ];
+		view: #gtLiveFor:
+]
+
+{ #category : #accessing }
+CarpCliOutput >> gtOutputFor: aView [
+	<gtView>
+	^ aView textEditor
+		title: 'Output';
+		priority: 1;
+		text: [ Character lf join: (self text lines allButLast: 2) ]
+]
+
+{ #category : #accessing }
+CarpCliOutput >> gtRawOutputFor: aView [
+	<gtView>
+	^ aView textEditor
+		title: 'Raw Output';
+		priority: 3;
+		text: [ self text ]
+]
+
+{ #category : #accessing }
+CarpCliOutput >> text [
+	^ text
+]
+
+{ #category : #accessing }
+CarpCliOutput >> text: aString [ 
+	text := aString
+]

src/Carp/CarpExecutionResult.class.st

@@ -0,0 +1,68 @@
+Class {
+	#name : #CarpExecutionResult,
+	#superclass : #Object,
+	#instVars : [
+		'value',
+		'warnings',
+		'view'
+	],
+	#category : #'Carp-Execution'
+}
+
+{ #category : #'instance creation' }
+CarpExecutionResult class >> from: aCarpResult [
+	^ self new
+		value: (aCarpResult at: #value);
+		warnings: (aCarpResult at: #warnings)
+]
+
+{ #category : #accessing }
+CarpExecutionResult >> gtValueFor: aView [
+	<gtView>
+	| v |
+	v := aView forward
+		title: 'Value';
+		priority: 1;
+		object: value.
+	view ifNotNil: [ v view: view ].
+	^ v
+]
+
+{ #category : #accessing }
+CarpExecutionResult >> gtWarningsFor: aView [
+	<gtView>
+	^ aView list
+		title: 'Warnings';
+		priority: 2;
+		items: [ warnings ]
+]
+
+{ #category : #accessing }
+CarpExecutionResult >> parse [
+	value := CarpParser parse: value
+]
+
+{ #category : #accessing }
+CarpExecutionResult >> transformValue: aBlock [
+	value := aBlock value: value
+]
+
+{ #category : #accessing }
+CarpExecutionResult >> value [
+	^ value
+]
+
+{ #category : #accessing }
+CarpExecutionResult >> value: aValue [
+	value := aValue
+]
+
+{ #category : #accessing }
+CarpExecutionResult >> view: aView [
+	view := aView
+]
+
+{ #category : #accessing }
+CarpExecutionResult >> warnings: aCollection [
+	warnings := aCollection
+]

src/Carp/CarpPostMortemDebugger.class.st

@@ -19,11 +19,20 @@ CarpPostMortemDebugger >> exception: anException [
 	exception := anException
 ]
 
+{ #category : #accessing }
+CarpPostMortemDebugger >> findTrace: inputLines [
+	| lines |
+	lines := inputLines asOrderedCollection.
+	[ lines isNotEmpty and: [ (lines first = 'Traceback:') not ] ]
+		whileTrue: [ lines removeFirst ].
+	^ lines
+]
+
 { #category : #accessing }
 CarpPostMortemDebugger >> initialize [
 
 	super initialize.
-	frameRegex := '(.*)\s+at.+([^:]+)\:(\d+)\:(\d+)\.' asRegexIgnoringCase.
+	frameRegex := '(.*)\s+at\s+([^:]+)\:(\d+)\:(\d+)\.' asRegexIgnoringCase.
 ]
 
 { #category : #accessing }
@@ -40,11 +49,10 @@ CarpPostMortemDebugger >> stackFrameFromLine: aString ordinal: ordinal [
 	| file line column source |
 
 	^ (frameRegex search: aString) ifTrue:
-		[ file := frameRegex subexpression: 2.
+		[ source := frameRegex subexpression: 2.
 		file := frameRegex subexpression: 3.
 		line := frameRegex subexpression: 4.
 		column := frameRegex subexpression: 5.
-		self halt.
 		CarpPostMortemStackFrame new
 				ordinal: ordinal;
 				displayString: aString;
@@ -62,17 +70,28 @@ CarpPostMortemDebugger >> stackFrameFromLine: aString ordinal: ordinal [
 CarpPostMortemDebugger >> stackFrames [
 	"Answer a ordered collection of stack frames.
 	This is called many times by the debugger, so cache"
+
 	| ordinal |
-
+	^ stackFrames
-	^ stackFrames ifNil:
+		ifNil: [ ordinal := 1.
-		[ ordinal := 1.
+			stackFrames := OrderedCollection new.
-		stackFrames := OrderedCollection new.
+			(self findTrace: exception trace lines)
-		exception trace lines do: [ :line | 
+				do: [ :line | 
-			(self stackFrameFromLine: line ordinal: ordinal) ifNotNil: [ :frame | 
+					(self stackFrameFromLine: line ordinal: ordinal)
-				stackFrames add: frame.
+						ifNotNil: [ :frame | 
-				ordinal := ordinal + 1 ] ].
+							stackFrames add: frame.
-		stackFrames ].
+							ordinal := ordinal + 1 ] ].
-
+			(exception trace lines last beginsWith: '[RUNTIME ERROR]')
+				ifTrue: [ stackFrames
+						add: (CarpPostMortemStackFrame new
+								ordinal: 1;
+								displayString: exception trace lines last;
+								exception: exception;
+								source: exception trace lines last;
+								file: 'REPL' asFileReference;
+								line: 0;
+								column: 0) ].
+			stackFrames ]
 ]
 
 { #category : #accessing }

src/Carp/CarpPostMortemStackFrame.class.st

@@ -14,5 +14,18 @@ CarpPostMortemStackFrame >> source: aString [
 
 { #category : #accessing }
 CarpPostMortemStackFrame >> sourceText [
-	^ source
+	| mySource text indexes lineNumber |
+	file exists
+		ifTrue: [ mySource := file contents.
+			lineNumber := line ]
+		ifFalse: [ ^ source asRopedText
+				attribute: (BlTextHighlightAttribute paint: BrGlamorousColors errorBackgroundColor)
+						beNotOverwritableByStyler ].
+	text := mySource asRopedText.
+	indexes := mySource gtIndexOfLineNumber: lineNumber.
+	indexes
+		ifNotNil: [ (text from: indexes key + column - 1 to: indexes value)
+				attribute: (BlTextHighlightAttribute paint: BrGlamorousColors errorBackgroundColor)
+						beNotOverwritableByStyler ].
+	^ text
 ]

src/Carp/CarpTypeSignature.class.st

@@ -0,0 +1,199 @@
+Class {
+	#name : #CarpTypeSignature,
+	#superclass : #Object,
+	#instVars : [
+		'signature',
+		'model',
+		'tooltipsContainer'
+	],
+	#category : #'Carp-Coder'
+}
+
+{ #category : #'instance creation' }
+CarpTypeSignature class >> on: aValue using: aModel [
+	^ self new
+		fromAST: aValue;
+		model: aModel
+]
+
+{ #category : #accessing }
+CarpTypeSignature >> elementsList [
+	| tokens verticalContainer docsRegex |
+	tokens := signature value source findTokens: ' () []'.
+	docsRegex := 'Documentation\: (.*)' asRegexIgnoringCase.
+
+	verticalContainer := BrVerticalPane new
+			fitContent;
+			padding: (BlInsets all: 10).
+
+	tokens
+		do: [ :each | 
+			| res |
+			res := model bindAndExecuteRaw: '(info ' , each , ')'.
+			(docsRegex search: (res at: #value))
+				ifTrue: [ | docs |
+					docs := docsRegex subexpression: 2.
+					verticalContainer
+						addChild: (BrLabel new
+								aptitude: BrGlamorousLabelAptitude new
+										+ (GtExplainerExplanationAptitude new explanationModel: each)
+										+ (BrStyleCommonAptitude new
+												hovered: [ :aStyle | 
+													aStyle background: BrGlamorousColors textHighlightColor.
+													aStyle
+														do: [ tooltipsContainer
+																text: docs;
+																visibility: BlVisibility visible ]
+														after: [ tooltipsContainer
+																text: '' asRopedText;
+																visibility: BlVisibility gone ] ]);
+								geometry: (BlRoundedRectangleGeometry cornerRadius: 4);
+								text: each;
+								padding: (BlInsets all: 5)) ] ].
+
+	(tokens includes: '<StaticLifetime>')
+		ifTrue: [ verticalContainer
+				addChild: (BrLabel new
+						aptitude: BrGlamorousLabelAptitude new
+								+ (GtExplainerExplanationAptitude new explanationModel: '<StaticLifetime>')
+								+ (BrStyleCommonAptitude new
+										hovered: [ :aStyle | 
+											aStyle background: BrGlamorousColors textHighlightColor.
+											aStyle
+												do: [ tooltipsContainer
+														text: 'is the default static lifetime of values (this lifetime includes the entire program run).';
+														visibility: BlVisibility visible ]
+												after: [ tooltipsContainer
+														text: '' asRopedText;
+														visibility: BlVisibility gone ] ]);
+						geometry: (BlRoundedRectangleGeometry cornerRadius: 4);
+						text: '<StaticLifetime>';
+						padding: (BlInsets all: 5)) ].
+
+	(tokens includes: 'Fn')
+		ifTrue: [ verticalContainer
+				addChild: (BrLabel new
+						aptitude: BrGlamorousLabelAptitude new
+								+ (GtExplainerExplanationAptitude new explanationModel: 'Fn')
+								+ (BrStyleCommonAptitude new
+										hovered: [ :aStyle | 
+											aStyle background: BrGlamorousColors textHighlightColor.
+											aStyle
+												do: [ tooltipsContainer
+														text: 'is the function type and is read: ' asRopedText, '(Fn [<arguments>] <return type> <lifetime>).' asRopedText glamorousCodeFont;
+														visibility: BlVisibility visible ]
+												after: [ tooltipsContainer
+														text: '' asRopedText;
+														visibility: BlVisibility gone ] ]);
+						geometry: (BlRoundedRectangleGeometry cornerRadius: 4);
+						text: 'Fn';
+						padding: (BlInsets all: 5)) ].
+
+	^ verticalContainer asScrollableElement
+		constraintsDo: [ :c | 
+			c horizontal fitContent.
+			c vertical matchParent ];
+		background: Color white;
+		aptitude: BrShadowAptitude new
+]
+
+{ #category : #accessing }
+CarpTypeSignature >> explainSignature [
+	| mainContainer coderElement leftContainer rightContainer rightContainerLabel leftContainerLabel tooltipsTarget coder elementsContainer editor |
+	mainContainer := BrHorizontalPane new
+			matchParent;
+			padding: (BlInsets all: 5).
+	mainContainer explainer isExplanationHolder: true.
+
+	leftContainer := BrVerticalPane new
+			hFitContent;
+			vMatchParent;
+			padding: (BlInsets all: 5);
+			margin: (BlInsets right: 20).
+
+	rightContainer := BrVerticalPane new
+			matchParent;
+			padding: (BlInsets all: 5).
+
+	tooltipsContainer := BrEditor new
+			text: '' asRopedText;
+			padding: (BlInsets all: 10);
+			margin: (BlInsets
+					top: 10
+					right: 0
+					bottom: 0
+					left: 0);
+			constraintsDo: [ :c | c horizontal matchParent ];
+			visibility: BlVisibility gone;
+			border: (BlBorder paint: BrGlamorousColors textHighlightColor width: 2);
+			aptitude: BrShadowAptitude + BrGlamorousEditorAptitude;
+			vFitContent;
+			background: BrGlamorousColors textHighlightColor.
+
+	tooltipsTarget := BrButton new
+			constraintsDo: [ :c | c ignoreByLayout ];
+			size: 0 @ 0;
+			elevation: (BlRelativeElevation elevation: 10);
+			geometry: BlCircleGeometry new.
+
+	elementsContainer := self elementsList.
+
+	leftContainerLabel := BrLabel new
+			text: ('Type Elements:' asRopedText
+					glamorousRegularFont;
+					foreground: Color gray);
+			aptitude: BrGlamorousLabelAptitude;
+			hFitContent;
+			margin: (BlInsets
+					top: 0
+					right: 0
+					bottom: 5
+					left: 0).
+	rightContainerLabel := BrLabel new
+			text: ('Type:' asRopedText
+					glamorousRegularFont;
+					foreground: Color gray);
+			aptitude: BrGlamorousLabelAptitude;
+			margin: (BlInsets
+					top: 0
+					right: 0
+					bottom: 5
+					left: 5).
+
+	editor := BrEditorElement new
+			constraintsDo: [ :c | 
+				c horizontal matchParent.
+				c vertical matchParent ];
+			editor: (BrTextEditor new text: signature value source asRopedText glamorousCodeFont).
+
+	leftContainer addChild: leftContainerLabel.
+	leftContainer addChild: elementsContainer.
+
+	rightContainer addChild: rightContainerLabel.
+	rightContainer addChild: editor.
+	rightContainer addChild: tooltipsContainer.
+
+	mainContainer addChild: leftContainer.
+	mainContainer addChild: rightContainer.
+
+	^ mainContainer
+]
+
+{ #category : #accessing }
+CarpTypeSignature >> fromAST: anASTNode [
+	signature := anASTNode
+]
+
+{ #category : #accessing }
+CarpTypeSignature >> gtLiveFor: aView [
+	<gtView>
+	^ aView explicit
+		title: 'Signature';
+		priority: 1;
+		stencil: [ self explainSignature ]
+]
+
+{ #category : #accessing }
+CarpTypeSignature >> model: aModel [
+	model := aModel
+]

src/Carp/GtCarpCoderModel.class.st

@@ -4,7 +4,9 @@ Class {
 	#instVars : [
 		'pharoBindings',
 		'carpLinkApplicationStrategy',
-		'exception'
+		'exception',
+		'application',
+		'commandFactory'
 	],
 	#category : #'Carp-Coder'
 }
@@ -28,7 +30,7 @@ GtCarpCoderModel >> bindAndExecute: sourceString [
 
 	<gtIgnoreConstraint: #GtRBAcceptVisitorCalledFromNonVisitingMethods>
 	<remoteDebuggerSignal>
-	| carpSource trimmedSource ast varNames lastStatement application commandFactory res |
+	| res trimmedSource ast varNames lastStatement carpSource |
 	trimmedSource := SmaCCString on: sourceString trimRight.
 	ast := CarpParser parse: trimmedSource.	"The variables to be returned are names that are in pharoBindings"
 	varNames := pharoBindings bindingNames asSet.	"Assign the final statement to snippetResult"
@@ -41,16 +43,9 @@ GtCarpCoderModel >> bindAndExecute: sourceString [
 	carpSource := self
 			sourceFrom: trimmedSource asString
 			returnedVarNames: varNames.
+	res := self bindAndExecuteRaw: sourceString.
 
-	application := carpLinkApplicationStrategy applicationServer.
+	(res at: #result) = 'success' ifTrue: [ ^ CarpExecutionResult from: res ].
-	application isRunning ifFalse: [ application start ].
-	commandFactory := application newCommandFactory.
-
-	res := commandFactory
-			<< carpSource;
-			sendAndWait.
-
-	(res at: #result) = 'success' ifTrue: [ ^ res at: #value ].
 	exception := (PharoLinkRemoteError new
 		application: application;
 		command: commandFactory command;
@@ -58,6 +53,17 @@ GtCarpCoderModel >> bindAndExecute: sourceString [
 	exception signal
 ]
 
+{ #category : #accessing }
+GtCarpCoderModel >> bindAndExecuteRaw: sourceString [
+	application := carpLinkApplicationStrategy applicationServer.
+	application isRunning ifFalse: [ application start ].
+	commandFactory := application newCommandFactory.
+
+	^ commandFactory
+		<< sourceString;
+		sendAndWait
+]
+
 { #category : #accessing }
 GtCarpCoderModel >> carpLinkApplicationStrategy: anApplicationStrategy [
 	carpLinkApplicationStrategy := anApplicationStrategy
@@ -78,7 +84,8 @@ GtCarpCoderModel >> exception [
 GtCarpCoderModel >> initializeAddOns: addOns [
 	super initializeAddOns: addOns.
 
-	addOns addStyler: (GtCoderAstSmaCCParserStyler new smaccStyler: CarpParser gtStyler).
+	addOns
+		addStyler: (GtCoderAstSmaCCParserStyler new smaccStyler: CarpParser gtStyler).
 
 	addOns
 		addMainAction: 'Evaluate' translated
@@ -98,6 +105,29 @@ GtCarpCoderModel >> initializeAddOns: addOns [
 				element: anElement;
 				execute ]
 		id: GtSourceCoderDoItAndGoActionId.
+	addOns
+		addMainAction: 'Expand Macros' translated
+		icon: BrGlamorousVectorIcons repair
+		action: [ :aCoderUIModel :anElement | 
+			| source |
+			source := '(expand ''' , sourceCode currentSourceText value text , ')'.
+			anElement phlow
+				spawnObject: ((self bindAndExecute: source) parse view: #gtSourceFor:) ]
+		id: #'source-coder--macro-expand-action'.
+	addOns
+		addMainAction: 'Build and Run' translated
+		icon: BrGlamorousVectorIcons refresh
+		action: [ :aCoderUIModel :anElement | 
+			| source |
+			source := '' , sourceCode currentSourceText value text , '(build) (run)'.
+			anElement phlow
+				spawnObject: (CarpCliOutput text: ((self bindAndExecuteRaw: source) at: 'value')) ]
+		id: #'source-coder--build-and-run-action'.
+	addOns
+		addMainAction: 'Infer Type' translated
+		icon: BrGlamorousVectorIcons inspect
+		action: [ :aCoderUIModel :anElement | self inspectTypeSpawningOn: anElement phlow]
+		id: #'source-coder--type-infer-action'
 ]
 
 { #category : #accessing }
@@ -109,6 +139,21 @@ GtCarpCoderModel >> initializeShortcuts: addOns [
 		addShortcut: GtSourceCoderDoItAndInspectShortcut new
 ]
 
+{ #category : #accessing }
+GtCarpCoderModel >> inspectTypeSpawningOn: aPhlow [
+	| source ast |
+	source := sourceCode currentSourceText value text.
+	ast := CarpParser parse: source.
+	
+	(ast expressions size = 1 and: [ ast expressions first isDefinition ])
+		ifTrue: [ self bindAndExecute: source asString.
+			source := ast expressions first definitionVariable value source ].
+			
+	source := '(def *type-infer-this* ' , source
+			, ') (defdynamic *type-infer-result* (type *type-infer-this*)) (def *type-infer-this* 0) *type-infer-result*'.
+	aPhlow spawnObject: ((self bindAndExecute: source) parse transformValue: [:aValue | CarpTypeSignature on: aValue expressions first using: self])
+]
+
 { #category : #accessing }
 GtCarpCoderModel >> newCompletionStrategy [
 	^ GtCompletionStrategy new
@@ -121,7 +166,8 @@ GtCarpCoderModel >> pharoBindings: anObject [
 
 { #category : #accessing }
 GtCarpCoderModel >> primitiveEvaluate: aSourceString inContext: aGtSourceCoderEvaluationContext onFailDo: anEvaluationFailBlock [
-	^ (CarpParser parse: (self bindAndExecute: aSourceString)) expressions first toPharo
+	^ (self bindAndExecute: aSourceString) parse
+		transformValue: [ :aValue | aValue expressions first toPharo ]
 ]
 
 { #category : #accessing }