gistfile1.clj

(ns codegen)

(def line "\r\n")
(def line2 "\r\n\r\n")


(def integer
     {:delphiClass "integer" :valueType true
      :read #(str %1 ":=so.I['" %1 "']")
      :save #(str "so.I['" %1 "']:=" %1 )
      :to-string #(str "IntToStr(" %1 ")")
      :to-formatted-string #(str "Sysutils.Format(FormatStr,[" %1 "])")
      :from-string  (str "StrToIntDef(Value,0)")
     })

(def nullInteger
     {:delphiClass "integer" :valueType true
      :read #(str %1 ":=so.I['" %1 "']")
      :save #(str " if " %1 "=0 then so.O['" %1 "']:=nil else so.I['" %1 "']:=" %1 )
      :to-string #(str "IntToStr(" %1 ")")
      :to-formatted-string #(str "Sysutils.Format(FormatStr,[" %1 "])") 
      :from-string  (str "StrToIntDef(Value,0)")
     })

(def json
     {:delphiClass "ISuperObject" :valueType true
      :read #(str %1 ":=so.O['" %1 "']")
      :save #(str "if " %1 "=nil then so.O['" %1 "']:=nil else so.O['" %1 "']:=" %1 )
      :to-string (fn [name] (str "''"))
      :from-string  (str "nil")
     })


(def int64
     {:delphiClass "int64" :valueType true
      :read #(str %1 ":=so.I['" %1 "']")
      :save #(str "so.I['" %1 "']:=" %1 )
      :to-string #(str "IntToStr(" %1 ")")
      :to-formatted-string #(str "Format(FormatStr,[" %1 "])") 
      :from-string  (str "StrToIntDef(Value,0)")

     })

(def bool
     {:delphiClass "boolean" :valueType true
      :read #(str %1 ":=so.B['" %1 "']")
      :save #(str "so.B['" %1 "']:=" %1 )
      :to-string #(str "BoolToStr(" %1 ")")
      :from-string  (str "StrToBool(Value)")

     })

(def date
     {:delphiClass "TDate" :valueType true
      :read #(str %1 ":=JsonToDateDef(so.S['" %1 "'],0)")
      ;:save #(str "so.S['" %1 "']:=DateToJson(" %1 ")" )
      :save #(str "SetDateToJson(so,'" %1 "'," %1 ")" ) 
      :to-string #(str "DateToStr(" %1 ")")
      :to-formatted-string #(str "FormatDateTime(FormatStr," %1 ")")  
      :from-string  (str "StrToIntDateDef(Value,0)")

     })

(def datetime
     {:delphiClass "TDateTime" :valueType true
      :read #(str %1 ":=JsonToDateTimeDef(so.S['" %1 "'],0)")
      :save #(str "so.S['" %1 "']:=DateTimeToJson(" %1 ")" )
      :to-string #(str "DateTimeToStr(" %1 ")")
      :to-formatted-string #(str "FormatDateTime(FormatStr," %1 ")")  
      :from-string  (str "StrToDateTime(Value)")

     })


(def string
     {:delphiClass "string" :valueType true
      :read #(str %1 ":=so.S['" %1 "']")
      :save #(str "so.S['" %1 "']:=" %1 )
      :to-string #(str %1)
      :from-string   "Value" 

     })

(def currency
     {:delphiClass "currency" :valueType true
      :right-align true
      :read #(str %1 ":=so.C['" %1 "']")
      :save #(str "so.C['" %1 "']:=" %1 )
      ;:to-string #(str "Format('%16m'," %1 ")")
      :to-string #(str "CurrToStr(" %1 ")")
      :to-formatted-string #(str "Sysutils.Format(FormatStr,[" %1 "])")  
      :from-string  (str "StrToCurrDef(ReplaceComma(Value),0)")
     })

(def dictionary
  {:delphiClass "TBaseJsonDictionary"
   :valueType false
   :custom-by-name #(str " if " % ".TryGetValue(Name,Result) then Exit else" line)
    })

