path: root/stdlib/source/library/lux/world/db/sql.lux

... 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/.

(.require
 [library
  [lux (.except Source Definition function and or not int)
   [control
    [monad (.only do)]]
   [data
    [number
     ["i" int]]
    ["[0]" text (.use "[1]#[0]" equivalence)
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor)]]]
   [meta
    [macro
     ["[0]" template]]]
   ["[0]" type (.only)
    ["[0]" nominal (.except def)]]]])

(def parenthesize
  (-> Text Text)
  (text.enclosed ["(" ")"]))

... Kind
(with_template [<declaration>]
  [(nominal.def .public <declaration> Any)]

  [Literal']
  [Column']
  [Placeholder']
  [(Value' kind)]
  
  [Function']
  
  [Condition']

  [Index']
  
  [Table']
  [View']
  [Source']
  [DB']
  
  [No_Limit] [With_Limit]
  [No_Offset] [With_Offset]
  [Order']
  [No_Order] [With_Order]
  [No_Group] [With_Group]
  [(Query' order group limit offset)]

  [Command']

  [No_Where] [With_Where] [Without_Where]
  [No_Having] [With_Having] [Without_Having]
  [(Action' where having kind)]
  
  [(Schema' kind)]
  [Definition']
  [(Statement' kind)]
  )

(type .public Alias
  Text)

(def .public no_alias Alias "")

(nominal.def .public (SQL kind)
  Text

  ... SQL
  (with_template [<declaration> <kind>]
    [(type .public <declaration>
       (SQL <kind>))]

    [Literal (Value' Literal')]
    [Column (Value' Column')]
    [Placeholder (Value' Placeholder')]
    [Value (Value' Any)]
    
    [Function Function']
    [Condition Condition']

    [Index Index']
    
    [Table Table']
    [View View']
    [Source Source']
    [DB DB']
    
    [Order Order']

    [(Schema kind) (Schema' kind)]
    
    [(Query where having order group limit offset) (Statement' (Action' where having (Query' order group limit offset)))]
    [(Command where having) (Statement' (Action' where having Command'))]
    [(Action where having kind) (Statement' (Action' where having kind))]

    [Definition (Statement' Definition')]
    [Statement (Statement' Any)]
    )

  (def Base_Query
    (type.literal
     (Query No_Where No_Having No_Order No_Group No_Limit No_Offset)))
  
  (def Any_Query
    (type.literal
     (Query Any Any Any Any Any Any)))

  ... Only use this function for debugging purposes.
  ... Do not use this function to actually execute SQL code.
  (def .public read
    (-> (SQL Any) Text)
    (|>> representation))

  (def .public (sql action)
    (-> Statement Text)
    (format (representation action) ";"))

  (def listing
    (-> (List (SQL Any)) Text)
    (|>> (list#each (|>> representation))
         (text.interposed ", ")))

  ... Value
  (def .public ? Placeholder (abstraction "?"))

  (def literal
    (-> Text Literal)
    (|>> abstraction))

  (def .public null Literal (..literal "NULL"))

  (def .public (int value)
    (-> Int Literal)
    (..literal (if (i.< +0 value)
                 (%.int value)
                 (%.nat (.nat value)))))

  (def .public function
    (-> Text Function)
    (|>> abstraction))

  (def .public (call function parameters)
    (-> Function (List Value) Value)
    (abstraction (format (representation function)
                         (..parenthesize (..listing parameters)))))

  ... Condition
  (with_template [<name> <sql_op>]
    [(def .public (<name> reference sample)
       (-> Value Value Condition)
       (abstraction
        (..parenthesize
         (format (representation sample)
                 " " <sql_op> " "
                 (representation reference)))))]

    [=      "="]
    [<>     "<>"]
    [is?    "IS"]
    [>      ">"]
    [>=     ">="]
    [<      "<"]
    [<=     "<="]
    [like?  "LIKE"]
    [ilike? "ILIKE"]
    )

  (def .public (between from to sample)
    (-> Value Value Value Condition)
    (abstraction
     (..parenthesize
      (format (representation sample)
              " BETWEEN " (representation from)
              " AND " (representation to)))))

  (def .public (in options value)
    (-> (List Value) Value Condition)
    (abstraction
     (format (representation value)
             " IN "
             (..parenthesize (listing options)))))

  (with_template [<func_name> <sql_op>]
    [(def .public (<func_name> left right)
       (-> Condition Condition Condition)
       (abstraction
        (format (..parenthesize (representation left))
                " " <sql_op> " "
                (..parenthesize (representation right)))))]

    [and "AND"]
    [or  "OR"]
    )

  (with_template [<name> <type> <sql>]
    [(def .public <name>
       (-> <type> Condition)
       (|>> representation ..parenthesize (format <sql> " ") abstraction))]

    [not    Condition "NOT"]
    [exists Any_Query "EXISTS"]
    )

  ... Query
  (with_template [<name> <type> <decoration>]
    [(def .public <name>
       (-> <type> Source)
       (|>> representation <decoration> abstraction))]

    [from_table Table     (<|)]
    [from_view  View      (<|)]
    [from_query Any_Query ..parenthesize]
    )

  (with_template [<func_name> <op>]
    [(def .public (<func_name> columns source)
       (-> (List [Column Alias]) Source Base_Query)
       (abstraction
        (format <op>
                " "
                (when columns
                  {.#End}
                  "*"
                  
                  _
                  (|> columns
                      (list#each (.function (_ [column alias])
                                   (if (text#= ..no_alias alias)
                                     (representation column)
                                     (format (representation column) " AS " alias))))
                      (text.interposed ", ")))
                " FROM " (representation source))))]


    [select          "SELECT"]
    [select_distinct "SELECT DISTINCT"]
    )

  (with_template [<name> <join_text>]
    [(def .public (<name> table condition prev)
       (-> Table Condition Base_Query Base_Query)
       (abstraction
        (format (representation prev)
                " " <join_text> " "
                (representation table)
                " ON " (representation condition))))]

    [inner_join      "INNER JOIN"]
    [left_join       "LEFT JOIN"]
    [right_join      "RIGHT JOIN"]
    [full_outer_join "FULL OUTER JOIN"]
    )

  (with_template [<function> <sql_op>]
    [(def .public (<function> left right)
       (-> Any_Query Any_Query (Query Without_Where Without_Having No_Order No_Group No_Limit No_Offset))
       (abstraction
        (format (representation left)
                " " <sql_op> " "
                (representation right))))]

    [union     "UNION"]
    [union_all "UNION ALL"]
    [intersect "INTERSECT"]
    )

  (with_template [<name> <sql> <variables> <input> <output>]
    [(`` (def .public (<name> value query)
           (All (_ (,, (template.spliced <variables>)))
             (-> Nat <input> <output>))
           (abstraction
            (format (representation query)
                    " " <sql> " "
                    (%.nat value)))))]

    [limit "LIMIT" [where having order group offset]
     (Query where having order group No_Limit offset)
     (Query where having order group With_Limit offset)]

    [offset "OFFSET" [where having order group limit]
     (Query where having order group limit No_Offset)
     (Query where having order group limit With_Offset)]
    )

  (with_template [<name> <sql>]
    [(def .public <name>
       Order
       (abstraction <sql>))]

    [ascending  "ASC"]
    [descending "DESC"]
    )

  (def .public (order_by pairs query)
    (All (_ where having group limit offset)
      (-> (List [Value Order])
          (Query where having No_Order group limit offset)
          (Query where having With_Order group limit offset)))
    (when pairs
      {.#End}
      (|> query representation abstraction)
      
      _
      (abstraction
       (format (representation query)
               " ORDER BY "
               (|> pairs
                   (list#each (.function (_ [value order])
                                (format (representation value) " " (representation order))))
                   (text.interposed ", "))))))

  (def .public (group_by pairs query)
    (All (_ where having order limit offset)
      (-> (List Value)
          (Query where having order No_Group limit offset)
          (Query where having order With_Group limit offset)))
    (when pairs
      {.#End}
      (|> query representation abstraction)
      
      _
      (abstraction
       (format (representation query)
               " GROUP BY "
               (..listing pairs)))))

  ... Command
  (def .public (insert table columns rows)
    (-> Table (List Column) (List (List Value)) (Command Without_Where Without_Having))
    (abstraction
     (format "INSERT INTO " (representation table) " "
             (..parenthesize (..listing columns))
             " VALUES "
             (|> rows
                 (list#each (|>> ..listing ..parenthesize))
                 (text.interposed ", "))
             )))

  (def .public (update table pairs)
    (-> Table (List [Column Value]) (Command No_Where No_Having))
    (abstraction (format "UPDATE " (representation table)
                         (when pairs
                           {.#End}
                           ""
                           
                           _
                           (format " SET " (|> pairs
                                               (list#each (.function (_ [column value])
                                                            (format (representation column) "=" (representation value))))
                                               (text.interposed ", ")))))))

  (def .public delete
    (-> Table (Command No_Where No_Having))
    (|>> representation (format "DELETE FROM ") abstraction))

  ... Action
  (def .public (where condition prev)
    (All (_ kind having)
      (-> Condition (Action No_Where having kind) (Action With_Where having kind)))
    (abstraction
     (format (representation prev)
             " WHERE "
             (representation condition))))

  (def .public (having condition prev)
    (All (_ where kind)
      (-> Condition (Action where No_Having kind) (Action where With_Having kind)))
    (abstraction
     (format (representation prev)
             " HAVING "
             (representation condition))))

  ... Schema
  (def .public type
    (-> Text (Schema Value))
    (|>> abstraction))
  
  (with_template [<name> <attr>]
    [(def .public (<name> attr)
       (-> (Schema Value) (Schema Value))
       (abstraction
        (format (representation attr) " " <attr>)))]

    [unique   "UNIQUE"]
    [not_null "NOT NULL"]
    [stored   "STORED"]
    )

  (def .public (default value attr)
    (-> Value (Schema Value) (Schema Value))
    (abstraction
     (format (representation attr) " DEFAULT " (representation value))))

  (def .public (define_column name type)
    (-> Column (Schema Value) (Schema Column))
    (abstraction
     (format (representation name) " " (representation type))))

  (def .public (auto_increment offset column)
    (-> Int (Schema Column) (Schema Column))
    (abstraction
     (format (representation column) " AUTO_INCREMENT=" (representation (..int offset)))))

  (def .public (create_table or_replace? table columns)
    (-> Bit Table (List (Schema Column)) Definition)
    (let [command (if or_replace?
                    "CREATE OR REPLACE TABLE"
                    "CREATE TABLE IF NOT EXISTS")]
      (abstraction
       (format command " " (representation table)
               (..parenthesize (..listing columns))))))

  (def .public (create_table_as table query)
    (-> Table Any_Query Definition)
    (abstraction
     (format "CREATE TABLE " (representation table) " AS " (representation query))))

  (with_template [<name> <sql>]
    [(def .public (<name> table)
       (-> Table Definition)
       (abstraction
        (format <sql> " TABLE " (representation table))))]
    
    [drop     "DROP"]
    [truncate "TRUNCATE"]
    )

  (def .public (add_column table column)
    (-> Table (Schema Column) Definition)
    (abstraction
     (format "ALTER TABLE " (representation table) " ADD " (representation column))))

  (def .public (drop_column table column)
    (-> Table Column Definition)
    (abstraction
     (format "ALTER TABLE " (representation table) " DROP COLUMN " (representation column))))

  (with_template [<name> <type>]
    [(def .public (<name> name)
       (-> Text <type>)
       (abstraction name))]

    [column Column]
    [table Table]
    [view View]
    [index Index]
    [db DB]
    )

  (with_template [<name> <type> <sql>]
    [(def .public <name>
       (-> <type> Definition)
       (|>> representation (format <sql> " ") abstraction))]

    [create_db  DB    "CREATE DATABASE"]
    [drop_db    DB    "DROP DATABASE"]
    [drop_view  View  "DROP VIEW"]
    )

  (with_template [<name> <sql>]
    [(def .public (<name> view query)
       (-> View Any_Query Definition)
       (abstraction
        (format <sql> " " (representation view) " AS " (representation query))))]

    [create_view            "CREATE VIEW"]
    [create_or_replace_view "CREATE OR REPLACE VIEW"]
    )

  (def .public (create_index index table unique? columns)
    (-> Index Table Bit (List Column) Definition)
    (abstraction
     (format "CREATE " (if unique? "UNIQUE" "") " INDEX " (representation index)
             " ON " (representation table) " " (..parenthesize (..listing columns)))))

  (def .public (with alias query body)
    (All (_ where having order group limit offset)
      (-> Table Any_Query
          (Query where having order group limit offset)
          (Query where having order group limit offset)))
    (abstraction
     (format "WITH " (representation alias)
             " AS " (..parenthesize (representation query))
             " " (representation body))))
  )