gcanti
commented
7 years ago A first attempt
// adapted from http://okmij.org/ftp/Computation/free-monad.html
import { HKT, HKTS } from 'fp-ts/lib/HKT'
import { FantasyMonad, StaticMonad } from 'fp-ts/lib/Monad'
export type NaturalTransformation<F extends HKTS, G extends HKTS> = <A>(fa: HKT<A>[F]) => HKT<A>[G]
declare module 'fp-ts/lib/HKT' {
interface HKT<A> {
Free: Free<any, A>
}
}
export const URI = 'Free'
export type URI = typeof URI
export type Free<F extends HKTS, A> = Pure<F, A> | Impure<F, A, any>
export class Pure<F extends HKTS, A> implements FantasyMonad<URI, A> {
static of = of
readonly _tag: 'Pure'
readonly _F: F
readonly _A: A
readonly _URI: URI
constructor(public readonly a: A) {}
map<B>(f: (a: A) => B): Free<F, B> {
return new Pure<F, B>(f(this.a))
}
of<B>(b: B): Free<F, B> {
return of<F, B>(b)
}
ap<B>(fab: Free<F, (a: A) => B>): Free<F, B> {
return fab.chain(f => this.map(f)) // <- derived
}
chain<B>(f: (a: A) => Free<F, B>): Free<F, B> {
return f(this.a)
}
foldMap<M extends HKTS>(monad: StaticMonad<M>, f: NaturalTransformation<F, M>): HKT<A>[M] {
return monad.of(this.a)
}
}
export class Impure<F extends HKTS, A, X> implements FantasyMonad<URI, A> {
static of = of
readonly _tag: 'Impure'
readonly _F: F
readonly _A: A
readonly _X: X
readonly _URI: URI
constructor(public readonly fx: HKT<X>[F], public readonly f: (x: X) => Free<F, A>) {}
map<B>(f: (a: A) => B): Free<F, B> {
return new Impure<F, B, X>(this.fx, x => this.f(x).map(f))
}
of<B>(b: B): Free<F, B> {
return of<F, B>(b)
}
ap<B>(fab: Free<F, (a: A) => B>): Free<F, B> {
return fab.chain(f => this.map(f)) // <- derived
}
chain<B>(f: (a: A) => Free<F, B>): Free<F, B> {
return new Impure<F, B, X>(this.fx, x => this.f(x).chain(f))
}
foldMap<M extends HKTS>(monad: StaticMonad<M>, f: NaturalTransformation<F, M>): HKT<A>[M] {
return monad.chain<X, A>((x: X) => this.f(x).foldMap(monad, f), f<X>(this.fx))
}
}
export function of<F extends HKTS, A>(a: A): Free<F, A> {
return new Pure<F, A>(a)
}
export function liftFree<F extends HKTS, A>(fa: HKT<A>[F]): Free<F, A> {
return new Impure<F, A, A>(fa, of)
}Usage
//
// Adapted from http://typelevel.org/cats/datatypes/freemonad.html
//
// Create an ADT representing your grammar
import { Option, fromNullable } from 'fp-ts/lib/Option'
declare module 'fp-ts/lib/HKT' {
interface HKT<A> {
KVStoreA: KVStoreA<A>
}
}
export class KVStoreA<A> {
_A: A
}
class Put<T> extends KVStoreA<void> {
constructor(public readonly key: string, public readonly value: T) {
super()
}
}
class Get<T> extends KVStoreA<Option<T>> {
constructor(public readonly key: string) {
super()
}
}
class Delete extends KVStoreA<void> {
constructor(public readonly key: string) {
super()
}
}
//
// Free your ADT
//
// Create a Free type based on your ADT
type KVStore<A> = Free<'KVStoreA', A>
// Create smart constructors using liftF
function put<T>(key: string, value: T): KVStore<void> {
return liftFree<'KVStoreA', void>(new Put(key, value))
}
function get<T>(key: string): KVStore<Option<T>> {
return liftFree<'KVStoreA', Option<T>>(new Get<T>(key))
}
function del(key: string): KVStore<void> {
return liftFree<'KVStoreA', void>(new Delete(key))
}
// Update composes get and set, and returns nothing
function update<T>(key: string, f: (t: T) => T): KVStore<void> {
return get<T>(key).chain(o => o.map(v => put<T>(key, f(v))).getOrElse(() => of<'KVStoreA', void>(undefined)))
}
// Build a program
// program :: Free<"KVStoreA", Option<number>>
const program = put('wild-cats', 2)
.chain(() => update('wild-cats', (n: number) => n + 12))
.chain(() => put('tame-cats', 5))
.chain(() => get<number>('wild-cats'))
.chain(n => del('tame-cats').map(() => n))
//
// Write a compiler for your program
//
import * as identity from 'fp-ts/lib/Identity'
// a very simple (and imprecise) key-value store
const kvs: { [key: string]: any } = {}
// the program will crash if a key is not found,
// or if a type is incorrectly specified
function compile<A>(fa: KVStoreA<A>): identity.Identity<A> {
if (fa instanceof Put) {
console.log(`put(${fa.key}, ${fa.value})`)
kvs[fa.key] = fa.value
return identity.of(undefined) as any
} else if (fa instanceof Get) {
console.log(`get(${fa.key})`)
return identity.of(fromNullable(kvs[fa.key])) as any
} else if (fa instanceof Delete) {
console.log(`del(${fa.key})`)
delete kvs[fa.key]
return identity.of(undefined) as any
}
throw new Error('never')
}
// Run your program
const result = program.foldMap(identity, compile).value
console.log(result) // =>
/*
put(wild-cats, 2)
get(wild-cats)
put(wild-cats, 14)
put(tame-cats, 5)
get(wild-cats)
del(tame-cats)
Some(14)
*/
danielepolencic
sledorze
Flow-static-land has an implementation of the Free monad.
Is it possible to include it in this library too?