;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.presentation)

(def localization-loader-callback presentation-localization-loader :hu.dwim.presentation "localization/")

;;;;;;
;;; Localization primitives

(def method localize ((class class))
  (lookup-first-matching-resource
    ("class-name" (fully-qualified-symbol-name/for-localization-entry (class-name class)))
    ("class-name" (string-downcase (class-name class)))))

(def (generic e) localized-slot-name (slot &key capitalize-first-letter prefix-with)
  (:method ((slot effective-slot-definition) &key &allow-other-keys)
    (bind ((slot-name (slot-definition-name slot)))
      (lookup-first-matching-resource
        ((class-name (owner-class-of-effective-slot-definition slot)) slot-name)
        ("slot-name" slot-name)
        ("class-name" (awhen (find-class-for-type (slot-definition-type slot))
                        (class-name it))))))

  (:method :around ((slot effective-slot-definition) &key (capitalize-first-letter #t) prefix-with)
    (bind (((:values str found?) (call-next-method)))
      (assert str)
      (when capitalize-first-letter
        (setf str (capitalize-first-letter str)))
      (values (if prefix-with
                  (string+ prefix-with str)
                  str)
              found?))))

(def function localized-slot-name<> (slot &rest args)
  (bind (((:values str found) (apply #'localized-slot-name slot args)))
    <span (:class ,(string+ "slot-name " (unless found +missing-localization-style-class+)
                            ;; TODO this is fragile here, should use a public api in dmm
                            ;; something like associationp
                            ;;(when (typep slot 'hu.dwim.meta-model:effective-association-end)
                            ;;  "association")
                            ))
      ,str>))

;; TODO: what is special about this function to classes? could be easily generalized to functions, etc.
(def function localized-class-name (class &key capitalize-first-letter with-article plural)
  (assert (typep class 'class))
  (bind (((:values class-name found?) (localize class)))
    (when plural
      (setf class-name (plural-of class-name)))
    (when with-article
      (setf class-name (if plural
                           (with-definite-article class-name)
                           (with-indefinite-article class-name))))
    (values (if capitalize-first-letter
                (capitalize-first-letter class-name)
                class-name)
            found?)))

;; TODO: what is special about this function to classes? could be easily generalized to functions, etc.
(def function localized-class-name<> (class &key capitalize-first-letter with-indefinite-article)
  (assert (typep class 'class))
  (bind (((:values class-name found?) (localize class)))
    (when with-indefinite-article
      (bind ((article (with-indefinite-article class-name)))
        (write (if capitalize-first-letter
                   (capitalize-first-letter article)
                   article)
               :stream *xml-stream*)
        (write-char #\Space *xml-stream*)))
    <span (:class ,(string+ "class-name " (unless found? +missing-localization-style-class+)))
          ,(if (and capitalize-first-letter
                    (not with-indefinite-article))
               (capitalize-first-letter class-name)
               class-name)>))

(def function member-value-name/for-localization-entry (value)
  (typecase value
    (symbol (string-downcase value))
    (class (string-downcase (class-name value)))
    (integer (integer-to-string value))
    (number (princ-to-string value))
    (t nil)))

(def function localized-enumeration-member (member-value &key class slot capitalize-first-letter)
  ;; TODO fails with 'person 'sex: '(OR NULL SEX-TYPE)
  (unless class
    (setf class (when slot
                  (owner-class-of-effective-slot-definition slot))))
  (bind ((member-value-name (member-value-name/for-localization-entry member-value))
         (slot-definition-type (when slot
                                 (slot-definition-type slot)))
         (class-name (when class
                       (class-name class)))
         (slot-name (when slot
                      (symbol-name (slot-definition-name slot))))
         ((:values str found?)
          (lookup-first-matching-resource
            (when (and class-name
                       slot-name)
              class-name slot-name member-value-name)
            (when slot-name
              slot-name member-value-name)
            (when (and slot-definition-type
                       ;; TODO strip off (or null ...) from the type
                       (symbolp slot-definition-type))
              slot-definition-type member-value-name)
            ("member-type-value" member-value-name))))
    (when (and (not found?)
               (typep member-value 'class))
      (setf (values str found?) (localized-class-name member-value)))
    (when capitalize-first-letter
      (setf str (capitalize-first-letter str)))
    (values str found?)))

(def function localized-enumeration-member<> (member-value &key class slot capitalize-first-letter)
  (bind (((:values str found?) (localized-enumeration-member member-value :class class :slot slot
                                                             :capitalize-first-letter capitalize-first-letter)))
    <span (:class ,(unless found? +missing-localization-style-class+))
      ,str>))

(def constant +timestamp-format+ '((:year 4) #\- (:month 2) #\- (:day 2) #\Space
                                   (:hour 2) #\: (:min 2) #\: (:sec 2)))

(def (function e) localized-timestamp (timestamp &key verbosity (relative-mode #f) display-day-of-week)
  (declare (ignore verbosity relative-mode display-day-of-week))
  ;; TODO many
  (local-time:format-timestring nil timestamp :format +timestamp-format+)
  ;; TODO (cl-l10n:format-timestamp nil timestamp)
  )

#+nil ;; TODO port this old localized-timestamp that supports relative mode
(def function localized-timestamp (local-time &key
                                              (relative-mode nil)
                                              (display-day-of-week nil display-day-of-week-provided?))
  "DWIMish timestamp printer. RELATIVE-MODE requests printing human friendly dates based on (NOW)."
  (setf local-time (local-time:adjust-local-time local-time (set :timezone *client-timezone*)))
  (bind ((*print-pretty* nil)
         (*print-circle* nil)
         (cl-l10n::*time-zone* nil)
         (now (local-time:now)))
    (with-output-to-string (stream)
      (with-decoded-local-time (:year year1 :month month1 :day day1 :day-of-week day-of-week1) now
        (with-decoded-local-time (:year year2 :month month2 :day day2) local-time
          (bind ((year-distance (abs (- year1 year2)))
                 (month-distance (abs (- month1 month2)))
                 (day-distance (- day2 day1))
                 (day-of-week-already-encoded? nil)
                 (day-of-week-should-be-encoded? (or display-day-of-week
                                                     (and relative-mode
                                                          (zerop year-distance)
                                                          (zerop month-distance)
                                                          (< (abs day-distance) 7))))
                 (format-string/date (if (and relative-mode
                                              (zerop year-distance))
                                         (if (zerop month-distance)
                                             (cond
                                               ((<= -1 day-distance 1)
                                                (setf day-of-week-already-encoded? t)
                                                (setf day-of-week-should-be-encoded? nil)
                                                (case day-distance
                                                  (0  (lookup-resource "today"))
                                                  (-1 (lookup-resource "yesterday"))
                                                  (1  (lookup-resource "tomorrow"))))
                                               (t
                                                ;; if we are within the current week
                                                ;; then print only the name of the day.
                                                (if (and (< (abs day-distance) 7)
                                                         (<= 1 ; but sunday can be a potential source of confusion
                                                             (+ day-of-week1
                                                                day-distance)
                                                             6))
                                                    (progn
                                                      (setf day-of-week-already-encoded? t)
                                                      "%A")
                                                    (progn
                                                      (setf day-of-week-should-be-encoded? nil)
                                                      "%b. %e."))))
                                             "%b. %e.")
                                         "%Y. %b. %e."))
                 (format-string (string+ format-string/date
                                         (if (or day-of-week-already-encoded?
                                                 (not day-of-week-should-be-encoded?)
                                                 (and display-day-of-week-provided?
                                                      (not display-day-of-week)))
                                             ""
                                             " %A")
                                         " %H:%M:%S")))
            (cl-l10n::print-time-string format-string stream
                                        (local-time:universal-time
                                         (local-time:adjust-local-time! local-time
                                           (set :timezone local-time:*default-timezone*)))
                                        (current-locale))))))))

;;;;;;
;;; Utilities

;; TODO: resolve this duality among localize and localized-instance-name, why do we have both? [because -instance-name, which should really be /short-human-readable or somesuch, specifies the context of usage which may influence the implementation. but a cleanup is sure needed nevertheless...]
;; TODO localized-instance-name is quite a bad name, because it's not the instance's name, only a mere human readable, short text representation
(def (generic e) localized-instance-name (value)
  (:method (value)
    (bind ((*print-level* 3)
           (*print-length* 3))
      (princ-to-string value)))

  (:method ((value number))
    value)

  (:method ((value string))
    value)

  (:method ((value sequence))
    (cond ((emptyp value)
           (lookup-resource "sequence.empty"))
          ((proper-list-p value)
           (bind ((length (length value))
                  (first (elt value 0))
                  (class (class-of first))
                  (elements-name (lookup-resource "sequence.element")))
             (string+ (princ-to-string length)
                      " "
                      (when (every (of-type class) value)
                        (localized-class-name class))
                      " "
                      (if (= length 1)
                          elements-name
                          (plural-of elements-name))
                      " "
                      (call-next-method))))
          (t
           (call-next-method))))

  (:method ((class class))
    (localized-class-name class))

  (:method ((timestamp local-time:timestamp))
    (localized-timestamp timestamp))

  (:method ((function function))
    (bind ((name (function-name function)))
      (cond ((symbolp name)
             (lookup-first-matching-resource
               ("function-name" (fully-qualified-symbol-name/for-localization-entry name))
               ("function-name" (string-downcase name))))
            ((and (consp name)
                  (eq (first name) 'macro-function))
             (lookup-first-matching-resource
               ("macro-name" (fully-qualified-symbol-name/for-localization-entry (second name)))
               ("macro-name" (string-downcase (second name)))))
            (t "unknown function")))))