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

pragma.syntax("0.9")
pragma.enable("accumulator")

def defineException := <import:org.cubik.cle.fail.defineException>
def defineExceptionGuard := <import:org.cubik.cle.fail.defineExceptionGuard>
def EventuallyDeepFrozen :(<import:org.erights.e.elib.slot.Same>)[DeepFrozen."eventually"()] := DeepFrozen."eventually"()

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

def mapV(f, coll) implements DeepFrozen \
  { 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 ExitViaHere { # implements DeepFrozen
  to run(lisp) {

    # XXX duplicated code from IPAuthor.emaker
    def intern := lisp["CL", "INTERN"].getFunction()
    def read := lisp["CL", "READ-FROM-STRING"].getFunction()
    def l__quasiParser {
      to valueMaker(t :String) {
        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"].getFunction()
      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+"][]

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

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

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

    def mapToSymbol(input, map) {
      return map.fetch(
        input, 
        fn {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() :List, l`cl:list`),
            <kw:PRECEDENCE>, clCoerce(mapV(convertSymbol, precedence) :List, l`cl:list`),
            <kw:PRODUCTIONS>, clCoerce(accum [] for [fs, derives] + actionSection in productions {
              _.with(yaccMakeProduction(
                       convertSymbol(fs),
                       clCoerce(mapV(convertSymbol, derives) :List, l`cl:list`),
                       <kw:ACTION>,
                       switch (actionSection) {
                         match [action] { eToLispFunction(action) }
                         match [] { fdefinition(l`cl:vector`) }
                       }))
             } :List, 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(fn {
                  switch (stream.takeAtMost(1)) {
                    match [input] {
                      def [sym, value] := tokenFunction(input)
                      def ysym := convertSymbol(sym)
                      if (!terminalsSet.contains(ysym)) {
                        throw(`${E.toQuote(sym)} is not a terminal symbol`)
                      }
                      [ysym, value]
                    }
                    match ==null {
                      [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
  }
}