;; Haskell strict evaluator (Phase 2).
;;
;; Consumes the post-desugar core AST and produces SX values. Strict
;; throughout — laziness and thunks are Phase 3.
;;
;; Value representation:
;;   numbers / strings / chars      → raw SX values
;;   constructor values             → tagged lists (con-name first)
;;   functions: closure / multifun  → {:type "fn" :kind … …}
;;   constructor partials           → {:type "con-partial" …}
;;   built-ins                      → {:type "builtin" …}
;;
;; Multi-clause top-level definitions are bundled into a single
;; multifun keyed by name; arguments are gathered through currying
;; until arity is reached, then each clause's pattern list is matched
;; in order. Recursive let bindings work because the binding env is
;; built mutably so closures captured during evaluation see the
;; eventual full env.

(define
  hk-dict-copy
  (fn
    (d)
    (let ((nd (dict)))
      (for-each
        (fn (k) (dict-set! nd k (get d k)))
        (keys d))
      nd)))

;; ── Thunks (Phase 3 — laziness) ─────────────────────────────
;; A thunk wraps an unevaluated AST plus the env in which it was
;; created. The first call to `hk-force` evaluates the body, replaces
;; the body with the cached value, and flips `forced`. Subsequent
;; forces return the cached value directly.
(define
  hk-mk-thunk
  (fn
    (body env)
    {:type "thunk" :body body :env env :forced false :value nil}))

(define
  hk-is-thunk?
  (fn (v) (and (dict? v) (= (get v "type") "thunk"))))

(define
  hk-force
  (fn
    (v)
    (cond
      ((hk-is-thunk? v)
        (cond
          ((get v "forced") (get v "value"))
          (:else
            (let
              ((res (hk-force (hk-eval (get v "body") (get v "env")))))
              (dict-set! v "forced" true)
              (dict-set! v "value" res)
              res))))
      ((and (dict? v) (= (get v "type") "builtin") (= (get v "arity") 0))
        ((get v "fn")))
      (:else v))))

;; Recursive force — used at the test/output boundary so test
;; expectations can compare against fully-evaluated structures.
(define
  hk-deep-force
  (fn
    (v)
    (let ((fv (hk-force v)))
      (cond
        ((not (list? fv)) fv)
        ((empty? fv) fv)
        (:else (map hk-deep-force fv))))))

;; ── Function value constructors ──────────────────────────────
(define
  hk-mk-closure
  (fn
    (params body env)
    {:type "fn" :kind "closure" :params params :body body :env env}))

(define
  hk-mk-multifun
  (fn
    (arity clauses env)
    {:type "fn" :kind "multi" :arity arity :clauses clauses :env env :collected (list)}))

(define
  hk-mk-builtin
  (fn
    (name fn arity)
    {:type "builtin" :name name :fn fn :arity arity :lazy false :collected (list)}))

;; A lazy built-in receives its collected args as raw thunks (or
;; values, if those happened to be eager) — the implementation is
;; responsible for forcing exactly what it needs. Used for `seq`
;; and `deepseq`, which are non-strict in their second argument.
(define
  hk-mk-lazy-builtin
  (fn
    (name fn arity)
    {:type "builtin" :name name :fn fn :arity arity :lazy true :collected (list)}))

;; ── Apply a function value to one argument ──────────────────
(define
  hk-apply
  (fn
    (f arg)
    (let ((f (hk-force f)))
      (cond
        ((not (dict? f))
          (raise (str "apply: not a function value: " f)))
        ((= (get f "type") "fn")
          (cond
            ((= (get f "kind") "closure") (hk-apply-closure f arg))
            ((= (get f "kind") "multi") (hk-apply-multi f arg))
            (:else (raise "apply: unknown fn kind"))))
        ((= (get f "type") "con-partial") (hk-apply-con-partial f arg))
        ((= (get f "type") "builtin") (hk-apply-builtin f arg))
        (:else (raise "apply: not a function dict"))))))

(define
  hk-apply-closure
  (fn
    (cl arg)
    (let
      ((params (get cl "params"))
        (body (get cl "body"))
        (env (get cl "env")))
      (cond
        ((empty? params) (raise "apply-closure: no params"))
        (:else
          (let
            ((p1 (first params)) (rest-p (rest params)))
            (let
              ((env-after (hk-match p1 arg env)))
              (cond
                ((nil? env-after) (raise "pattern match failure in lambda"))
                ((empty? rest-p) (hk-eval body env-after))
                (:else (hk-mk-closure rest-p body env-after))))))))))

(define
  hk-apply-multi
  (fn
    (mf arg)
    (let
      ((arity (get mf "arity"))
        (clauses (get mf "clauses"))
        (env (get mf "env"))
        (collected (append (get mf "collected") (list arg))))
      (cond
        ((< (len collected) arity) (assoc mf "collected" collected))
        (:else (hk-dispatch-multi clauses collected env))))))

(define
  hk-dispatch-multi
  (fn
    (clauses args env)
    (cond
      ((empty? clauses)
        (raise "non-exhaustive patterns in function definition"))
      (:else
        (let
          ((c (first clauses)))
          (let
            ((pats (first c)) (body (first (rest c))))
            (let
              ((env-after (hk-match-args pats args env)))
              (cond
                ((nil? env-after)
                  (hk-dispatch-multi (rest clauses) args env))
                (:else (hk-eval body env-after))))))))))

(define
  hk-match-args
  (fn
    (pats args env)
    (cond
      ((empty? pats) env)
      (:else
        (let
          ((res (hk-match (first pats) (first args) env)))
          (cond
            ((nil? res) nil)
            (:else (hk-match-args (rest pats) (rest args) res))))))))

(define
  hk-apply-con-partial
  (fn
    (cp arg)
    (let
      ((name (get cp "name"))
        (arity (get cp "arity"))
        (args (append (get cp "args") (list arg))))
      (cond
        ((= (len args) arity) (hk-mk-con name args))
        (:else (assoc cp "args" args))))))

(define
  hk-apply-builtin
  (fn
    (b arg)
    (let
      ((arity (get b "arity"))
        (collected (append (get b "collected") (list arg))))
      (cond
        ((< (len collected) arity) (assoc b "collected" collected))
        (:else
          (cond
            ((get b "lazy") (apply (get b "fn") collected))
            (:else (apply (get b "fn") (map hk-force collected)))))))))

;; ── Bool helpers (Bool values are tagged conses) ────────────
(define
  hk-truthy?
  (fn (v) (and (list? v) (not (empty? v)) (= (first v) "True"))))

(define hk-true (hk-mk-con "True" (list)))
(define hk-false (hk-mk-con "False" (list)))
(define hk-of-bool (fn (b) (if b hk-true hk-false)))

