hy_odoo/hy_odoo/odoo.hy

;; -*- coding: utf-8 -*-
;;
;;    Copyright 2019-2022 Fabien Bourgeois <fabien@yaltik.com>
;;
;;    This program is free software: you can redistribute it and/or modify
;;    it under the terms of the GNU Affero General Public License as
;;    published by the Free Software Foundation, either version 3 of the
;;    License, or (at your option) any later version.
;;
;;    This program is distributed in the hope that it will be useful,
;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;    GNU Affero General Public License for more details.
;;
;;    You should have received a copy of the GNU Affero General Public License
;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.

" Odoo macros and helpers "

(import os [path]
        hy-odoo.xml_base [xmlroot xmln])

; Global helpers

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

; XML helpers functions and macros

(defn odoo [children] (xmlroot (xmln "odoo" {} children)))

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

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

; Actions
(defn act-window [&rest 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 [&rest 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 [&rest args] (xmln "group" #*args))
(defn header [&rest args] (xmln "header" #*args))
(defn footer [&rest args] (xmln "footer" #*args))
(defn sheet [&rest args] (xmln "sheet" #*args))
(defn button [&rest args] (xmln "button" #*args))
(defn p [&rest args] (xmln "p" #*args))
(defn xpath [&rest args] (xmln "xpath" #*args))
(defn attribute [name value] (xmln "attribute" {"name" name} [value]))

; Fields
(defn field [&rest args]
  "Special field allowing mangling name attribute"
  (setv attrs (nth args 0))
  (when (and (instance? dict attrs) (in "name" attrs))
        (assoc attrs "name" (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-model [model] (field {"name" "model"} [model]))
(defn field-inherit [xmlid] (field {"name" "inherit_id" "ref" xmlid} []))
(defn field-arch [&rest args] (field {"name" "arch" "type" "xml"} #*args))

; Search
(defn filter [&rest 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}")