A transpiler from a simple S-expression language to JS
{-# LANGUAGE LambdaCase #-} | |
-- http://gilmi.xyz/post/2016/10/14/lisp-to-js | |
module Main where | |
import Control.Applicative (Alternative, empty, (<|>)) | |
import Control.Arrow (first, (***)) | |
import Data.Bool (bool) | |
import Data.List (intercalate) | |
import System.Environment (getArgs) | |
------------ | |
-- Model | |
------------ | |
type Name = String | |
data Expr | |
= ATOM Atom | |
| LIST [Expr] | |
deriving (Eq, Read, Show) | |
data Atom | |
= Int Int | |
| Symbol Name | |
deriving (Eq, Read, Show) | |
------------ | |
-- Parser | |
------------ | |
newtype Parser a | |
= Parser (ParseString -> Either ParseError (a, ParseString)) | |
data ParseString | |
= ParseString Name (Int, Int) String | |
data ParseError | |
= ParseError ParseString Error | |
type Error = String | |
instance Functor Parser where | |
fmap f (Parser parser) = | |
Parser (\str -> first f <$> parser str) | |
instance Applicative Parser where | |
pure x = Parser (\str -> Right (x, str)) | |
(Parser p1) <*> (Parser p2) = | |
Parser $ | |
\str -> do | |
(f, rest) <- p1 str | |
(x, rest') <- p2 rest | |
pure (f x, rest') | |
instance Alternative Parser where | |
empty = Parser (`throwErr` "Failed consuming input") | |
(Parser p1) <|> (Parser p2) = | |
Parser $ | |
\pstr -> case p1 pstr of | |
Right result -> Right result | |
Left _ -> p2 pstr | |
instance Monad Parser where | |
(Parser p1) >>= f = | |
Parser $ | |
\str -> case p1 str of | |
Left err -> Left err | |
Right (rs, rest) -> | |
case f rs of | |
Parser parser -> parser rest | |
runParser :: String -> String -> Parser a -> Either ParseError (a, ParseString) | |
runParser name str (Parser parser) = parser $ ParseString name (0,0) str | |
throwErr :: ParseString -> String -> Either ParseError a | |
throwErr ps@(ParseString name (row,col) _) errMsg = | |
Left $ ParseError ps $ unlines | |
[ "*** " ++ name ++ ": " ++ errMsg | |
, "* On row " ++ show row ++ ", column " ++ show col ++ "." | |
] | |
oneOf :: String -> Parser Char | |
oneOf chars = | |
Parser $ \case | |
ps@(ParseString name (row, col) str) -> | |
case str of | |
[] -> throwErr ps "Cannot read character of empty string" | |
(c:cs) -> | |
if c `elem` chars | |
then | |
let | |
(row', col') | |
| c == '\n' = (row + 1, 0) | |
| otherwise = (row, col + 1) | |
in | |
Right (c, ParseString name (row', col') cs) | |
else | |
throwErr ps $ unlines ["Unexpected character " ++ [c], "Expecting one of: " ++ show chars] | |
char :: Char -> Parser Char | |
char c = oneOf [c] | |
string :: String -> Parser String | |
string = traverse char | |
many :: Parser a -> Parser [a] | |
many parser = go [] | |
where go cs = (parser >>= \c -> go (c:cs)) <|> pure (reverse cs) | |
many1 :: Parser a -> Parser [a] | |
many1 parser = | |
(:) <$> parser <*> many parser | |
optional :: Parser a -> Parser (Maybe a) | |
optional (Parser parser) = | |
Parser $ | |
\pstr -> case parser pstr of | |
Left _ -> Right (Nothing, pstr) | |
Right (x, rest) -> Right (Just x, rest) | |
space :: Parser Char | |
space = oneOf " \n" | |
spaces :: Parser String | |
spaces = many space | |
spaces1 :: Parser String | |
spaces1 = many1 space | |
withSpaces :: Parser a -> Parser a | |
withSpaces parser = | |
spaces *> parser <* spaces | |
parens :: Parser a -> Parser a | |
parens parser = | |
(withSpaces $ char '(') | |
*> withSpaces parser | |
<* (spaces *> char ')') | |
sepBy :: Parser a -> Parser b -> Parser [b] | |
sepBy sep parser = do | |
frst <- optional parser | |
rest <- many (sep *> parser) | |
pure $ maybe rest (:rest) frst | |
----------------- | |
-- Lisp Parser | |
----------------- | |
parseExpr :: Parser Expr | |
parseExpr = | |
fmap ATOM parseAtom | |
<|> fmap LIST parseList | |
parseAtom :: Parser Atom | |
parseAtom = parseSymbol <|> parseInt | |
parseSymbol :: Parser Atom | |
parseSymbol = fmap Symbol parseName | |
parseName :: Parser Name | |
parseName = do | |
c <- oneOf ['a'..'z'] | |
cs <- many $ oneOf $ ['a'..'z'] ++ "0123456789" | |
pure (c:cs) | |
parseInt :: Parser Atom | |
parseInt = do | |
sign <- optional $ char '-' | |
num <- many1 $ oneOf "0123456789" | |
let result = read $ maybe num (:num) sign | |
pure $ Int result | |
parseList :: Parser [Expr] | |
parseList = parens $ sepBy spaces1 parseExpr | |
runExprParser :: String -> String -> Either Error Expr | |
runExprParser name str = | |
case runParser name str (withSpaces parseExpr) of | |
Left (ParseError _ errMsg) -> Left errMsg | |
Right (result, _) -> Right result | |
------------------ | |
-- Pretty Print | |
------------------ | |
printExpr :: Expr -> String | |
printExpr = printExpr' False 0 | |
printAtom :: Atom -> String | |
printAtom = \case | |
Symbol s -> s | |
Int i -> show i | |
printExpr' :: Bool -> Int -> Expr -> String | |
printExpr' doindent level = \case | |
ATOM a -> indent (bool 0 level doindent) (printAtom a) | |
LIST (e:es) -> | |
indent (bool 0 level doindent) $ | |
concat | |
[ "(" | |
, printExpr' False (level + 1) e | |
, bool "\n" "" (null es) | |
, intercalate "\n" $ map (printExpr' True (level + 1)) es | |
, ")" | |
] | |
indent :: Int -> String -> String | |
indent tabs e = concat (replicate tabs " ") ++ e | |
---------------------- | |
-- Code Generation | |
---------------------- | |
type JSBinOp = String | |
data JSExpr | |
= JSInt Int | |
| JSSymbol Name | |
| JSBinOp JSBinOp JSExpr JSExpr | |
| JSReturn JSExpr | |
| JSLambda [Name] JSExpr | |
| JSFunCall JSExpr [JSExpr] | |
deriving (Eq, Show, Read) | |
printJSOp :: JSBinOp -> String | |
printJSOp op = op | |
printJSExpr :: Bool -> Int -> JSExpr -> String | |
printJSExpr doindent tabs = \case | |
JSInt i -> show i | |
JSSymbol name -> name | |
JSLambda vars expr -> (if doindent then indent tabs else id) $ unlines | |
["function(" ++ intercalate ", " vars ++ ") {" | |
,indent (tabs+1) $ printJSExpr False (tabs+1) expr | |
] ++ indent tabs "}" | |
JSBinOp op e1 e2 -> "(" ++ printJSExpr False tabs e1 ++ " " ++ printJSOp op ++ " " ++ printJSExpr False tabs e2 ++ ")" | |
JSFunCall f exprs -> "(" ++ printJSExpr False tabs f ++ ")(" ++ intercalate ", " (fmap (printJSExpr False tabs) exprs) ++ ")" | |
JSReturn expr -> (if doindent then indent tabs else id) $ "return " ++ printJSExpr False tabs expr ++ ";" | |
------------------ | |
-- Translation | |
------------------ | |
type TransError = String | |
translateToJS :: Expr -> Either TransError JSExpr | |
translateToJS = \case | |
ATOM (Symbol s) -> pure $ JSSymbol s | |
ATOM (Int i) -> pure $ JSInt i | |
LIST xs -> translateList xs | |
translateList :: [Expr] -> Either TransError JSExpr | |
translateList = \case | |
[] -> Left "translating empty list" | |
ATOM (Symbol s):xs | |
| Just f <- lookup s builtins -> | |
f xs | |
f:xs -> | |
JSFunCall <$> translateToJS f <*> traverse translateToJS xs | |
--------------- | |
type Builtin = [Expr] -> Either TransError JSExpr | |
type Builtins = [(Name, Builtin)] | |
builtins :: Builtins | |
builtins = | |
[("lambda", transLambda) | |
,("let", transLet) | |
,("add", transBinOp "add" "+") | |
,("mul", transBinOp "mul" "*") | |
,("sub", transBinOp "sub" "-") | |
,("div", transBinOp "div" "/") | |
,("print", transPrint) | |
] | |
transLambda :: [Expr] -> Either TransError JSExpr | |
transLambda = \case | |
[LIST vars, body] -> do | |
vars' <- traverse fromSymbol vars | |
JSLambda vars' <$> (JSReturn <$> translateToJS body) | |
vars -> | |
Left $ unlines | |
["Syntax error: unexpected arguments for lambda." | |
,"expecting 2 arguments, the first is the list of vars and the second is the body of the lambda." | |
,"In expression: " ++ show (LIST $ ATOM (Symbol "lambda") : vars) | |
] | |
fromSymbol :: Expr -> Either String Name | |
fromSymbol (ATOM (Symbol s)) = Right s | |
fromSymbol e = Left $ "cannot bind value to non symbol type: " ++ show e | |
transLet :: [Expr] -> Either TransError JSExpr | |
transLet = \case | |
[LIST binds, body] -> do | |
(vars, vals) <- letParams binds | |
vars' <- traverse fromSymbol vars | |
JSFunCall . JSLambda vars' <$> (JSReturn <$> translateToJS body) <*> traverse translateToJS vals | |
where | |
letParams :: [Expr] -> Either Error ([Expr],[Expr]) | |
letParams = \case | |
[] -> pure ([],[]) | |
LIST [x,y] : rest -> ((x:) *** (y:)) <$> letParams rest | |
x : _ -> Left ("Unexpected argument in let list in expression:\n" ++ printExpr x) | |
vars -> | |
Left $ unlines | |
["Syntax error: unexpected arguments for let." | |
,"expecting 2 arguments, the first is the list of var/val pairs and the second is the let body." | |
,"In expression:\n" ++ printExpr (LIST $ ATOM (Symbol "let") : vars) | |
] | |
transBinOp :: Name -> Name -> [Expr] -> Either TransError JSExpr | |
transBinOp f _ [] = Left $ "Syntax error: '" ++ f ++ "' expected at least 1 argument, got: 0" | |
transBinOp _ _ [x] = translateToJS x | |
transBinOp _ f list = foldl1 (JSBinOp f) <$> traverse translateToJS list | |
transPrint :: [Expr] -> Either TransError JSExpr | |
transPrint [expr] = JSFunCall (JSSymbol "console.log") . (:[]) <$> translateToJS expr | |
transPrint xs = Left $ "Syntax error. print expected 1 arguments, got: " ++ show (length xs) | |
---------- | |
-- Glue | |
---------- | |
main :: IO () | |
main = getArgs >>= \case | |
[file] -> | |
printCompile =<< readFile file | |
["--e",file] -> | |
either putStrLn print . runExprParser "--e" =<< readFile file | |
["--pp",file] -> | |
either putStrLn (putStrLn . printExpr) . runExprParser "--pp" =<< readFile file | |
["--jse",file] -> | |
either print (either putStrLn print . translateToJS) . runExprParser "--jse" =<< readFile file | |
["--ppc",file] -> | |
either putStrLn (either putStrLn putStrLn) . fmap (compile . printExpr) . runExprParser "--ppc" =<< readFile file | |
_ -> | |
putStrLn $ unlines | |
["Usage: runghc Main.hs [ --e, --pp, --jse, --ppc ] <filename>" | |
,"--e print the Expr" | |
,"--pp pretty print Expr" | |
,"--jse print the JSExpr" | |
,"--ppc pretty print Expr and then compile" | |
] | |
printCompile :: String -> IO () | |
printCompile = either putStrLn putStrLn . compile | |
compile :: String -> Either Error String | |
compile str = printJSExpr False 0 <$> (translateToJS =<< runExprParser "compile" str) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
This comment has been minimized.
A few sample programs: