Optimizing Tagless Final, adapted from http://lukajcb.github.io/blog/functional/2018/01/03/optimizing-tagless-final.html

optimizing-tagless-final.ts

// Adapted from http://lukajcb.github.io/blog/functional/2018/01/03/optimizing-tagless-final.html

import { Applicative, Applicative1 } from 'fp-ts/lib/Applicative'
import { Apply, Apply1, Apply2C, applySecond, liftA4 } from 'fp-ts/lib/Apply'
import * as array from 'fp-ts/lib/Array'
import * as const_ from 'fp-ts/lib/Const'
import { HKT, Type, Type2, URIS, URIS2 } from 'fp-ts/lib/HKT'
import { IO, io, URI as IOURI } from 'fp-ts/lib/IO'
import { Option, some } from 'fp-ts/lib/Option'
import { getProductSemigroup, Semigroup } from 'fp-ts/lib/Semigroup'
import { Setoid, setoidString } from 'fp-ts/lib/Setoid'
import { getMonoid, singleton, StrMap, traverseWithKey } from 'fp-ts/lib/StrMap'

interface KVStore<F> {
  get: (k: string) => HKT<F, Option<string>>
  put: (k: string, v: string) => HKT<F, void>
}

interface KVStore1<F extends URIS> {
  get: (k: string) => Type<F, Option<string>>
  put: (k: string, v: string) => Type<F, void>
}

interface KVStore2C<F extends URIS2, L> {
  get: (k: string) => Type2<F, L, Option<string>>
  put: (k: string, v: string) => Type2<F, L, void>
}

function program<F extends URIS2, L>(F: Apply2C<F, L> & KVStore2C<F, L>): Type2<F, L, Array<string>>
function program<F extends URIS>(F: Apply1<F> & KVStore1<F>): Type<F, Array<string>>
function program<F>(F: Apply<F> & KVStore<F>): HKT<F, Array<string>> {
  return liftA4(F)<Option<string>, Option<string>, void, Option<string>, Array<string>>(a => b => _ => c =>
    array.catOptions([a, b, c])
  )(F.get('Cats'))(F.get('Dogs'))(F.put('Mice', '42'))(F.get('Cats'))
}

// using an array as a poor man set
type M = [Array<string>, StrMap<string>]

class Const<A> extends const_.Const<M, A> {
  constructor(set: Array<string>, map: StrMap<string>) {
    super([set, map])
  }
}

const getSetSemigroup = <A>(S: Setoid<A>): Semigroup<Array<A>> => {
  return {
    concat: (x, y) => x.concat(y.filter(ey => !x.some(ex => S.equals(ex, ey))))
  }
}

const A = const_.getApply(getProductSemigroup(getSetSemigroup(setoidString), getMonoid<string>()))

const analysisInterpreter: Apply2C<const_.URI, M> & KVStore2C<const_.URI, M> = {
  ...A,
  get: (k: string) => new Const<Option<string>>([k], new StrMap({})),
  put: (k: string, v: string) => new Const<undefined>([], singleton(k, v))
}

console.log('-- analysisInterpreter --')
console.log(program<const_.URI, M>(analysisInterpreter).value)
// output:
// -- analysisInterpreter --
// [ [ 'Cats', 'Dogs' ], StrMap { value: { Mice: '42' } } ]

const ioInterpreter: Applicative1<IOURI> & KVStore1<IOURI> = {
  URI: io.URI,
  map: io.map,
  of: io.of,
  ap: io.ap,
  get: (k: string) =>
    new IO(() => {
      console.log(`get ${k}`)
      return some(`${k}-value`)
    }),
  put: (k: string, v: string) =>
    new IO(() => {
      console.log(`put ${k} ${v}`)
    })
}

console.log('-- ioInterpreter --')
program(ioInterpreter).run()
// output:
// -- ioInterpreter --
// get Cats
// get Dogs
// put Mice 42
// get Cats

function optimizedProgram<F extends URIS, L>(F: Applicative1<F> & KVStore1<F>): Type<F, Array<Option<string>>>
function optimizedProgram<F>(F: Applicative<F> & KVStore<F>): HKT<F, Array<Option<string>>> {
  const [gets, puts] = program<const_.URI, M>(analysisInterpreter).value
  const fputs = traverseWithKey(F)(puts, (k, v) => F.put(k, v))
  const fgets = array.traverse(F)(gets, F.get)
  return applySecond(F)(fputs, fgets)
}

console.log('-- optimizedProgram with ioInterpreter --')
optimizedProgram(ioInterpreter).run()
// output:
// -- optimizedProgram with ioInterpreter --
// put Mice 42
// get Cats
// get Dogs