(use goo)

(use goo/system)
(use goo/boot)

(use samurui/gtk.swig)

(use samurui/core/util)

(dc <interface-info> (<any>))

(dc <interface-constraint> (<any>))

(dv root-interface (new <interface-info>))

(dc <interface-action> (<interface-info>))
  (dp! name (<interface-action> => <str>))
  (dp! method (<interface-action> => <any>))
  (dp! description (<interface-action> => <any>))

(dm interface-action (new-name new-method new-description => <interface-action>)
  (let ((action (new <interface-action>)))
    (set (name action) new-name)
    (set (method action) new-method)
    (set (description action) new-description)
    action
    )
  )

(dc <interface-property> (<interface-info>))
  (dp! name (<interface-property> => <any>))
  (dp! type (<interface-property> => <class>))
  (dp! getter (<interface-property> => <any>))
  (dp! setter (<interface-property> => <any>))
  (dp! description (<interface-property> => <any>))
  (dp! constraint (<interface-property> => (t? <interface-constraint>)) #f)

(dm interface-property (new-name new-type new-getter new-setter new-description => <interface-property>)
  (let ((property (new <interface-property>)))
    (set (name property) new-name)
    (set (type property) new-type)
    (set (getter property) new-getter)
    (set (setter property) new-setter)
    (set (description property) new-description)
    property)
  )

;; This seems like a bad approach.  Better approaches include:
;; - Just directly using the <prop> class, but pester Jonathan to add support for the
;;    required meta-data. (eventual goal)
;; - Proxy / decorate / yadda-yadda. (Halfway.)
;; - Just rename the generics for this to overlap the other dude?
(dm prop-to-interface-prop (prop => <interface-property>)
  (def new-prop (new <interface-property>))
  (set (name new-prop) (as <str> (fun-name (prop-getter prop))))
  (set (type new-prop) (prop-type prop))
  (set (getter new-prop) (prop-getter prop))
  (set (setter new-prop) (prop-setter prop))
  (set (description new-prop) "Native Property")
  new-prop
  )

; Maps class of object to a vector of potential interface-models
(dv interface-models (fab <tab> 0))

(dc <interface-class-info> (<any>))
  (dp! properties (<interface-class-info> => <str-tab>))
  (dp! actions (<interface-class-info> => <str-tab>))

(dm interface-class-info ( => <interface-class-info>)
  (let ((info (new <interface-class-info>)))
    (set (properties info) (fab <str-tab> 0))
    (set (actions info) (fab <str-tab> 0))
    info
    )
)

; An interface model is just a tup
(dv <interface-model> <tup>)

(dm interface-model ((eval-func <fun>) (factory <fun>) => <interface-model>)
  (tup eval-func factory)
)

(dm interface-model ((eval-func <fun>) (list <lst>) => <interface-model>)
  (tup eval-func list)
)

(dv imodel-eval 1st)
(dv imodel-payload 2nd)

; Maps class of object to <interface-class-info> object for that class
(dv interface-infos (fab <tab> 0))


; --
; --- Macro Support Functionality
; --

(dm register-interface-model ((class <class>) (the-model <interface-model>))
  (let ((models (or (elt-or interface-models class #f)
                    (set (elt interface-models class) (fab <vec> 0)))))
    ; put it in the list
    (ad! models the-model))
  )

(dm has-interface-model? ((class <class>))
  (let ((models (elt-or interface-models class #f)))
    models) ; Should both verify that it is non-nul and non-zero in length
  )
         
; return an arbitrary model associated directly with the given class
(dm get-interface-model (class|<class> info|<interface-info> attribs|<col>)
  (let ((models (elt interface-models class))
        (best-score 0)
        (best-model #f))
    (do 
     (fun (model)
       (let ((cur-score ((imodel-eval model) info attribs)))
         (if (> cur-score best-score)
             (seq
               (set best-score cur-score)
               (set best-model model)
               )
             )
         )
       )

     models)
    best-model            
    )
  )

(dm get-interface-models ((class <class>))
  (let ((models (elt interface-models class)))
    models
    )
  )

; Note! We assume that the most specific set of interface models forms the complete set
;  that we want to consider.  An alternate implementation might mush them all together
;  and then check them each out, but since there is nothing preventing someone from
;  copying an interface-model (or models) down from higher in the hierarchy, this seems
;  like the optimal solution.
(dm find-interface-model (class|<class> info|<interface-info> attribs|<col> => (t? <interface-model>))
  (let ((first-class (find-first-class has-interface-model? class)))
    (get-interface-model first-class info attribs)
    )
  )

(dm get-class-info ((class <class>) => <interface-class-info>)
  (let ((info (or (elt-or interface-infos class #f) (set (elt interface-infos class) (interface-class-info)))))
    info)
  )

(dm add-property ((class <class>) (property <interface-property>))
  (let ((info (get-class-info class)))
    ; Add the property to the properties hash using its name as the key
    (set (elt (properties info) (name property)) property)
    )
  )

(dm add-action ((class <class>) (action <interface-action>))
  (let ((info (get-class-info class)))
    (set (elt (actions info) (name action)) action)
    )
  )
  
; Returns the actions directly associated with the given class.
;  (Eg, does not handle ancestral actions.)
(dm get-class-actions ((class <class>) => <col>)
  (actions (get-class-info class))
  )
  
(dm get-all-actions ((class <class>) => <col>)
  (let ((actions (fab <str-tab> 0)))
    (do (fun (c)
          (add-all! actions (get-class-actions c))
          )
        (add (class-parents class) class)
        )
    actions
    )
  )

(dm find-action ((class <class>) (name <str>) => <any>) ; should be false-or <interface-action>
  (elt-or (get-all-actions class) name #f)
  )

(dm get-class-properties ((class <class>) => <col>)
  (properties (get-class-info class))
  )

(dm get-all-properties ((class <class>) => <col>)
  (let ((properties (fab <str-tab> 0)))
    (do (fun (c)
          (add-all! properties (get-class-properties c))
          )        
        (add (class-parents class) class) ; need the class in there too!
        )
    properties
    )
  )

(dm find-property ((class <class>) (name <str>) => (t? <interface-property>))
  (or (elt-or (get-all-properties class) name #f)
      (seq ;; I like this way more than let...
        (def native-prop (esc found-it
                           (do (fun (cur-prop)
                                 (when (= name (as <str> (fun-name (prop-getter cur-prop))))
                                   (found-it cur-prop)
                                   )
                                 )
                               (class-props class))
                           ))
        (when native-prop
          (def new-prop (prop-to-interface-prop native-prop))
          (add-property class new-prop)
          new-prop
          )
        )
      )
  )

(export
  <interface-info>
  <interface-class-info>
  <interface-constraint>
  <interface-action>
  <interface-property>
  <interface-model>
  )

(export
  name
  name-setter

  type
  type-setter

  getter
  getter-setter

  setter
  setter-setter

  method
  method-setter

  description
  description-setter

  constraint
  constraint-setter

  properties
  properties-setter

  actions
  actions-setter
  )

(export
  root-interface
  interface-models
  
  imodel-eval
  imodel-payload

  interface-infos
  )

(export
  interface-action
  interface-property
  interface-class-info
  interface-model
  
  register-interface-model
  has-interface-model?
  get-interface-model
  get-interface-models
  find-interface-model
  get-class-info
  add-property
  add-action
  get-class-actions
  get-all-actions
  find-action
  get-class-properties
  get-all-properties
  find-property
  )