;; Top-level declarations: function clauses, type signatures, data,
;; type, newtype, fixity. Driven by hk-parse-top which produces
;; a (:program DECLS) node.

(define
  hk-prog
  (fn
    (&rest decls)
    (list :program decls)))

;; ── Function clauses & pattern bindings ──
(hk-test
  "simple fun-clause"
  (hk-parse-top "f x = x + 1")
  (hk-prog
    (list
      :fun-clause
      "f"
      (list (list :p-var "x"))
      (list :op "+" (list :var "x") (list :int 1)))))

(hk-test
  "nullary decl"
  (hk-parse-top "answer = 42")
  (hk-prog
    (list :fun-clause "answer" (list) (list :int 42))))

(hk-test
  "multi-clause fn (separate defs for each pattern)"
  (hk-parse-top "fact 0 = 1\nfact n = n")
  (hk-prog
    (list :fun-clause "fact" (list (list :p-int 0)) (list :int 1))
    (list
      :fun-clause
      "fact"
      (list (list :p-var "n"))
      (list :var "n"))))

(hk-test
  "constructor pattern in fn args"
  (hk-parse-top "fromJust (Just x) = x")
  (hk-prog
    (list
      :fun-clause
      "fromJust"
      (list (list :p-con "Just" (list (list :p-var "x"))))
      (list :var "x"))))

(hk-test
  "pattern binding at top level"
  (hk-parse-top "(a, b) = pair")
  (hk-prog
    (list
      :pat-bind
      (list
        :p-tuple
        (list (list :p-var "a") (list :p-var "b")))
      (list :var "pair"))))

;; ── Type signatures ──
(hk-test
  "single-name sig"
  (hk-parse-top "f :: Int -> Int")
  (hk-prog
    (list
      :type-sig
      (list "f")
      (list :t-fun (list :t-con "Int") (list :t-con "Int")))))

(hk-test
  "multi-name sig"
  (hk-parse-top "f, g, h :: Int -> Bool")
  (hk-prog
    (list
      :type-sig
      (list "f" "g" "h")
      (list :t-fun (list :t-con "Int") (list :t-con "Bool")))))

(hk-test
  "sig with type application"
  (hk-parse-top "f :: Maybe a -> a")
  (hk-prog
    (list
      :type-sig
      (list "f")
      (list
        :t-fun
        (list :t-app (list :t-con "Maybe") (list :t-var "a"))
        (list :t-var "a")))))

(hk-test
  "sig with list type"
  (hk-parse-top "len :: [a] -> Int")
  (hk-prog
    (list
      :type-sig
      (list "len")
      (list
        :t-fun
        (list :t-list (list :t-var "a"))
        (list :t-con "Int")))))

(hk-test
  "sig with tuple and right-assoc ->"
  (hk-parse-top "pair :: a -> b -> (a, b)")
  (hk-prog
    (list
      :type-sig
      (list "pair")
      (list
        :t-fun
        (list :t-var "a")
        (list
          :t-fun
          (list :t-var "b")
          (list
            :t-tuple
            (list (list :t-var "a") (list :t-var "b"))))))))

(hk-test
  "sig + implementation together"
  (hk-parse-top "id :: a -> a\nid x = x")
  (hk-prog
    (list
      :type-sig
      (list "id")
      (list :t-fun (list :t-var "a") (list :t-var "a")))
    (list
      :fun-clause
      "id"
      (list (list :p-var "x"))
      (list :var "x"))))

;; ── data declarations ──
(hk-test
  "data Maybe"
  (hk-parse-top "data Maybe a = Nothing | Just a")
  (hk-prog
    (list
      :data
      "Maybe"
      (list "a")
      (list
        (list :con-def "Nothing" (list))
        (list :con-def "Just" (list (list :t-var "a")))))))

(hk-test
  "data Either"
  (hk-parse-top "data Either a b = Left a | Right b")
  (hk-prog
    (list
      :data
      "Either"
      (list "a" "b")
      (list
        (list :con-def "Left" (list (list :t-var "a")))
        (list :con-def "Right" (list (list :t-var "b")))))))

(hk-test
  "data with no type parameters"
  (hk-parse-top "data Bool = True | False")
  (hk-prog
    (list
      :data
      "Bool"
      (list)
      (list
        (list :con-def "True" (list))
        (list :con-def "False" (list))))))

(hk-test
  "recursive data type"
  (hk-parse-top "data Tree a = Leaf | Node (Tree a) a (Tree a)")
  (hk-prog
    (list
      :data
      "Tree"
      (list "a")
      (list
        (list :con-def "Leaf" (list))
        (list
          :con-def
          "Node"
          (list
            (list :t-app (list :t-con "Tree") (list :t-var "a"))
            (list :t-var "a")
            (list :t-app (list :t-con "Tree") (list :t-var "a"))))))))

;; ── type synonyms ──
(hk-test
  "simple type synonym"
  (hk-parse-top "type Name = String")
  (hk-prog
    (list :type-syn "Name" (list) (list :t-con "String"))))

(hk-test
  "parameterised type synonym"
  (hk-parse-top "type Pair a = (a, a)")
  (hk-prog
    (list
      :type-syn
      "Pair"
      (list "a")
      (list
        :t-tuple
        (list (list :t-var "a") (list :t-var "a"))))))

;; ── newtype ──
(hk-test
  "newtype"
  (hk-parse-top "newtype Age = Age Int")
  (hk-prog (list :newtype "Age" (list) "Age" (list :t-con "Int"))))

(hk-test
  "parameterised newtype"
  (hk-parse-top "newtype Wrap a = Wrap a")
  (hk-prog
    (list :newtype "Wrap" (list "a") "Wrap" (list :t-var "a"))))

;; ── fixity declarations ──
(hk-test
  "infixl with precedence"
  (hk-parse-top "infixl 5 +:, -:")
  (hk-prog (list :fixity "l" 5 (list "+:" "-:"))))

(hk-test
  "infixr"
  (hk-parse-top "infixr 9 .")
  (hk-prog (list :fixity "r" 9 (list "."))))

(hk-test
  "infix (non-assoc) default prec"
  (hk-parse-top "infix ==")
  (hk-prog (list :fixity "n" 9 (list "=="))))

(hk-test
  "fixity with backtick operator name"
  (hk-parse-top "infixl 7 `div`")
  (hk-prog (list :fixity "l" 7 (list "div"))))

;; ── Several decls combined ──
(hk-test
  "mixed: data + sig + fn + type"
  (hk-parse-top "data Maybe a = Nothing | Just a\ntype Entry = Maybe Int\nf :: Entry -> Int\nf (Just x) = x\nf Nothing = 0")
  (hk-prog
    (list
      :data
      "Maybe"
      (list "a")
      (list
        (list :con-def "Nothing" (list))
        (list :con-def "Just" (list (list :t-var "a")))))
    (list
      :type-syn
      "Entry"
      (list)
      (list :t-app (list :t-con "Maybe") (list :t-con "Int")))
    (list
      :type-sig
      (list "f")
      (list :t-fun (list :t-con "Entry") (list :t-con "Int")))
    (list
      :fun-clause
      "f"
      (list (list :p-con "Just" (list (list :p-var "x"))))
      (list :var "x"))
    (list
      :fun-clause
      "f"
      (list (list :p-con "Nothing" (list)))
      (list :int 0))))

{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}