{-# LANGUAGE OverloadedStrings #-}
module LambdaCBV.Parser where
import GLL.Combinators
import Funcons.EDSL
import Funcons.Core hiding (string_, tuple_)
import Funcons.Core.Manual
import Funcons.MetaProgramming
import qualified Data.Map as M
import Data.Text (Text)
lexerSettings = emptyLanguage {
keywords = ["this", "let", "letdown", "in", "<=", "if", "then", "else", "+"
,"[|", "|]", "$(", "lift", "output"]
, keychars = ['=', '\\', '.', '(', ')', '$', '!']
}
type Parser a = BNF Token a
parser :: [Token] -> [Either String Funcons]
parser = parseWithParseOptions [] [maximumErrors 1, throwErrors]
(Right . sem_program <$$> pExpr)
pExpr :: Parser Funcons
pExpr = "expr"
<::= sem_id <$$> pId
<||> sem_id (string_ "this") <$$ keyword "this"
<||> sem_lam <$$ keychar '\\' <**> pId <** keychar '.' <**> pExpr
<||> sem_let <$$ keyword "let" <**> pId <** keychar '=' <**> pExpr
<** keyword "in" <**> pExpr
<||> sem_letdown <$$ keyword "letdown" <**> pId <** keychar '=' <**> pExpr
<** keyword "in" <**> pExpr
<||> sem_ite <$$ keyword "if" <**> pExpr <** keyword "then" <**> pExpr
<** keyword "else" <**> pExpr
<||> sem_binary_infix "plus" <$$> pExpr <** keyword "+" <**>>> pExpr
<||> sem_leq <$$> pExpr <** keyword "<=" <**>>> pExpr
<||> sem_app <$$> pExpr <**>>> pExpr
<||> sem_lift <$$ keyword "lift" <**> pExpr -- exactly like application, syntactically
<||> sem_output <$$ keyword "output" <**> pExpr -- exactly like application, syntactically
<||> int_ <$$> int_lit
<||> parens pExpr
<||> sem_upML <$$ keyword "[|" <**> pExpr <** keyword "|]"
<||> sem_downML <$$ keyword "$(" <**> pExpr <** keychar ')'
<||> sem_splice_id <$$ keychar '!' <**> pId
<||> string_ <$$> string_lit
pId :: Parser Funcons
pId = "identifiers" <:=> string_ <$$> id_lit <||> string_ <$$> alt_id_lit
sem_binary_infix name p q = sem_app (sem_app (sem_id (string_ name)) p) q
sem_id x = current_value_ [bound_ [x]]
sem_let x m n =
scope_ [bind_ [x, allocate_initialised_variable_ [values_,m]],n]
sem_letdown x m n = meta_let_ [x, m, n]
sem_app m n = give_ [m, apply_ [given_, tuple_ [n, given_]]]
sem_lam x m =
function_ [closure_ [scope_ [bind_ [x
,allocate_initialised_variable_ [values_,given1_]
]
,scope_[bind_[string_ "this" ,given2_],m]
]
]
]
sem_output m = give_ [m, seq_ [print_ [given_], given_]]
sem_ite g m n = if_true_else_ [g,m,n]
sem_plus m n = integer_add_ [m,n]
sem_leq m n = is_less_or_equal_ [m,n]
sem_upML m = meta_up_ [m]
sem_downML m = meta_down_ [m]
sem_lift m = give_ [m, ast_ [type_of_ [given_], given_ ]]
sem_splice_id x = give_ [eval_ [sem_id x]
,seq_ [assign_ [bound_ [x]
,ast_ [type_of_ [given_], given_]
]
,given_
]
]
sem_program main = finalise_abrupting_ [initialise_binding_ [initialise_storing_ [scope_ [builtins, main]]]]
builtins = env_fromlist_
[("Output", fun_ [applyFuncon "ast-output" [given1_]])
,("Bind", fun_ [applyFuncon "ast-bind" [sem_lift given1_]])
,("Bound", fun_ [applyFuncon "ast-bound" [sem_lift given1_]])
,("Lam", curry_ [fun_ [applyFuncon "ast-lam" [fst_ [given1_], fst_[given2_]]]])
,("App", curry_ [fun_ [applyFuncon "ast-app" [fst_[given1_], fst_[given2_]]]])
,("Plus", curry_ [fun_ [applyFuncon "ast-plus" [fst_[given1_], fst_[given2_]]]])
,("plus", curry_ [fun_ [integer_add_ [fst_ [given1_], fst_[given2_]]]])
,("eval", fun_ [eval_ [given1_]])
]
translation :: [(Text, [Funcons] -> Funcons)]
translation = [
("ast-this", nullary (sem_id (string_ "this")))
, ("ast-output", unary sem_output)
, ("ast-bind", unary id)
, ("ast-bound", unary sem_id)
, ("ast-lam", binary sem_lam)
, ("ast-let", ternary sem_let)
, ("ast-app", binary sem_app)
, ("ast-plus", binary sem_plus)
]
astLib :: FunconLibrary
astLib = M.fromList $ map (uncurry mkLibEntry) translation
where mkLibEntry key f = (key, StrictFuncon (translationStep f))
nullary f [] = f
unary f [x] = f x
binary f [x,y] = f x y
ternary f [x,y,z] = f x y z
given1_ = fst_ [given_]
given2_ = snd_ [given_]
fst_ xs = first_ [tuple_elements_ xs]
snd_ xs = second_ [tuple_elements_ xs]
fun_ abs = function_ [abstraction_ abs]