derive.llrl

(no-implicit-std)

(import "std/prelude/stage-0" _)
(import "std/s" s/_)
(import "std/control" _)
(export derive derive/_)

(macro (derive s)
  (s/match s
    [(_ ,classes ,@body)
      (s/for-each derive/derive-class/validate classes)!
      (derive/data/validate body)!
      (ok `(begin
        ,body
        ,@(s/traverse [^1 (ok `(,(derive/symbol/concat 'derive/ %1)! ,@body))] classes)!))]
    [_
      (err "Expected (derive (<class> ...) <data or value-data or c-data> <type-con> <value-con> ...)")]))

(function (derive/derive-class/validate cls) {(-> (Syntax Sexp) (Result unit String))}
  (match cls
    [(s:symbol _) (ok unit)]
    [_ (err "derive: derive-class: Expected symbol")]))

(function (derive/type-parameter/validate ty-param) {(-> (Syntax Sexp) (Result unit String))}
  (match ty-param
    [(s:symbol _) (ok unit)]
    [_ (err "derive: type-parameter: Expected symbol")]))

(function (derive/data/validate decl) {(-> (Syntax Sexp) (Result unit String))}
  (with1
    (: (let type-con) (let value-cons))
    (s/match decl
      [(data ,type-con ,@value-cons) (: type-con value-cons)]
      [(value-data ,type-con ,@value-cons) (: type-con value-cons)]
      [(c-data ,type-con ,@value-cons) (: type-con value-cons)]
      [_ (err "derive: data: Expected (<data or value-data or c-data> <type-con> <value-con> ...)")!])
    (derive/data/type-con/validate type-con)!
    (s/for-each derive/data/value-con/validate value-cons)))

(function (derive/data/type-con/validate type-con) {(-> (Syntax Sexp) (Result unit String))}
  (s/match type-con
    [,(s:symbol _) (ok unit)]
    [(,(s:symbol _) ,@params) (s/for-each derive/type-parameter/validate params)]
    [_ (err "derive: type-con: Expected <type-name> or (<type-name> <ty-param> ...)")]))

(function (derive/data/type-con/name type-con) {(-> (Syntax Sexp) (Syntax Sexp))}
  (s/match type-con
    [(,name ,@_) name]
    [,name name]))

(function (derive/data/type-con/ty-params type-con) {(-> (Syntax Sexp) (Option (Syntax Sexp)))}
  (s/match type-con
    [(_ ,@params) (some params)]
    [_ none]))

;    (instance-signature \Eq (Foo A B))
; => (ok '[(forall A B) (Eq (Foo A B)) (where (Eq A) (Eq B))])
(function (derive/data/type-con/instance-signature cls type-con) {(-> (Syntax Sexp) (Syntax Sexp) (Result (Syntax Sexp) String))}
  (ok (if-match1 (some (let params)) (derive/data/type-con/ty-params type-con)
    `[(forall ,@params) (,cls ,type-con) (where ,@(s/map [^1 `(,cls ,%1)] params)!)]
    `[(,cls ,type-con)])))

(function (derive/data/value-con/validate value-con) {(-> (Syntax Sexp) (Result unit String))}
  (s/match value-con
    [,(s:symbol _) (ok unit)]
    [(,(s:symbol _) ,@fields) (ok unit)]
    [_ (err "derive: value-con: Expected <con-name> or (<con-name> <field> ...)")]))

(function (derive/data/value-con/name value-con) {(-> (Syntax Sexp) (Syntax Sexp))}
  (s/match value-con
    [(,name ,@_) name]
    [,name name]))

(function (derive/data/value-con/fields value-con) {(-> (Syntax Sexp) (Option (Syntax Sexp)))}
  (s/match value-con
    [(_ ,@fields) (some fields)]
    [_ none]))

(function (derive/symbol/string sym) {(-> (Syntax Sexp) (Result (Syntax Sexp) String))}
  (match sym
    [(s:symbol (let s)) (ok (s:string s))]
    [_ (err "Expected symbol")]))

(function (derive/symbol/concat a b) {(-> (Syntax Sexp) (Syntax Sexp) (Result (Syntax Sexp) String))}
  (match (: a b)
    [(: (s:symbol (let a)) (s:symbol (let b))) (ok (s:symbol (<symbol/concat> a b)))]
    [_ (err "Expected symbol")]))

(builtin-op <symbol/concat> {(-> String String String)} "string.concat")