# Copyright 2005 Kevin Reid, under the terms of the MIT X license
# found at http://www.opensource.org/licenses/mit-license.html ................

pragma.enable("easy-return")
pragma.disable("explicit-result-guard")
pragma.enable("dot-props")
pragma.enable("verb-curry")
pragma.enable("accumulator")
pragma.enable("trinary-define")

def defineException := <import:org.cubik.cle.fail.defineException>
def defineExceptionGuard := <import:org.cubik.cle.fail.defineExceptionGuard>
def mapStream := <import:org.cubik.cle.io.mapStream>
def EventuallyDeepFrozen := DeepFrozen."eventually"()

def makeParseError := defineException(
  [def parseErrorFQN := meta.context().getFQNPrefix() + "ParseError"], 
  def pePrinter implements DeepFrozen {
   to run(tw :TextWriter, [=> found, => expected]) {  
    tw.write("parse error: expected one of ")
    tw.quote(expected.getElements())
    tw.write(", got ")
    tw.quote(found)
  }})
def ParseError := defineExceptionGuard([parseErrorFQN])

def mapV implements DeepFrozen {
  to run(f, coll) { return accum [] for v in coll {_.with(f(v))}}}

def GSymbol := any
def GProduction := any[Tuple[any, List[any]],
                       Tuple[any, List[any], any]]

def makeLALR1ParserAuthor { # implements DeepFrozen
  to run(lisp) {

    # XXX duplicated code from IPAuthor.emaker
    def intern := lisp["CL", "INTERN"]::"function"
    def read := lisp["CL", "READ-FROM-STRING"]::"function"
    def l__quasiParser {
      to valueMaker(t) {
        return def vm {
          to substitute(values) { return read(simple__quasiParser.valueMaker(t).substitute(values)) }
        } 
      }
    }
    def <kw> { to get(k :String) { return intern(k, "KEYWORD") }}
    
    { def asdfOperate := lisp["ASDF", "OPERATE"]::"function"
      def load_op := intern("LOAD-OP", "ASDF")
      
      # XXX :verbose nil for asdf loads
      asdfOperate(load_op, intern("YACC", "KEYWORD"))
    }
    
    def DeepFrozenStamp := lisp["E.ELIB", "+DEEP-FROZEN-STAMP+"]::value

    def clCoerce := lisp["CL", "COERCE"]::"function"
    def makeSymbol := lisp["CL", "MAKE-SYMBOL"]::"function"
    def fdefinition := lisp["CL", "FDEFINITION"]::"function"
    def symbolValue := lisp["CL", "SYMBOL-VALUE"]::"function"
    def set := lisp["CL", "SET"]::"function"
    def eToLispFunction := lisp["E.KNOT", "E-TO-LISP-FUNCTION"]::"function"
    def eToLispMVFunction := lisp["E.KNOT", "E-TO-LISP-MV-FUNCTION"]::"function"

    def yaccMakeParser := lisp["YACC", "MAKE-PARSER"]::"function"
    def yaccMakeGrammar := lisp["YACC", "MAKE-GRAMMAR"]::"function"
    def yaccMakeProduction := lisp["YACC", "MAKE-PRODUCTION"]::"function"
    def yaccParseWithLexer := lisp["YACC", "PARSE-WITH-LEXER"]::"function"
    def YaccParseErrorT := lisp.unsealingConditionGuard(l`yacc:yacc-parse-error`)
       
    def ypeTerminal := lisp["YACC", "YACC-PARSE-ERROR-TERMINAL"]::"function"
    def ypeExpectedTerminals := lisp["YACC", "YACC-PARSE-ERROR-EXPECTED-TERMINALS"]::"function"
    def EOF := l`yacc::eof` # XXX internal symbol

    def unmapSymbol(sym) {
      return if (sym == EOF) { sym } else { symbolValue(sym) }
    }

    def mapToSymbol(input, map) {
      return map.fetch(
        input, 
        thunk {map[input] := def sym := makeSymbol(E.toString(input) + "SYM")
               set(sym, input)
               sym})
    }

    def makeLALR1Parser implements DeepFrozenStamp {
      to getEOF() { return EOF }
      to getParseError() { return ParseError }
      to getMakeParseError() { return makeParseError }
    
      to run(label :String, 
             startSymbol :GSymbol,
             terminals :List[GSymbol],
             productions :List[GProduction],
             [=> precedence :List[GSymbol] := [],
              => tokenFunction]) { 
             # , optWarningHandler
        
        def symbolsFlex := [].asMap().diverge()
        
        def convertSymbol(i) { return mapToSymbol(i, symbolsFlex) }
        
        def terminalsSet := mapV(convertSymbol, terminals).asSet()
             
        def yp := yaccMakeParser(
          yaccMakeGrammar(
            <kw:NAME>, makeSymbol(label), 
            <kw:START-SYMBOL>, convertSymbol(startSymbol), 
            <kw:TERMINALS>, clCoerce(terminalsSet.getElements(), l`cl:list`),
            <kw:PRECEDENCE>, clCoerce(mapV(convertSymbol, precedence), l`cl:list`),
            <kw:PRODUCTIONS>, clCoerce(accum [] for [fs, derives] + actionSection in productions {
              _.with(yaccMakeProduction(
                       convertSymbol(fs),
                       clCoerce(mapV(convertSymbol, derives), l`cl:list`),
                       <kw:ACTION>,
                       switch (actionSection) {
                         match [action] { eToLispFunction(action) }
                         match [] { fdefinition(l`cl:vector`) }
                       }))
             }, l`cl:list`)))
        
        def parser implements DeepFrozenStamp {
          to __printOn(tw :TextWriter) {
            tw.write("<")
            tw.print(label)
            tw.write(" LALR(1) parser>")
          }
          
          to parse(stream) {
            # XXX error path
            try {
              return yaccParseWithLexer(
                eToLispMVFunction(thunk {
                  if (stream.remaining() != 0) {
                    def [sym, value] := tokenFunction(stream.read(1, 1)[0])
                    def ysym := convertSymbol(sym)
                    if (!terminalsSet.contains(ysym)) {
                      throw(`${E.toQuote(sym)} is not a terminal symbol`)
                    }
                    [ysym, value]
                  } else {
                    [null, null]
                  }
                }), 
                yp)
            } catch p :YaccParseErrorT {
              # XXX provision for source spans
              return Ref.broken(makeParseError([
                "expected" => mapV(unmapSymbol, clCoerce(ypeExpectedTerminals(p), l`cl:vector`)).asSet(), 
                "found" => unmapSymbol(ypeTerminal(p))]))
            }
          }
        }
        
        return parser
      }
      
      to getLalr1__quasiParser() { return <import:org.cubik.cle.parser.lalr1__quasiParser> }
    }
    
    return makeLALR1Parser
  }
}