overhaul monad impls

package-lock.json

@@ -14,7 +14,7 @@
     },
     "node_modules/folktest": {
       "version": "1.0.0",
-      "resolved": "git+https://git.kitsu.cafe/rowan/folktest.git#1e03ea78b2fab14af89cfb7bd43ed9f384e513c6",
+      "resolved": "git+https://git.kitsu.cafe/rowan/folktest.git#b130e6fd1839a32ca62ffe9c96da58d8bdf39b38",
       "dev": true,
       "license": "GPL-3.0-or-later"
     }

src/either.js

@@ -1,33 +0,0 @@
-import { toList } from './utils.js'
-
-/**
- * @template L, R
- * @typedef {Left<L> | Right<R>} Either
- */
-
-/**
- * @template T
- * @constructor
- * @param {T} value
- */
-export const Left = value => ({
-    ...Monad(Left, value),
-    bind: _f => Left(value),
-    map: _f => Left(value),
-    isLeft: () => true,
-    isRight: () => false,
-    ...Tag('Left', toList(value))
-})
-
-/**
- * @template T
- * @constructor
- * @param {T} value
- */
-export const Right = value => ({
-    ...Monad(Right, value),
-    isLeft: () => false,
-    isRight: () => true,
-    ...Tag('Right', toList(value))
-})
-

src/identity.js

@@ -1,7 +0,0 @@
-/**
- * @template T
- * @constructor
- * @param {T} value
- */
-export const Identity = value => Monad(Identity, value)
-

src/index.js

@@ -1,7 +1,139 @@
-export { Union, UnmatchedTagError } from './union.js'
+export class MatchError extends Error {
-export { Identity } from './identity.js'
+  constructor(name) {
-export { Left, Right } from './either.js'
+    super(`Pattern not matched: ${name}`)
-export { Some, None } from './option.js'
+  }
-export { Ok, Err } from './result.js'
+}
+
+const ValueKey = Symbol()
+
+const create = (...args) => Object.freeze(Object.assign(...args))
+
+function constant() { return this }
+function extract() { return this[ValueKey] }
+function extend(f) { return this.lift(f(this)) }
+function bind(fn) { return fn(this[ValueKey]) }
+function ap(other) { return other.map(this[ValueKey]) }
+function map(fn) {
+  return this.lift(this.bind(fn))
+}
+
+function match(pattern) {
+  const name = this.of.name
+
+  if (name in pattern) {
+    return this.bind(pattern[name])
+  } else if ('_' in pattern) {
+    return pattern['_']()
+  } else {
+    throw new MatchError(name)
+  }
+}
+
+const Value = v => ({ [ValueKey]: v })
+
+const Functor = {
+  map
+}
+
+const ConstantFunctor = {
+  map: constant
+}
+
+const ConstantMonad = {
+  bind: constant
+}
+
+const PointedFunctor = of => ({
+  of
+})
+
+const Applicative = {
+  ...Functor,
+  ap
+}
+
+const Monad = {
+  ...PointedFunctor,
+  bind
+}
+
+const Comonad = {
+  extract,
+  extend
+}
+
+export const Identity = value => create(
+  Value(value),
+  Functor,
+  PointedFunctor(Identity),
+  Monad
+)
+
+export const Constant = value => create(
+  Value(value),
+  ConstantFunctor,
+  ConstantMonad,
+  PointedFunctor(constant)
+)
+
+export const Ok = value => create(
+  Value(value),
+  Functor,
+  PointedFunctor(Ok),
+  Monad,
+  {
+    isOk: true,
+    isErr: false,
+    match
+  })
+
+export const Err = value => create(
+  Value(value),
+  ConstantFunctor,
+  ConstantMonad,
+  PointedFunctor(Err),
+  {
+    isOk: false,
+    isErr: true,
+    match
+  }
+)
+
+export const Some = value => create(
+  Value(value),
+  Functor,
+  PointedFunctor(Some),
+  Monad,
+  {
+    isSome: true,
+    isNone: false,
+    match
+  }
+)
+
+export const None = () => NoneConstant
+
+const NoneConstant = create(
+  ConstantFunctor,
+  ConstantMonad,
+  PointedFunctor(None),
+  {
+    isSome: false,
+    isNone: true,
+    match
+  }
+)
+
+export function curry(func) {
+  return function curried(...args) {
+    if (args.length >= func.length) {
+      return func.apply(this, args)
+    } else {
+      return function(...args2) {
+        return curried.apply(this, args.concat(args2))
+      }
+    }
+  }
+}
 
 

