applicative parser built with Tubes

output.txt

Code: (+ 5 5)
Free (AApp (Free (ASymbol "+")) [Free (ANumber 5),Free (ANumber 5)])
---
Code: (lambda (x) (* x x))
Free (ALambda [Free (ASymbol "x")] (Free (AApp (Free (ASymbol "*")) [Free (ASymbol "x"),Free (ASymbol "x")])))
---
Code: ((\ (x) (* x x)) 5 (+ 10 2))
Free (AApp (Free (ALambda [Free (ASymbol "x")] (Free (AApp (Free (ASymbol "*")) [Free (ASymbol "x"),Free (ASymbol "x")])))) [Free (ANumber 5),Free (AApp (Free (ASymbol "+")) [Free (ANumber 10),Free (ANumber 2)])])
---
Code: '(1 2 3)
Free (AList [Free (ASymbol "1"),Free (ASymbol "2"),Free (ASymbol "3")])
---
Code: (* 2 (car '(1 2 3)))
Free (AApp (Free (ASymbol "*")) [Free (ANumber 2),Free (AApp (Free (ASymbol "car")) [Free (AList [Free (ASymbol "1"),Free (ASymbol "2"),Free (ASymbol "3")])])])
---
Code: (print "Hello, World!")
Free (AApp (Free (ASymbol "print")) [Free (AString "Hello, World!")])
---

tubes-parse.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}

import Prelude hiding (map, take, filter)
import qualified Prelude as P
import Control.Monad (forever, forM, forM_)
import Control.Monad.Trans
import Tubes
import Control.Applicative hiding (many, optional)
import Data.Monoid ((<>))
import Data.Char (isDigit, isPrint)
import Control.Monad.Free
import Data.Bool (bool)
import Control.Arrow ((***))
import Data.Either (isRight)

import Data.List (intercalate, replicate, null)

-- |
-- A 'Parser' transforms a stream of tokens into a stream of possible parsed
-- values along with unused input.
--
-- Tokens of type @s@ are potentially parsed into structures of type @t@.
newtype Parser m s t = P {
    runParser :: Source m s -> Source m (t, Source m s)
}

instance Monad m => Functor (Parser m s) where
    fmap f (P srcFn) = P $ \src -> fmap (\(a,b) -> (f a, b)) $ srcFn src

instance Monad m => Applicative (Parser m s) where
    pure x = P $ \inp -> Source $ yield (x, inp)
    (P p1) <*> (P p2) = P $ \inp -> do
        (v1, ss1) <- p1 inp
        (v2, ss2) <- p2 ss1
        return (v1 v2, ss2)

instance Monad m => Alternative (Parser m s) where
    empty = P $ \inp -> empty
    (P p1) <|> (P p2) = P $ \inp -> (p1 inp) <|> (p2 inp)

-- * Fundamental parser combinators

(<++>) :: Applicative f => f [a] -> f [a] -> f [a]
a <++> b = (++) <$> a <*> b

(<:>) :: Applicative f => f a -> f [a] -> f [a]
a <:> b = (:) <$> a <*> b

optional :: (Alternative f, Monoid a) => f a -> f a
optional p = p <|> pure mempty

many :: (Alternative f, Monoid (g a), Applicative g) => f a -> f (g a)
many p = (\x xs -> (pure x) <> xs) <$> p <*> optional (many p)

sepBy1 :: (Alternative f, Monoid (g a), Applicative g)
       => f a -> f b -> f (g a)
sepBy1 p sep = (\x xs -> (pure x) <> xs) <$> p <*> many (id <$ sep <*> p)

sepBy :: (Alternative f, Monoid (g a), Applicative g)
      => f a -> f b -> f (g a)
sepBy p sep = sepBy1 p sep <|> (pure <$> p)

-- * More advanced parser combinators, and 'Char' based parsers

-- | Succeeds iff the incoming token is among those in the argument list.
oneOf :: (Monad m, Eq t) => [t] -> Parser m t t
oneOf these = P $ \inp -> Source $ do
    mv <- lift $ unyield $ sample inp
    case mv of
        Nothing -> halt
        Just (c, inp') -> if elem c these
            then yield (c, Source inp')
            else halt

-- | Succeeds iff the next token is equal to the specified character.
char :: Monad m => Char -> Parser m Char Char
char target = P $ \inp -> Source $ do
    mC <- lift $ unyield $ sample inp
    case mC of
        Nothing -> halt
        Just (c, inp') ->
            if c == target
                then yield (c, Source inp')
                else halt

-- | Succeeds iff the incoming token is a printable character.
printable :: Monad m => Parser m Char Char
printable = P $ \inp -> Source $ do
    mc <- lift $ unyield $ sample inp
    case mc of
        Nothing -> halt
        Just (c, inp') ->
            if isPrint c
                then yield (c, Source inp')
                else halt

-- | Succeeds if the incoming token is a numeric digit, and parses it as such.
digit :: Monad m=> Parser m Char Int
digit = P $ \inp -> Source $ do
    ms <- lift $ unyield $ sample inp
    case ms of
        Nothing -> halt
        Just (c, inp') -> if isDigit c
            then let d = read [c]
                 in  if d >= 0 && d <= 9
                         then yield (d, Source inp')
                         else halt
            else halt

-- | Succeeds iff the next tokens form the given string.
string :: Monad m => String -> Parser m Char String
string target = P $ \inp -> Source $ go target [] (sample inp) where
    go [] acc inp = yield (acc, Source inp)
    go (x:xs) acc inp = do
        mc <- lift $ unyield inp
        case mc of
            Nothing -> halt
            Just (c, inp') ->
                if c == x
                    then go xs (acc++[c]) inp'
                    else halt

-- * Programming language parsing utilities for 'Char' streams

num :: (Monad m) => Parser m Char String
num = many (oneOf "1234567890")

plus :: (Monad m) => Parser m Char String
plus = char '+' *> num

minus :: (Monad m) => Parser m Char String
minus = char '-' *> num

-- | Succeeds iff the tokens form an integer literal
integer :: Monad m => Parser m Char Int
integer = rd <$> (plus <|> minus <|> num)
    where rd = read :: String -> Int

-- | Succeeds iff the tokens form a double literal
double :: Monad m => Parser m Char Double
double = fmap rd $ num' <++> decimal <++> exponent where
    rd = read :: String -> Double
    num' = plus <|> minus <|> num
    decimal = optional $ char '.' <:> num
    exponent = optional $ oneOf "eE" <:> num

-- | Succeeds iff the token is a single whitespace character
space :: Monad m => Parser m Char Char
space = char ' ' <|> char '\t' <|> char '\n'

spaces :: Monad m => Parser m Char String
spaces = many space

-- | Succeeds iff the given sub-parser suceeds and is delimited by the
-- specified tokens.
delim :: Monad m => Char -> Char -> Parser m Char a -> Parser m Char a
delim start end p = id
    <$  char start
    <*  optional spaces
    <*> p
    <*  optional spaces
    <*  char end

-- | 'delim' specifically for parentheses
parens :: Monad m => Parser m Char a -> Parser m Char a
parens = delim '(' ')'

-- | 'delim' specifically for double quotes
quotes :: Monad m => Parser m Char a -> Parser m Char a
quotes = delim '"' '"'

-- | Succeeds iff the next tokens form a legal symbol
sym :: Monad m => Parser m Char String
sym = many $ letter <|> alphanum <|> (oneOf ".!@#$%^&*{}[]+-/\\")

letter :: Monad m => Parser m Char Char
letter = oneOf "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"

alphanum :: Monad m => Parser m Char Char
alphanum = letter <|> oneOf "1234567890"

-- | Our AST
data AST a
    = ANumber Double -- ^ Numeric literal
    | AString String -- ^ String literals
    | ASymbol String -- ^ barewords
    | AList [a]      -- ^ quoted things
    deriving (Show, Functor)

-- | Expression language
type Expr = Free AST

aNumber :: (MonadFree AST m) => Double -> m a
aNumber d = liftF $ ANumber d

aString :: (MonadFree AST m) => String -> m a
aString s = liftF $ AString s

aSymbol :: (MonadFree AST m) => String -> m a
aSymbol s = liftF $ ASymbol s

aList :: (MonadFree AST m) => [a] -> m a
aList items = liftF $ AList items

-- * Fundamental language parsers for each branch of the AST

parse_number :: Monad m => Parser m Char (Expr a)
parse_number = aNumber <$> double

parse_string :: Monad m => Parser m Char (Expr a)
parse_string = aString <$> (quotes (many printable))

parse_symbol :: Monad m => Parser m Char (Expr a)
parse_symbol = aSymbol <$> sym

parse_list :: Monad m => Parser m Char (Expr a)
parse_list = fmap Free $
    AList
    <$  optional (string "'")
    <*> parens (parse_expr `sepBy` spaces)

parse_expr :: Monad m => Parser m Char (Expr a)
parse_expr = parse_list
             <|> parse_symbol
             <|> parse_number
             <|> parse_string


-- | Attempts to parse a 'Foldable' stream of 'Char' tokens into an 'Expr'.

parse :: (Foldable f, Monad m)
      => f Char
      -> Source m (Expr a, Source m Char)
parse src = runParser parse_expr (Source (each src))


print_expr :: Expr a -> String
print_expr = print_expr' False 0

print_expr' :: Bool -> Int -> Expr a -> String
print_expr' doindent level expr = case expr of
    (Free (AList (e:es))) ->
        indent (bool 0 level doindent) $
        concat
        [ "("
        , print_expr' False (level + 1) e
        , bool "\n" "" (null es)
        , intercalate "\n" $ fmap (print_expr' True (level + 1)) es
        , ")"
        ]
    (Free (ANumber n)) -> indent (bool 0 level doindent) (print_atom n)
    (Free (AString s)) -> indent (bool 0 level doindent) (print_atom s)
    (Free (ASymbol s)) -> indent (bool 0 level doindent) (print_atom s)
    (Pure _) -> ""

print_atom n = show n

indent tabs e = concat (replicate tabs "  ") ++ e

-- JavaScript subset

type JSBinOp = String

data JSExpr
  = JSInt Double
  | 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
    ["(" ++ 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 ++ ";"

-- translate to javascript

type TransError = String

translateToJs :: Expr () -> Either TransError JSExpr
translateToJs expr = case expr of
    Free (ASymbol s) -> pure $ JSSymbol s
    Free (ANumber n) -> pure $ JSInt n
    Free (AList xs) -> translateList xs

translateList :: [Expr ()] -> Either TransError JSExpr
translateList items = case items of
    [] -> Left "translating empty list"
    (Free (ASymbol s)):xs
        | Just f <- lookup s builtins ->
          f xs
    f:xs ->
        JSFunCall <$> translateToJs f <*> traverse translateToJs xs

type Name = String
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 xs = case xs of
    [Free (AList 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."
                 ]

fromSymbol :: Expr () -> Either String Name
fromSymbol (Free (ASymbol s)) = Right s
fromSymbol e = Left $ "cannot bind value to non symbol type: " ++ show e

transLet :: [Expr ()] -> Either TransError JSExpr
transLet lst = case lst of
    [Free (AList binds), body] -> do
        (vars, vals) <- letParams binds
        vars' <- traverse fromSymbol vars
        JSFunCall . JSLambda vars' <$> (JSReturn
                                       <$> translateToJs body)
               <*> traverse translateToJs vals

    vars -> Left "Syntax error bruh"
    where
        letParams :: [Expr a] -> Either TransError ([Expr a], [Expr a])
        letParams things = case things of
            [] -> pure ([], [])
            Free (AList [x,y]): rest -> ((x:) *** (y:)) <$> letParams rest
            x : _ -> Left ("Unexpected argument in let list expression")

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 argument."

code :: [String]
{-
code = [ "5.5"
       , "(+ 5 5)"
       , "(lambda (x) (* x x))"
       , "((lambda (x) (* x x)) 5.5 (+ 10 2))"
       , "'(1     2 3)"
       , "(* 2 (car '(1 2 3)))"
--       , "(print \"Hello, World!\")"
       , "(map-and-filter m-fun filter-fun my-list)"
       , "(lambda (x y) (+ x y))"
       , "(let ((x 5) (y 2)) (+ x y))"
       , "(print 5)"
       ]
-}

prog1 = unlines
    ["(let "
    ,"  ((compose "
    ,"    (lambda (f g) "
    ,"      (lambda (x) (f (g x))))) "
    ,"  (double "
    ,"    (lambda (x) (mul x x))) "
    ,"  (add1 "
    ,"    (lambda (x) (add x 1)))) "
    ,"  (print ((compose double add1) 5)))"
    ]

code = [prog1]
main :: IO ()
main = forM_ code $ \c -> do
    runTube $ sample (parse c)
           >< take 1
           >< map fst
           >< map translateToJs
           >< filter isRight
           >< map (\(Right x) -> x)
           >< map (printJSExpr False 0)
           >< pour display