{-# 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]