src/monad.js

@@ -1,17 +0,0 @@
-/**
- * @template M, T
- * @constructor
- * @param {(value: T) => M} lift 
- * @param {T} value
- */
-export function Monad(lift, value) {
-    const name = lift.name
-
-    return {
-        bind: f => f(value),
-        map(f) { return lift(this.bind(f)) },
-        toString: () => `${name}(${value})`
-    }
-}
-
-

src/option.js

@@ -1,29 +0,0 @@
-import { Monad } from './monad.js'
-import { Tag } from './union.js'
-import { emptyList, toList } from './utils.js'
-
-/**
- * @template T
- * @typedef {Some<T> | None} Option
- */
-export const None = Object.freeze({
-    bind: _f => None,
-    map: _f => None,
-    isSome: () => false,
-    isNone: () => true,
-    ...Tag('None', emptyList),
-    toString: () => 'None'
-})
-
-/**
- * @template T
- * @constructor
- * @param {T} value
- */
-export const Some = value => ({
-    ...Monad(Some, value),
-    isSome: () => true,
-    isNone: () => false,
-    ...Tag('Some', toList(value))
-})
-

src/result.js

@@ -1,35 +0,0 @@
-import { Monad } from './monad.js'
-import { Tag } from './union.js'
-import { toList } from './utils.js'
-
-/**
- * @template T, E
- * @typedef {Ok<T> | Err<E>} Result
- */
-
-/**
- * @template T
- * @constructor
- * @param {T} value
- */
-export const Err = value => ({
-    ...Monad(Err, value),
-    bind: _f => Err(value),
-    map: _f => Err(value),
-    isError: () => true,
-    isOk: () => false,
-    ...Tag('Err', toList(value))
-})
-
-/**
- * @template T
- * @constructor
- * @param {T} value
- */
-export const Ok = value => ({
-    ...Monad(Ok, value),
-    isError: () => false,
-    isOk: () => true,
-    ...Tag('Ok', toList(value))
-})
-

src/union.js

@@ -1,44 +0,0 @@
-export class UnmatchedTagError extends Error {
-    constructor(tag) {
-        super(`unmatched tag in union: ${tag}`)
-    }
-}
-
-// TODO: verify patterns against union
-/**
- * @template Type, Value
- * @constructor
- * @param {Type} type
- * @param {Iterable<Value>} values
- */
-export const Tag = (type, values) => ({
-    /**
-     * @template T
-     * @typedef {(...args: T[]) => void}) Pattern
-     * @param {Object.<string, Pattern>} patterns
-     * @throws {UnmatchedTagError}
-     */
-    fold: patterns => {
-        if (type in patterns) {
-            return patterns[type](...values)
-        } else if ('_' in patterns) {
-            return patterns._()
-        } else {
-            throw new UnmatchedTagError(type)
-        }
-    },
-    toString: () => `${type}(${values.join(', ')})`
-})
-
-export const Union = types => {
-    const result = {}
-
-    const len = types.length
-    for (let i = 0; i < len; i++) {
-        const type = types[i]
-        result[type] = (...values) => Tag(type, values)
-    }
-
-    return result
-}
-

src/utils.js

@@ -1,3 +0,0 @@
-export const emptyList = []
-export const toList = x => Array.isArray(x) ? x : [x]
-

tests/index.js