;; ── Core eval ───────────────────────────────────────────────
(define
  hk-eval
  (fn
    (node env)
    (cond
      ((not (list? node)) (raise (str "eval: not a list: " node)))
      ((empty? node) (raise "eval: empty list node"))
      (:else
        (let
          ((tag (first node)))
          (cond
            ((= tag "int") (nth node 1))
            ((= tag "float") (nth node 1))
            ((= tag "string") (nth node 1))
            ((= tag "char") (nth node 1))
            ((= tag "var") (hk-eval-var (nth node 1) env))
            ((= tag "con") (hk-eval-con-ref (nth node 1)))
            ((= tag "neg") (- 0 (hk-force (hk-eval (nth node 1) env))))
            ((= tag "if") (hk-eval-if node env))
            ((= tag "let") (hk-eval-let (nth node 1) (nth node 2) env))
            ((= tag "lambda")
              (hk-mk-closure (nth node 1) (nth node 2) env))
            ((= tag "app")
              (hk-apply
                (hk-eval (nth node 1) env)
                (hk-mk-thunk (nth node 2) env)))
            ((= tag "rec-update")
              (let
                ((rec-val (hk-force (hk-eval (nth node 1) env)))
                  (updates (nth node 2)))
                (let
                  ((cname (first rec-val))
                    (args (rest rec-val))
                    (new-args (list)))
                  (begin
                    (let
                      ((i 0))
                      (for-each
                        (fn
                          (a)
                          (let
                            ((fname-at-i
                                (cond
                                  ((nil? (hk-record-field-names cname)) nil)
                                  (:else
                                    (nth (hk-record-field-names cname) i)))))
                            (let
                              ((override
                                  (cond
                                    ((nil? fname-at-i) nil)
                                    (:else
                                      (hk-find-rec-pair updates fname-at-i)))))
                              (begin
                                (append!
                                  new-args
                                  (cond
                                    ((nil? override) a)
                                    (:else
                                      (hk-mk-thunk (nth override 1) env))))
                                (set! i (+ i 1))))))
                        args))
                    (cons cname new-args)))))
            ((= tag "op")
              (hk-eval-op (nth node 1) (nth node 2) (nth node 3) env))
            ((= tag "case") (hk-eval-case (nth node 1) (nth node 2) env))
            ((= tag "tuple")
              (hk-mk-tuple (map (fn (e) (hk-eval e env)) (nth node 1))))
            ((= tag "list")
              (hk-mk-list (map (fn (e) (hk-eval e env)) (nth node 1))))
            ((= tag "range")
              (let
                ((from (hk-force (hk-eval (nth node 1) env)))
                  (to (hk-force (hk-eval (nth node 2) env))))
                (hk-build-range from to 1)))
            ((= tag "range-step")
              (let
                ((from (hk-force (hk-eval (nth node 1) env)))
                  (nxt (hk-force (hk-eval (nth node 2) env)))
                  (to (hk-force (hk-eval (nth node 3) env))))
                (hk-build-range from to (- nxt from))))
            ((= tag "range-from")
              (hk-eval
                (list
                  :app (list
                    :app (list :var "iterate")
                    (list :sect-right "+" (list :int 1)))
                  (nth node 1))
                env))
            ((= tag "sect-left")
              (hk-eval-sect-left (nth node 1) (nth node 2) env))
            ((= tag "sect-right")
              (hk-eval-sect-right (nth node 1) (nth node 2) env))
            (:else (raise (str "eval: unknown node tag '" tag "'")))))))))

(define
  hk-eval-var
  (fn
    (name env)
    (cond
      ((has-key? env name) (get env name))
      ((hk-is-con? name) (hk-eval-con-ref name))
      (:else (raise (str "unbound variable: " name))))))

(define
  hk-eval-con-ref
  (fn
    (name)
    (let
      ((arity (hk-con-arity name)))
      (cond
        ((nil? arity) (raise (str "unknown constructor: " name)))
        ((= arity 0) (hk-mk-con name (list)))
        (:else {:args (list) :arity arity :type "con-partial" :name name})))))

(define
  hk-eval-if
  (fn
    (node env)
    (let
      ((cv (hk-force (hk-eval (nth node 1) env))))
      (cond
        ((hk-truthy? cv) (hk-eval (nth node 2) env))
        ((and (list? cv) (= (first cv) "False"))
          (hk-eval (nth node 3) env))
        ((= cv true) (hk-eval (nth node 2) env))
        ((= cv false) (hk-eval (nth node 3) env))
        (:else (raise "if: condition is not Bool"))))))

(define
  hk-extend-env-with-match!
  (fn
    (env match-env)
    (for-each
      (fn (k) (dict-set! env k (get match-env k)))
      (keys match-env))))

(define
  hk-eval-let-bind!
  (fn
    (b env)
    (let
      ((tag (first b)))
      (cond
        ((= tag "fun-clause")
          (let
            ((name (nth b 1)) (pats (nth b 2)) (body (nth b 3)))
            (cond
              ((empty? pats) (dict-set! env name (hk-eval body env)))
              (:else (dict-set! env name (hk-mk-closure pats body env))))))
        ((or (= tag "bind") (= tag "pat-bind"))
          (let
            ((pat (nth b 1)) (body (nth b 2)))
            (let
              ((val (hk-eval body env)))
              (let
                ((res (hk-match pat val env)))
                (cond
                  ((nil? res) (raise "let: pattern bind failure"))
                  (:else (hk-extend-env-with-match! env res)))))))
        (:else nil)))))

(define
  hk-eval-let
  (fn
    (binds body env)
    (let
      ((new-env (hk-dict-copy env)))
      (hk-bind-decls! new-env binds)
      (hk-eval body new-env))))

(define
  hk-eval-case
  (fn
    (scrut alts env)
    (let ((sv (hk-force (hk-eval scrut env)))) (hk-try-alts alts sv env))))

(define
  hk-try-alts
  (fn
    (alts val env)
    (cond
      ((empty? alts) (raise "case: non-exhaustive patterns"))
      (:else
        (let
          ((alt (first alts)))
          (let
            ((pat (nth alt 1)) (body (nth alt 2)))
            (let
              ((res (hk-match pat val env)))
              (cond
                ((nil? res) (hk-try-alts (rest alts) val env))
                (:else (hk-eval body res))))))))))

(define
  hk-eval-op
  (fn
    (op left right env)
    (cond
      ((= op ":")
        (hk-mk-cons (hk-mk-thunk left env) (hk-mk-thunk right env)))
      (:else
        (let
          ((lv (hk-force (hk-eval left env)))
            (rv (hk-force (hk-eval right env))))
          (hk-binop op lv rv))))))

(define
  hk-list-append
  (fn
    (a b)
    (let
      ((a (hk-force a)))
      (cond
        ((hk-str? a) (str (hk-str-to-native a) (hk-str-to-native b)))
        ((and (list? a) (= (first a) "[]")) b)
        ((and (list? a) (= (first a) ":"))
          (hk-mk-cons (nth a 1) (hk-list-append (nth a 2) b)))
        (:else (raise "++: not a list"))))))

;; Eager finite-range spine — handles [from..to] and [from,next..to].
;; Step direction is governed by the sign of `step`; when step > 0 we
;; stop at to; when step < 0 we stop at to going down.
(define
  hk-build-range
  (fn
    (from to step)
    (cond
      ((and (> step 0) (> from to)) (hk-mk-nil))
      ((and (< step 0) (< from to)) (hk-mk-nil))
      ((= step 0) (hk-mk-nil))
      (:else (hk-mk-cons from (hk-build-range (+ from step) to step))))))

(define
  hk-try-charlist-to-string
  (fn
    (v)
    (let
      ((acc "") (ok true) (cur v))
      (begin
        (define
          hk-tcs-loop
          (fn
            ()
            (when
              ok
              (cond
                ((not (list? cur)) (set! ok false))
                ((empty? cur) (set! ok false))
                ((= (first cur) "[]") nil)
                ((= (first cur) ":")
                  (let
                    ((h (hk-deep-force (nth cur 1))))
                    (cond
                      ((and (number? h) (>= h 0) (<= h 1114111))
                        (begin
                          (set! acc (str acc (char-from-code h)))
                          (set! cur (hk-deep-force (nth cur 2)))
                          (hk-tcs-loop)))
                      (:else (set! ok false)))))
                (:else (set! ok false))))))
        (hk-tcs-loop)
        (if ok acc nil)))))

(define
  hk-normalize-for-eq
  (fn
    (v)
    (cond
      ((string? v) v)
      ((and (list? v) (not (empty? v)) (= (first v) ":"))
        (let ((s (hk-try-charlist-to-string v))) (if (nil? s) v s)))
      ((and (list? v) (not (empty? v)) (= (first v) "[]")) "")
      (:else v))))

