A compiler for a Lisp like calculator language which compiles to JavaScript from scratch

CalcCompiler.hs

{-# LANGUAGE LambdaCase #-}

module CalcCompiler where

import Data.Monoid (Monoid,mempty)
import Control.Applicative (Applicative, pure, (<$>), (<*>), Alternative, empty, (<|>))
import Control.Arrow (first)
import qualified Data.Map as M

------------
--  Model
------------

type Name  = String
type Error = String

data Fun = Fun [Name] Expr deriving (Show)

data Expr = ATOM Atom
          | LAMBDA Fun
          | LIST [Expr] deriving (Show)

data Atom = Int Int
          | Symbol  Name deriving (Show)


------------------------
-- Parser Combinators
------------------------

data ParseError = ParseError ParseString String

data ParseString = ParseString String (Int, Int) String

data Parser a = Parser (ParseString -> Either ParseError (a, ParseString))

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 p2) <*> (Parser p1) =
    Parser
      (\str -> do
        (x, rest)  <- p1 str
        (f, rest') <- p2 rest
        return (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
  return = pure
  (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 ++ "."]

readCharacter :: (Char -> Bool) -> Parser Char
readCharacter test =
  Parser (\pstr ->
    case pstr of
      ps@(ParseString name (row, col) str) ->
        case str of
          []     -> throwErr ps "Cannot read character of empty string"
          (c:cs) -> if test c
                    then Right (c, ParseString name (row, col+1) cs)
                    else throwErr ps $ "Unexpected character " ++ [c])



oneOf :: String -> Parser Char
oneOf chars =
  Parser (\pstr ->
    case pstr of
      ps@(ParseString name (row, col) str) ->
        case str of
          []     -> throwErr ps "Cannot read character of empty string"
          (c:cs) -> if c `elem` chars
                    then Right (c, ParseString name (row, col+1) 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 = mapM char

many :: Parser a -> Parser [a]
many parser = go []
  where go cs = (parser >>= \c -> go (c:cs)) <|> return (reverse cs)

many1 :: Parser a -> Parser [a]
many1 parser = do
  frst <- parser
  more <- many parser
  return (frst:more)

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 = do
  _      <- spaces
  result <- parser
  _      <- spaces
  return result


parens :: Parser a -> Parser a
parens parser = do
  _      <- withSpaces $ char '('
  result <- withSpaces parser
  _      <- spaces >> char ')'
  return result

sepBy :: Parser a -> Parser b -> Parser [b]
sepBy sep parser = do
  frst <- optional parser
  rest <- many (sep >> parser)
  return $ maybe rest (:rest) frst

-----------------
-- Lisp Parser
-----------------

parseExpr :: Parser Expr
parseExpr = fmap LAMBDA parseLambda <|> fmap ATOM parseAtom <|> fmap LIST parseList

parseLambda :: Parser Fun
parseLambda = parens $ do
  _ <- string "lambda"
  l <- withSpaces $ parens $ spaces >> sepBy spaces1 parseName
  e <- withSpaces parseExpr
  return $ Fun l e


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"
  return (c:cs)


parseInt :: Parser Atom
parseInt = do
  sign <- optional $ char '-'
  num  <- many1 $ oneOf "0123456789"
  let result = read $ maybe num (:num) sign
  return $ Int result

parseList :: Parser [Expr]
parseList = parens $ sepBy spaces1 parseExpr

runExprParser :: String -> String -> Either String Expr
runExprParser name str =
  case runParser name str (withSpaces parseExpr) of
    Left (ParseError _ errMsg) -> Left errMsg
    Right (result, _) -> Right result

----------------------
-- Code Generation
----------------------

type TransError = String

type JSBinOp = String

data JSExpr = JSInt Int
            | JSSymbol Name
            | JSReturn JSExpr
            | JSLambda [Name] JSExpr
            | JSBinOp JSBinOp JSExpr JSExpr
            | JSAssign Name JSExpr
            | JSFunCall JSExpr [JSExpr] deriving (Show)


seperateBy :: String -> [String] -> String
seperateBy _   [] = []
seperateBy str (x:xs) = concat $ x : fmap (str++) xs


indent :: Int -> String -> String
indent tabs e = concat (replicate tabs "  ") ++ e

generateJSOp :: JSBinOp -> String
generateJSOp op = op

generateJS :: Bool -> Int -> JSExpr -> String
generateJS doindent tabs = \case
  JSInt    i     -> show i
  JSSymbol name  -> name
  JSLambda vars expr -> (if doindent then indent tabs else id) $ unlines ["function(" ++ seperateBy ", " vars ++ ") {", indent (tabs+1) $ generateJS False (tabs+1) expr] ++ indent tabs "}"
  JSBinOp  op e1 e2  -> "(" ++ generateJS False tabs e1 ++ " " ++ generateJSOp op ++ " " ++ generateJS False tabs e2 ++ ")"
  JSAssign var expr  -> var ++ " = " ++ generateJS False tabs expr ++ ";"
  JSFunCall f exprs  -> "(" ++ generateJS False tabs f ++ ")(" ++ seperateBy ", " (fmap (generateJS False tabs) exprs) ++ ")"
  JSReturn expr      -> (if doindent then indent tabs else id) $ "return " ++ generateJS False tabs expr ++ ";"


------------------
-- Translation
------------------


type Builtin  = [Expr] -> Either TransError JSExpr
type Builtins = M.Map Name Builtin

builtins :: Builtins
builtins =
  M.fromList
    [("let", emitLet)
    ,("add", emitBinOp "add" "+")
    ,("mul", emitBinOp "mul" "*")
    ,("sub", emitBinOp "sub" "-")
    ,("div", emitBinOp "div" "/")
    ,("print", emitPrint)]

emitLet :: [Expr] -> Either TransError JSExpr
emitLet [LIST binds, body] = do
  (vars, vals) <- split binds
  vars' <- mapM fromSymbol vars
  JSFunCall . JSLambda vars' <$> translateToJS body <*> mapM translateToJS vals
emitLet xs = Left $ "Syntax error. let expected 2 arguments, got: " ++ show (length xs)

emitPrint :: [Expr] -> Either TransError JSExpr
emitPrint [expr] = JSFunCall (JSSymbol "console.log") . (:[]) <$> translateToJS expr
emitPrint xs     = Left $ "Syntax error. print expected 1 arguments, got: " ++ show (length xs)


emitBinOp :: Name -> Name -> [Expr] -> Either TransError JSExpr
emitBinOp _ _ [x]          = translateToJS x
emitBinOp _ f [x, y]       = JSBinOp f <$> translateToJS x <*> translateToJS y
emitBinOp n f (x:xs@(_:_)) = JSBinOp f <$> translateToJS x <*> translateList (ATOM (Symbol n) : xs)
emitBinOp _ f []           = Left $ "Syntax error. " ++ f ++ " expected at least 1 argument, got: 0"

---------------

fromSymbol :: Expr -> Either String Name
fromSymbol (ATOM (Symbol s)) = Right s
fromSymbol _ = Left "cannot bind value to non symbol type"

split :: [a] -> Either Error ([a],[a])
split [] = Right ([],[])
split [_] = Left "uneven amount of parameters for let"
split (x:y:xs) =
  case split xs of
    Right (l1,l2) -> Right (x:l1, y:l2)
    Left err -> Left err


translateToJS :: Expr -> Either TransError JSExpr
translateToJS = \case
  ATOM (Symbol s) -> pure $ JSSymbol s
  ATOM (Int i)    -> pure $ JSInt i
  LAMBDA (Fun vars body) -> JSLambda vars . JSReturn <$> translateToJS body
  LIST xs -> translateList xs

translateList :: [Expr] -> Either TransError JSExpr
translateList = \case
  []     -> Left "translating empty list"
  (g:xs) ->
    (fromSymbol g >>= maybeToEither "" . flip M.lookup builtins >>= \f -> f xs)
    <|> JSFunCall <$> translateToJS g <*> mapM translateToJS xs

instance Monoid a => Alternative (Either a) where
  empty = Left mempty
  a <|> b = case a of
              Left _  -> b
              Right x -> Right x

maybeToEither :: a -> Maybe b -> Either a b
maybeToEither e Nothing  = Left e
maybeToEither _ (Just x) = Right x

----------
-- Glue
----------

fromEither :: Either a a -> a
fromEither y = case y of { Right x -> x; Left x -> x; }

printCompile :: String -> IO ()
printCompile = putStrLn . fromEither . compile

compile :: String -> Either Error String
compile str = generateJS False 0 <$> (translateToJS =<< runExprParser "test" str)