@@ -7,7 +7,7 @@ const fmt = ({ success, description, error }) => {
   if (success) {
     return `${description}: PASS`
   } else {
-        return `${description}: FAIL\n${error}`
+    return `${description}: FAIL\n${error.stack}`
   }
 }
 

tests/units/index.js

@@ -1,5 +1,2 @@
 export { Tests as Monad } from './monad.js'
-export { Tests as Option } from './option.js'
-export { Tests as Result } from './result.js'
-export { Tests as Union } from './union.js'
 

tests/units/monad.js

@@ -1,5 +1,5 @@
 import { it, assertEq } from 'folktest'
-import { Monad } from '../../src/monad.js'
+import { Identity, Constant, Ok, Err, Some, None } from '../../src/index.js'
 
 const leftIdentity = (M, a, f) => {
   assertEq(M(a).bind(f), f(a))
@@ -21,7 +21,7 @@ export const prove = (M, m, a, f, g) => {
 
 export const Tests = [
   it('should adhere to monadic laws', () => {
-        const ctr = Monad.bind(undefined, Monad)
+    [Identity, Constant, Ok, Err, Some, None].forEach(ctr => {
       prove(
         ctr,
         ctr(1),
@@ -30,4 +30,5 @@ export const Tests = [
         x => ctr(x * 2)
       )
     })
+  })
 ]

tests/units/option.js

@@ -1,26 +0,0 @@
-import { it, assertEq } from 'folktest'
-import { Some, None } from '../../src/option.js'
-import { prove } from './monad.js'
-
-const id = x => () => x
-export const Tests = [
-    it('some should pass monadic laws', () => {
-        prove(
-            Some,
-            Some(1),
-            1,
-            x => Some(x + 1),
-            x => Some(x * 2)
-        )
-    }),
-
-    it('should not bind none', () => {
-        const opt = Some(1)
-            .bind(id(None))
-            .bind(id(Some(1)))
-            .map(x => x + 1)
-
-        assertEq(opt, None)
-    }),
-]
-

tests/units/result.js

@@ -1,37 +0,0 @@
-import { it, assertEq } from 'folktest'
-import { Ok, Err } from '../../src/result.js'
-import { prove } from './monad.js'
-
-const id = x => () => x
-export const Tests = [
-    it('should pass monadic laws', () => {
-        prove(
-            Ok,
-            Ok(1),
-            1,
-            x => Ok(x + 1),
-            x => Ok(x * 2)
-        )
-
-        const e = new Error()
-        prove(
-            Err,
-            Err(e),
-            e,
-            x => Err(new Error()),
-            x => Err(new Error())
-        )
-    }),
-
-    it('should not bind err', () => {
-        const e = new Error()
-        const result = Ok(1)
-            .bind(id(Err(e)))
-            .bind(id(Ok(1)))
-            .map(x => x + 1)
-
-        assertEq(result, Err(e))
-    }),
-]
-
-

tests/units/union.js

@@ -1,39 +0,0 @@
-import { it, assert, assertEq } from 'folktest'
-import { Union } from '../../src/union.js'
-
-export const Tests = [
-    it('should create a valid tagged union', () => {
-        const union = Union(['Nothing', 'Void'])
-
-        assert(Object.hasOwn(union, 'Nothing'))
-        assert(Object.hasOwn(union, 'Void'))
-    }),
-
-    it('can be matched', () => {
-        const union = Union(['Adrift', 'Nonextant', 'Dream'])
-        const dreaming = union.Dream('mercury')
-        const drifting = union.Adrift('19589')
-        const gone = union.Nonextant('rowan', Infinity)
-
-        dreaming.fold({
-            Dream(name) {
-                assertEq(name, 'mercury')
-            }
-        })
-
-        drifting.fold({
-            Adrift(name) {
-                assertEq(name, '19589')
-            }
-        })
-
-        gone.fold({
-            Nonextant(name, when) {
-                assertEq(name, 'rowan')
-                assertEq(when, Infinity)
-            }
-        })
-    })
-]
-
-