Create a gist now

Instantly share code, notes, and snippets.

@gatlin /output.txt
Last active Oct 26, 2016

What would you like to do?
applicative parser built with Tubes
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!")])
---
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment