First version including test data

graphviz-sql-hs.cabal

@@ -18,3 +18,5 @@ executable graphviz-sql-hs
   main-is:             Main.hs
   default-language:    Haskell2010
   build-depends:       base >= 4.7 && < 5
+                     , megaparsec
+                     , text

src/Main.hs

+{-# 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 "}"

stack.yaml.lock

+# 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

test-data/test-create-table.sql

+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)
+)