eq.llrl

(no-implicit-std)

(import "std/prelude/stage-0" _)
(import "std/s" s/_)
(import "std/never" Never never)
(import "std/control" _)
(import "std/derive" derive/_)
(import "std/bool" Bool not and)
(export Eq eq? ne? = Eq._ derive/Eq)

(class (Eq A)
  (function (eq? a b) {(-> A A Bool)})
  (transparent-function (ne? a b) {(-> A A Bool)}
    (not (eq? a b))))

(macro (= s)
  (s/match s
    [(_)
      (ok '#t)]
    [(_ _)
      (ok '#t)]
    [(_ ,a ,b)
      (ok `(,\eq? ,a ,b))]
    [(_ ,a ,@bs)
      @let ([tmp-a (gensym)])
      (ok
        `(let ([,tmp-a ,a])
          (,\and ,@(s/map (lambda (b) `(,\eq? ,tmp-a ,b)) bs)!)))]
    [_
      (err "Expected (= expr ...)")]))

(instance Eq.Never (Eq Never)
  (transparent-function (eq? a b) (never a) (never b)))

(instance Eq.Bool (Eq Bool)
  (transparent-function (eq? a b) (<bool/eq?> a b)))

(builtin-op <bool/eq?> {(-> Bool Bool Bool)} "integer.eq")

(macro (derive/Eq s)
  (s/match s
    [(_ _ ,type-con ,@value-cons)
      @let (
        [inst-name (derive/symbol/concat 'Eq. (derive/data/type-con/name type-con))!]
        [inst-signature (derive/data/type-con/instance-signature \Eq type-con)!]
        [match-body
          (match value-cons
            [(s:list (let value-con)) `(,(equality-clause value-con)!)]
            [_ `(,@(s/traverse equality-clause value-cons)! [_ #f])])])
      (ok
        `(instance ,inst-name ,@inst-signature
          (function (eq? a b)
            (match (: a b)
              ,@match-body))))]
    [_
      (err "Unsupported derivation")]))

(function (equality-clause value-con)
  @let (
    [con-name (derive/data/value-con/name value-con)]
    [con-fields (derive/data/value-con/fields value-con)])
  (ok (if-match1 (some (let fields)) con-fields
    (let ([l-names (s/map [^1 (gensym)] fields)!]
          [r-names (s/map [^1 (gensym)] fields)!])
      `[(: (,con-name ,@(s/map [^1 `(let ,%1)] l-names)!)
            (,con-name ,@(s/map [^1 `(let ,%1)] r-names)!))
        (,\and ,@(s/zip [^2 `(,\eq? ,%1 ,%2)] l-names r-names)!)])
    `[(: ,con-name ,con-name) #t])))