(local fennel (require :fennel))

(fn safesym [name]
    (let [str (tostring (gensym name))]
        (str:gsub "[^%w_]" #(string.format "_%02x" ($:byte)))))

(fn kv-table? [tbl] ; this should be exported to macros but is not ;_;
    (and (table? tbl) (not (sequence? tbl))))

(fn new-scope []
    {:locals {}
     :env {}
     :input []
     :push (fn [self] (set self.locals (setmetatable {} {:__index self.locals})))
     :pop (fn [self] (set self.locals (. (getmetatable self.locals) :__index)))
     :expr (fn [self expr]
        (if (and (sym? expr) (not (multi-sym? expr))) (self:env-ref expr)
            (= (type expr) :number)                      (tostring expr)
            (= expr nil)                                 :nil
            (let [name (safesym :inline-expr)]
                (table.insert self.input {: name : expr})
                name)))
     :env-ref (fn [self symbol]
        (let [name (tostring symbol)
              loc (. self.env name)]
            (if loc loc
                (let [envloc (safesym name)]
                    (tset self.env name envloc)
                    (table.insert self.input {:name envloc :expr (sym name)})
                    envloc))))
     :reference (fn [self symbol]
        (let [name (tostring symbol)
              loc (. self.locals name)]
            (if loc loc (self:env-ref symbol))))
     :addlocal (fn [self symbol]
        (let [name (tostring symbol)
              loc (safesym name)]
            (tset self.locals name loc)
            loc))})

(local comp {})
(local forms {})

(fn commasep [list f]
    (table.concat (icollect [_ v (ipairs list)] (f v)) ", "))
(fn kvcommasep [tbl f]
    (commasep (. (getmetatable tbl) :keys) #(f $1 (. tbl $1))))

(fn comp.expr [form scope]
    (case form
        (where [head & rest] (sym? head) (list? form) (. forms (tostring head)))
        ((. forms (tostring head)) rest scope)

        (where [head & rest] (list? form))
        (.. (comp.expr head scope) "(" (commasep rest #(comp.expr $1 scope)) ")")

        (where [array] (sequence? form) (= (length form) 1))
        (.. "@" (comp.expr array scope))

        (where [array & indexes] (sequence? form))
        (.. "(" (comp.expr array scope) ")" (table.concat (icollect [_ i (ipairs indexes)] (.. "[" (comp.expr i scope) "]"))))

        (where struct (kv-table? struct))
        (.. "{ " (kvcommasep struct #(.. (tostring $1) " = " (comp.expr $2 scope))) " }")

        (where multisym (multi-sym? multisym))
        (string.gsub (tostring multisym) "[^.:]+" #(scope:reference $1) 1)

        (where symbol (sym? symbol))
        (scope:reference symbol)

        (where lit (or (= (type lit) :string) (= (type lit) :number) (= (type lit) :nil)))
        (scope:expr lit)

        _ (error (.. "Failed to parse expression: " (view form)))))

(local type-constructors {})

(fn comp.type [typ scope]
    (case typ
        (where [innertyp index] (sequence? typ))
        (.. "(" (comp.type innertyp scope) ")[" (comp.type index scope) "]")

        (where [innertyp] (sequence? typ) (= (length typ) 1))
        (.. "&" (comp.type innertyp scope))

        (where struct (kv-table? struct))
        (.. "struct { " (kvcommasep struct #(comp.type-field $1 $2 scope)) " }")

        (where [head & args] (list? typ) (sym? head) (. type-constructors (tostring head)))
        ((. type-constructors (tostring head)) args scope)

        (where [head & args] (list? typ))
        (.. (comp.type head scope) "(" (commasep args #(comp.type $1 scope)) ")")

        (where multisym (multi-sym? multisym))
        (string.gsub (tostring multisym) "[^.:]+" #(scope:reference $1) 1)

        _ (scope:expr typ)))

(fn comp.type-field [name typ scope]
    (case name
        (where name (sym? name) (not (multi-sym? name)))
        (.. (tostring name) " : " (comp.type typ scope))
        
        :union
        (.. "union { " (kvcommasep typ #(comp.type-field $1 $2 scope)) " }") ; unions shouldn't nest :/
        
        _ (error (.. "Invalid field name: " (view name)))))

(fn arglist-type [arglist scope] (.. "{ " (commasep (or arglist []) #(comp.type $1 scope)) " }"))
(tset type-constructors :-> (fn [[in out] scope] (.. (arglist-type in scope) " -> " (arglist-type out scope))))
(tset type-constructors :&  (fn [[typ] scope]    (.. :& (comp.type typ scope))))
(tset type-constructors :$  (fn [typs scope]     (.. "tuple(" (commasep typs #(comp.type $1 scope)) ")")))
(fn type-constructors.hashfn [[expr] scope] (scope:expr expr))

(fn forms.rawterra [[text] scope] text)
(fn forms.var [defn scope]
    (case defn
        [name typ initval] (.. "var " (scope:addlocal name) " : " (comp.type typ scope) " = " (comp.expr initval scope)) 
        [name initval] (.. "var " (scope:addlocal name) " = " (comp.expr initval scope))))

(fn forms.do [stmts scope]
    (scope:push)
    (local lines (icollect [_ stmt (ipairs stmts)] (comp.expr stmt scope)))
    (scope:pop)
    (table.concat lines "\n"))

(fn find-ival [tbl pred]
    (var ival nil)
    (each [i val (ipairs tbl)]
        (when (pred val) (set ival i)))
    ival)

(fn forms.def [[arglist & stmts] scope]
    (scope:push)
    (let [iarg-return-sep (find-ival arglist #(and (sym? $1) (= (tostring $1) ":")))
          argpairs (fcollect [i 1 (length arglist) 2 &until (= i iarg-return-sep)] 
                        {:name (. arglist i) :type (. arglist (+ i 1))})
          rettyps (when iarg-return-sep (icollect [i typ (ipairs arglist)] (when (> i iarg-return-sep) typ)))
          rettyp  (if rettyps (.. ": { " (commasep rettyps #(comp.type $1 scope)) " }") "")
          argdefs (commasep argpairs #(.. (scope:addlocal $1.name) " : " (comp.type $1.type scope)))
          fulldef (.. "terra (" argdefs ")" rettyp "\n" (forms.do stmts scope) "\nend")]
        (scope:pop)
        fulldef))
(fn forms.predef [fntyp scope] (.. ))
(fn forms.return [[expr] scope] (.. "return " (comp.expr expr scope)))
(fn forms.cast [[typ expr] scope]
    (.. "([" (comp.type typ scope)"](" (comp.expr expr scope) "))"))
(fn forms.hashfn [[expr] scope] (.. "([" (scope:expr expr) "])"))

(tset forms :& (fn [[expr] scope] (.. :& (comp.expr expr scope))))
(tset forms :$ (fn [items scope] (.. "{ " (commasep items #(comp.expr $1 scope)) " }")))

(fn def-infix [fnlop luaop]
    (tset forms fnlop (fn [[left right] scope]
        (.. "(" (comp.expr left scope) " " luaop " " (comp.expr right scope) ")"))))
(each [_ op (ipairs [:+ :- :* :/ :% :< :<= :> :>= :and :or :not :^ :<< :>>])]
    (def-infix op op))
(def-infix := :==)
(def-infix :not= "~=")
(def-infix :set :=)

(fn build [expr compiler]
    (let [scope (new-scope)
          terra-expr (compiler expr scope)
          env-setup (if (= (length scope.input) 0) ""
                        (.. "local " (commasep scope.input #$1.name) " = ...\n"))
          compiled (.. env-setup "return " terra-expr)
          call `((terralib.loadstring ,compiled))]
        (icollect [_ {: expr} (ipairs scope.input) &into call] expr)
        call))

(fn terra [expr] (build expr comp.expr))
(fn ttype [expr] (build expr comp.type))

(fn def [...] (terra `(,(sym :def) ,...)))
(fn q [...] (terra `(,(sym :quote) ,...)))
(fn unterra [...] (view (macroexpand (terra ...))))
(fn untype [...] (view (macroexpand (ttype ...))))

{: terra : ttype : def : q : unterra : untype}