rose-ash/lib/haskell/runtime.sx

;; Haskell runtime: constructor registry.
;;
;; A mutable dict keyed by constructor name (e.g. "Just", "[]") with
;; entries of shape  {:arity N :type TYPE-NAME-STRING}.
;; Populated by ingesting `data` / `newtype` decls from parsed ASTs.
;; Pre-registers a small set of constructors tied to Haskell syntactic
;; forms (Bool, list, unit) — every nontrivial program depends on
;; these, and the parser/desugar pipeline emits them as (:var "True")
;; etc. without a corresponding `data` decl.

(define hk-constructors (dict))

(define
  hk-register-con!
  (fn (cname arity type-name) (dict-set! hk-constructors cname {:arity arity :type type-name})))

(define hk-is-con? (fn (name) (has-key? hk-constructors name)))

(define
  hk-con-arity
  (fn
    (name)
    (if
      (has-key? hk-constructors name)
      (get (get hk-constructors name) "arity")
      nil)))

(define
  hk-con-type
  (fn
    (name)
    (if
      (has-key? hk-constructors name)
      (get (get hk-constructors name) "type")
      nil)))

(define hk-con-names (fn () (keys hk-constructors)))

;; ── Registration from AST ────────────────────────────────────
;; (:data NAME TVARS ((:con-def CNAME FIELDS) …))
(define
  hk-register-data!
  (fn
    (data-node)
    (let
      ((type-name (nth data-node 1)) (cons-list (nth data-node 3)))
      (for-each
        (fn (cd) (hk-register-con! (nth cd 1) (len (nth cd 2)) type-name))
        cons-list))))

;; (:newtype NAME TVARS CNAME FIELD)
(define
  hk-register-newtype!
  (fn (nt-node) (hk-register-con! (nth nt-node 3) 1 (nth nt-node 1))))

;; Walk a decls list, registering every `data` / `newtype` decl.
(define
  hk-register-decls!
  (fn
    (decls)
    (for-each
      (fn
        (d)
        (cond
          ((and (list? d) (not (empty? d)) (= (first d) "data"))
            (hk-register-data! d))
          ((and (list? d) (not (empty? d)) (= (first d) "newtype"))
            (hk-register-newtype! d))
          (:else nil)))
      decls)))

(define
  hk-register-program!
  (fn
    (ast)
    (cond
      ((nil? ast) nil)
      ((not (list? ast)) nil)
      ((empty? ast) nil)
      ((= (first ast) "program") (hk-register-decls! (nth ast 1)))
      ((= (first ast) "module") (hk-register-decls! (nth ast 4)))
      (:else nil))))

;; Convenience: source → AST → desugar → register.
(define hk-load-source! (fn (src) (hk-register-program! (hk-core src))))

;; ── Built-in constructors pre-registered ─────────────────────
;; Bool — used implicitly by `if`, comparison operators.
(hk-register-con! "True" 0 "Bool")
(hk-register-con! "False" 0 "Bool")
;; List — used by list literals, range syntax, and cons operator.
(hk-register-con! "[]" 0 "List")
(hk-register-con! ":" 2 "List")
;; Unit — produced by empty parens `()`.
(hk-register-con! "()" 0 "Unit")
;; Standard Prelude types — pre-registered so expression-level
;; programs can use them without a `data` decl.
(hk-register-con! "Nothing" 0 "Maybe")
(hk-register-con! "Just" 1 "Maybe")
(hk-register-con! "Left" 1 "Either")
(hk-register-con! "Right" 1 "Either")
(hk-register-con! "LT" 0 "Ordering")
(hk-register-con! "EQ" 0 "Ordering")
(hk-register-con! "GT" 0 "Ordering")
(hk-register-con! "SomeException" 1 "SomeException")

(define
  hk-str?
  (fn (v) (or (string? v) (and (dict? v) (has-key? v "hk-str")))))

(define
  hk-str-head
  (fn
    (v)
    (if
      (string? v)
      (char-code (char-at v 0))
      (char-code (char-at (get v "hk-str") (get v "hk-off"))))))

(define
  hk-str-tail
  (fn
    (v)
    (let
      ((buf (if (string? v) v (get v "hk-str")))
        (off (if (string? v) 1 (+ (get v "hk-off") 1))))
      (if (>= off (string-length buf)) (list "[]") {:hk-off off :hk-str buf}))))

(define
  hk-str-null?
  (fn
    (v)
    (if
      (string? v)
      (= (string-length v) 0)
      (>= (get v "hk-off") (string-length (get v "hk-str"))))))

(define
  hk-str-to-native
  (fn
    (v)
    (if
      (string? v)
      v
      (let
        ((buf (get v "hk-str")) (off (get v "hk-off")))
        (reduce
          (fn (acc i) (str acc (char-at buf i)))
          ""
          (range off (string-length buf)))))))