Initial sketch

src/Functors-Tests/FuntorialityTestTest.class.st

@@ -0,0 +1,36 @@
+Class {
+	#name : #FuntorialityTestTest,
+	#superclass : #TestCase,
+	#category : #'Functors-Tests'
+}
+
+{ #category : #tests }
+FuntorialityTestTest >> checkFunctorialityFor: aClass [
+	self
+		assert: ((aClass with: 42) collect: #squared)
+		equals: (aClass with: 42 squared)
+]
+
+{ #category : #tests }
+FuntorialityTestTest >> functorsUnderTest [
+	^{ Array. Bag. Set. OrderedCollection. Just }
+]
+
+{ #category : #tests }
+FuntorialityTestTest >> testCommutativityEmpty [
+	self
+		assert: (nil collect: #moooooo)
+		equals: nil
+]
+
+{ #category : #tests }
+FuntorialityTestTest >> testFunctoriality [
+	self functorsUnderTest do: [ :F | self checkFunctorialityFor: F ]
+]
+
+{ #category : #tests }
+FuntorialityTestTest >> testIdentityEmpty [
+	self
+		assert: (nil collect: #yourself)
+		equals: nil
+]

src/Functors-Tests/package.st

@@ -0,0 +1 @@
+Package { #name : #'Functors-Tests' }

src/Functors/ApplicativeFunctor.class.st

@@ -0,0 +1,5 @@
+Class {
+	#name : #ApplicativeFunctor,
+	#superclass : #Functor,
+	#category : #Functors
+}

src/Functors/Class.extension.st

@@ -0,0 +1,11 @@
+Extension { #name : #Class }
+
+{ #category : #'*Functors' }
+Class >> changeSuperclassTo: newSuperclass [
+	| oldSuperclass |
+	oldSuperclass := self superclass.
+	self basicSuperclass: newSuperclass.
+	oldSuperclass removeSubclass: self.
+	newSuperclass addSubclass: self.
+
+]

src/Functors/Functor.class.st

@@ -0,0 +1,22 @@
+Class {
+	#name : #Functor,
+	#superclass : #Object,
+	#category : #Functors
+}
+
+{ #category : #'class initialization' }
+Functor class >> initialize [
+	Collection changeSuperclassTo: Functor.
+]
+
+{ #category : #'Functor API' }
+Functor >> collect: aMorphism [
+	"Lift a morphism a→b to Fa→Fb.
+	 The resulting morphism is expressed set-theoretically aka pointwise:
+	 Assuming self is an element of Fa, and given the a→b,
+	 answer an element of Fb.
+	
+	 Implementors of #collect: must respect identity and composition."
+
+	^self subclassResponsibility
+]

src/Functors/Just.class.st

@@ -0,0 +1,41 @@
+Class {
+	#name : #Just,
+	#superclass : #Maybe,
+	#instVars : [
+		'content'
+	],
+	#category : #Functors
+}
+
+{ #category : #'instance creation' }
+Just class >> with: anObject [
+	^self basicNew
+		content: anObject;
+		yourself
+]
+
+{ #category : #comparing }
+Just >> = rhs [
+	rhs class = Just ifFalse: [ ^false ].
+	^content = rhs content
+]
+
+{ #category : #'Functor API' }
+Just >> collect: aBlock [
+	^Just with: (aBlock value: content)
+]
+
+{ #category : #private }
+Just >> content [
+	^ content
+]
+
+{ #category : #private }
+Just >> content: anObject [
+	content := anObject
+]
+
+{ #category : #comparing }
+Just >> hash [
+	^content hash
+]

src/Functors/Maybe.class.st

@@ -0,0 +1,10 @@
+Class {
+	#name : #Maybe,
+	#superclass : #Functor,
+	#category : #Functors
+}
+
+{ #category : #'class initialization' }
+Maybe class >> initialize [
+	UndefinedObject changeSuperclassTo: Maybe
+]

src/Functors/UndefinedObject.extension.st

@@ -0,0 +1,6 @@
+Extension { #name : #UndefinedObject }
+
+{ #category : #'*Functors' }
+UndefinedObject >> collect: _ [
+	^self
+]

src/Functors/package.st

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