(define
  hk-binop
  (fn
    (op lv rv)
    (cond
      ((= op "+") (+ lv rv))
      ((= op "-") (- lv rv))
      ((= op "*") (* lv rv))
      ((= op "/") (/ lv rv))
      ((= op "==")
        (hk-of-bool
          (=
            (hk-normalize-for-eq (hk-deep-force lv))
            (hk-normalize-for-eq (hk-deep-force rv)))))
      ((= op "/=")
        (hk-of-bool
          (not
            (=
              (hk-normalize-for-eq (hk-deep-force lv))
              (hk-normalize-for-eq (hk-deep-force rv))))))
      ((= op "<") (hk-of-bool (< lv rv)))
      ((= op "<=") (hk-of-bool (<= lv rv)))
      ((= op ">") (hk-of-bool (> lv rv)))
      ((= op ">=") (hk-of-bool (>= lv rv)))
      ((= op "&&") (hk-of-bool (and (hk-truthy? lv) (hk-truthy? rv))))
      ((= op "||") (hk-of-bool (or (hk-truthy? lv) (hk-truthy? rv))))
      ((= op ":") (hk-mk-cons lv rv))
      ((= op "++") (hk-list-append lv rv))
      ((= op "mod") (mod lv rv))
      ((= op "div") (floor (/ lv rv)))
      ((= op "rem") (mod lv rv))
      ((= op "quot") (truncate (/ lv rv)))
      ((= op "**") (pow lv rv))
      ((= op ">>=")
        (if
          (and (list? lv) (= (first lv) "IO"))
          (hk-apply rv (nth lv 1))
          (raise "(>>=): left side is not an IO action")))
      ((= op ">>")
        (if
          (and (list? lv) (= (first lv) "IO"))
          rv
          (raise "(>>): left side is not an IO action")))
      (:else (raise (str "unknown operator: " op))))))

;; ── Top-level program evaluation ────────────────────────────
;; Operator-as-value built-ins — let `(+)`, `(*)`, etc. work as
;; first-class functions for `zipWith (+)` and friends. Strict in
;; both args (built-ins are forced via hk-apply-builtin).
(define
  hk-eval-sect-left
  (fn
    (op e env)
    (let
      ((ev (hk-eval e env)))
      (let
        ((cenv (hk-dict-copy env)))
        (dict-set! cenv "__hk-sect-l" ev)
        (hk-mk-closure
          (list (list :p-var "__hk-sect-x"))
          (list :op op (list :var "__hk-sect-l") (list :var "__hk-sect-x"))
          cenv)))))

;; Inline Prelude source — loaded into the initial env so simple
;; programs can use `head`, `take`, `repeat`, etc. without each
;; user file redefining them. The Prelude itself uses lazy `:` for
;; the recursive list-building functions.
(define
  hk-eval-sect-right
  (fn
    (op e env)
    (let
      ((ev (hk-eval e env)))
      (let
        ((cenv (hk-dict-copy env)))
        (dict-set! cenv "__hk-sect-r" ev)
        (hk-mk-closure
          (list (list :p-var "__hk-sect-x"))
          (list :op op (list :var "__hk-sect-x") (list :var "__hk-sect-r"))
          cenv)))))

(define
  hk-make-binop-builtin
  (fn
    (name op-name)
    (hk-mk-builtin name (fn (a b) (hk-binop op-name a b)) 2)))

(define
  hk-prelude-src
  "head (x:_) = x\nhead [] = error \"Prelude.head: empty list\"\ntail (_:xs) = xs\ntail [] = error \"Prelude.tail: empty list\"\nfst (a, _) = a\nsnd (_, b) = b\ntake 0 _ = []\ntake _ [] = []\ntake n (x:xs) = x : take (n - 1) xs\ndrop 0 xs = xs\ndrop _ [] = []\ndrop n (_:xs) = drop (n - 1) xs\nrepeat x = x : repeat x\niterate f x = x : iterate f (f x)\nlength [] = 0\nlength (_:xs) = 1 + length xs\nmap _ [] = []\nmap f (x:xs) = f x : map f xs\nfilter _ [] = []\nfilter p (x:xs) = if p x then x : filter p xs else filter p xs\nzipWith _ [] _ = []\nzipWith _ _ [] = []\nzipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\nfibs = 0 : 1 : zipWith plus fibs (tail fibs)\nplus a b = a + b\nconcat [] = []\nconcat (xs:xss) = xs ++ concat xss\nconcatMap f [] = []\nconcatMap f (x:xs) = f x ++ concatMap f xs\nabs x = if x < 0 then 0 - x else x\nnegate x = 0 - x\nnull [] = True\nnull _ = False\nflip f x y = f y x\nconst x _ = x\nid x = x\ncurry f x y = f (x, y)\nuncurry f p = f (fst p) (snd p)\nfoldr f z [] = z\nfoldr f z (x:xs) = f x (foldr f z xs)\nfoldl f z [] = z\nfoldl f z (x:xs) = foldl f (f z x) xs\nfoldl1 f (x:xs) = foldl f x xs\nfoldr1 f [x] = x\nfoldr1 f (x:xs) = f x (foldr1 f xs)\nzip [] _ = []\nzip _ [] = []\nzip (x:xs) (y:ys) = (x, y) : zip xs ys\nreverse [] = []\nreverse (x:xs) = reverse xs ++ [x]\nelem _ [] = False\nelem x (y:ys) = if x == y then True else elem x ys\nnotElem x xs = not (elem x xs)\nany _ [] = False\nany f (x:xs) = if f x then True else any f xs\nall _ [] = True\nall f (x:xs) = if f x then all f xs else False\nand [] = True\nand (x:xs) = if x then and xs else False\nor [] = False\nor (x:xs) = if x then True else or xs\nsum [] = 0\nsum (x:xs) = x + sum xs\nproduct [] = 1\nproduct (x:xs) = x * product xs\nmaximum [x] = x\nmaximum (x:xs) = let m = maximum xs in if x >= m then x else m\nminimum [x] = x\nminimum (x:xs) = let m = minimum xs in if x <= m then x else m\ncompare x y = if x < y then LT else if x == y then EQ else GT\nmin x y = if x <= y then x else y\nmax x y = if x >= y then x else y\nsignum x = if x < 0 then negate 1 else if x == 0 then 0 else 1\nfromIntegral x = x\nfromInteger x = x\ntoInteger x = x\nceiling x = x\nfloor x = x\nround x = x\ntruncate x = x\nlookup _ [] = Nothing\nlookup k ((k2,v):rest) = if k == k2 then Just v else lookup k rest\nmaybe d _ Nothing = d\nmaybe _ f (Just x) = f x\neither f _ (Left x) = f x\neither _ g (Right y) = g y\nmapMaybe _ [] = []\nmapMaybe f (x:xs) = case f x of { Nothing -> mapMaybe f xs; Just y -> y : mapMaybe f xs }\nfromJust (Just x) = x\nfromJust Nothing = error \"Maybe.fromJust: Nothing\"\nfromMaybe d Nothing = d\nfromMaybe _ (Just x) = x\nisJust (Just _) = True\nisJust Nothing = False\nisNothing Nothing = True\nisNothing (Just _) = False\nfmap = map\npure = return\nwhen b m = if b then m else return ()\nunless b m = if b then return () else m\nmapM_ _ [] = return ()\nmapM_ f (x:xs) = f x >> mapM_ f xs\nsequence_ [] = return ()\nsequence_ (m:ms) = m >> sequence_ ms\ninteractApply f s = putStr (f s)\ninteract f = getContents >>= interactApply f\nnub [] = []\nnub (x:xs) = x : nub (filter notEqX xs)\n  where notEqX y = y /= x\nsort [] = []\nsort (x:xs) = sort (filter ltX xs) ++ [x] ++ sort (filter geX xs)\n  where ltX y = y < x\n        geX y = y >= x\nsortBy _ [] = []\nsortBy cmp (x:xs) = sortBy cmp smaller ++ [x] ++ sortBy cmp bigger\n  where smaller = filter ltCmp xs\n        bigger  = filter geCmp xs\n        ltCmp y = cmp y x /= GT\n        geCmp y = cmp y x == GT\nsortOnCmpFst p1 p2 = compare (fst p1) (fst p2)\nsortOn f xs = map snd (sortBy sortOnCmpFst (zip (map f xs) xs))\nsplitAt 0 xs = ([], xs)\nsplitAt _ [] = ([], [])\nsplitAt n (x:xs) = (x : a, b) where (a, b) = splitAt (n - 1) xs\nspan _ [] = ([], [])\nspan p (x:xs) = if p x then (x : a, b) else ([], x : xs) where (a, b) = span p xs\nbreak p xs = span notP xs\n  where notP y = not (p y)\npartition _ [] = ([], [])\npartition p (x:xs) = if p x then (x : a, b) else (a, x : b) where (a, b) = partition p xs\nunzip [] = ([], [])\nunzip ((a, b) : rest) = (a : as, b : bs) where (as, bs) = unzip rest\ntails [] = [[]]\ntails (x:xs) = (x:xs) : tails xs\ninits [] = [[]]\ninits (x:xs) = [] : map (x:) (inits xs)\nisPrefixOf [] _ = True\nisPrefixOf _ [] = False\nisPrefixOf (x:xs) (y:ys) = if x == y then isPrefixOf xs ys else False\nisSuffixOf xs ys = isPrefixOf (reverse xs) (reverse ys)\nisInfixOf [] _ = True\nisInfixOf _ [] = False\nisInfixOf xs ys = if isPrefixOf xs ys then True else isInfixOf xs (tail ys)\nintercalate _ [] = []\nintercalate _ [x] = x\nintercalate sep (x:xs) = x ++ sep ++ intercalate sep xs\nintersperse _ [] = []\nintersperse _ [x] = [x]\nintersperse sep (x:xs) = x : sep : intersperse sep xs\nunwords [] = \"\"\nunwords [w] = w\nunwords (w:ws) = w ++ \" \" ++ unwords ws\nunlines [] = \"\"\nunlines (l:ls) = l ++ \"\\n\" ++ unlines ls\nprint x = putStrLn (show x)\nshows x s = show x ++ s\nshowString prefix rest = prefix ++ rest\nshowParen True p s = \"(\" ++ p (\")\" ++ s)\nshowParen False p s = p s\nshowsPrec _ x s = show x ++ s\nreads s = []\nreadsPrec _ s = reads s\nread s = fst (head (reads s))\nundefined = error \"Prelude.undefined\"\n")

