for Grassy https://github.com/susisu/Grassy

lib.ml

(* basic functions *)
let id x        = x
let const x y   = x
let compose f g = fun x -> f (g x)
let flip f      = fun x y -> f y x
let fix f       = (fun x -> f (fun y -> x x y)) (fun x -> f (fun y -> x x y))
let void        = fix (fun void x -> void)

(* data types *)
let match = id

(* unit *)
let Unit = fix (fun X u -> u X)

(* boolean *)
let False = fix (fun X f t -> f X)
let True  = fix (fun X f t -> t X)
let if a f g  = match a g f
let not a     = if a (fun _ -> False) (fun _ -> True)
let or a b    = if a (fun _ -> True) (fun _ -> b)
let and a b   = if a (fun _ -> b) (fun _ -> False)

(* pair *)
let Pair x y = fix (fun X p -> p X x y)
let fst p = match p
    (fun _ x y -> x)
let snd p = match p
    (fun _ x y -> y)

(* either *)
let Left x  = fix (fun X l r -> l X x)
let Right x = fix (fun X l r -> r X x)

(* maybe *)
let Nothing = fix (fun X n j -> n X)
let Just x  = fix (fun X n j -> j X x)
let fromMaybe alt m = match m
    (fun _   -> alt)
    (fun _ x -> x)

(* numeral *)
let Z   = fix (fun X z s -> z X)
let S n = fix (fun X z s -> s X n)
let succ n = S n
let pred n = match n
    (fun _    -> n)
    (fun _ n' -> n')
let itr = fix (fun itr n f x ->
        match n
            (fun _    -> x)
            (fun _ n' -> itr n' f (f x))
    )
let add m n = itr m succ n
let sub m n = itr n pred m
let mul m n = itr m (add n) Z
let divmod m n = match n
    (fun _   -> Pair n m)
    (fun _ _ ->
        let go = fix (fun go q m n ->
                match (sub m n)
                    (fun _   -> Pair q (pred m))
                    (fun r _ -> go (succ q) r n)
            )
        in go Z (succ m) n
    )
