add IxMonad module (#180)

examples/ixIO.ts

@@ -0,0 +1,82 @@
+import { IxIO } from 'fp-ts/lib/IxIO'
+import * as io from 'fp-ts/lib/IO'
+
+/*
+
+  Usage
+
+  Based on State Machines All The Way Down
+  An Architecture for Dependently Typed Applications
+  https://eb.host.cs.st-andrews.ac.uk/drafts/states-all-the-way.pdf
+  by Edwin Brady
+
+*/
+
+//
+// finite state machine
+//
+
+// By defining this state machine in a type, we can ensure that any sequence
+// of operations which type checks is a valid sequence of operations on a door.
+// The door can be open or closed
+export type DoorState = 'Open' | 'Closed'
+
+//
+// operations
+//
+
+// A  represents the return type of the operation
+// I represents the input state (the precondition)
+// O represents output state (the postcondition)
+export class Operation<I extends DoorState, O extends DoorState, A> extends IxIO<I, O, A> {}
+
+class Open extends Operation<'Closed', 'Open', void> {
+  constructor() {
+    super(
+      new io.IO(() => {
+        console.log(`Opening the door`)
+      })
+    )
+  }
+}
+class Close extends Operation<'Open', 'Closed', void> {
+  constructor() {
+    super(
+      new io.IO(() => {
+        console.log(`Closing the door`)
+      })
+    )
+  }
+}
+class RingBell extends Operation<'Closed', 'Closed', void> {
+  constructor() {
+    super(
+      new io.IO(() => {
+        console.log(`Ringing the bell`)
+      })
+    )
+  }
+}
+
+// tip: decomment the following lines to see the static errors
+
+// error: Type '"Open"' is not assignable to type '"Closed"'
+// if you open the door, you must close it
+// const x1: Operation<'Closed', 'Closed', void> = new Open()
+
+// ok
+export const x2: Operation<'Closed', 'Closed', void> = new Open().ichain(() => new Close())
+
+// error: Type '"Closed"' is not assignable to type '"Open"'
+// you can't ring the bell when the door is open
+// const x3 = new Open().ichain(() => new RingBell())
+
+// ok
+export const x4 = new Open().ichain(() => new Close()).ichain(() => new RingBell())
+
+x4.value.run()
+/*
+Opening the door
+Closing the door
+Ringing the bell
+*/

src/HKT.ts

@@ -7,26 +7,34 @@ export interface HKT2<URI, L, A> extends HKT<URI, A> {
   readonly _L: L
 }
 
+export interface HKT3<URI, U, L, A> extends HKT2<URI, L, A> {
+  readonly _U: U
+}
+
 // type-level dictionaries for HKTs
 
 export interface URI2HKT<A> {}
 export interface URI2HKT2<L, A> {}
+export interface URI2HKT3<U, L, A> {}
 
 // URI constraints with dictionary integrity constraint
 
 export type HKTS = (URI2HKT<any> & { never: HKT<never, never> })[keyof URI2HKT<any> | 'never']['_URI']
-
 export type HKT2S = (URI2HKT2<any, any> & { never: HKT<never, never> })[keyof URI2HKT2<any, any> | 'never']['_URI']
+export type HKT3S = (URI2HKT3<any, any, any> & { never: HKT<never, never> })[
+  | keyof URI2HKT3<any, any, any>
+  | 'never']['_URI']
 
 // HKTAs<U, A> is the same as URI2HKT<A>[U], but checks for URI constraints
 
 export type HKTAs<URI extends HKTS, A> = URI2HKT<A>[URI]
-
 export type HKT2As<URI extends HKT2S, L, A> = URI2HKT2<L, A>[URI]
+export type HKT3As<URI extends HKT3S, U, L, A> = URI2HKT3<U, L, A>[URI]
 
 // Type-level integrity check
 
 /* tslint:disable */
 (null! as URI2HKT<any>) as { [k in keyof URI2HKT<any>]: HKT<k, any> }
 (null! as URI2HKT2<any, any>) as { [k in keyof URI2HKT2<any, any>]: HKT2<k, any, any> }
+(null! as URI2HKT3<any, any, any>) as { [k in keyof URI2HKT3<any, any, any>]: HKT3<k, any, any, any> }
 /* tslint:enable */

src/IxIO.ts

@@ -0,0 +1,76 @@
+import { Monad } from '../src/Monad'
+import { IxMonad, FantasyIxMonad } from '../src/IxMonad'
+import { IO } from '../src/IO'
+import * as io from '../src/IO'
+
+declare module './HKT' {
+  interface URI2HKT3<U, L, A> {
+    IxIO: IxIO<U, L, A>
+  }
+}
+
+export const URI = 'IxIO'
+
+export type URI = typeof URI
+
+export class IxIO<I, O, A> implements FantasyIxMonad<URI, A, O, I> {
+  static iof = iof
+  readonly _A: A
+  readonly _L: O
+  readonly _U: I
+  readonly _URI: URI
+  constructor(public readonly value: IO<A>) {}
+  run(): A {
+    return this.value.run()
+  }
+  iof<I, B>(b: B): IxIO<I, I, B> {
+    return iof<I, B>(b)
+  }
+  ichain<Z, B>(f: (a: A) => IxIO<O, Z, B>): IxIO<I, Z, B> {
+    return new IxIO<I, Z, B>(this.value.chain(a => f(a).value))
+  }
+  of<I, B>(b: B): IxIO<I, I, B> {
+    return iof<I, B>(b)
+  }
+  map<B>(f: (a: A) => B): IxIO<I, O, B> {
+    return new IxIO<I, O, B>(this.value.map(f))
+  }
+  ap<B>(fab: IxIO<I, I, (a: A) => B>): IxIO<I, I, B> {
+    return new IxIO<I, I, B>(this.value.ap(fab.value))
+  }
+  chain<B>(f: (a: A) => IxIO<I, I, B>): IxIO<I, I, B> {
+    return new IxIO<I, I, B>(this.value.chain(a => f(a).value))
+  }
+}
+
+export function iof<I, A>(a: A): IxIO<I, I, A> {
+  return new IxIO<I, I, A>(io.of(a))
+}
+
+export function ichain<I, O, Z, A, B>(f: (a: A) => IxIO<O, Z, B>, fa: IxIO<I, O, A>): IxIO<I, Z, B> {
+  return fa.ichain(f)
+}
+
+export function map<I, A, B>(f: (a: A) => B, fa: IxIO<I, I, A>): IxIO<I, I, B> {
+  return fa.map(f)
+}
+
+export const of = iof
+
+export function ap<I, A, B>(fab: IxIO<I, I, (a: A) => B>, fa: IxIO<I, I, A>): IxIO<I, I, B> {
+  return fa.ap(fab)
+}
+
+export function chain<I, A, B>(f: (a: A) => IxIO<I, I, B>, fa: IxIO<I, I, A>): IxIO<I, I, B> {
+  return fa.chain(f)
+}
+
+export const ixIO: Monad<URI> & IxMonad<URI> = {
+  URI,
+  map,
+  of,
+  ap,
+  chain,
+  iof,
+  ichain
+}

src/IxMonad.ts

@@ -0,0 +1,39 @@
+import { HKT3, HKT3S, HKT3As } from './HKT'
+import { constant } from './function'
+
+// Adapted from https://github.com/garyb/purescript-indexed-monad
+
+export interface IxMonad<F> {
+  readonly URI: F
+  iof<I, A>(a: A): HKT3<F, I, I, A>
+  ichain<I, O, Z, A, B>(f: (a: A) => HKT3<F, O, Z, B>, fa: HKT3<F, I, O, A>): HKT3<F, I, Z, B>
+}
+
+export interface FantasyIxMonad<F, A, O, I> {
+  iof<I, B>(b: B): HKT3<F, I, I, B>
+  ichain<Z, B>(f: (a: A) => HKT3<F, O, Z, B>): HKT3<F, I, Z, B>
+}
+
+export class Ops {
+  iapplyFirst<F extends HKT3S>(
+    ixmonad: IxMonad<F>
+  ): <I, O, Z, A, B>(fa: HKT3As<F, I, O, A>, fb: HKT3As<F, O, Z, B>) => HKT3As<F, I, Z, A>
+  iapplyFirst<F>(ixmonad: IxMonad<F>): <I, O, Z, A, B>(fa: HKT3<F, I, O, A>, fb: HKT3<F, O, Z, B>) => HKT3<F, I, Z, A>
+  iapplyFirst<F>(ixmonad: IxMonad<F>): <I, O, Z, A, B>(fa: HKT3<F, I, O, A>, fb: HKT3<F, O, Z, B>) => HKT3<F, I, Z, A> {
+    return (fa, fb) => ixmonad.ichain(a => ixmonad.ichain(() => ixmonad.iof(a), fb), fa)
+  }
+
+  iapplySecond<F extends HKT3S>(
+    ixmonad: IxMonad<F>
+  ): <I, O, Z, A, B>(fa: HKT3As<F, I, O, A>, fb: HKT3As<F, O, Z, B>) => HKT3As<F, I, Z, B>
+  iapplySecond<F>(ixmonad: IxMonad<F>): <I, O, Z, A, B>(fa: HKT3<F, I, O, A>, fb: HKT3<F, O, Z, B>) => HKT3<F, I, Z, B>
+  iapplySecond<F>(
+    ixmonad: IxMonad<F>
+  ): <I, O, Z, A, B>(fa: HKT3<F, I, O, A>, fb: HKT3<F, O, Z, B>) => HKT3<F, I, Z, B> {
+    return (fa, fb) => ixmonad.ichain(constant(fb), fa)
+  }
+}
+
+const ops = new Ops()
+export const iapplyFirst: Ops['iapplyFirst'] = ops.iapplyFirst
+export const iapplySecond: Ops['iapplySecond'] = ops.iapplySecond

src/index.ts

@@ -48,6 +48,10 @@ import * as identity from './Identity'
 export { identity }
 import * as io from './IO'
 export { io }
+import * as ixIo from './IxIO'
+export { ixIo }
+import * as ixMonad from './IxMonad'
+export { ixMonad }
 import * as monad from './Monad'
 export { monad }
 import * as monoid from './Monoid'

test/IxIO.ts

@@ -0,0 +1,83 @@
+import * as assert from 'assert'
+import { iapplyFirst, iapplySecond } from '../src/IxMonad'
+import { IxIO } from '../src/IxIO'
+import * as ixIO from '../src/IxIO'
+import * as io from '../src/IO'
+
+//
+// finite state machine
+//
+
+// By defining this state machine in a type, we can ensure that any sequence
+// of operations which type checks is a valid sequence of operations on a door.
+// The door can be open or closed
+type DoorState = 'Open' | 'Closed'
+
+//
+// operations
+//
+
+let log: Array<string> = []
+
+// A  represents the return type of the operation
+// I represents the input state (the precondition)
+// O represents output state (the postcondition)
+class Operation<I extends DoorState, O extends DoorState, A> extends IxIO<I, O, A> {
+  constructor(ma: io.IO<A>) {
+    super(ma)
+  }
+}
+
+class Open extends Operation<'Closed', 'Open', number> {
+  constructor() {
+    super(
+      new io.IO(() => {
+        log.push(`Opening the door`)
+        return 1
+      })
+    )
+  }
+}
+class Close extends Operation<'Open', 'Closed', void> {
+  constructor() {
+    super(
+      new io.IO(() => {
+        log.push(`Closing the door`)
+        return undefined
+      })
+    )
+  }
+}
+class RingBell extends Operation<'Closed', 'Closed', void> {
+  constructor() {
+    super(
+      new io.IO(() => {
+        log.push(`Ringing the bell`)
+        return undefined
+      })
+    )
+  }
+}
+
+describe('IxIO', () => {
+  it('should run', () => {
+    log = []
+    const action = new Open().ichain(() => new Close()).ichain(() => new RingBell())
+    action.run()
+    assert.deepEqual(log, ['Opening the door', 'Closing the door', 'Ringing the bell'])
+  })
+
+  it('iapplyFirst', () => {
+    log = []
+    const action = iapplyFirst(ixIO)(new Open(), new Close())
+    action.run()
+    assert.deepEqual(log, ['Opening the door', 'Closing the door'])
+  })
+
+  it('iapplySecond', () => {
+    log = []
+    const action = iapplySecond(ixIO)(new Open(), new Close())
+    action.run()
+    assert.deepEqual(log, ['Opening the door', 'Closing the door'])
+  })
+})