(define
  hk-load-into!
  (fn
    (env src)
    (let
      ((ast (hk-core src)))
      (hk-register-program! ast)
      (let
        ((decls (cond ((= (first ast) "program") (nth ast 1)) ((= (first ast) "module") (nth ast 4)) (:else (list)))))
        (hk-bind-decls! env decls)))))

(define
  hk-join-strs
  (fn
    (strs sep)
    (cond
      ((empty? strs) "")
      ((= (len strs) 1) (first strs))
      (:else
        (let
          ((acc (first strs)))
          (for-each (fn (s) (set! acc (str acc sep s))) (rest strs))
          acc)))))

;; ── Source-level convenience ────────────────────────────────
(define
  hk-collect-hk-list
  (fn
    (v)
    (let
      ((result (list)))
      (let
        ((loop (fn (node) (let ((fnode (hk-force node))) (cond ((and (list? fnode) (= (first fnode) "[]")) result) ((and (list? fnode) (= (first fnode) ":")) (do (append! result (nth fnode 1)) (loop (nth fnode 2)))) (:else (do (append! result fnode) result)))))))
        (loop v)
        result))))

;; Eagerly build the Prelude env once at load time; each call to
;; hk-eval-expr-source copies it instead of re-parsing the whole Prelude.
(define
  hk-show-num
  (fn
    (n)
    (cond
      ((integer? n) (str n))
      (:else
        (let
          ((a (if (< n 0) (- 0 n) n)))
          (cond
            ((or (>= a 10000000) (< a 0.1)) (hk-show-float-sci n))
            (:else
              (let
                ((s (str n)))
                (if (>= (index-of s ".") 0) s (str s ".0"))))))))))

(define
  hk-show-float-sci
  (fn
    (n)
    (let
      ((sign (if (< n 0) "-" "")) (a (if (< n 0) (- 0 n) n)))
      (let
        ((e 0) (m a))
        (begin
          (define
            hk-norm-up
            (fn
              ()
              (when
                (>= m 10)
                (begin (set! m (/ m 10)) (set! e (+ e 1)) (hk-norm-up)))))
          (define
            hk-norm-down
            (fn
              ()
              (when
                (< m 1)
                (begin (set! m (* m 10)) (set! e (- e 1)) (hk-norm-down)))))
          (hk-norm-up)
          (hk-norm-down)
          (let
            ((mstr (str m)))
            (str
              sign
              (if (>= (index-of mstr ".") 0) mstr (str mstr ".0"))
              "e"
              e)))))))

(define
  hk-show-prec
  (fn
    (v p)
    (let
      ((fv (hk-force v)))
      (cond
        ((= (type-of fv) "number")
          (let
            ((s (hk-show-num fv)))
            (if (and (< fv 0) (>= p 11)) (str "(" s ")") s)))
        ((= (type-of fv) "string") (str "\"" fv "\""))
        ((= (type-of fv) "boolean") (if fv "True" "False"))
        ((not (list? fv)) (str fv))
        ((empty? fv) "()")
        ((= (first fv) "[]") "[]")
        ((= (first fv) ":")
          (let
            ((elems (hk-collect-hk-list fv)))
            (str
              "["
              (hk-join-strs (map (fn (e) (hk-show-prec e 0)) elems) ",")
              "]")))
        ((= (first fv) "Tuple")
          (str
            "("
            (hk-join-strs (map (fn (e) (hk-show-prec e 0)) (rest fv)) ",")
            ")"))
        ((= (first fv) "()") "()")
        (:else
          (let
            ((cname (first fv)) (args (rest fv)))
            (if
              (empty? args)
              cname
              (let
                ((s (str cname " " (hk-join-strs (map (fn (a) (hk-show-prec a 11)) args) " "))))
                (if (>= p 11) (str "(" s ")") s)))))))))

(define hk-show-val (fn (v) (hk-show-prec v 0)))