(defn field
      [type metadata]
      (merge type metadata)
)

(defn array
     [type]
     (let [isValueType (:valueType type)
           elemTypeName (:delphiClass type)]
          
          {:isArray true 
           :isElementTypeValue isValueType
           :elementType elemTypeName
           :className (str (if isValueType "T" "") elemTypeName "List")
          }
     )
)


(defn null
      [type]
      (merge type (:nullable true))
)
      

(defn toType
      "convert field type to type description"
      [t] 
      
      (cond (instance? clojure.lang.Symbol t)
              (do           
               ;(println t (class t) (resolve t)) 
               (if (resolve t)
                   t
                   (str t)
               ))
            (list? t)
               (eval t)
            :else (str t))
)

(defn- pair-to-field
  "convert [name type] pair to field description"
  [[n t]]
  ;(println n t)
  (zipmap [:n :t] [(str n) (toType t)])
  ;[(str n) (toType t)]  
)

(defn- fix-field
  "convert [name type] pair to field description"
  [[n t]]  
  [(str n) (toType t)]
)


(defmacro defDclass
    "define simple class for codegeneration"
    [name & fields]  
    ;(println "defDClass")  
    ;(println " class:" name) 
    ;(println " fields:" fields) 
    ;(println (class name))
    ;(println (class fields))
    ;(println (class (first fields)))
    
    
    (let [sname (str name)
          pfields (partition-all 2 fields)
          ;sfields (map pair-to-field pfields)
          mfields (mapcat fix-field pfields)
         ]
      ;(println "sfields:" mfields)
      `(def ~name {:name ~sname :delphiClass ~sname :valueType false :fields (array-map ~@mfields)}) ;:seqfields [~@sfields] 
    )

)



(defn concatStr
      [seqs] 
      (reduce str "" seqs)
)


(defn fieldName
      [fd]
      (str "m" (key fd))
)

(defn fieldType
      [fd]
      (let [t (val fd)]
        (if (:isArray t)
            (:className t)
            (:delphiClass t)
        )
      )
)


(defn- fieldsDecl
      "generate class fields"
      [cls]
      (map #(str "       " (fieldName %1) ":" (fieldType %1) ";" line) (:fields cls))
      
)


(defn- propertyDecl
      "generate class property"
      [cls]
      (let [ ; valueFields (filter #(:valueType (val %1)) (:fields cls))
           ]
           (map #(str "       " "property " (key %1) ":" (fieldType %1) 
                        " read " (fieldName %1) 
                        (if (:valueType (val %1)) (str " write " (fieldName %1)) "") ";" line) (:fields cls))
           ;TODO: count and Items for  Lists?
      ) 
)


(defn- generateClass
      "Generate class declaration"
      [cls]  
      (str "     " (:name cls) "=class(TBaseJsonObject)" line
           "     private" line
           (reduce str "" (fieldsDecl cls))
           "     protected" line
           "       class procedure FillObjectDescs(descs:TObjectFieldDescList);override;" line
           "       function  DoGetFormattedFieldByName(const Name,FormatStr:string):string;override;" line 
           "     public" line
           "       constructor Create;override;" line
           "       destructor Destroy;override;" line
           "       procedure LoadFromJson(so:ISuperObject);override;" line
           "       procedure SaveToJson(so:ISuperObject;needClass:boolean=false);override;" line
           "       function Clone:" (:name cls) ";" line
           "       function  GetFieldByName(const Name:string):string;override;" line           
           "       procedure SetFieldByName(const Name,Value:string);override;" line

           (reduce str "" (propertyDecl cls))
           "     end;" line2 line  
      )
)


(defn- constr
       [fd]
       (str " " (fieldName fd) ":=" (fieldType fd) ".Create;" line)
)

(defn- destr
       [fd]
       (str " FreeAndNil(" (fieldName fd) ");" line)  
)


(defn load-field
      [fd]
      (if (:valueType (val fd))
          (str " " ((:read (val fd)) (key fd)) ";" line)          
          (str " " (fieldName fd) ".TryLoadFromJson(so.O['" (key fd) "']);" line)
      )  
)

(defn save-field
      [fd] 
      (if (:valueType (val fd))
          (str " " ((:save (val fd)) (key fd)) ";" line)
          (str " " "so.O['" (key fd) "']:=" (fieldName fd) ".SaveToJson;" line)
          ;(str " " (fieldName fd) ".SaveToJson(so.O['" (key fd) "']);" line)
      )  

)

(defn fill-field-desc
      [fd]
      (if (:valueType (val fd))
          (str 
             " d:=TObjectFieldDesc.Create;" line
             " d.Name:='" (key fd) "';" line
             " d.Caption:=Utf8ToAnsi('" (:caption (val fd)) "');" line
             " d.Align:=" (if (:right-align (val fd)) "True" "False") ";" line             
             " descs.Add(d);" line
          )
          ""
      )
)


(defn has-to-string
  [field-type]
  (or (:to-string field-type)
      (:to-formatted-string field-type) 
      (:value-type field-type)))


(defn get-field-by-name
      [fd]
      (println fd) 
      (let [custom-by-name (:custom-by-name (val fd))]
        (if custom-by-name
          (custom-by-name (key fd))
          (if (has-to-string (val fd))
            (str " if Name='" (key fd) "' then Result:=" 
                 ((:to-string (val fd)) (fieldName fd)) " else " line)
            ""))))

      

(defn get-formatted-field-by-name
      [fd]
      (println fd) 
      (if (has-to-string (val fd))
          (let [to-fmt-string (or (:to-formatted-string (val fd)) (:to-string (val fd)))]      
               (str
                  " if Name='" (key fd) "' then Result:=" (to-fmt-string (fieldName fd)) " else " line
               ))
          ""
      )
)


(defn set-field-by-name
      [fd]
      (println fd)
      (if (:valueType (val fd))
          (str
             " if Name='" (key fd) "' then " (fieldName fd) ":=" (:from-string (val fd)) " else " line 
          )
          ""
      )
)


(defn- generateClassImpl
      "Generate class implementation"
      [cls]  
      (let [ownedObjs (filter #(not (:valueType (val %1))) (:fields cls))]
           (str "//---------------------------------------" line
                "//--" (:name cls) line2  
                "constructor "  (:name cls) ".Create;" line
                "begin" line
                " inherited;" line  
                (concatStr (map constr ownedObjs))
                "end;" line2 line
                
                "destructor "  (:name cls) ".Destroy;" line
                "begin" line
                (concatStr (map destr (reverse ownedObjs)))
                " inherited;" line 
                "end;" line2 line 

                "class procedure " (:name cls) ".FillObjectDescs(descs:TObjectFieldDescList);" line
                "var d:TObjectFieldDesc;" line
                "begin" line
                (concatStr (map fill-field-desc (:fields cls)))
                "end;" line2 line 

                "procedure " (:name cls) ".LoadFromJson(so:ISuperObject);" line
                "begin" line
                " inherited;" line 
                (concatStr (map load-field  (:fields cls)))
                "end;" line2 line 

                "procedure " (:name cls) ".SaveToJson(so:ISuperObject;needClass:boolean=false);" line
                "begin" line
                " inherited;" line 
                (concatStr (map save-field  (:fields cls)))
                "end;" line2 line 

                "function " (:name cls) ".Clone:" (:name cls) ";" line
                "begin" line
                " Result:=" (:name cls) ".Create;" line
                " Result.LoadFromJson(SaveToJson);" line
                "end;" line2 line 

                "function " (:name cls) ".GetFieldByName(const Name:string):string;" line
                "begin" line
                (concatStr (map get-field-by-name  (:fields cls)))
                " Result:=inherited GetFieldByName(Name);" line 
                "end;" line2 line 

                "function " (:name cls) ".DoGetFormattedFieldByName(const Name,FormatStr:string):string;" line
                "begin" line
                (concatStr (map get-formatted-field-by-name  (:fields cls)))
                " Result:=inherited DoGetFormattedFieldByName(Name,FormatStr);" line 
                "end;" line2 line 


                "procedure " (:name cls) ".SetFieldByName(const Name,Value:string);" line
                "begin" line                
                (concatStr (map set-field-by-name (:fields cls)))
                " inherited;" line 
                "end;" line2 line 


                line2
           ))
)


(defn- forwardDecl
    [cls]
    (str "     " (:name cls) "=class;" line)
)

(defn- extract-generics 
    [cls]
    (let [fields (mapcat :fields cls)
          genericFields (filter #(:isArray (val %1)) fields)
          genericTypes (filter #(not (:isElementTypeValue %1)) (map #(val %1) genericFields))
          genericset (set genericTypes)]
          (println "generics:" genericset)
          ;(map (partial str line) genericset)
          ;(map #(merge %1 {:className (str "" (:elementType %1) "List")}) genericset)
          genericset
    )
)


(defn- generate-generic
    [gencls]
    (let []
      (str "     " (:className gencls) "=class" (if (:isElementTypeValue gencls) "" "(TBaseJsonObjectList)")   line
           "     private" line
           "     protected" line
           "       class function CheckClass(Item:TBaseJsonObject):boolean;override;" line
           "       class function GetClass:TBaseJsonObjectClass;override;" line
           "       class function IsPolymorphic:boolean;override;" line
           "       function GetItems(Index:integer):" (:elementType gencls) ";" line
           "     public" line
           "       property Items[Index:integer]:" (:elementType gencls) " read GetItems;" line  
           "       function Add(Item:" (:elementType gencls) "):integer;" line
           "     end;" line2 line  
      ))

)

(defn- generate-generic-impl
      [gencls]
      (let []
           (str "//---------------------------------------" line
                "//--" (:className gencls) line2  
                line2
                "class function " (:className gencls) ".CheckClass(Item:TBaseJsonObject):boolean;" line
                "begin" line
                "  Result:=Item is " (:elementType gencls) ";" line
                "end;" line2
       
                "class function " (:className gencls) ".GetClass:TBaseJsonObjectClass;" line
                "begin" line
                "  Result:=" (:elementType gencls) ";" line
                "end;" line2
       
                "class function " (:className gencls) ".IsPolymorphic:boolean;" line
                "begin" line
                "  Result:=false;" line
                "end;" line2

                "function " (:className gencls) ".GetItems(Index:integer):" (:elementType gencls) ";" line
                "begin" line
                "  CheckIndex(Index,'" (:className gencls) "GetItems(Index:integer)');" line
                "  Result:=GetBaseItems(Index) as " (:elementType gencls) ";" line
                "end;" line2

                "function " (:className gencls) ".Add(Item:" (:elementType gencls) "):integer;" line
                "begin" line
                "  Result:=UncheckedAdd(Item);" line
                "end;" line2
           ))
)


(defn- generateInner
    [classes unit]
    (let [genericLists (extract-generics classes)
          genericClasses (map generate-generic genericLists)
          genericClassesImpl (map generate-generic-impl genericLists)  
          strClasses (map generateClass classes)
          strImplementation (map generateClassImpl classes)]
      (str "unit " unit ";" line2
           "interface" line2            
           "uses superobject,BaseJsonObject,classes;" line2
           "type " line
           (reduce str "" (map forwardDecl classes))
           line2
           (reduce str "" genericClasses)
           line2
           (reduce str "" strClasses)
           line2 "implementation" line2
           "uses sysutils;" line2 
           (reduce str "" strImplementation)
           line2
           (reduce str "" genericClassesImpl)           
           "end." line)
      )
)


(defn generate
      "write sequence of classes"
      ([classes] (generateInner classes "Default"))
      ([classes unitName] (generateInner classes unitName))
)

(defn writeUnit 
      "create and write to file unit from classes"
      [classes unit]
      (spit (str unit ".pas") (generate classes unit))
)