AST.hs

{-# LANGUAGE DeriveFunctor #-}

module AST where

data AST var
    = Constant String
    | Variable var String
    | (:->)   [var] (AST var)
    | Call    (AST var) [AST var]
    | If      (AST var) (AST var) (AST var)
    | Let      var      (AST var) (AST var)
    | Halt

    deriving (Show, Functor)

compile.sh

#!/usr/bin/bash

runhaskell Tokenize.hs $1.l
echo -e "#!/usr/bin/node\n" > header
cat header runtime.js $1.l.js > $1
rm header $1.l.js
chmod +x $1

Export2JS.hs

module Export2JS where

import AST

import Data.List (intercalate)
import Data.Maybe (fromMaybe)

export     = toJS . adaptNames
adaptNames = rename . renameOps
rename     = fmap ("_" ++)

renameOps :: AST String -> AST String
renameOps = fmap (>>= \char -> fromMaybe [char] (lookup char table))
  where
    table = zip "!@$%^&*[]-+.\\|/<>=" $
        words $ "bang doge swag percent powah and mult open "
             ++ "close minus plus dot slash stick backslash lt gt eq"

toJS :: AST String -> String
toJS ast = case ast of
    Constant x    -> x
    Variable v x  -> v
    args :-> body -> "function (" ++ intercalate ", " args 
                  ++ ") { return " ++ toJS body ++ " }"
    Call f xs     -> toJS f ++ "(" ++ intercalate ", " (map toJS xs) ++ ")"
    If b y n      -> "(" ++ toJS b ++ "? " ++ toJS y ++ ": " ++ toJS n ++ ")"
    Let x val c   -> "var " ++ x ++ " = " ++ toJS val ++ ";\n" ++ toJS c
    Halt          -> "halt"

thunk x = "function () { return " ++ toJS x ++ " }"

Parser.hs

module Parser where

import AST
import Control.Monad (void, guard)

import Text.ParserCombinators.Parsec as P

import Debug.Trace

{-
    PROGRAM  ::= APP `sepBy1` ","

    APP      ::= POINT [POINT]

    POINT    ::= name | const | IF-EXPR | LET-EXPR | LAMBDA

    LET-EXPR ::= "let" NAME [NAME] "=" PROGRAM ";" PROGRAM

    IF-EXPR  ::= "if" PROGRAM "?" PROGRAM "else" PROGRAM

    LAMBDA   ::= "->" [NAME] ":" PROGRAM

-}

program' = spaces' >> program <* eof

program :: Parser (AST String)
program = do
    things <- app `sepBy1` comma

    let 
        attach l r = case l of
            Call f xs -> Call f (xs ++ [r])
            other     -> Call other [r]

    return (foldr1 attach things)

app = do
    f : xs <- many1 atomic

    return $ 
        if null xs 
        then f 
        else Call f xs

atomic = number 
     <|> stringLiteral 
     <|> lambda 
     <|> if_expr 
     <|> let_expr
     <|> name 
     <|> try (lbr *> program <* rbr)

number = tokenized $ Constant <$> many1 digit

stringLiteral = tokenized $ Constant <$> do
    init    <- oneOf "\"'`"
    content <- anyChar `manyTill` char init

    return ([init] ++ content ++ [init])

reserved = words "if ? else let in ; , = -> : ( )"

[if_, then_, else_, let_, in_, inside, comma, equals, fun, arrow, lbr, rbr] 
    = map tok reserved

name = ("name" ?=) . tokenized . try $ do
    notFollowedBy $ foldl1 (<|>) $ map tok reserved

    first <-       letter <|> operator
    rest  <- many (letter <|> operator <|> digit)

    let n = first : rest

    guard (n `notElem` reserved)

    p <- getPosition

    return (Variable n (show p))

operator = oneOf "!@$%^&*[]-+.\\|/<>="

if_expr = "if-expression" ?= do
    bool <- try (if_ *> program <* then_)
    yes  <- program <* else_
    no   <- program

    return (If bool yes no)


let_expr = "let-expression" ?= do
    let_
    label <- name
    args  <- name `manyTill` equals
    body <- program
    inside
    context <- program

    let value = if null args then body else map onlyName args :-> body

    return (Let (onlyName label) value context)

lambda :: Parser (AST String)
lambda = "lambda-function" ?= do
    try fun
    args <- many name <* arrow
    body <- program

    return (map onlyName args :-> body)

onlyName (Variable n _) = n

tokenized p = p <* spaces'

tok = try . tokenized . string

spaces' = many (space <|> newline <|> comment)

comment = try (char '#' <* anyChar `manyTill` newline)

(?=) = flip (<?>)

file name = do
    text <- readFile name
    return (parse program' name text)

runtime.js

var keypress = require('keypress');

keypress(process.stdin)

_go = function(f) { f() }

_plus = function() {
    var result = arguments[0]

    for (var i = 1; i < arguments.length; i++)
        result += arguments[i]

    return result
}

_equal = function (a, b) {
    return a == b
}

_split = function (string, cons, nil) {
    if (string.length > 0) {
        cons(string[0], string.slice(1))
    } else {
        nil()
    }
}

_putchar = function(c, next) {
    process.stdout.write(c)
    return next()
}

_getchar = function(consume) {
    process.stdin.once('keypress', function (c) {
        consume(c)
    })
}

var l = console.log
var s = JSON.stringify
var _halt = function() { process.exit(0) }

test.l

# ; read \n-terminated line from input
let getline return = 
    getchar -> c:
    if equal c "\n"?
        return ""
    else
        getline -> s:
        return (+ c s) ;

# ; write \n-terminated line to the output
let putline string next =
    split string
        (-> c s:
            putchar c ->:
            putline s ->:
            go next)
        (-> :
            go next);

# ; simulate amnesia
let echo = ->:
    putline "What is your name, again? " ->:
    getline -> s:
    if s? 
        putline (+ "Hello, " s "!\n\n") ->:
        go echo
    else
        putline "Bye!\n",
        halt;

go echo

Tokenize.hs

import Parser
import Export2JS

import System.Environment

import Control.Monad (forM)

main = do
    inputs <- getArgs

    forM inputs $ \input -> do
        result <- file input

        case result of
            Right ast -> do
                let output = input ++ ".js"
                output `writeFile` export ast

            Left err -> do
                print err