Improve type compiler, implement pointers / arrays, structs

go.fnl

@@ -1,7 +1,28 @@
 (local fennel (require :fennel))
-(import-macros {: terra : unterra : def : q} :terra)
+(import-macros {: terra : unterra : untype : def : q : ttype} :terra)
 
-(local N 5)
+; (local N 5)
-(print (unterra (def [x int] (return (+ x N)))))
+; (print (unterra 
-(local inc (def [x int] (return (+ x N))))
+;     (def [x [int] : int64] 
-(print (inc 5))
+;         (var y (+ x N))
+;         (return (cast int64 (& [y]))))))
+(print (untype 
+    {key int 
+     :union { 
+        string [int8] 
+        number float 
+        complex {real float imag float}
+      }
+    }))
+
+(print (fennel.view (ttype
+    {key int 
+     :union {
+        string [int8] 
+        number float 
+        complex {real float imag float}
+      }
+    })))
+
+; (local inc (def [x [int]] (return [x N])))
+; (print (inc 5))

terra.fnl

@@ -4,6 +4,9 @@
     (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 {}
@@ -11,9 +14,12 @@
      :push (fn [self] (set self.locals (setmetatable {} {:__index self.locals})))
      :pop (fn [self] (set self.locals (. (getmetatable self.locals) :__index)))
      :expr (fn [self expr]
-        (let [name (safesym :inline-expr)]
+        (if (and (sym? expr) (not (multi-sym? expr))) (self:env-ref expr)
-            (table.insert self.input {: name : expr})
+            (= (type expr) :number)                      (tostring expr)
-            name))
+            (= 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)]
@@ -32,27 +38,30 @@
             (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]
+(fn comp.expr [form scope]
     (case form
-        (where [head & rest] (sym? head) (list? form) (. forms (tostring head))) 
+        (where [head & rest] (sym? head) (list? form) (. forms (tostring head)))
         ((. forms (tostring head)) rest scope)
 
-        (where [head & rest] (sym? head) (list? form)) 
+        (where [head & rest] (list? form))
-        (.. (comp-expr head scope) "(" (commasep rest #(comp-expr $1 scope)) ")")
+        (.. (comp.expr head scope) "(" (commasep rest #(comp.expr $1 scope)) ")")
 
-        (where [escape] (sequence? form))
+        (where [array] (sequence? form) (= (length form) 1))
-        (scope:expr escape)
+        (.. "@" (comp.expr array scope))
 
-        (where str (= (type str) :string))
+        (where [array & indexes] (sequence? form))
-        (scope:expr str)
+        (.. "(" (comp.expr array scope) ")" (table.concat (icollect [_ i (ipairs indexes)] (.. "[" (comp.expr i scope) "]"))))
 
-        (where num (= (type num) :number))
+        (where struct (kv-table? struct))
-        (tostring num)
+        (.. "{ " (kvcommasep struct #(.. (tostring $1) " = " (comp.expr $2 scope))) " }")
 
         (where multisym (multi-sym? multisym))
         (string.gsub (tostring multisym) "[^.:]+" #(scope:reference $1) 1)
@@ -60,60 +69,94 @@
         (where symbol (sym? symbol))
         (scope:reference symbol)
 
-        nil           
+        (where lit (or (= (type lit) :string) (= (type lit) :number) (= (type lit) :nil)))
-        "nil"
+        (scope:expr lit)
-        
+
         _ (error (.. "Failed to parse expression: " (view form)))))
 
-(fn comp-type [typ scope] 
+(local type-constructors {})
+
+(fn comp.type [typ scope]
     (case typ
-        (where typlist (sequence? typlist))
+        (where [innertyp index] (sequence? typ))
-        (.. "{" (commasep typlist #(comp-type $1 scope)) "}")
+        (.. "(" (comp.type innertyp scope) ")[" (comp.type index scope) "]")
 
-        (where [vec typ n] (list? typ) (= (type n) :number) (= vec (sym :vec)))
+        (where [innertyp] (sequence? typ) (= (length typ) 1))
-        (.. "vector(" (comp-type typ scope) ", " (tostring n) ")")
+        (.. "&" (comp.type innertyp scope))
 
-        (where tuple (list? tuple))
+        (where struct (kv-table? struct))
-        (.. "tuple(" (commasep tuple #(comp-type $1 scope)) ")")
+        (.. "struct { " (kvcommasep struct #(comp.type-field $1 $2 scope)) " }")
 
-        (where [to in out] (list? typ) (= to (sym :->)))
+        (where [head & args] (list? typ) (sym? head) (. type-constructors (tostring head)))
-        (.. (comp-type in scope) " -> " (comp-type out scope))
+        ((. type-constructors (tostring head)) args scope)
 
-        (where symbol (sym? symbol))
+        (where [head & args] (list? typ))
-        (tostring symbol)
+        (.. (comp.type head scope) "(" (commasep args #(comp.type $1 scope)) ")")
 
-        (where symbol (= (type symbol) :string))
+        (where multisym (multi-sym? multisym))
-        symbol
+        (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))
         
-        _ (error (.. "Failed to parse type: " (view typ)))))
+        :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 [[name typ] scope]
+(fn forms.var [defn scope]
-    (.. "var " (scope:addlocal name) " " (comp-type typ 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)))
+    (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 [argpairs (fcollect [i 1 (length arglist) 2] {:name (. arglist i) :type (. arglist (+ i 1))})
+    (let [iarg-return-sep (find-ival arglist #(and (sym? $1) (= (tostring $1) ":")))
-          _ (print (view argpairs))
+          argpairs (fcollect [i 1 (length arglist) 2 &until (= i iarg-return-sep)] 
-          argdefs (commasep argpairs #(.. (scope:addlocal $1.name) " : " (comp-type $1.type scope)))
+                        {:name (. arglist i) :type (. arglist (+ i 1))})
-          fulldef (.. "terra (" argdefs ")\n" (forms.do stmts scope) "\nend")]
+          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.return [[expr] scope] (.. "return " (comp-expr expr scope)))
+(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) ")"))))
+        (.. "(" (comp.expr left scope) " " luaop " " (comp.expr right scope) ")"))))
 (each [_ op (ipairs [:+ :- :* :/ :% :< :<= :> :>= :and :or :not :^ :<< :>>])]
     (def-infix op op))
-(fn forms.cast [[typ expr] scope]
-    (.. "([" (comp-type typ scope)"]" (comp-expr expr scope) ")"))
-
 (def-infix := :==)
 (def-infix :not= "~=")
 (def-infix :set :=)
@@ -128,11 +171,12 @@
         (icollect [_ {: expr} (ipairs scope.input) &into call] expr)
         call))
 
-(fn terra [expr] (build expr comp-expr))
+(fn terra [expr] (build expr comp.expr))
-(fn ttype [expr] (build expr comp-type))
+(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}
+{: terra : ttype : def : q : unterra : untype}