let div m n = fst (divmod m n)
let mod m n = snd (divmod m n)
let eq = fix (fun eq m n ->
        match m
            (fun _    ->
                match n
                    (fun _    -> True)
                    (fun _ n' -> False)
            )
            (fun _ m' ->
                match n
                    (fun _    -> False)
                    (fun _ n' -> eq m' n')
            )
    )
let neq m n = not (eq m n)
let lt = fix (fun lt m n ->
        match m
            (fun _ ->
                match n
                    (fun _    -> False)
                    (fun _ n' -> True)
            )
            (fun _ m' ->
                match n
                    (fun _    -> False)
                    (fun _ n' -> lt m' n')
            )
    )
let gt = fix (fun gt m n ->
        match m
            (fun _ ->
                match n
                    (fun _    -> False)
                    (fun _ n' -> False)
            )
            (fun _ m' ->
                match n
                    (fun _    -> True)
                    (fun _ n' -> gt m' n')
            )
    )
let leq = fix (fun leq m n ->
        match m
            (fun _ ->
                match n
                    (fun _    -> True)
                    (fun _ n' -> True)
            )
            (fun _ m' ->
                match n
                    (fun _    -> False)
                    (fun _ n' -> leq m' n')
            )
    )
let geq = fix (fun geq m n ->
        match m
            (fun _ ->
                match n
                    (fun _    -> True)
                    (fun _ n' -> False)
            )
            (fun _ m' ->
                match n
                    (fun _    -> True)
                    (fun _ n' -> geq m' n')
            )
    )
let max m n = if (lt m n)
    (fun _ -> n)
    (fun _ -> m)
let min m n = if (lt m n)
    (fun _ -> m)
    (fun _ -> n)

let n0   = Z
let n1   = succ n0
let n2   = succ n1
let n4   = mul n2 n2
let n8   = mul n4 n2
let n16  = mul n8 n2
let n32  = mul n16 n2
let n64  = mul n32 n2
let n128 = mul n64 n2

let n3  = add n1 n2
let n5  = add n2 n3
let n6  = add n3 n3
let n7  = add n3 n4
let n9  = add n3 n6
let n10 = add n2 n8

(* list *)
let Nil       = fix (fun X n c -> n X)
let Cons x xs = fix (fun X n c -> c X x xs)
let null list = match list
    (fun _     -> True)
    (fun _ _ _ -> False)
let length list =
    let go = fix (fun go n list ->
            match list
                (fun _    -> n)
                (fun _ x xs -> go (succ n) xs)
        )
    in go n0 list
let reverse list =
    let go = fix (fun go list' list ->
            match list
                (fun _      -> list')
                (fun _ x xs -> go (Cons x list') xs)
        )
    in go Nil list
let append list list' =
    let go = fix (fun go list' list ->
            match list
                (fun _      -> list')
                (fun _ x xs -> go (Cons x list') xs)
        )
    in reverse (go (go Nil list) list')
let headMay list = match list
    (fun _      -> Nothing)
    (fun _ x xs -> Just x)
let tailMay list = match list
    (fun _      -> Nothing)
    (fun _ x xs -> Just xs)
let initMay list =
    let go = fix (fun go list' list ->
            match list
                (fun _      -> Nothing)
                (fun _ x xs ->
                    if (null xs)
                        (fun _ -> Just (reverse list'))
                        (fun _ -> go (Cons x list') xs)
                )
        )
    in go Nil list
let lastMay = fix (fun lastMay list ->
        match list
            (fun _      -> Nothing)
            (fun _ x xs ->
                if (null xs)
                    (fun _ -> Just x)
                    (fun _ -> lastMay xs)
            )
    )
let head alt list = fromMaybe alt (headMay list)
let tail alt list = fromMaybe alt (tailMay list)
let init alt list = fromMaybe alt (initMay list)
let last alt list = fromMaybe alt (lastMay list)
let atMay = fix (fun atMay list n ->
        match list
            (fun _      -> Nothing)
            (fun _ x xs ->
                match n
                    (fun _    -> Just x)
                    (fun _ n' -> atMay xs n')
            )
    )
let at alt list n = fromMaybe alt (atMay list n)
let take n list =
    let go = fix (fun go list' n list ->
            match list
                (fun _      -> reverse list')
                (fun _ x xs ->
                    match n
                        (fun _    -> reverse list')
                        (fun _ n' -> go (Cons x list') n' xs)
                    )
        )
    in go Nil n list
let drop = fix (fun drop n list ->
        match list
            (fun _      -> list)
            (fun _ x xs ->
                match n
                    (fun _    -> list)
                    (fun _ n' -> drop n' xs)
            )
    )
let map f list =
    let go = fix (fun go list' list ->
            match list
                (fun _      -> reverse list')
                (fun _ x xs -> go (Cons (f x) list') xs)
        )
    in go Nil list
let filter f list =
    let go = fix (fun go list' list ->
            match list
                (fun _      -> reverse list')
                (fun _ x xs -> if (f x)
                    (fun _ -> go (Cons x list') xs)
                    (fun _ -> go list' xs)
                )
        )
    in go Nil list
let foldl f x list =
    let go = fix (fun go acc list ->
            match list
                (fun _      -> acc)
                (fun _ x xs -> go (f acc x) xs)
        )
    in go x list
let foldr f x list = foldl (flip f) x (reverse list)
let concat lists = foldr append Nil lists
let sum list     = foldl add n0 list
let product list = foldl mul n1 list
let maximum list = foldl max n0 list
let minimum list = foldl min (head n0 list) list
let singleton x = Cons x Nil
let replicate n x =
    let go = fix (fun go n xs ->
            match n
                (fun _    -> xs)
                (fun _ n' -> go n' (Cons x xs))
        )
    in go n Nil

(* character *)
let eqChar c d = (c d) True False
let succChar c = Succ c
let predChar c = let n255 = mul (mul (succ n2) (succ n4)) (succ n16) in itr n255 succChar c

let charNULL = let n137 = succ (add n8 n128) in itr n137 succChar w
let chr n = itr n succChar charNULL
let ord c =
    let go = fix (fun go n c ->
            if (eqChar c charNULL)
                (fun _ -> n)
                (fun _ -> go (succ n) (predChar c))
        )
    in go n0 c

let charLF  = chr n10
let char'0' = let n48 = add n16 n32 in chr n48
let char'1' = succChar char'0'
let char'2' = succChar char'1'
let char'3' = succChar char'2'
let char'4' = succChar char'3'
let char'5' = succChar char'4'
let char'6' = succChar char'5'
let char'7' = succChar char'6'
let char'8' = succChar char'7'
let char'9' = succChar char'8'
let char'A' = let n65 = succ n64 in chr n65
let char'B' = succChar char'A'
let char'C' = succChar char'B'
let char'D' = succChar char'C'
let char'E' = succChar char'D'
let char'F' = succChar char'E'
let char'G' = succChar char'F'
let char'H' = succChar char'G'
let char'I' = succChar char'H'
let char'J' = succChar char'I'
let char'K' = succChar char'J'
let char'L' = succChar char'K'
let char'M' = succChar char'L'
let char'N' = succChar char'M'
let char'O' = succChar char'N'
let char'P' = succChar char'O'
let char'Q' = succChar char'P'
let char'R' = succChar char'Q'
let char'S' = succChar char'R'
let char'T' = succChar char'S'
let char'U' = succChar char'T'
let char'V' = succChar char'U'
let char'W' = succChar char'V'
let char'X' = succChar char'W'
let char'Y' = succChar char'X'
let char'Z' = succChar char'Y'
let char'a' = let n97 = succ (add n32 n64) in chr n97
let char'b' = succChar char'a'
let char'c' = succChar char'b'
let char'd' = succChar char'c'
let char'e' = succChar char'd'
let char'f' = succChar char'e'
let char'g' = succChar char'f'
let char'h' = succChar char'g'
let char'i' = succChar char'h'
let char'j' = succChar char'i'
let char'k' = succChar char'j'
let char'l' = succChar char'k'
let char'm' = succChar char'l'
let char'n' = succChar char'm'
let char'o' = succChar char'n'
let char'p' = succChar char'o'
let char'q' = succChar char'p'
let char'r' = succChar char'q'
let char's' = succChar char'r'
let char't' = succChar char's'
let char'u' = succChar char't'
let char'v' = succChar char'u'
let char'w' = succChar char'v'
let char'x' = succChar char'w'
let char'y' = succChar char'x'
let char'z' = succChar char'y'

let readDigitMay c =
    let out = predChar char'0' in
    let go = fix (fun go n c ->
            if (eqChar c out)
                (fun _ -> Nothing)
                (fun _ ->
                    if (eqChar c char'9')
                        (fun _ -> Just n)
                        (fun _ -> go (pred n) (succChar c))
                )
        )
    in go n9 c

let readDigit alt c = fromMaybe alt (readDigitMay c)

(* string (list of characters) *)
let show n =
    let go = fix (fun go str n ->
            let qr = divmod n n10 in
            let c = itr (snd qr) succChar char'0' in
            match (fst qr)
                (fun _   -> Cons c str)
                (fun q _ -> go (Cons c str) q)
        )
    in go Nil n
let readMay str =
    let go = fix (fun go n str ->
            match str
                (fun _      -> Just n)
                (fun _ c cs ->
                    match (readDigitMay c)
                        (fun _   -> Nothing)
                        (fun _ m -> go (add (mul n n10) m) cs)
                )
        )
    in go n0 str
let read alt str = fromMaybe alt (readMay str)

(* IO *)
let putChar c    = let _ = Out c in Unit
let getCharMay _ = let c = In (const (fun x y -> y)) in (c c) (Just c) Nothing
let getChar alt  = match (getCharMay Unit)
    (fun _   -> alt)
    (fun _ c -> c)

let putStr = fix (fun putStr str ->
        match str
            (fun _      -> Unit)
            (fun _ c cs -> let _ = putChar c in putStr cs)
    )
let putStrLn = fix (fun putStrLn str ->
        match str
            (fun _      -> putChar charLF)
            (fun _ c cs -> let _ = putChar c in putStrLn cs)
    )
let print n = putStrLn (show n)

let getContents _ =
    let go = fix (fun go cs ->
            match (getCharMay Unit)
                (fun _   -> reverse cs)
                (fun _ c -> go (Cons c cs))
        )
    in go Nil
let getLine _ =
    let go = fix (fun go cs ->
            match (getCharMay Unit)
                (fun _   -> reverse cs)
                (fun _ c -> if (eqChar c charLF)
                    (fun _ -> reverse cs)
                    (fun _ -> go (Cons c cs))
                )
        )
    in go Nil
let readLine alt = read alt (getLine Unit)