Prototyping a Functional Language
using Higher-Order Logic Programming

A Functional Pearl on Learning the Ways of λProlog/Makam

Antonis Stampoulis (Originate NYC), Adam Chlipala (MIT CSAIL)

PL research ideas:
ability to experiment ↔ implementation time

Metalanguages help minimize implementation time

λProlog is good for prototyping advanced type systems

Concise and readable rules
Very expressive
Incremental definitions

Example implemented in the paper

Simply typed lambda calculus
Multi-arity functions and letrec
System F polymorphism
Pattern matching
Algebraic datatypes
Type synonyms
Heterogeneous metaprogramming
Hindley-Milner generalization

Also in the paper

Complex binding structures
GADT support in λProlog
Structural recursion
Use of reflective predicates

Roza
(advisor)

Hagop
(student)

Lambros
from next door

Simply typed lambda calculus

tests : testsuite. %testsuite tests.
%use "00-adapted-stdlib.makam".

term : type.
typ : type.
typeof : term -> typ -> prop.

app : term -> term -> term.
lam : typ -> (term -> term) -> term.
arrow : typ -> typ -> typ.

\[\frac{\Gamma \vdash e_1 : \tau \to \tau' \hspace{1.0em} \Gamma \vdash e_2: \tau}{\Gamma \vdash e_1 \; e_2 : \tau'} \hspace{2em} \frac{\Gamma, x : \tau \vdash e : \tau'}{\Gamma \vdash \lambda x : \tau.e : \tau \to \tau'}\]

typeof (app E1 E2) T' :-
  typeof E1 (arrow T T'), typeof E2 T.

typeof (lam T X_E) (arrow T T') :-
  (x:term -> typeof x T -> typeof (X_E x) T').

typeof (lam _ (fun x => x)) T ?

term : type.
typ : type.
typeof : term -> typ -> prop.

\[e := e_1 e_2 \; | \; λx:\tau.e \\ \tau := \tau_1 \to \tau_2\]

\[e := \texttt{app}(e_1, e_2) \; | \; \texttt{lam}(\tau, x.e) \\ \tau := \texttt{arrow}(\tau_1, \tau_2)\]

app : term -> term -> term.
lam : typ -> (term -> term) -> term.
arrow : typ -> typ -> typ.

Multi-arity functions and let rec

\[e := \texttt{lammany}(\vec{xs}.e) \; | \; \texttt{appmany}(e, \vec{es}) \\ \tau := \texttt{arrowmany}(\vec{\tau{}s}, \tau)\]

lammany : bindmany term term -> term.
appmany : term -> list term -> term.
arrowmany : list typ -> typ -> typ.

typeof (lammany XS_E) (arrowmany TS T) :-
  openmany XS_E (pfun XS E =>
    assumemany typeof XS TS (typeof E T)).

typeof (appmany E ES) T :-
  typeof E (arrowmany TS T), map typeof ES TS.

\[e := \texttt{letrec} \; \vec{xs} \; = \; \vec{es} \; \texttt{in} \; e\]

\[e := \texttt{letrec}(\vec{xs}.(\vec{es}, e))\]

letrec : bindmany term
           (list term * term) -> term.

\[e := \texttt{letrec}(\vec{xs}.(\vec{es}, e))\]

letrec : vbindmany term N
           (vector term N * term) -> term.

typeof (letrec XS_DefsBody) T' :-
  vopenmany XS_DefsBody (pfun XS (Defs, Body) =>
    vassumemany typeof XS TS (vmap typeof Defs TS),
    vassumemany typeof XS TS (typeof Body T')).

ML-style generalization

``We mentioned Hindley-Milner / we don't want you to be sad.
This talk is very short I feel, / I hope it isn't bad.
Please come and find me afterwards / to talk about these things,
or if you'd like to learn about / the songs that Roza sings.''

generalize : (Type: typ) (GeneralizedType: typ) -> prop.
let : term -> (term -> term) -> term.
get_types_in_environment : [A] A -> prop.
tforall : (typ -> typ) -> typ.

get_types_in_environment Gamma :-
  refl.assume_get typeof Gamma.

\[\frac{\Gamma \vdash e : \tau \hspace{1em} \Gamma \vdash \tau \leadsto \tau_{gen} \hspace{1em} \Gamma, x : \tau_{gen} \vdash e' : \tau'}{\Gamma \vdash \text{let} \; x = e \; \text{in} \; e' : \tau'}\]

typeof (let E X_Body) T' :-
  typeof E T,
  generalize T Tgen,
  (x:term -> typeof x Tgen -> typeof (X_Body x) T').

\[\frac{\vec{\alpha} = \text{fv}(\tau) - \text{fv}(\Gamma)}{\Gamma \vdash \tau \leadsto \forall \vec{\alpha'}.\tau[\vec{\alpha'}/\vec{\alpha}]}\]

generalize T T :-
  not(findunif T (A: typ)).

generalize T Res :-
  findunif T A,
  (a:typ ->
    (replaceunif A a T (T' a),
     generalize (T' a) (T'' a))),
  get_types_in_environment GammaTypes,
  if (hasunif A GammaTypes)
  then (eq Res (T'' A))
  else (eq Res (tforall T'')).

replaceunif Which ToWhat Where ToWhat :-
  refl.isunif Where,
  refl.sameunif Which Where.

replaceunif Which ToWhat Where Where :-
  refl.isunif Where,
  not(refl.sameunif Which Where).

replaceunif Which ToWhat Where Result :-
  not(refl.isunif Where),
  structural_recursion @(replaceunif Which ToWhat)
    Where Result.

typeof (let (lam _ (fun x => x)) (fun id => id)) T ?

Thank you!

``That's it, thank you so much folks, / the talk is now done.
A note before I leave though / and off this stage I run:
The company I work for / is hiring engineers
So if you're looking for a job / I'll pay for all the beers''

Additional slides

Tests:

>> typeof (lam _ (fun x => x)) T ?
>> Yes:
>> T := arrow T1 T1.

>> typeof (lam _ (fun x => app x x)) T ?
>> Impossible.

typeof (lammany (bind (fun x => bind (fun y => body (app y x))))) T ?
>> Yes:
>> T := arrowmany [T_X, arrow T_X T_Y] T_Y.

typeof (letrec (vbind (fun f => vbody (vcons (lam _ (fun x => app f x)) vnil, f)))) T ?
>> Yes:
>> T := arrow T1 T2.

>> generalize (arrow T T) X ?
>> Yes:
>> X := tforall (fun a => arrow a a).

>> typeof (let (lam _ (fun x => x)) (fun id => id)) T ?
>> Yes:
>> T := tforall (fun a => arrow a a).

>> typeof (let (lam _ (fun x => let x (fun y => y))) (fun id => id)) T ?
>> Yes:
>> T := tforall (fun a => arrow a a).

run_tests X ?