yaltik_odoo_custom/hy_odoo/odoo.hy

;; Copyright 2019-2022 Fabien Bourgeois <fabien@yaltik.com>
;;
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at https://mozilla.org/MPL/2.0/.

" Odoo macros and helpers "

(require hyrule.collections [assoc]
         odoo.addons.hy-odoo.mgeneral [instance?])
(import os [path]
        odoo.addons.hy-odoo.xml [xmlroot xmln])

; Global helpers

(defn strdm [hy-domain]
  "Generate Odoo domain from Hy like tuple domain"
  (do
    (setv #(op field value) hy-domain
           field (hy.mangle field)
           value (when (string? value) f"'{value}'" value))
    (return f"('{field}', '{op}', {value})")))

; XML helpers functions and macros

(defn odoo [children] (xmlroot {"tag" "odoo" "attrs" {} "children" children}))

(defn data [#* args]
  "Special data node, allow optional args on data tag"
  (when (= (len args) 1) (do (setv args (list args))
                             (.insert args 0 {})))
  (xmln "data" #* args))

; Aliases
(defn function [#* args] (xmln "function" #*args))
(defn record [#* args] (xmln "record" #*args))
(defn form [#* args] (xmln "form" #*args))
(defn tree [#* args] (xmln "tree" #*args))
(defn search [#* args] (xmln "search" #*args))

; Actions
(defn act-window [#* args] (xmln "act_window" #*args))

(defn act-window-model [model attrs]
  " Build new act_window from model and args"
  (setv model-und (.replace model "." "_")
        model-cap (.join " " (lfor w (.split model ".") (.capitalize w)))
        xmlid f"{model-und}_view_action"
        name f"{model-cap} Action"
        cloned-attrs (.copy attrs)) ; Avoid side-effect
  (.update cloned-attrs {"id" xmlid "name" name "res_model" model})
  (act-window cloned-attrs))

(defn actions-server-code [xmlid name modelref code]
  "Server actions of type code"
  (record {"id" xmlid "model" "ir.actions.server"}
    [(field-name name)
     (field {"name" "model_id" "ref" modelref} [])
     (field {"name" "state"} ["code"])
     (field {"name" "code"} [code])]))

(defn client-action-multi [xmlid name model action]
  "Client action multi (ir.values), with own xmlid, name, targeted model and
  action"
  (setv action f"'ir.actions.server,%d'%{action}")
  (record {"id" xmlid "model" "ir.values"}
    [(field-name name)
     (field {"name" "key2" "eval" "'client_action_multi'"} [])
     (field {"name" "model" "eval" (% "'%s'" model)} [])
     (field {"name" "value" "eval" action})]))

; Menus
(defn menuitem [#* args] (xmln "menuitem" #*args))

(defn menuitem-model [model attrs]
  " Build new menuitem from model and attrs"
  (setv model-und (.replace model "." "_")
        actionid f"{model-und}_view_action"
        xmlid f"{model-und}_menu"
        cloned-attrs (.copy attrs))
  (.update cloned-attrs {"id" xmlid "action" actionid})
  (menuitem cloned-attrs))

; Form aliases
(defn group [#* args] (xmln "group" #*args))
(defn header [#* args] (xmln "header" #*args))
(defn footer [#* args] (xmln "footer" #*args))
(defn sheet [#* args] (xmln "sheet" #*args))
(defn button [#* args] (xmln "button" #*args))
(defn p [#* args] (xmln "p" #*args))
(defn xpath [#* args] (xmln "xpath" #*args))
(defn attribute [name value] (xmln "attribute" {"name" name} [value]))

; Fields
(defn field [#* args]
  "Special field allowing mangling name attribute"
  (setv attrs (get args 0))
  (when (and (instance? dict attrs) (in "name" attrs))
        (assoc attrs "name" (hy.mangle (get attrs "name")))
        (setv args (list args))
        (assoc args 0 attrs)
        (setv args (tuple args)))
  (xmln "field" #*args))

(defn field-name [name] (field {"name" "name"} [name]))
(defn field-nval [name value] (field {"name" name} [value]))
(defn field-model [model] (field {"name" "model"} [model]))
(defn field-inherit [xmlid] (field {"name" "inherit_id" "ref" xmlid} []))
(defn field-arch [#* args] (field {"name" "arch" "type" "xml"} #*args))

; Search
(defn filter [#* args] (xmln "filter" #*args))

; Views
(defn view [xmlid children] (record {"id" xmlid "model" "ir.ui.view"} children))

(defn view-def [xmlid name model arch]
  "View and first fields simplification with record xmlid, name, targeted model"
   (view xmlid [(field-name name) (field-model model) (field-arch arch)]))

(defn view-new[view_type model arch]
  "View : new view definition, based on type (form, tree, ...) and model ID"
  (setv model-und (.replace model "." "_")
        model-cap (.join " " (lfor w (.split model ".") (.capitalize w)))
        xmlid f"{model-und}_view_{view_type}"
        name f"{model-cap} {(.capitalize view_type)}")
  (view-def :xmlid xmlid :name name :model model :arch arch))

(defn view-inherit [filename model inherit arch]
  "Inherited View simplification with name of the record, xmlid for model and
  inherited view"
  (setv module (get (.split filename ".") 2)
        inherited (get (.split inherit ".") 1)
        xmlid f"{inherited}_inherit_{module}"
        model-cap (.join " " (lfor w (.split model ".") (.capitalize w)))
        name f"{model-cap} Adaptations")
  (view xmlid [(field-name name)
               (field-model model)
               (field-inherit inherit)
               (field-arch arch)]))

; Hy-related helpers

(defn modulehytopy [module-path hy-files]
  "Transforms hy to py for translation purpose"
  (import astor)
  (import os.path [dirname]
          io [open :as iopen]
          hy.lex [hy-parse]
          hy.compiler [hy-compile]
          hy.errors [filtered-hy-exceptions])

  (defn hytopy [source path]
    "Hy source to Py source"
    (setv hst (with [(filtered-hy-exceptions)] (hy-parse source :filename path))
          -ast (with [(filtered-hy-exceptions)] (hy-compile hst "__main__" :filename path :source source)))
    (.to-source (. astor code-gen) -ast))

  (for [hy-file hy-files]
    (setv hy-path (% "%s/%s.hy" #((dirname module-path) hy-file))
          hy-source (with [o (iopen hy-path "r" :encoding "utf-8")] (.read o))
          output-path (.replace hy-path ".hy" ".py")
          content ["# Generate from Hy AST, for Babel translation purpose only."
                   "# For real source code, please see and use HY source."
                   (hytopy hy-source hy-path)])
    (setv output-py (.join "\n" content))
    (with [f (iopen output-path "w")] (.write f output-py))))

; Migrations

(defn generate-fn-name [filepath]
  "Generate function name from filepath"
  (setv version (.replace (get (.split (.dirname path filepath) "/") -1) "." "_")
        pre-post (get (.split (.basename path filepath) "-") 0))
  f"{pre-post}_{version}")