From 5e3d43b57597ac4e72799b7e4bdbf90ff73a11c9 Mon Sep 17 00:00:00 2001 From: Boris Shingarov Date: Mon, 27 May 2024 15:50:37 -0400 Subject: [PATCH] Initial sketch --- .../FuntorialityTestTest.class.st | 36 ++++++++++++++++ src/Functors-Tests/package.st | 1 + src/Functors/ApplicativeFunctor.class.st | 5 +++ src/Functors/Class.extension.st | 11 +++++ src/Functors/Functor.class.st | 22 ++++++++++ src/Functors/Just.class.st | 41 +++++++++++++++++++ src/Functors/Maybe.class.st | 10 +++++ src/Functors/UndefinedObject.extension.st | 6 +++ src/Functors/package.st | 1 + 9 files changed, 133 insertions(+) create mode 100644 src/Functors-Tests/FuntorialityTestTest.class.st create mode 100644 src/Functors-Tests/package.st create mode 100644 src/Functors/ApplicativeFunctor.class.st create mode 100644 src/Functors/Class.extension.st create mode 100644 src/Functors/Functor.class.st create mode 100644 src/Functors/Just.class.st create mode 100644 src/Functors/Maybe.class.st create mode 100644 src/Functors/UndefinedObject.extension.st create mode 100644 src/Functors/package.st diff --git a/src/Functors-Tests/FuntorialityTestTest.class.st b/src/Functors-Tests/FuntorialityTestTest.class.st new file mode 100644 index 000000000..c3182db46 --- /dev/null +++ b/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 checkIdentityFor: F ] +] + +{ #category : #tests } +FuntorialityTestTest >> testIdentityEmpty [ + self + assert: (nil collect: #yourself) + equals: nil +] diff --git a/src/Functors-Tests/package.st b/src/Functors-Tests/package.st new file mode 100644 index 000000000..e31fed245 --- /dev/null +++ b/src/Functors-Tests/package.st @@ -0,0 +1 @@ +Package { #name : #'Functors-Tests' } diff --git a/src/Functors/ApplicativeFunctor.class.st b/src/Functors/ApplicativeFunctor.class.st new file mode 100644 index 000000000..79d486fc6 --- /dev/null +++ b/src/Functors/ApplicativeFunctor.class.st @@ -0,0 +1,5 @@ +Class { + #name : #ApplicativeFunctor, + #superclass : #Functor, + #category : #Functors +} diff --git a/src/Functors/Class.extension.st b/src/Functors/Class.extension.st new file mode 100644 index 000000000..ab635994a --- /dev/null +++ b/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. + +] diff --git a/src/Functors/Functor.class.st b/src/Functors/Functor.class.st new file mode 100644 index 000000000..a29ea93cf --- /dev/null +++ b/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 +] diff --git a/src/Functors/Just.class.st b/src/Functors/Just.class.st new file mode 100644 index 000000000..9ee0976e2 --- /dev/null +++ b/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 +] diff --git a/src/Functors/Maybe.class.st b/src/Functors/Maybe.class.st new file mode 100644 index 000000000..cb496ffb7 --- /dev/null +++ b/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 +] diff --git a/src/Functors/UndefinedObject.extension.st b/src/Functors/UndefinedObject.extension.st new file mode 100644 index 000000000..ef78d895c --- /dev/null +++ b/src/Functors/UndefinedObject.extension.st @@ -0,0 +1,6 @@ +Extension { #name : #UndefinedObject } + +{ #category : #'*Functors' } +UndefinedObject >> collect: _ [ + ^self +] diff --git a/src/Functors/package.st b/src/Functors/package.st new file mode 100644 index 000000000..ebb5a1140 --- /dev/null +++ b/src/Functors/package.st @@ -0,0 +1 @@ +Package { #name : #Functors }