Commit d47b0e0b authored by Philipp Middendorf's avatar Philipp Middendorf
Browse files

First version including test data

parent 5d289ee8
......@@ -18,3 +18,5 @@ executable graphviz-sql-hs
main-is: Main.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, megaparsec
, text
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Data.Maybe(fromMaybe, mapMaybe)
import Prelude hiding(interact, getContents, putStrLn)
import Text.Megaparsec(Parsec, satisfy, sepBy, sepBy1, noneOf, parseTest, optional, (<?>), parse, errorBundlePretty)
import Data.Functor(($>))
import Data.Void(Void)
import Data.Text(Text, pack)
import Data.Text.IO(getContents, putStrLn)
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Megaparsec.Char(space1, char, alphaNumChar)
import Control.Applicative(empty, some, many, (<|>))
type Parser = Parsec Void Text
sc :: Parser ()
sc = L.space
space1
(L.skipLineComment "--")
empty
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
symbol :: Text -> Parser Text
symbol = L.symbol sc
data SqlType = SqlInteger
| SqlFloat
| SqlJson
| SqlText
| SqlBoolean
| SqlDateTime
| SqlVarChar (Maybe Int)
instance Show SqlType where
show SqlInteger = "INTEGER"
show SqlFloat = "FLOAT"
show SqlJson = "JSON"
show SqlText = "TEXT"
show SqlBoolean = "BOOLEAN"
show SqlDateTime = "DATETIME"
show (SqlVarChar _) = "VARCHAR"
data SqlForeignKey = SqlForeignKey {
originalTable :: Text
, originalColumn :: Text
, foreignTable :: Text
, foreignColumn :: Text
}
data SqlField = NormalField Text SqlType Bool
| PrimaryKey [Text]
| ForeignKey SqlForeignKey
| Constraint
data SqlCreateTable = SqlCreateTable {
ctName :: Text
, ctFields :: [SqlField]
}
parserQuoted :: Parser Text
parserQuoted = pack <$> (char '"' *> some (satisfy (/= '\"')) <* symbol "\"")
parserCreateTable :: Parser SqlCreateTable
parserCreateTable = do
symbol "CREATE"
symbol "TABLE"
tableName <- parserQuoted
symbol "("
fields <- parserField tableName `sepBy` symbol ","
symbol ")"
pure (SqlCreateTable tableName fields)
parserIdentifier :: Parser Text
parserIdentifier = pack <$> some (alphaNumChar <|> char '_')
parserPrimaryKey :: Parser SqlField
parserPrimaryKey =
let prefix = symbol "PRIMARY" *> symbol "KEY" *> symbol "("
infix_ = lexeme parserIdentifier `sepBy1` symbol ","
suffix = symbol ")"
in prefix *> (PrimaryKey <$> infix_) <* suffix
parserForeignKey :: Text -> Parser SqlField
parserForeignKey tableName = do
symbol "FOREIGN"
symbol "KEY"
symbol "("
column <- pack <$> some (satisfy (/= ')'))
symbol ")"
symbol "REFERENCES"
otherTable <- parserQuoted
symbol "("
otherColumn <- pack <$> some (satisfy (/= ')'))
symbol ")"
optional (symbol "ON" *> symbol "DELETE" *> symbol "cascade")
pure (ForeignKey (SqlForeignKey tableName column otherTable otherColumn))
parserConstraint :: Parser SqlField
parserConstraint = do
symbol "CONSTRAINT"
lexeme parserIdentifier
symbol "CHECK"
symbol "("
lexeme parserIdentifier
symbol "IN"
symbol "("
lexeme $ some (satisfy (/= ')'))
symbol ")"
symbol ")"
pure Constraint
parserCheck :: Parser SqlField
parserCheck = do
symbol "CHECK"
symbol "("
lexeme parserIdentifier
symbol "IN"
symbol "("
some (satisfy (/= ')'))
symbol ")"
symbol ")"
pure Constraint
parserType :: Parser SqlType
parserType = (symbol "INTEGER" $> SqlInteger)
<|> (symbol "VARCHAR" *> (SqlVarChar <$> optional (symbol "(" *> lexeme L.decimal <* symbol ")")))
<|> (symbol "JSON" $> SqlJson)
<|> (symbol "BOOLEAN" $> SqlBoolean)
<|> (symbol "TEXT" $> SqlText)
<|> (symbol "DATETIME" $> SqlDateTime)
<|> (symbol "FLOAT" $> SqlFloat)
parserNormalField :: Parser SqlField
parserNormalField = do
fieldName <- lexeme parserIdentifier <?> "column identifier"
fieldType <- lexeme parserType <?> "column type"
optional (symbol "DEFAULT (CURRENT_TIMESTAMP)")
nullability <- optional (symbol "NOT" *> symbol "NULL" $> True) <?> "column nullability"
pure (NormalField fieldName fieldType (fromMaybe True nullability))
parserField :: Text -> Parser SqlField
parserField tableName = parserPrimaryKey
<|> parserForeignKey tableName
<|> parserConstraint
<|> parserCheck
<|> parserNormalField
serializeField :: SqlField -> Text
serializeField (NormalField name type_ nullability) = "<tr><td port=\"" <> name <> "\">" <> name <> "</td><td port=\"" <> name <> "_right\">" <> pack (show type_) <> "</td></tr>"
serializeField _ = ""
serializeCreateTable :: SqlCreateTable -> Text
serializeCreateTable ct = "\"" <> ctName ct <> "\" [\nshape=none\nlabel=<\n <table border=\"0\" cellspacing=\"0\" cellborder=\"1\">\n <tr><td bgcolor=\"lightblue2\" colspan=\"2\"><font point-size=\"20\"> " <> ctName ct <> " </font></td></tr>\n " <> foldMap serializeField (ctFields ct) <> "\n</table>\n>];\n"
serializeForeignKey :: SqlForeignKey -> Text
serializeForeignKey (SqlForeignKey tableLeft leftColumn tableRight rightColumn) = "\"" <> tableLeft <> "\":" <> leftColumn <> "_right -> \"" <> tableRight <> "\":" <> rightColumn
tableForeignKeys :: SqlCreateTable -> [SqlForeignKey]
tableForeignKeys ct =
let maybeForeign (ForeignKey f) = Just f
maybeForeign _ = Nothing
in mapMaybe maybeForeign (ctFields ct)
main :: IO ()
main = do
putStrLn "hello world"
stdinContents <- getContents
putStrLn "digraph g { graph [ rankdir = \"LR\" ];"
case parse (some parserCreateTable) "stdin" stdinContents of
Left e -> putStr (errorBundlePretty e)
Right v -> do
mapM_ (putStrLn . serializeCreateTable) v
mapM_ (putStrLn . serializeForeignKey) (v >>= tableForeignKeys)
putStrLn "}"
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files
packages: []
snapshots:
- completed:
size: 565715
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/7.yaml
sha256: 1b5e4124989399e60e7a7901f0cefd910beea546131fb07a13a7208c4cc8b7ee
original:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/7.yaml
CREATE TABLE "Proposal" (
id INTEGER NOT NULL,
metadata JSON,
PRIMARY KEY (id)
)
CREATE TABLE "Attributo" (
name VARCHAR(255) NOT NULL,
description VARCHAR(255),
suffix VARCHAR(255),
associated_table VARCHAR(6) NOT NULL,
json_schema JSON NOT NULL,
PRIMARY KEY (name, associated_table),
CONSTRAINT associatedtable CHECK (associated_table IN ('RUN', 'SAMPLE'))
)
CREATE TABLE "Target" (
id INTEGER NOT NULL,
name VARCHAR(255) NOT NULL,
short_name VARCHAR(255) NOT NULL,
molecular_weight FLOAT,
uniprot_id VARCHAR(64),
PRIMARY KEY (id)
)
CREATE TABLE "HitFindingParameters" (
id INTEGER NOT NULL,
min_peaks INTEGER NOT NULL,
tag VARCHAR,
comment VARCHAR,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
PRIMARY KEY (id)
)
CREATE TABLE "IntegrationParameters" (
id INTEGER NOT NULL,
tag VARCHAR,
comment VARCHAR,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
method VARCHAR,
center_boxes INTEGER,
overpredict INTEGER,
push_res FLOAT,
radius_inner FLOAT,
radius_middle FLOAT,
radius_outer FLOAT,
PRIMARY KEY (id)
)
CREATE TABLE "MergeParameters" (
id INTEGER NOT NULL,
tag VARCHAR,
comment VARCHAR,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
software VARCHAR NOT NULL,
software_version VARCHAR,
software_git_repository TEXT,
software_git_sha VARCHAR,
command_line TEXT NOT NULL,
parameters JSON NOT NULL,
partiality_model VARCHAR,
num_iterations INTEGER,
scale_linear BOOLEAN,
scale_bfactor BOOLEAN,
post_refine BOOLEAN,
symmetry VARCHAR,
polarization VARCHAR,
min_measurements INTEGER,
max_adu FLOAT,
min_res FLOAT,
PRIMARY KEY (id),
CHECK (scale_linear IN (0, 1)),
CHECK (scale_bfactor IN (0, 1)),
CHECK (post_refine IN (0, 1))
)
CREATE TABLE "AmbiguityParameters" (
id INTEGER NOT NULL,
tag VARCHAR,
comment VARCHAR,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
software VARCHAR NOT NULL,
software_version VARCHAR,
software_git_repository TEXT,
software_git_sha VARCHAR,
parameters JSON NOT NULL,
PRIMARY KEY (id)
)
CREATE TABLE "Sample" (
id INTEGER NOT NULL,
target_id INTEGER,
compounds JSON,
micrograph TEXT,
protocol TEXT,
modified DATETIME NOT NULL,
attributi JSON NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY(target_id) REFERENCES "Target" (id)
)
CREATE TABLE "MergeResults" (
id INTEGER NOT NULL,
merge_parameters_id INTEGER NOT NULL,
result_hkl_filename TEXT,
result_mtz_filename TEXT,
rsplit FLOAT NOT NULL,
cc_half FLOAT NOT NULL,
comment VARCHAR,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY(merge_parameters_id) REFERENCES "MergeParameters" (id)
)
CREATE TABLE "Run" (
id INTEGER NOT NULL,
modified DATETIME NOT NULL,
proposal_id INTEGER NOT NULL,
sample_id INTEGER,
attributi JSON NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY(proposal_id) REFERENCES "Proposal" (id),
FOREIGN KEY(sample_id) REFERENCES "Sample" (id)
)
CREATE TABLE "RunComment" (
id INTEGER NOT NULL,
run_id INTEGER,
author VARCHAR(255) NOT NULL,
comment_text VARCHAR(255) NOT NULL,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY(run_id) REFERENCES "Run" (id) ON DELETE cascade
)
CREATE TABLE "DataSource" (
id INTEGER NOT NULL,
run_id INTEGER NOT NULL,
source VARCHAR,
tag VARCHAR,
comment VARCHAR,
number_of_frames INTEGER,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY(run_id) REFERENCES "Run" (id)
)
CREATE TABLE "PeakSearchParameters" (
id INTEGER NOT NULL,
data_source_id INTEGER NOT NULL,
tag VARCHAR,
comment VARCHAR,
method VARCHAR NOT NULL,
software VARCHAR NOT NULL,
software_version VARCHAR,
software_git_repository TEXT,
software_git_sha VARCHAR,
command_line TEXT NOT NULL,
max_num_peaks FLOAT,
adc_threshold FLOAT,
minimum_snr FLOAT,
min_pixel_count FLOAT,
max_pixel_count FLOAT,
min_res FLOAT,
max_res FLOAT,
bad_pixel_filename TEXT,
bad_pixel_map_hdf5_filename TEXT,
local_bg_radius FLOAT,
min_peak_over_neighbor FLOAT,
min_snr_biggest_pix FLOAT,
min_snr_peak_pix FLOAT,
min_sig FLOAT,
min_squared_gradient FLOAT,
geometry TEXT,
geometry_filename TEXT,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY(data_source_id) REFERENCES "DataSource" (id)
)
CREATE TABLE "HitFindingResults" (
id INTEGER NOT NULL,
peak_search_parameters_id INTEGER NOT NULL,
hit_finding_parameters_id INTEGER NOT NULL,
tag VARCHAR,
comment VARCHAR,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
number_of_hits INTEGER NOT NULL,
hit_rate FLOAT NOT NULL,
result_filename TEXT NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY(peak_search_parameters_id) REFERENCES "PeakSearchParameters" (id),
FOREIGN KEY(hit_finding_parameters_id) REFERENCES "HitFindingParameters" (id)
)
CREATE TABLE "IndexingParameters" (
id INTEGER NOT NULL,
hit_finding_results_id INTEGER NOT NULL,
tag VARCHAR,
comment VARCHAR,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
software VARCHAR NOT NULL,
software_version VARCHAR,
software_git_repository TEXT,
software_git_sha VARCHAR,
command_line TEXT NOT NULL,
parameters JSON NOT NULL,
methods JSON,
target_cell_filename TEXT,
geometry TEXT,
geometry_filename TEXT,
PRIMARY KEY (id),
FOREIGN KEY(hit_finding_results_id) REFERENCES "HitFindingResults" (id)
)
CREATE TABLE "IndexingResults" (
id INTEGER NOT NULL,
indexing_parameters_id INTEGER NOT NULL,
integration_parameters_id INTEGER NOT NULL,
ambiguity_parameters_id INTEGER,
tag VARCHAR,
comment VARCHAR,
created DATETIME DEFAULT (CURRENT_TIMESTAMP) NOT NULL,
result_filename TEXT,
num_indexed INTEGER NOT NULL,
num_crystals INTEGER NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY(indexing_parameters_id) REFERENCES "IndexingParameters" (id),
FOREIGN KEY(integration_parameters_id) REFERENCES "IntegrationParameters" (id),
FOREIGN KEY(ambiguity_parameters_id) REFERENCES "AmbiguityParameters" (id)
)
CREATE TABLE "MergeHasIndexing" (
merge_results_id INTEGER NOT NULL,
indexing_results_id INTEGER NOT NULL,
PRIMARY KEY (merge_results_id, indexing_results_id),
FOREIGN KEY(merge_results_id) REFERENCES "MergeResults" (id),
FOREIGN KEY(indexing_results_id) REFERENCES "IndexingResults" (id)
)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment