(use testament)
(import /fugue)

(def tab @{})

(deftest table-not-a-proto
  (is (not (fugue/prototype? tab))))

(defn- proto-tests [proto]
  (is (fugue/prototype? proto))
  (is (fugue/Root? proto))
  (is (fugue/Root*? proto))
  (is (= fugue/Root (table/getproto proto))))

(defmacro- inst-tests [proto inst]
  @[~(is ,(symbol proto "?") ,inst)
    ~(is ,(symbol proto "*?") ,inst)
    ~(is (not (fugue/prototype? ,inst)))
    ~(is (= ,proto (table/getproto ,inst)))])

(defmacro- accessor-tests [accessor objs &opt refute]
  ~(each obj ,objs (is (,(if refute not= =) (,accessor obj) (obj ,(keyword accessor))))))

(fugue/defproto Animal ())

(deftest base-defproto
  (proto-tests Animal)
  (let [an-animal (:new Animal)]
    (inst-tests Animal an-animal)))

(deftest constructor
  (let [cat (:new Animal :name "Bowler Cat")]
    (inst-tests Animal cat)
    (is (= "Bowler Cat" (cat :name)))))

(deftest new-form
  (let [an-animal (new-Animal)]
    (inst-tests Animal an-animal)))

(fugue/defproto Human () name {:default "John Doe"})

(deftest defaults
  (proto-tests Human)
  (let [a-human (:new Human)]
    (inst-tests Human a-human)
    # The default value has been set on the instance
    (is (= "John Doe" (a-human :name)))
    # But it's not on the Prototype.
    (is (nil? (Human :name)))
    (is (== @[:name] (fugue/fields Human)))
    (is (== @[:name] (fugue/fields a-human)))
    (accessor-tests name [a-human Human])))

(fugue/defproto Light () speed {:default math/inf})

(deftest symbol-defaults
  (proto-tests Light)
  (let [a-light (:new Light)]
    (inst-tests Light a-light)
    (is (number? (a-light :speed)))))

(fugue/defproto Stack () data {})
(fugue/defmethod _init Stack [self] (put self :data @[]))

(deftest mutable-default-fns
  (let [a-stack (:new Stack)
        b-stack (:new Stack)]
    (array/push (a-stack :data) :ok)
    (is (empty? (b-stack :data)))))

(fugue/defproto SharingStack () data {:default @[]})

(deftest mutable-defaults
  (let [a-stack (:new SharingStack)
        b-stack (:new SharingStack)]
    (array/push (a-stack :data) :ok)
    (is (== @[:ok] (b-stack :data)))))

(def inner-stack @[])
(fugue/defproto DeepStack () data {})
(fugue/defmethod _init DeepStack [self] (put self :data @[inner-stack]))

(deftest inner-references-are-not-copied
  (let [a-stack (:new DeepStack)
        b-stack (:new DeepStack)]
    (put-in a-stack [:data 0 0] :ok)
    (is (== @[@[:ok]] (b-stack :data)))))

(fugue/defproto Container () capacity {:init? true})

(deftest init
  (proto-tests Container)
  (is (thrown? (:new Container)))
  (let [a-container (:new Container 500)]
    (inst-tests Container a-container)
    (is (= 500 (a-container :capacity)))
    (accessor-tests capacity [a-container Container])))

(fugue/defproto Concat () left {:init? true} right {:init? true})

(deftest multi-inits
  (is (thrown? (:new Concat "left"))))

(fugue/defproto Citizen () president {:allocation :prototype})

(deftest allocation
  (proto-tests Citizen)
  (let [a-citizen (:new Citizen)
        another-citizen (:new Citizen)]
    (inst-tests Citizen a-citizen)
    (fugue/allocate a-citizen :president "The Next Guy")
    # Allocating a field on one instance sets the value on the
    # prototype, and thus is inherited by all instances.
    (is (= "The Next Guy" (Citizen :president)))
    (is (= "The Next Guy" (another-citizen :president)))
    (accessor-tests president [a-citizen another-citizen Citizen])))

(fugue/defproto Editor () mode {:allocate-value "vi"})
(fugue/defproto Light () speed {:allocate-value math/inf})
(fugue/defproto Physics () light {:allocate-value Light})

(deftest allocate-value
  (proto-tests Editor)
  (let [an-editor (:new Editor)
        another-editor (:new Editor)
        some-light (:new Light)
        a-physics (:new Physics)]
    (inst-tests Editor an-editor)
    (fugue/allocate an-editor :mode "emacs")
    # The prototype has been allocated a value for `:mode`, which is
    # inherited; but allocating a new value to an instance shadows, it
    # doesn't overwrite.
    (is (= "vi" (Editor :mode)))
    (is (= "vi" (another-editor :mode)))
    (is (= "emacs" (an-editor :mode)))
    (accessor-tests mode [an-editor another-editor Editor])
    (is (= :number (type (some-light :speed))))
    (is (> (some-light :speed) 0))
    (is (= Light (a-physics :light)))))

(fugue/defproto Dog ()
                name {:allocate-value "Fido"}
                collar-color {:default "blue"})
(fugue/defproto Pekingese Dog
                size {:default "Extremely Small"})

(deftest inheritance
  (is (= Dog (table/getproto Pekingese)))

  (let [a-pekingese (:new Pekingese)]

    (inst-tests Pekingese a-pekingese)
    (accessor-tests name [a-pekingese Dog Pekingese])
    (accessor-tests size [a-pekingese Pekingese])

    (is (thrown? (size Dog)))
    (is (= "Fido" (name a-pekingese)))
    (is (= "Fido" (a-pekingese (fugue/@ Pekingese :name))))

    (is (= "Extremely Small" (size a-pekingese)))

    (is (Pekingese? a-pekingese))

    (is (Dog? Pekingese))
    (is (not (Dog? a-pekingese)))

    (is (Dog*? a-pekingese))
    (is (Dog*? Pekingese))

    (is (= "blue" (collar-color a-pekingese)))
    (is (= "blue" (a-pekingese (fugue/@ Pekingese :collar-color))))))

(fugue/defproto Form () unique-field {:getter get-unique-field})

(deftest getter
  (let [a-form (:new Form :unique-field :echo)
        a-dog (:new Dog)]
    (is (nil? (dyn 'unique-field)))
    (is (= :echo (get-unique-field a-form)))
    (is (= :echo (a-form (fugue/@ Form :unique-field))))
    (is (thrown? (apply fugue/@ '[Dog :unique-field])))))

(fugue/defproto Form2 () second-unique-field {:getter false})

(deftest no-getter
  (let [a-form (:new Form :second-unique-field :echo)]
    (is (nil? (dyn 'second-unique-field)))))

(fugue/defproto Caster ())
(fugue/defmethod _init Caster [inst] (freeze inst))

(deftest after-init
  (let [casted (:new Caster)]
    (is (not (table? casted)))
    (is (struct? casted))))

(fugue/defgeneric do-nothing [_] :ok)
(fugue/defgeneric raise [_])
(fugue/defgeneric shout [x] (string x "!"))

(deftest generics
  (let [shouting-Dog (:new Dog)]
    (put shouting-Dog :shout (fn [self] (string (name self) "!")))

    (is (= :ok (do-nothing :ok)))
    (is (thrown? (raise :ok)))
    (is (= "hi!" (shout "hi")))
    (is (= "Fido!" (shout shouting-Dog)))))

(fugue/defgeneric informative-function
                  "gives you useful information"
                  [x]
                  (+ x 1))

(deftest generic-docstrings
  (is (= 2 (informative-function 1)))
  (is (string/has-suffix? "gives you useful information" ((dyn 'informative-function) :doc))))

(fugue/defmethod speak Dog [self] (string "My name is " (self :name)))
(fugue/defmethod speak Pekingese [self] (string (__super self) " and I am " (self :size)))

(deftest methods
  (let [a-pekingese (:new Pekingese)]
    (is (= "My name is Fido and I am Extremely Small" (speak a-pekingese)))
    (is (thrown? (speak (:new Editor))))))

(fugue/defmethod speak2 Dog [self speech] (string "Speak the speech, " speech))

(deftest n-arg methods
  (let [a-dog (:new Dog)]
    (is (= "Speak the speech, I am a dog." (speak2 a-dog "I am a dog.")))))

(fugue/defmethod eat Dog
                 [self & objects]
                 (string (self :name) " eats all of " (string/join objects ", ")))

(deftest ampersand
  (let [a-dog (:new Dog)]
    (is (= "Fido eats all of ball, shoe" (eat a-dog "ball" "shoe")))))

(fugue/defmulti add [Animal] [f] (put f :value 1))
(fugue/defmulti add [:number] [x] (+ x 1))
(fugue/defmulti add [:string] [s] (string s "!"))

(deftest multimethods
  (let [an-animal (:new Animal)]
    (add an-animal)
    (is (= 11 (add 10)))
    (is (= "s!" (add "s")))
    (is (= 1 (an-animal :value)))))

(fugue/defmulti cat [:string _] [s1 s2] (string s1 s2))
(fugue/defmulti cat [:string :number] [s n] (string s " #" n))
(fugue/defmulti cat [_ :number] [m n] (+ m n))
(fugue/defmulti cat [_ _] [x y] (string/format "Falling back to %q<>%q" x y))

(deftest multi-specialization
  # [:string :string] matches [:string :_]
  (is (= "hello world" (cat "hello " @"world")))
  # [:string :number] matches [:string :_] and [:_ :number], but
  # [:string :number] is more specific
  (is (= "hello #100" (cat "hello" 100)))
  # [:number :number] matches [:_ :number]}
  (is (= 9 (cat 4 5)))
  # [:_ :_] will never match before a more specific typing
  (is (= "Falling back to @\"x\"<>@\"y\"" (cat @"x" @"y"))))

(fugue/defmulti cat2 [_ :number] [n m] (+ n m))
(fugue/defmulti cat2 [:string _] [s s2] (string s "+" s2))

(deftest positional-specialization
  # Both [:_ :number] and [:string :_] match, but where there are
  # multiple matches, choose the typing with the more specific term in
  # the earliest position.
  (is (= "x+2" (cat2 "x" 2))))

(fugue/defproto Stack ())
(fugue/defproto Operation ())

(fugue/defmulti push [Stack _] [_ _] :fallback)
(fugue/defmulti push [Stack Operation] [_ _] :pattern-match)

(deftest proto-specialization
  (let [s (:new Stack)
        add (:new Operation)]
    (is (= :fallback (push s 5)))
    (is (= :pattern-match (push s add)))))

(fugue/defmulti to-string [:number] [n] (string "+" n))
(do
  (fugue/defmulti to-string [:string] [s] (string s "!")))

(fugue/declare-open-multi to-string2)
(do
  (fugue/extend-multi to-string2 [:number] [n] (string "+" n))
  (fugue/extend-multi to-string2 [:string] [s] (string s "!")))

(deftest open-multimethods
  # normal multimethods obey scoping rules; a scoped def is not
  # available in enclosing (or adjacent) environments.
  (is (= "+10" (to-string 10)))
  (is (thrown? (to-string "s")))

  # open methods can be extended from other scopes.
  (is (= "s!" (to-string2 "s")))
  (is (= "+10" (to-string2 10))))

(fugue/declare-open-multi to-string3)
(defn inner-f [] :ok)
(fugue/extend-multi to-string3 [:number] [n] (inner-f))
(defn inner-f [] :notok)
(fugue/extend-multi to-string3 [:string] [n] "trigger redefinition of to-string3")

(deftest multi-closures
  (is (= :ok (to-string3 10))))

(deftest multimethod-type-validation
  (is (thrown? (apply fugue/defmulti ['bongo ["ok"] ['x] :ok]))))

(def bare-table @{})
(def child (table/setproto @{} bare-table))
(fugue/defmulti match-on-table [bare-table] [_] :ok)

(deftest table-multimethod
  (is (= :ok (match-on-table child)))
  (is (thrown? (match-on-table @{}))))

(deftest new-root
  (let [a-root (:new fugue/Root)]
    (inst-tests fugue/Root a-root)))

(deftest defproto-in-test
  (fugue/defproto InTest ())
  (proto-tests InTest)
  (let [a-in-test (:new InTest)]
    (inst-tests InTest a-in-test)))

(deftest defproto-child-in-test
  (fugue/defproto InTestParent nil)
  (fugue/defproto InTestChild InTestParent)

  (is (InTestParent? InTestChild))
  (is (InTestChild? (new-InTestChild))))

(deftest value-in-test
  (def some-particular-name "Wonkus")
  (def some-particular-table @{})
  (fugue/defproto ValueInTest nil name {:default some-particular-name})
  (fugue/defproto MutableValueInTest nil tab {:default some-particular-table})
  (is (= "Wonkus" ((new-ValueInTest) :name)))
  (is (= some-particular-table ((new-MutableValueInTest) :tab))))

(deftest allocation-in-test
  (def some-particular-name "Wonkus")
  (def some-particular-table @{})
  (fugue/defproto ValueInTest nil name {:allocate-value some-particular-name})
  (fugue/defproto MutableValueInTest nil tab {:allocate-value some-particular-table})
  (is (= "Wonkus" (ValueInTest :name)))
  (is (= some-particular-table (MutableValueInTest :tab))))

(deftest proto-attributes
  (fugue/defproto BasicConstructor nil)
  (fugue/defproto NameConstructor nil {:constructor another-name})
  (fugue/defproto NoConstructor nil {:constructor false})

  (is (BasicConstructor? (new-BasicConstructor)))
  (is (== @[] (fugue/fields BasicConstructor)))
  (is (NameConstructor? (another-name)))
  (is (== @[] (fugue/fields NameConstructor)))
  (is (nil? (dyn 'new-NoConstructor)))
  (is (== @[] (fugue/fields NoConstructor))))

(deftest defgeneric-in-test
  (fugue/defgeneric in-test [x] (string x " ok"))
  (is (= "a ok" (in-test "a"))))

(deftest defmethod-in-test
  (fugue/defproto HasMethod () name {})
  (fugue/defmethod in-test HasMethod [m] (m :name))
  (let [a-has-method (:new HasMethod :name "dobby")]
    (is (= "dobby" (in-test a-has-method)))))

(fugue/defproto ToShadowField nil name {})

(deftest defmethod-warning
  (def buffer @[])
  (with-dyns [:macro-lints buffer]
    (apply fugue/defmethod '[name ToShadowField [x] "ok"]))

  (let [[[level l c msg]] buffer]
    (is (== :normal level))
    (is (==
         "you are defining a method named name on the prototype ToShadowField; there is a field of the same name on that prototype."
         msg))))

# Define generic so we get a clean stdout
(fugue/defgeneric height [x] :ok)

(deftest defmethod-warning-in-test
  (fugue/defproto ShadowInTest nil height {})

  (def buffer @[])
  (with-dyns [:macro-lints buffer]
    (apply fugue/defmethod '[height ShadowInTest [x] "ok"]))

  (let [[[level l c msg]] buffer]
    (is (== :normal level))
    (is (==
         "you are defining a method named height on the prototype ShadowInTest; there is a field of the same name on that prototype."
         msg))))

(deftest defmulti-in-test
  (fugue/defmulti in-test-multi [:number] [n] (inc n))
  (is (= 2 (in-test-multi 1))))

(deftest extend-multi-in-test
  (fugue/declare-open-multi open-in-test)
  (fugue/extend-multi open-in-test [:number] [n] (inc n))
  (is (= 2 (open-in-test 1))))

(fugue/declare-open-multi open-headless)

(deftest open-defaults
  (is (thrown? (open-headless))))

(fugue/defproto SlotHaver () name {})

(deftest slots-test
  (let [a-slot-haver (:new SlotHaver)]
    (def res (fugue/with-slots SlotHaver a-slot-haver
                               (set (@ name) "will shortz")
                               (is (= "will shortz" (@ name)))
                               (is (= "will shortz" (@ :name)))
                               (is (= "will shortz" (name @)))))
    (is (= res a-slot-haver))
    (is (= "will shortz" (a-slot-haver :name)))))

(deftest slots-as-test
  (let [a-slot-haver (:new SlotHaver)]
    (def res (fugue/with-slots-as SlotHaver a-slot-haver s
                                  (set (s name) "will shortz")
                                  (is (= "will shortz" (s name)))
                                  (is (= "will shortz" (s :name)))
                                  (is (= "will shortz" (name s)))))
    (is (= res a-slot-haver))
    (is (= "will shortz" (a-slot-haver :name)))))

(deftest slots-validation
  (is (thrown? (apply fugue/with-slots '[SlotHaver {} (@ other)]))))

(deftest nested-with-slots
  (let [a-slot-haver (new-SlotHaver :name "A")
        b-slot-haver (new-SlotHaver :name "B")]
    (fugue/with-slots SlotHaver a-slot-haver
                      (fugue/with-slots-as SlotHaver b-slot-haver @@
                                           (set (@ name) "A2")
                                           (set (@@ name) "B2")))
    (is (= "A2" (a-slot-haver :name)))
    (is (= "B2" (b-slot-haver :name)))))

(def DefinedButNotAProto @{})

(deftest @-macro
  (is (= (fugue/@ SlotHaver :name) :name))
  (let [a-slot-haver (new-SlotHaver :name "Freddie")
        not-a-member-of-queen @{:name "Queen Victoria"}]
    (is (= "Freddie" (a-slot-haver (fugue/@ SlotHaver :name))))
    (is (= "Freddie" (fugue/@ SlotHaver a-slot-haver :name)))
    (set (a-slot-haver (fugue/@ SlotHaver :name)) "Brian May")
    (is (= "Brian May" (a-slot-haver :name)))
    # Throws at runtime, because the table isn't a child of SlotHaver
    (is (thrown? (fugue/@ SlotHaver not-a-member-of-queen :name)))
    # Throws at compiletime, because the symbol isn't defined
    (is (thrown? (apply [fugue/@ 'SomeUndefinedProto :one-of-its-fields])))
    # Throws at compiletime, because the symbol is defined but not
    # known to Fugue
    (is (thrown? (apply [fugue/@ 'DefinedButNotAProto :one-of-its-fields])))))

(fugue/defproto MyMatcher nil name {})

(deftest fugue-match
  (defn try-match [obj]
    (fugue/match obj
                 (@ MyMatcher {:name some-name}) (string some-name "!")
                 {:name some-name} (string some-name ".")))
  (is (= "Matcher!" (try-match (new-MyMatcher :name "Matcher"))))
  (is (= "Non-Matcher." (try-match {:name "Non-Matcher"}))))

(deftest fugue-match-warnings
  (is (thrown?
        "Field `some-other-field` not found on MyMatcher; got: @[:name]"
        (apply fugue/match '[:ok (@ MyMatcher {:some-other-field foo}) foo]))))

(deftest fugue-match-else
  (defn try-match [obj]
    (fugue/match obj
                 (@ MyMatcher {:name some-name}) (string some-name "!")
                 (string obj ".")))
  (is (= "Matcher!" (try-match (new-MyMatcher :name "Matcher"))))
  (is (= "Non-Matcher." (try-match "Non-Matcher"))))

(run-tests!)