(define
  hk-init-env
  (fn
    ()
    (let
      ((env (dict)))
      (dict-set! env "otherwise" hk-true)
      (dict-set!
        env
        "error"
        (hk-mk-builtin "error" (fn (msg) (raise (str "hk-error: " msg))) 1))
      (dict-set!
        env
        "not"
        (hk-mk-builtin "not" (fn (b) (hk-of-bool (not (hk-truthy? b)))) 1))
      (dict-set! env "id" (hk-mk-builtin "id" (fn (x) x) 1))
      (dict-set!
        env
        "seq"
        (hk-mk-lazy-builtin "seq" (fn (a b) (do (hk-force a) b)) 2))
      (dict-set!
        env
        "deepseq"
        (hk-mk-lazy-builtin
          "deepseq"
          (fn (a b) (do (hk-deep-force a) b))
          2))
      (dict-set!
        env
        "return"
        (hk-mk-lazy-builtin "return" (fn (x) (list "IO" x)) 1))
      (dict-set!
        env
        ">>="
        (hk-mk-lazy-builtin
          ">>="
          (fn
            (m f)
            (let
              ((io-val (hk-force m)))
              (cond
                ((and (list? io-val) (= (first io-val) "IO"))
                  (hk-apply (hk-force f) (nth io-val 1)))
                (:else (raise "(>>=): left side is not an IO action")))))
          2))
      (dict-set!
        env
        ">>"
        (hk-mk-lazy-builtin
          ">>"
          (fn
            (m n)
            (let
              ((io-val (hk-force m)))
              (cond
                ((and (list? io-val) (= (first io-val) "IO"))
                  (hk-force n))
                (:else (raise "(>>): left side is not an IO action")))))
          2))
      (dict-set! env "+" (hk-make-binop-builtin "+" "+"))
      (dict-set! env "-" (hk-make-binop-builtin "-" "-"))
      (dict-set! env "*" (hk-make-binop-builtin "*" "*"))
      (dict-set! env "/" (hk-make-binop-builtin "/" "/"))
      (dict-set! env "==" (hk-make-binop-builtin "==" "=="))
      (dict-set! env "/=" (hk-make-binop-builtin "/=" "/="))
      (dict-set! env "<" (hk-make-binop-builtin "<" "<"))
      (dict-set! env "<=" (hk-make-binop-builtin "<=" "<="))
      (dict-set! env ">" (hk-make-binop-builtin ">" ">"))
      (dict-set! env ">=" (hk-make-binop-builtin ">=" ">="))
      (dict-set! env "&&" (hk-make-binop-builtin "&&" "&&"))
      (dict-set! env "||" (hk-make-binop-builtin "||" "||"))
      (dict-set! env "++" (hk-make-binop-builtin "++" "++"))
      (dict-set! env "mod" (hk-make-binop-builtin "mod" "mod"))
      (dict-set! env "div" (hk-make-binop-builtin "div" "div"))
      (dict-set! env "rem" (hk-make-binop-builtin "rem" "rem"))
      (dict-set! env "quot" (hk-make-binop-builtin "quot" "quot"))
      (dict-set! env "show" (hk-mk-lazy-builtin "show" hk-show-val 1))
      (hk-bind-exceptions! env)
      (hk-load-into! env hk-prelude-src)
      (begin
        (dict-set!
          env
          "putStrLn"
          (hk-mk-lazy-builtin
            "putStrLn"
            (fn
              (s)
              (begin
                (append! hk-io-lines (hk-force s))
                (list "IO" (list "Tuple"))))
            1))
        (dict-set!
          env
          "putStr"
          (hk-mk-lazy-builtin
            "putStr"
            (fn
              (s)
              (begin
                (append! hk-io-lines (hk-force s))
                (list "IO" (list "Tuple"))))
            1))
        (dict-set!
          env
          "getLine"
          (hk-mk-lazy-builtin
            "getLine"
            (fn
              ()
              (if
                (empty? hk-stdin-lines)
                (error "getLine: no more input")
                (let
                  ((line (first hk-stdin-lines)))
                  (begin
                    (set! hk-stdin-lines (rest hk-stdin-lines))
                    (list "IO" line)))))
            0))
        (dict-set!
          env
          "getContents"
          (hk-mk-lazy-builtin
            "getContents"
            (fn
              ()
              (let
                ((lines hk-stdin-lines))
                (begin
                  (set! hk-stdin-lines (list))
                  (list
                    "IO"
                    (if
                      (empty? lines)
                      ""
                      (reduce
                        (fn (acc s) (str acc "\n" s))
                        (first lines)
                        (rest lines)))))))
            0))
        (dict-set!
          env
          "readFile"
          (hk-mk-lazy-builtin
            "readFile"
            (fn
              (path)
              (let
                ((p (hk-force path)))
                (if
                  (has-key? hk-vfs p)
                  (list "IO" (get hk-vfs p))
                  (error (str "readFile: " p ": file not found")))))
            1))
        (dict-set!
          env
          "writeFile"
          (hk-mk-lazy-builtin
            "writeFile"
            (fn
              (path contents)
              (begin
                (dict-set! hk-vfs (hk-force path) (hk-force contents))
                (list "IO" (list "Tuple"))))
            2))
        (dict-set! env "sqrt" (hk-mk-builtin "sqrt" (fn (x) (sqrt x)) 1))
        (dict-set!
          env
          "floor"
          (hk-mk-builtin "floor" (fn (x) (floor x)) 1))
        (dict-set!
          env
          "ceiling"
          (hk-mk-builtin
            "ceiling"
            (fn (x) (let ((f (floor x))) (if (= x f) f (+ f 1))))
            1))
        (dict-set!
          env
          "round"
          (hk-mk-builtin "round" (fn (x) (round x)) 1))
        (dict-set!
          env
          "truncate"
          (hk-mk-builtin "truncate" (fn (x) (truncate x)) 1))
        (dict-set! env "recip" (hk-mk-builtin "recip" (fn (x) (/ 1 x)) 1))
        (dict-set!
          env
          "fromRational"
          (hk-mk-builtin "fromRational" (fn (x) x) 1))
        (dict-set! env "pi" 3.14159)
        (dict-set! env "exp" (hk-mk-builtin "exp" (fn (x) (exp x)) 1))
        (dict-set! env "log" (hk-mk-builtin "log" (fn (x) (log x)) 1))
        (dict-set! env "sin" (hk-mk-builtin "sin" (fn (x) (sin x)) 1))
        (dict-set! env "cos" (hk-mk-builtin "cos" (fn (x) (cos x)) 1))
        (let
          ((--sx-to-hk-- (fn (lst) (if (empty? lst) (list "[]") (list ":" (first lst) (--sx-to-hk-- (rest lst))))))
            (--words--
              (fn
                (s n i start acc)
                (if
                  (>= i n)
                  (let
                    ((w (substr s start (- n start))))
                    (reverse (if (= (len w) 0) acc (cons w acc))))
                  (let
                    ((c (char-code (nth s i))))
                    (if
                      (or (= c 32) (= c 9) (= c 10) (= c 13))
                      (if
                        (= i start)
                        (--words-- s n (+ i 1) (+ i 1) acc)
                        (--words--
                          s
                          n
                          (+ i 1)
                          (+ i 1)
                          (cons (substr s start (- i start)) acc)))
                      (--words-- s n (+ i 1) start acc))))))
            (--lines--
              (fn
                (s n i start acc)
                (if
                  (>= i n)
                  (if
                    (= start n)
                    (reverse acc)
                    (reverse (cons (substr s start (- n start)) acc)))
                  (let
                    ((c (char-code (nth s i))))
                    (if
                      (= c 10)
                      (--lines--
                        s
                        n
                        (+ i 1)
                        (+ i 1)
                        (cons (substr s start (- i start)) acc))
                      (--lines-- s n (+ i 1) start acc)))))))
          (dict-set!
            env
            "ord"
            (hk-mk-builtin
              "ord"
              (fn
                (c)
                (let ((v (hk-force c))) (if (number? v) v (char-code v))))
              1))
          (dict-set!
            env
            "isAlpha"
            (hk-mk-builtin
              "isAlpha"
              (fn
                (c)
                (let
                  ((v (hk-force c)))
                  (let
                    ((code (if (number? v) v (char-code v))))
                    (hk-of-bool
                      (or
                        (and (>= code 65) (<= code 90))
                        (and (>= code 97) (<= code 122)))))))
              1))
          (dict-set!
            env
            "isAlphaNum"
            (hk-mk-builtin
              "isAlphaNum"
              (fn
                (c)
                (let
                  ((v (hk-force c)))
                  (let
                    ((code (if (number? v) v (char-code v))))
                    (hk-of-bool
                      (or
                        (and (>= code 65) (<= code 90))
                        (and (>= code 97) (<= code 122))
                        (and (>= code 48) (<= code 57)))))))
              1))
          (dict-set!
            env
            "isDigit"
            (hk-mk-builtin
              "isDigit"
              (fn
                (c)
                (let
                  ((v (hk-force c)))
                  (let
                    ((code (if (number? v) v (char-code v))))
                    (hk-of-bool (and (>= code 48) (<= code 57))))))
              1))
          (dict-set!
            env
            "isSpace"
            (hk-mk-builtin
              "isSpace"
              (fn
                (c)
                (let
                  ((v (hk-force c)))
                  (let
                    ((code (if (number? v) v (char-code v))))
                    (hk-of-bool
                      (or (= code 32) (= code 9) (= code 10) (= code 13))))))
              1))
          (dict-set!
            env
            "isUpper"
            (hk-mk-builtin
              "isUpper"
              (fn
                (c)
                (let
                  ((v (hk-force c)))
                  (let
                    ((code (if (number? v) v (char-code v))))
                    (hk-of-bool (and (>= code 65) (<= code 90))))))
              1))
          (dict-set!
            env
            "isLower"
            (hk-mk-builtin
              "isLower"
              (fn
                (c)
                (let
                  ((v (hk-force c)))
                  (let
                    ((code (if (number? v) v (char-code v))))
                    (hk-of-bool (and (>= code 97) (<= code 122))))))
              1))
          (dict-set!
            env
            "chr"
            (hk-mk-builtin "chr" (fn (n) (char-from-code (hk-force n))) 1))
          (dict-set!
            env
            "toUpper"
            (hk-mk-builtin
              "toUpper"
              (fn
                (n)
                (let
                  ((code (hk-force n)))
                  (if (and (>= code 97) (<= code 122)) (- code 32) code)))
              1))
          (dict-set!
            env
            "toLower"
            (hk-mk-builtin
              "toLower"
              (fn
                (n)
                (let
                  ((code (hk-force n)))
                  (if (and (>= code 65) (<= code 90)) (+ code 32) code)))
              1))
          (dict-set!
            env
            "digitToInt"
            (hk-mk-builtin
              "digitToInt"
              (fn
                (c)
                (let
                  ((v (hk-force c)))
                  (- (if (number? v) v (char-code v)) 48)))
              1))
          (dict-set!
            env
            "words"
            (hk-mk-builtin
              "words"
              (fn
                (s)
                (let
                  ((str (hk-force s)))
                  (--sx-to-hk-- (--words-- str (len str) 0 0 (list)))))
              1))
          (dict-set!
            env
            "lines"
            (hk-mk-builtin
              "lines"
              (fn
                (s)
                (let
                  ((str (hk-force s)))
                  (if
                    (= (len str) 0)
                    (list "[]")
                    (--sx-to-hk-- (--lines-- str (len str) 0 0 (list))))))
              1))
          env)))))

