defpackage firrtl/parser :
   import core
   import verse
   import firrtl/ir2
   import stz/parser
   import stz/lexer

;======= Convenience Functions ========
defn first-info? (form) -> FileInfo|False :
   match(form) :
      (form:Token) : info(form)
      (form:List) : search(first-info?, form)
      (form) : false

defn first-info (form:List) :
   match(first-info?(form)) :
      (i:FileInfo) : i
      (f:False) : FileInfo()

defn FPE (form, x) :
   throw $ new Exception :
      defmethod print (o:OutputStream, this) :
         print(o, "[~] FIRRTL Parsing Error: ~" << [first-info(form), x])

defn* apply-suffix-ops (x, fs:List) :
   if empty?(fs) : x
   else : apply-suffix-ops(head(fs)(x), tail(fs))

;======== Parser Utilities ==============
defn atom? (x) : unwrap-token(x) not-typeof List

defn primop (x:Symbol) : get?(OPERATORS, x, false)
val OPERATORS = HashTable<Symbol, PrimOp>(symbol-hash)
OPERATORS[`add] = ADD-OP
OPERATORS[`sub] = SUB-OP
OPERATORS[`mul] = MUL-OP
OPERATORS[`div] = DIV-OP
OPERATORS[`mod] = MOD-OP
OPERATORS[`quo] = QUO-OP
OPERATORS[`rem] = REM-OP
OPERATORS[`add-wrap] = ADD-WRAP-OP
OPERATORS[`sub-wrap] = SUB-WRAP-OP
OPERATORS[`lt] = LESS-OP
OPERATORS[`leq] = LESS-EQ-OP
OPERATORS[`gt] = GREATER-OP
OPERATORS[`geq] = GREATER-EQ-OP
OPERATORS[`eq] = EQUAL-OP
OPERATORS[`neq] = NEQUAL-OP
OPERATORS[`mux] = MUX-OP
OPERATORS[`pad] = PAD-OP
OPERATORS[`neg] = NEG-OP
OPERATORS[`as-UInt] = AS-UINT-OP
OPERATORS[`as-SInt] = AS-SINT-OP
OPERATORS[`dshl] = DYN-SHIFT-LEFT-OP
OPERATORS[`dshr] = DYN-SHIFT-RIGHT-OP
OPERATORS[`shl] = SHIFT-LEFT-OP
OPERATORS[`shr] = SHIFT-RIGHT-OP
OPERATORS[`convert] = CONVERT-OP
OPERATORS[`bit-and-reduce] = BIT-AND-REDUCE-OP
OPERATORS[`bit-or-reduce] = BIT-OR-REDUCE-OP
OPERATORS[`bit-xor-reduce] = BIT-XOR-REDUCE-OP
OPERATORS[`bit-not] = BIT-NOT-OP
OPERATORS[`bit-and] = BIT-AND-OP
OPERATORS[`bit-or] = BIT-OR-OP
OPERATORS[`bit-xor] = BIT-XOR-OP
OPERATORS[`cat] = CONCAT-OP
OPERATORS[`bit] = BIT-SELECT-OP
OPERATORS[`bits] = BITS-SELECT-OP

;======== Parser Rules ==================
defsyntax firrtl :
   ;Useful Atoms
   defrule atoms :
      ;Unconditionally parse next form as identifier.
      id = (?x) when atom?(x) :
         match(unwrap-token(x)) :
            (x:Symbol) : x
            (x) : FPE(form, "Expected an identifier here. Got ~ instead." << [x])

      ;Parses next form if integer literal
      int = (?x) when unwrap-token(x) typeof Int :
         unwrap-token(x)

      ;Parses next form if symbol
      sym = (?x) when unwrap-token(x) typeof Symbol :
         unwrap-token(x)
         
   ;Error Handling Productions
   defrule :
      ;Error if not an identifier
      id! = (?x:#id) : x
      id! != () : FPE(form, "Expected an identifier here.")

      ;Error if not a colon
      :! = (:) : (`:)
      :! != () : FPE(form, "Expected a colon here.")

      ;Error if not 'of' keyword
      of! = (of) : `of
      of! != () : FPE(form, "Expected the 'of' keyword here.")

      ;Error if not a =
      =! = (=) : `=
      =! != () : FPE(form, "Expected a '=' here.")

      ;Error if not a single integer
      int$ = (?i:#int ?rest ...) when empty?(rest) : i
      int$ != () : FPE(form, "Expected a single integer literal here.")

      ;Error if not a single width
      width$ = (?w:#width ?rest ...) when empty?(rest) : w
      width$ != () : FPE(form, "Expected a single width specifier here.")

      ;Error if not a type
      type! = (?t:#type) : t
      type! != () : FPE(form, "Expected a type here.")

      ;Error if not a vec type
      vectype! = (?t:#type!) :
         FPE(form, "Expected a vector type here.") when t not-typeof VectorType
         t

      ;Error if not an expression
      exp! = (?e:#exp) : e
      exp! != () : FPE(form, "Expected an expression here.")

      ;Error if not a single expression
      exp$ = (?e:#exp ?rest ...) when empty?(rest) : e
      exp$ != () : FPE(form, "Expected a single expression here.")

      ;Error if not a stmt
      stmt! = (?s:#stmt) : s
      stmt! != () : FPE(form, "Expected a statement here.")

      ;Error if not a reference expression
      ref! = (?e:#exp!) :
         FPE(form, "Expected a reference expression here.") when e not-typeof Ref
         e
   
   ;Main Circuit Production
   defrule circuit :
      circuit = (circuit ?name:#id! #:! (?ms:#module ... ?rest ...)) :
         if not empty?(rest) :
            FPE(rest, "Expected a module declaration here.")
         Circuit(first-info(form),ms, name)
      circuit != (circuit) :
         FPE(form, "Invalid syntax for circuit definition.")

   ;Main Module Production
   defrule module :
      module = (module ?name:#id! #:! (?ps:#port ... ?cs:#stmt ... ?rest ...)) :
         if not empty?(rest) :
            FPE(rest, "Expected a statement here.")
         InModule(first-info(form),name, ps, Begin(cs))
      module = (exmodule ?name:#id! #:! (?ps:#port ... ?rest ...)) :
         if not empty?(rest) :
            FPE(rest, "Expected a port here.")
         ExModule(first-info(form),name, ps)
      module != (module) :
         FPE(form, "Invalid syntax for module definition.")
      module != (exmodule) :
         FPE(form, "Invalid syntax for exmodule definition.")
   
   defrule port :
      port = (input ?name:#id! #:! ?type:#type!) : Port(first-info(form),name, INPUT, type)
      port = (output ?name:#id! #:! ?type:#type!) : Port(first-info(form),name, OUTPUT, type)
         
   ;Main Type Productions
   defrule type :
      inttype = (UInt<?w:#width$>) : UIntType(w)
      inttype = (UInt) : UIntType(UnknownWidth())
      inttype = (SInt<?w:#width$>) : SIntType(w)
      inttype = (SInt) : SIntType(UnknownWidth())

      type = (?t:#typeterm ?ops:#typeop ...) : apply-suffix-ops(t, ops)
      typeop = ((@get ?size:#int$)) : (fn (t) : VectorType(t, size))
      
      typeterm = (?t:#inttype) : t
      typeterm = ({?fs:#field ... ?rest ...}) :
         if not empty?(rest) :
            FPE(rest, "Expected a bundle field declaration here.")
         BundleType(fs)

   defrule field :
      field = (flip ?name:#id! #:! ?type:#type!) : Field(name, REVERSE, type)
      field = (?name:#id #:! ?type:#type!) : Field(name, DEFAULT, type)

   defrule width :
      width = (?x:#int) : IntWidth(x)
      width = (?) : UnknownWidth()

   ;Main Statement Productions
   defrule statements :
      stmt = (wire ?name:#id! #:! ?t:#type!) : DefWire(first-info(form),name, t)
      stmt = (reg ?name:#id! #:! ?t:#type!) : DefRegister(first-info(form),name, t)
      stmt = (cmem ?name:#id! #:! ?t:#vectype!) : DefMemory(first-info(form),name, t, false)
      stmt = (smem ?name:#id! #:! ?t:#vectype!) : DefMemory(first-info(form),name, t, true)
      stmt = (inst ?name:#id! #of! ?m:#ref!) : DefInstance(first-info(form),name, m)
      stmt = (node ?name:#id! #=! ?e:#exp!) : DefNode(first-info(form),name, e)
      stmt = (accessor ?name:#id! #=! ?s:#exp![?i:#exp$]) : DefAccessor(first-info(form),name, s, i)
      stmt = (?s:#stmt/when) : s

      stmt = (?x:#exp := ?y:#exp!) : Connect(first-info(form),x, y)
      stmt = (?x:#exp <> ?y:#exp!) : BulkConnect(first-info(form),x, y)
      stmt = (on-reset ?x:#exp := ?y:#exp!) : OnReset(first-info(form),x, y)

      stmt = ((?s:#stmt ?ss:#stmt ... ?rest ...)) :
         if not empty?(rest) :
            FPE(rest, "Expected a statement here.")
         Begin(List(s, ss))
      stmt = (()) :
         Begin(List())
         
   defrule stmt/when :
      stmt/when = (when ?pred:#exp! #:! ?conseq:#stmt! else ?alt:#stmt/when) :
         Conditionally(first-info(form),pred, conseq, alt)
      stmt/when = (when ?pred:#exp! #:! ?conseq:#stmt! else #:! ?alt:#stmt!) :
         Conditionally(first-info(form),pred, conseq, alt)
      stmt/when = (when ?pred:#exp! #:! ?conseq:#stmt!) :
         Conditionally(first-info(form),pred, conseq, EmptyStmt())

   ;Main Expressions
   defrule exp :
      ;Suffix Operators
      exp = (?x:#expterm ?ops:#expop ...) : apply-suffix-ops(x, ops)      
      expop = ((@get ?f:#int)) : (fn (x) : Index(x, f, UnknownType()))
      expop = (. ?f:#id!) : (fn (x) : Subfield(x, f, UnknownType()))
      
      ;Prefix Operators
      expterm = (?t:#inttype(?v:#int$)) :
         match(t) :
            (t:UIntType) : UIntValue(v, width(t))
            (t:SIntType) : SIntValue(v, width(t))

      expterm = (WritePort(?m:#exp, ?i:#exp, ?e:#exp)) : WritePort(m, i, UnknownType(), e)
      expterm != (WritePort) : FPE(form, "Invalid syntax for WritePort expression.")

      expterm = (ReadPort(?m:#exp, ?i:#exp, ?e:#exp)) : ReadPort(m, i, UnknownType(), e)
      expterm != (ReadPort) : FPE(form, "Invalid syntax for ReadPort expression.")

      expterm = (Register(?v:#exp, ?e:#exp)) : Register(UnknownType(), v, e)
      expterm != (Register) : FPE(form, "Invalid syntax for Register expression.")

      expterm = (?op:#sym(?es:#exp ... ?ints:#int ... ?rest ...)) :
         if not empty?(rest) :
            FPE(rest, "Illegal operands to primitive operator.")
         match(primop(op)) :
            (p:PrimOp) : DoPrim(p, es, ints, UnknownType())
            (p:False) : FPE(form, "Unrecognized primitive operator '~'." << [op])
      expterm = (?op:#sym) :
         Ref(op, UnknownType())

public defn parse-firrtl (forms:List) :
   with-syntax(firrtl) :
      match-syntax(forms) :
         (?c:#circuit) : c
         (_ ...) : FPE(form, "Invalid firrtl circuit.")

public defn parse-firrtl-file (filename:String) :
   parse-firrtl(lex-file(filename))