REBOL [
    Title: "MySQL Schema Tools"
    Date:  8-Aug-2012
    Author: "Christopher Ross-Gill"
    Type: 'module
    Exports: [schema-create schema-get]
]

with: func [object [any-word! object! port!] block [any-block!] /only][
    block: bind block object
    either only [block] :block
]

envelop: func [data [any-type!]][either any-block? data [data][reduce [data]]]

press: func [values [any-block! none!] /local out][
    any [values return none]
    values: reduce envelop values
    remove-each value values [any [unset? get/any 'value none? value]]
    append copy "" values
]

gather: func [from [block!] /into bucket [block!] /then body [block!]][
    if none? bucket [bucket: :from from: copy []]

    with context [
        storage: :from
        hold: func [data /only][
            do either only ['append/only]['append] storage data
        ]
        rehold: func [data /only][
            do either only ['repend/only]['repend] storage data
        ]
        every: func ['words [get-word! word! block!] body [block!]][
            foreach :words storage :body
        ]
    ] compose/deep [
        (bucket)
        if all [then not empty? storage] [(body)]
        storage
    ]
]

schema-get: use [result new-lines to-key][
    new-lines: func [block [block!] /local pos][
        pos: block
        while [pos: find pos set-word!][
            new-line pos true
            pos: next pos
        ]
        block
    ]

    to-key: func [key [word! string!]][
        to set-word! replace/all form key "_" "-"
    ]

    schema-get: func ['database [word!] /local out][
        database: new-line/all/skip out: reduce [
            to-key :database 'database

            new-line/all/skip map query-db ["SHOW FULL TABLES FROM ?" database] func [table [block!]][
                switch table/2 [
                    "BASE TABLE" [
                        table: to word! table/1
                        reduce [
                            to-key table 'table
                            new-lines map query-db [
                                "SHOW COLUMNS FROM ?" to-path reduce [database table]
                            ] func [column /local type size][
                                ; probe column
                                remove-each val reduce [
                                    to-key column/1
                                    if column/3 = "YES" ['opt]
                                    if parse/all column/2 ammend [
                                        (size: none)
                                          "varchar(" copy size some digit ")"
                                          (type: 'string! size: load size)
                                        | "text" (type: 'string!)
                                        | "enum(" copy size to ")" skip
                                          (type: string! size: parse replace/all size "'" "^"" ",")
                                        | "int(" copy size some digit ")"
                                          (type: integer! size: load size)
                                        | "float" (type: 'decimal!)
                                        | "datetime" (type: 'date!)
                                        | "tinyint(1)" (type: 'logic!)
                                        | "varbinary(" copy size some digit ")"
                                          (type: 'any-type! size: load size)
                                        | "blob" (type: 'any-type!)
                                    ][
                                        type
                                    ]
                                    size
                                    switch column/4 [
                                        "PRI" ['primary]
                                    ]
                                    switch column/6 [
                                        "auto_increment" ['increment]
                                    ]
                                    if column/5 [reduce ['init column/5]]
                                ][none? val]
                            ]
                        ]
                    ]

                    "VIEW" [
                        table: to word! table/1
                        reduce [
                            to-key table 'view
                            new-line/all query-db ["SHOW CREATE VIEW ?" table] true
                        ]
                    ]
                ]
            ] true 3
        ] true 3

        out: copy #{}
        save/header out database compose [
            Title: "Detected Database Schema"
            Type: 'schema
            Date: (now/date)
        ]
        to-string replace/all out "    " "^-"
    ]
]

schema-create: use [result to-key escape form-value listify][
    escape: use [cut safe escapes][
        safe: complement cut: charset {^(00)^/^-^M^(08)'"\}
        escapes: make hash! [
            #"^(00)"    "\0"
            #"^/"       "\n"
            #"^-"       "\t"
            #"^M"       "\r"
            #"^(08)"    "\b"
            #"'"        "\'"
            #"^""       {\"}
            #"\"        "\\"
        ]

        escape: func [value [string!] /local mk][
            parse/all value: copy value [
                any [
                    mk: some safe |
                    cut (mk: change/part mk select escapes mk/1 1) :mk
                ] end
            ]
            value
        ]
    ]

    listify: func [list [block!] /with comma][
        comma: any [comma ", "]
        press remove gather [
            foreach value list [
                hold comma
                hold form-value value
            ]
        ]
    ]

    form-value: func [value [any-type!]][
        switch/default type?/word value [
            path! [listify/with to-block value "."]
            paren! [listify/with to-block value " "]
            word! [
                either value = '* [form value][
                    press ["`" replace/all form value "-" "_" "`"]
                ]
            ]
            get-word! [form-value get :value]
            string! [press ["'" escape value "'"]]
            integer! decimal! [form value]
            block! [listify value]
        ][
            "[UNSUPPORTED TYPE]"
        ]
    ]

    result: context [
        out: copy ""
        reset: does [out: copy ""]
        emit: func [data][repend out data]

        depth: 0
        comma: ""
        feed: does [emit "^/"]
        indent: does [emit head insert/dup copy "" "^-" depth]

        open-paren: does [
            depth: depth + 1
            comma: ""
            "("
        ]

        close-paren: does [
            depth: depth - 1
            comma: ","
            ")"
        ]

        add: func [fragment][
            foreach part fragment [
                switch/default type?/word part [
                    string! [emit part]
                    get-word! [emit form-value get :part]
                ][
                    switch/default part [
                        feed [feed]
                        indent [indent]
                        open [emit open-paren]
                        close [emit close-paren]
                        _ [emit " "]
                        comma [emit comma]
                        next [
                            switch depth [
                                0 [emit ";^/"]
                                1 [emit ",^/"]
                                2 [emit ","]
                            ]
                        ]
                    ][make error! join "Don't Know What This Is: " mold part]
                ]
            ] 
        ]

        add-field: func [field][
            gather with/only field [
                add [comma feed indent :name _]
                comma: ","

                emit switch/default to-word type [
                    string! [
                        case [
                            integer? width [
                                press ["VARCHAR(" width ")"]
                            ]
                            block? width [
                                press ["ENUM" open-paren listify width close-paren]
                            ]
                            true ["TEXT"]
                        ]
                    ]
                    integer! [press ["INT(" width ")"]]
                    decimal! ["FLOAT"]
                    date! ["DATETIME"]
                    logic! [required: false "TINYINT(1)"]
                    url! email! block! tuple! [
                        either integer? width [
                            press ["VARBINARY(" width ")"]
                        ]["BLOB"]
                    ]
                ][make error! join "Unknown Type: " type]

                case/all [
                    required [emit " NOT NULL"]
                    increment [emit " auto_increment"]
                    default [emit " DEFAULT " emit default]
                ]
            ]
        ]

        add-expression: use [prepare][
            prepare: func [expression /with wrappers /local ref dv][
                wrappers: any [wrappers ["" "" ""]]
                dv: ""
                press gather [
                    parse expression [
                        (hold wrappers/1)
                        some [
                            'all set expression block!
                            (hold dv dv: wrappers/2)
                            (hold prepare/with expression ["(" " AND " ")"])
                            |
                            'any set expression block!
                            (hold dv dv: wrappers/2)
                            (hold prepare/with expression ["(" " OR " ")"])
                            |
                            into [
                                (hold dv dv: wrappers/2)
                                'find set expression block! set ref [path! | word!]
                                (rehold [form-value ref " IN (" listify expression ")"])
                                |
                                set ref [word! | path!]
                                set with word!
                                set expression skip
                                (
                                    rehold [
                                        form-value ref
                                        " " form with " "
                                        form-value expression
                                    ]
                                )
                            ]
                        ]
                        (hold wrappers/3)
                    ]
                ]
            ]

            add-expression: func [expression][
                emit "WHERE "
                parse expression [
                    'all set expression block!
                    (expression: prepare/with expression ["" " AND " ""])
                    |
                    'any set expression block!
                    (expression: prepare/with expression ["" " OR " ""])
                    |
                    paren! (expression: prepare expression)
                ]
                emit expression
                feed
            ]
        ]

        add-tables: func [from /comma][
            emit "FROM"
            emit press gather [
                parse from [
                    some [
                        set from [word! | path!] (
                            rehold [comma " " form-value from]
                            comma: ","
                        )
                        |
                        copy from [set-word! [word! | path!]] (
                            rehold [comma " " form-value from/2]
                            rehold [" " form-value to-word from/1]
                            comma: ","
                        )
                    ]
                ]
            ]
            feed
        ]
    ]

    schema-create: func [schema][
        result/reset

        foreach [name database] schema [
            result/add [
                "##^/## NEW DATABASE^/##^/^/"
                "DROP DATABASE IF EXISTS " :name next
                "CREATE DATABASE IF NOT EXISTS " :name 
                " CHARACTER SET utf8 COLLATE utf8_general_ci" next
                "USE " :name next feed
            ]

            foreach [name table] database/tables [
                result/add [
                    "DROP TABLE IF EXISTS" _ :name next
                    "CREATE TABLE" _ :name _ open
                ]

                foreach [name field] table/fields [
                    result/add-field field
                ]

                if word? table/primary [
                    result/add with/only table [
                        comma feed indent "PRIMARY KEY (" :primary ")"
                    ]
                ]

                unless empty? table/indices [
                    result/add with/only table [
                        comma feed indent "INDEX (" :indices ")"
                    ]
                ]

                result/add [feed close next feed]
            ]

            foreach [name view] database/views [
                result/add with/only view [
                    "DROP VIEW IF EXISTS" _ :name next
                    "CREATE VIEW" _ :name _ "AS" feed
                    "SELECT" _ :fields feed
                ]

                result/add-tables view/tables

                result/add-expression view/expressions

                if view/order with/only view [
                    result/add [
                        "ORDER BY" _ :order
                    ]
                    switch view/direction [
                        ascending [result/emit " ASC"]
                        descending [result/emit " DESC"]
                    ]
                ]

                result/add [next feed]
            ]
        ]

        result/out
    ]
]