(define
  hk-bind-data-map!
  (fn
    (env alias)
    (let
      ((p (str alias ".")))
      (begin
        (dict-set! env (str p "empty") hk-map-empty)
        (dict-set!
          env
          (str p "singleton")
          (hk-mk-lazy-builtin
            "Map.singleton"
            (fn (k v) (hk-map-singleton (hk-force k) (hk-force v)))
            2))
        (dict-set!
          env
          (str p "insert")
          (hk-mk-lazy-builtin
            "Map.insert"
            (fn
              (k v m)
              (hk-map-insert (hk-force k) (hk-force v) (hk-force m)))
            3))
        (dict-set!
          env
          (str p "lookup")
          (hk-mk-lazy-builtin
            "Map.lookup"
            (fn (k m) (hk-map-lookup (hk-force k) (hk-force m)))
            2))
        (dict-set!
          env
          (str p "member")
          (hk-mk-lazy-builtin
            "Map.member"
            (fn
              (k m)
              (hk-of-bool (hk-map-member (hk-force k) (hk-force m))))
            2))
        (dict-set!
          env
          (str p "size")
          (hk-mk-lazy-builtin
            "Map.size"
            (fn (m) (hk-map-size (hk-force m)))
            1))
        (dict-set!
          env
          (str p "null")
          (hk-mk-lazy-builtin
            "Map.null"
            (fn (m) (hk-of-bool (hk-map-null (hk-force m))))
            1))
        (dict-set!
          env
          (str p "delete")
          (hk-mk-lazy-builtin
            "Map.delete"
            (fn (k m) (hk-map-delete (hk-force k) (hk-force m)))
            2))
        (dict-set!
          env
          (str p "insertWith")
          (hk-mk-lazy-builtin
            "Map.insertWith"
            (fn
              (f k v m)
              (hk-map-insert-with
                (fn (a b) (hk-force (hk-apply (hk-apply f a) b)))
                (hk-force k)
                (hk-force v)
                (hk-force m)))
            4))
        (dict-set!
          env
          (str p "adjust")
          (hk-mk-lazy-builtin
            "Map.adjust"
            (fn
              (f k m)
              (hk-map-adjust
                (fn (v) (hk-force (hk-apply f v)))
                (hk-force k)
                (hk-force m)))
            3))
        (dict-set!
          env
          (str p "findWithDefault")
          (hk-mk-lazy-builtin
            "Map.findWithDefault"
            (fn
              (d k m)
              (let
                ((res (hk-map-lookup (hk-force k) (hk-force m))))
                (cond
                  ((= (first res) "Just") (nth res 1))
                  (:else (hk-force d)))))
            3))))))

(define
  hk-bind-data-set!
  (fn
    (env alias)
    (let
      ((p (str alias ".")))
      (begin
        (dict-set! env (str p "empty") hk-set-empty)
        (dict-set!
          env
          (str p "singleton")
          (hk-mk-lazy-builtin
            "Set.singleton"
            (fn (k) (hk-set-singleton (hk-force k)))
            1))
        (dict-set!
          env
          (str p "insert")
          (hk-mk-lazy-builtin
            "Set.insert"
            (fn (k s) (hk-set-insert (hk-force k) (hk-force s)))
            2))
        (dict-set!
          env
          (str p "delete")
          (hk-mk-lazy-builtin
            "Set.delete"
            (fn (k s) (hk-set-delete (hk-force k) (hk-force s)))
            2))
        (dict-set!
          env
          (str p "member")
          (hk-mk-lazy-builtin
            "Set.member"
            (fn
              (k s)
              (hk-of-bool (hk-set-member (hk-force k) (hk-force s))))
            2))
        (dict-set!
          env
          (str p "size")
          (hk-mk-lazy-builtin
            "Set.size"
            (fn (s) (hk-set-size (hk-force s)))
            1))
        (dict-set!
          env
          (str p "null")
          (hk-mk-lazy-builtin
            "Set.null"
            (fn (s) (hk-of-bool (hk-set-null (hk-force s))))
            1))
        (dict-set!
          env
          (str p "union")
          (hk-mk-lazy-builtin
            "Set.union"
            (fn (a b) (hk-set-union (hk-force a) (hk-force b)))
            2))
        (dict-set!
          env
          (str p "intersection")
          (hk-mk-lazy-builtin
            "Set.intersection"
            (fn (a b) (hk-set-intersection (hk-force a) (hk-force b)))
            2))
        (dict-set!
          env
          (str p "difference")
          (hk-mk-lazy-builtin
            "Set.difference"
            (fn (a b) (hk-set-difference (hk-force a) (hk-force b)))
            2))
        (dict-set!
          env
          (str p "isSubsetOf")
          (hk-mk-lazy-builtin
            "Set.isSubsetOf"
            (fn
              (a b)
              (hk-of-bool (hk-set-is-subset-of (hk-force a) (hk-force b))))
            2))))))

(define
  hk-bind-data-ioref!
  (fn
    (env alias)
    (let
      ((p (str alias ".")))
      (begin
        (dict-set!
          env
          (str p "newIORef")
          (hk-mk-lazy-builtin
            "IORef.newIORef"
            (fn
              (v)
              (let
                ((ref (dict)))
                (begin
                  (dict-set! ref "hk-ioref" true)
                  (dict-set! ref "hk-value" v)
                  (list "IO" ref))))
            1))
        (dict-set!
          env
          (str p "readIORef")
          (hk-mk-lazy-builtin
            "IORef.readIORef"
            (fn (r) (list "IO" (get (hk-force r) "hk-value")))
            1))
        (dict-set!
          env
          (str p "writeIORef")
          (hk-mk-lazy-builtin
            "IORef.writeIORef"
            (fn
              (r v)
              (begin
                (dict-set! (hk-force r) "hk-value" v)
                (list "IO" (list "Tuple"))))
            2))
        (dict-set!
          env
          (str p "modifyIORef")
          (hk-mk-lazy-builtin
            "IORef.modifyIORef"
            (fn
              (r f)
              (let
                ((ref (hk-force r)))
                (begin
                  (dict-set!
                    ref
                    "hk-value"
                    (hk-apply f (get ref "hk-value")))
                  (list "IO" (list "Tuple")))))
            2))
        (dict-set!
          env
          (str p "modifyIORef'")
          (hk-mk-lazy-builtin
            "IORef.modifyIORef'"
            (fn
              (r f)
              (let
                ((ref (hk-force r)))
                (begin
                  (dict-set!
                    ref
                    "hk-value"
                    (hk-deep-force (hk-apply f (get ref "hk-value"))))
                  (list "IO" (list "Tuple")))))
            2))))))

(define
  hk-strip-prefix
  (fn
    (s prefix)
    (let ((pl (string-length prefix)) (sl (string-length s)))
      (cond
        ((and (>= sl pl) (= (substr s 0 pl) prefix))
          (substr s pl (- sl pl)))
        (:else s)))))

(define
  hk-strip-quotes-once
  (fn
    (s)
    (let ((sl (string-length s)))
      (cond
        ((and (>= sl 2)
              (= (substr s 0 1) "\"")
              (= (substr s (- sl 1) 1) "\""))
          (substr s 1 (- sl 2)))
        ((and (>= sl 4)
              (= (substr s 0 2) "\\\"")
              (= (substr s (- sl 2) 2) "\\\""))
          (substr s 2 (- sl 4)))
        (:else s)))))

(define
  hk-strip-host-wrap-once
  (fn
    (s)
    (let ((s1 (hk-strip-prefix s "Unhandled exception: ")))
      (cond
        ((= s1 s) s)
        (:else (hk-strip-quotes-once s1))))))

(define
  hk-strip-host-wrap
  (fn
    (s)
    (let ((s1 (hk-strip-host-wrap-once s)))
      (cond
        ((= s1 s) s)
        (:else (hk-strip-host-wrap s1))))))

(define
  hk-exception-msg
  (fn
    (v)
    (let ((fv (hk-deep-force v)))
      (cond
        ((string? fv) fv)
        ((and (list? fv) (not (empty? fv))
              (= (first fv) "SomeException"))
          (let ((m (nth fv 1)))
            (if (string? m) m (str m))))
        (:else (str fv))))))

(define
  hk-exception-of
  (fn
    (e)
    (cond
      ((and (list? e) (not (empty? e))
            (= (first e) "hk-haskell-exception"))
        (nth e 1))
      ((string? e)
        (let ((s (hk-strip-host-wrap e)))
          (let ((s2 (hk-strip-prefix s "hk-error: ")))
            (list "SomeException" s2))))
      (:else (list "SomeException" (str e))))))

(define
  hk-bind-exceptions!
  (fn
    (env)
    (begin
      (dict-set! env "throwIO"
        (hk-mk-lazy-builtin "throwIO"
          (fn (e) (raise (str "hk-error: " (hk-exception-msg e))))
          1))
      (dict-set! env "throw"
        (hk-mk-lazy-builtin "throw"
          (fn (e) (raise (str "hk-error: " (hk-exception-msg e))))
          1))
      (dict-set! env "evaluate"
        (hk-mk-lazy-builtin "evaluate"
          (fn (x)
            (let ((v (hk-deep-force x)))
              (list "IO" v)))
          1))
      (dict-set! env "catch"
        (hk-mk-lazy-builtin "catch"
          (fn (action handler)
            (let
              ((outcome
                 (guard
                   (e (true (list "exn" e)))
                   (list "ok" (hk-force action)))))
              (cond
                ((= (first outcome) "ok") (nth outcome 1))
                (:else
                  (let ((some-ex (hk-exception-of (nth outcome 1))))
                    (hk-force (hk-apply (hk-force handler) some-ex)))))))
          2))
      (dict-set! env "try"
        (hk-mk-lazy-builtin "try"
          (fn (action)
            (guard
              (e (true
                   (list "IO" (list "Left" (hk-exception-of e)))))
              (let ((io-val (hk-force action)))
                (cond
                  ((and (list? io-val) (= (first io-val) "IO"))
                    (list "IO" (list "Right" (nth io-val 1))))
                  (:else
                    (raise "try: action did not produce IO"))))))
          1))
      (dict-set! env "handle"
        (hk-mk-lazy-builtin "handle"
          (fn (handler action)
            (let
              ((outcome
                 (guard
                   (e (true (list "exn" e)))
                   (list "ok" (hk-force action)))))
              (cond
                ((= (first outcome) "ok") (nth outcome 1))
                (:else
                  (let ((some-ex (hk-exception-of (nth outcome 1))))
                    (hk-force (hk-apply (hk-force handler) some-ex)))))))
          2))
      (dict-set! env "displayException"
        (hk-mk-lazy-builtin "displayException"
          (fn (e)
            (let ((v (hk-force e)))
              (cond
                ((and (list? v) (not (empty? v))
                      (= (first v) "SomeException"))
                  (hk-deep-force (nth v 1)))
                (:else (str v)))))
          1)))))

(define
  hk-bind-decls!
  (fn
    (env decls)
    (let
      ((groups (dict)) (group-order (list)) (pat-binds (list)))
      (for-each
        (fn
          (d)
          (cond
            ((= (first d) "fun-clause")
              (let
                ((name (nth d 1)))
                (when
                  (not (has-key? groups name))
                  (append! group-order name))
                (dict-set!
                  groups
                  name
                  (append
                    (if (has-key? groups name) (get groups name) (list))
                    (list (list (nth d 2) (nth d 3)))))
                (when (not (has-key? env name)) (dict-set! env name nil))))
            ((or (= (first d) "bind") (= (first d) "pat-bind"))
              (append! pat-binds d))
            ((= (first d) "class-decl")
              (let
                ((cls (nth d 1))
                  (tvar (nth d 2))
                  (method-decls (nth d 3)))
                (dict-set! env (str "__class__" cls) (list "class" cls tvar))
                (for-each
                  (fn
                    (m)
                    (when
                      (= (first m) "type-sig")
                      (for-each
                        (fn
                          (mname)
                          (dict-set!
                            env
                            mname
                            (hk-mk-lazy-builtin
                              mname
                              (fn
                                (x)
                                (let
                                  ((tv (hk-force x)))
                                  (let
                                    ((key (str "dict" cls "_" (hk-runtime-type tv))))
                                    (if
                                      (has-key? env key)
                                      (let
                                        ((inst (get env key)))
                                        (if
                                          (has-key? inst mname)
                                          (hk-apply (get inst mname) x)
                                          (if
                                            (has-key?
                                              env
                                              (str "__default__" cls "_" mname))
                                            (hk-apply
                                              (get
                                                env
                                                (str
                                                  "__default__"
                                                  cls
                                                  "_"
                                                  mname))
                                              x)
                                            (raise
                                              (str
                                                "No method "
                                                mname
                                                " in instance "
                                                cls
                                                " for "
                                                (hk-runtime-type tv))))))
                                      (if
                                        (has-key?
                                          env
                                          (str "__default__" cls "_" mname))
                                        (hk-apply
                                          (get
                                            env
                                            (str "__default__" cls "_" mname))
                                          x)
                                        (raise
                                          (str
                                            "No instance "
                                            cls
                                            " for "
                                            (hk-runtime-type tv))))))))
                              1)))
                        (nth m 1))))
                  method-decls)
                (for-each
                  (fn
                    (m)
                    (when
                      (= (first m) "fun-clause")
                      (let
                        ((mname (nth m 1))
                          (pats (nth m 2))
                          (body (nth m 3)))
                        (dict-set!
                          env
                          (str "__default__" cls "_" mname)
                          (if
                            (empty? pats)
                            (hk-eval body env)
                            (hk-eval (list "lambda" pats body) env))))))
                  method-decls)))
            ((= (first d) "instance-decl")
              (let
                ((cls (nth d 1))
                  (inst-type (nth d 2))
                  (method-decls (nth d 3)))
                (let
                  ((inst-dict (dict))
                    (type-str (hk-type-ast-str inst-type)))
                  (for-each
                    (fn
                      (m)
                      (when
                        (= (first m) "fun-clause")
                        (let
                          ((mname (nth m 1))
                            (pats (nth m 2))
                            (body (nth m 3)))
                          (dict-set!
                            inst-dict
                            mname
                            (if
                              (empty? pats)
                              (hk-eval body env)
                              (hk-eval (list "lambda" pats body) env))))))
                    method-decls)
                  (dict-set! env (str "dict" cls "_" type-str) inst-dict)
                  (dict-set!
                    env
                    (str "dict" cls "_" (hk-type-to-runtime-key type-str))
                    inst-dict))))
            ((= (first d) "data")
              (let
                ((deriving-list (if (> (len d) 4) (nth d 4) (list))))
                (when
                  (not (empty? deriving-list))
                  (let
                    ((cons-list (nth d 3)))
                    (for-each
                      (fn
                        (cls)
                        (for-each
                          (fn
                            (cdef)
                            (let
                              ((con-name (nth cdef 1)))
                              (cond
                                ((= cls "Show")
                                  (let
                                    ((inst-dict (dict)))
                                    (dict-set!
                                      inst-dict
                                      "show"
                                      (hk-mk-lazy-builtin "show" hk-show-val 1))
                                    (dict-set!
                                      env
                                      (str "dictShow_" con-name)
                                      inst-dict)))
                                ((= cls "Eq")
                                  (let
                                    ((inst-dict (dict)))
                                    (dict-set!
                                      inst-dict
                                      "=="
                                      (hk-mk-builtin
                                        "=="
                                        (fn
                                          (x y)
                                          (hk-of-bool
                                            (=
                                              (hk-deep-force x)
                                              (hk-deep-force y))))
                                        2))
                                    (dict-set!
                                      inst-dict
                                      "/="
                                      (hk-mk-builtin
                                        "/="
                                        (fn
                                          (x y)
                                          (hk-of-bool
                                            (not
                                              (=
                                                (hk-deep-force x)
                                                (hk-deep-force y)))))
                                        2))
                                    (dict-set!
                                      env
                                      (str "dictEq_" con-name)
                                      inst-dict))))))
                          cons-list))
                      deriving-list)))))
            ((or (= (first d) ":import") (= (first d) "import"))
              (let
                ((modname (nth d 2)) (as-name (nth d 3)))
                (let
                  ((alias (cond ((not (nil? as-name)) as-name) ((= modname "Data.Map") "Map") ((= modname "Data.Set") "Set") ((= modname "Data.IORef") "IORef") (:else modname))))
                  (cond
                    ((= modname "Data.Map") (hk-bind-data-map! env alias))
                    ((= modname "Data.Set") (hk-bind-data-set! env alias))
                    ((= modname "Data.IORef")
                      (hk-bind-data-ioref! env alias))
                    (:else nil)))))
            (:else nil)))
        decls)
      (let
        ((zero-arity (list)))
        (for-each
          (fn
            (name)
            (let
              ((clauses (get groups name)))
              (let
                ((arity (len (first (first clauses)))))
                (cond
                  ((> arity 0)
                    (dict-set! env name (hk-mk-multifun arity clauses env)))
                  (:else (append! zero-arity name))))))
          group-order)
        (for-each
          (fn
            (name)
            (let
              ((clauses (get groups name)))
              (dict-set!
                env
                name
                (hk-mk-thunk (first (rest (first clauses))) env))))
          zero-arity)
        (for-each
          (fn
            (d)
            (let
              ((pat (nth d 1)) (body (nth d 2)))
              (let
                ((val (hk-eval body env)))
                (let
                  ((res (hk-match pat val env)))
                  (cond
                    ((nil? res) (raise "top-level pattern bind failure"))
                    (:else (hk-extend-env-with-match! env res)))))))
          pat-binds))
      env)))

(define
  hk-eval-program
  (fn
    (ast)
    (cond
      ((nil? ast) (raise "eval-program: nil ast"))
      ((not (list? ast)) (raise "eval-program: not a list"))
      (:else
        (do
          (hk-register-program! ast)
          (let
            ((env (hk-dict-copy hk-env0)))
            (let
              ((imports (cond ((= (first ast) "module") (nth ast 3)) (:else (list))))
                (decls
                  (cond
                    ((= (first ast) "program") (nth ast 1))
                    ((= (first ast) "module") (nth ast 4))
                    (:else (raise "eval-program: bad shape")))))
              (begin (hk-bind-decls! env imports) (hk-bind-decls! env decls)))))))))

(define
  hk-run
  (fn
    (src)
    (let
      ((env (hk-eval-program (hk-core src))))
      (cond ((has-key? env "main") (get env "main")) (:else env)))))

(define hk-io-lines (list))

(define
  hk-run-io
  (fn
    (src)
    (do
      (set! hk-io-lines (list))
      (guard
        (e (true (append! hk-io-lines (if (string? e) e (str e)))))
        (hk-deep-force (hk-run src)))
      hk-io-lines)))

(define hk-stdin-lines (list))

(define hk-vfs (dict))

(define
  hk-run-io-with-input
  (fn
    (src stdin-lines)
    (begin
      (set! hk-io-lines (list))
      (set! hk-stdin-lines stdin-lines)
      (guard
        (e (true (append! hk-io-lines (if (string? e) e (str e)))))
        (hk-deep-force (hk-run src)))
      hk-io-lines)))

(define hk-env0 (hk-init-env))

(define
  hk-eval-expr-source
  (fn
    (src)
    (hk-deep-force (hk-eval (hk-core-expr src) (hk-dict-copy hk-env0)))))

(define
  hk-type-ast-str
  (fn
    (ast)
    (cond
      ((= (first ast) "t-con") (nth ast 1))
      ((= (first ast) "t-var") (nth ast 1))
      ((= (first ast) "t-list")
        (str "[" (hk-type-ast-str (nth ast 1)) "]"))
      ((= (first ast) "t-app")
        (str
          (hk-type-ast-str (nth ast 1))
          " "
          (hk-type-ast-str (nth ast 2))))
      (:else "?"))))

(define
  hk-runtime-type
  (fn
    (val)
    (let
      ((t (type-of val)))
      (cond
        ((= t "number") "number")
        ((= t "boolean") "boolean")
        ((= t "string") "string")
        ((and (= t "list") (not (empty? val)))
          (let
            ((tag (str (first val))))
            (cond
              ((or (= tag "True") (= tag "False")) "Bool")
              (:else tag))))
        (:else t)))))

(define
  hk-type-to-runtime-key
  (fn
    (ts)
    (cond
      ((= ts "Int") "number")
      ((= ts "Float") "number")
      ((= ts "Bool") "Bool")
      ((= ts "String") "string")
      ((= ts "Char") "string")
      (:else ts))))

(define
  hk-typecheck
  (fn
    (prog)
    (let
      ((results (hk-infer-prog prog (hk-type-env0))))
      (let
        ((errors (filter (fn (r) (= (first r) "err")) results)))
        (when (not (empty? errors)) (raise (nth (first errors) 1)))))))

(define
  hk-run-typed
  (fn
    (src)
    (let
      ((prog (hk-core src)))
      (begin
        (hk-typecheck prog)
        (let
          ((env (hk-eval-program prog)))
          (cond ((has-key? env "main") (get env "main")) (:else env)))))))
